module Sqel.Migration.Statement where
import qualified Control.Monad.Trans.Writer.Strict as Mtl
import qualified Data.Map.Strict as Map
import qualified Exon
import Hasql.Encoders (Params)
import qualified Hasql.Session as Session
import Hasql.Session (Session)
import qualified Sqel.Data.Migration as Migration
import Sqel.Data.Migration (
ColumnAction (AddColumn, RemoveColumn, RenameColumn, RenameColumnType),
MigrationActions (AutoActions, CustomActions),
TypeAction (AddAction, ModifyAction, RenameAction),
)
import Sqel.Data.PgType (
ColumnType (ColumnComp, ColumnPrim),
PgColumnName (PgColumnName),
PgComposite (PgComposite),
PgPrimName (PgPrimName),
PgTypeRef (PgTypeRef),
)
import Sqel.Data.PgTypeName (
pattern PgCompName,
PgTableName,
pattern PgTableName,
pattern PgTypeName,
PgTypeName,
pgTableName,
)
import Sqel.Data.Sql (Sql (Sql), sql)
import qualified Sqel.Sql.Type as Sql
import Sqel.Statement (unprepared)
import qualified Text.Show as Show
data MigrationStatement where
MigrationStatement :: p -> Params p -> Sql -> MigrationStatement
instance Show MigrationStatement where
show :: MigrationStatement -> String
show (MigrationStatement p
_ Params p
_ Sql
s) = forall b a. (Show a, IsString b) => a -> b
show Sql
s
migrationStatementSql :: MigrationStatement -> Sql
migrationStatementSql :: MigrationStatement -> Sql
migrationStatementSql (MigrationStatement p
_ Params p
_ Sql
s) =
Sql
s
alterStatement ::
PgTypeName table ->
p ->
Params p ->
(Sql -> Sql -> Sql) ->
Mtl.Writer [MigrationStatement] ()
alterStatement :: forall (table :: Bool) p.
PgTypeName table
-> p
-> Params p
-> (Sql -> Sql -> Sql)
-> Writer [MigrationStatement] ()
alterStatement PgTypeName table
typeName p
p Params p
enc Sql -> Sql -> Sql
f =
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Mtl.tell [forall p. p -> Params p -> Sql -> MigrationStatement
MigrationStatement p
p Params p
enc (Sql -> Sql -> Sql
f [sql|alter #{entity} ##{pgTableName name}|] Sql
attr)]
where
(Sql
entity, Sql
attr, Text
name) = case PgTypeName table
typeName of
PgTableName Text
n -> (Sql
"table", Sql
"column", Text
n)
PgCompName Text
n -> (Sql
"type", Sql
"attribute", Text
n)
columnStatements' ::
PgTypeName table ->
ColumnAction ->
Mtl.Writer [MigrationStatement] ()
columnStatements' :: forall (table :: Bool).
PgTypeName table -> ColumnAction -> Writer [MigrationStatement] ()
columnStatements' PgTypeName table
typeName = \case
AddColumn (PgColumnName Text
colName) ColumnType
tpe Maybe (a, Params a)
md -> do
(Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ \ Sql
alter Sql
attr -> [sql|#{alter} add #{attr} ##{colName} #{colTypeName}|]
case PgTypeName table
typeName of
PgTableName Text
_ -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (a, Params a)
md \ (a
defVal, Params a
enc) -> do
forall (table :: Bool) p.
PgTypeName table
-> p
-> Params p
-> (Sql -> Sql -> Sql)
-> Writer [MigrationStatement] ()
alterStatement PgTypeName table
typeName a
defVal Params a
enc \ Sql
_ Sql
_ -> [sql|update ##{comp} set ##{colName} = $1|]
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Sql]
optFrag) \ NonEmpty Sql
opt ->
(Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ \ Sql
alter Sql
attr ->
[sql|#{alter} alter #{attr} ##{colName} set #{Exon.intercalate " " opt}|]
PgCompName Text
_ -> forall (f :: * -> *). Applicative f => f ()
unit
where
([Sql]
optFrag, Sql
colTypeName) = case ColumnType
tpe of
ColumnPrim (PgPrimName Text
n) Bool
_ [Sql]
opt -> ([Sql]
opt, Text -> Sql
Sql Text
n)
ColumnComp (PgTypeRef Text
n) Bool
_ [Sql]
opt -> ([Sql]
opt, Text -> Sql
Sql Text
n)
RemoveColumn (PgColumnName Text
name) ColumnType
_ ->
(Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ \ Sql
alter Sql
attr -> [sql|#{alter} drop #{attr} ##{name}|]
RenameColumn (PgColumnName Text
old) (PgColumnName Text
new) ->
(Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ \ Sql
alter Sql
attr -> [sql|#{alter} rename #{attr} ##{old} to ##{new}|]
RenameColumnType (PgColumnName Text
old) (PgTypeName Text
new) ->
(Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ \ Sql
alter Sql
attr -> [sql|#{alter} alter #{attr} ##{old} set data type ##{new}|]
where
alter_ :: (Sql -> Sql -> Sql) -> Writer [MigrationStatement] ()
alter_ = forall (table :: Bool) p.
PgTypeName table
-> p
-> Params p
-> (Sql -> Sql -> Sql)
-> Writer [MigrationStatement] ()
alterStatement PgTypeName table
typeName () forall a. Monoid a => a
mempty
PgTypeName Text
comp = PgTypeName table
typeName
typeActionStatements :: PgTypeName table -> TypeAction table -> Mtl.Writer [MigrationStatement] ()
typeActionStatements :: forall (table :: Bool).
PgTypeName table
-> TypeAction table -> Writer [MigrationStatement] ()
typeActionStatements PgTypeName table
typeName = \case
ModifyAction PgTypeName table
_ [ColumnAction]
cols ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (table :: Bool).
PgTypeName table -> ColumnAction -> Writer [MigrationStatement] ()
columnStatements' PgTypeName table
typeName) [ColumnAction]
cols
RenameAction newName :: PgTypeName 'False
newName@(PgTypeName Text
new) [ColumnAction]
cols -> do
forall (table :: Bool) p.
PgTypeName table
-> p
-> Params p
-> (Sql -> Sql -> Sql)
-> Writer [MigrationStatement] ()
alterStatement PgTypeName table
typeName () forall a. Monoid a => a
mempty \ Sql
alter Sql
_ -> [sql|#{alter} rename to ##{new}|]
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (table :: Bool).
PgTypeName table -> ColumnAction -> Writer [MigrationStatement] ()
columnStatements' PgTypeName 'False
newName) [ColumnAction]
cols
AddAction PgColumns
cols ->
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Mtl.tell [forall p. p -> Params p -> Sql -> MigrationStatement
MigrationStatement () forall a. Monoid a => a
mempty (PgComposite -> Sql
Sql.createProdType (PgTypeName 'False -> PgColumns -> PgComposite
PgComposite PgTypeName table
typeName PgColumns
cols))]
typeStatements :: PgTypeName table -> TypeAction table -> [MigrationStatement]
typeStatements :: forall (table :: Bool).
PgTypeName table -> TypeAction table -> [MigrationStatement]
typeStatements PgTypeName table
name =
forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Mtl.runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (table :: Bool).
PgTypeName table
-> TypeAction table -> Writer [MigrationStatement] ()
typeActionStatements PgTypeName table
name
migrationStatements :: PgTableName -> MigrationActions ext -> [MigrationStatement]
migrationStatements :: forall ext.
PgTypeName 'True -> MigrationActions ext -> [MigrationStatement]
migrationStatements PgTypeName 'True
tableName = \case
AutoActions {Map (PgTypeName 'False) CompAction
TableAction
$sel:types:AutoActions :: forall ext.
MigrationActions ext -> Map (PgTypeName 'False) CompAction
$sel:table:AutoActions :: forall ext. MigrationActions ext -> TableAction
types :: Map (PgTypeName 'False) CompAction
table :: TableAction
..} ->
forall (table :: Bool).
PgTypeName table -> TypeAction table -> [MigrationStatement]
typeStatements PgTypeName 'True
tableName TableAction
table forall a. Semigroup a => a -> a -> a
<> (forall k a. Map k a -> [(k, a)]
Map.toList Map (PgTypeName 'False) CompAction
types forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (PgTypeName 'False
name, CompAction
actions) -> forall (table :: Bool).
PgTypeName table -> TypeAction table -> [MigrationStatement]
typeStatements PgTypeName 'False
name CompAction
actions)
CustomActions ext
_ ->
[]
migrationSession :: [MigrationStatement] -> Session ()
migrationSession :: [MigrationStatement] -> Session ()
migrationSession =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \ (MigrationStatement p
p Params p
enc Sql
stmt) -> forall params result.
params -> Statement params result -> Session result
Session.statement p
p (forall result d p.
ResultShape d result =>
Sql -> Row d -> Params p -> Statement p result
unprepared @() Sql
stmt forall (f :: * -> *). Applicative f => f ()
unit Params p
enc)