module Sqel.Migration.Type where
import Generics.SOP (NP (Nil, (:*)), SListI, Top, hcfoldMap)
import Sqel.Data.Migration (CompAction, TableAction, TypeAction (AddAction, ModifyAction, RenameAction))
import Sqel.Data.PgType (PgColumn (PgColumn), PgColumns (PgColumns), pgColumnName)
import Sqel.Data.PgTypeName (PgCompName)
import Sqel.Kind (type (++))
import Sqel.SOP.Constraint (symbolText)
import Sqel.Migration.Column (ColIndex (colIndex), ColumnsChanges (columnsChanges))
import Sqel.Migration.Data.Ddl (DdlColumn (DdlColumn), DdlColumnK, DdlType (DdlType), DdlTypeK (DdlTypeK))
data OldK =
OldK {
OldK -> Bool
table :: Bool,
OldK -> Symbol
name :: Symbol,
OldK -> [DdlColumnK]
cols :: [DdlColumnK]
}
data NewK =
NewK {
NewK -> Nat
index :: Nat,
NewK -> Bool
table :: Bool,
NewK -> Symbol
name :: Symbol,
NewK -> Maybe Symbol
rename :: Maybe Symbol,
NewK -> [DdlColumnK]
cols :: [DdlColumnK]
}
data ModK =
KeepK
|
AddK
|
RenameK
data ActionK =
ActionK {
ActionK -> ModK
mod :: ModK,
ActionK -> Nat
index :: Nat
}
|
UnusedK
type family OldKs (index :: Nat) (types :: [DdlTypeK]) :: [OldK] where
OldKs _ '[] = '[]
OldKs index ('DdlTypeK table name _ cols : types) =
'OldK table name cols : OldKs (index + 1) types
type family NewKs (index :: Nat) (types :: [DdlTypeK]) :: [NewK] where
NewKs _ '[] = '[]
NewKs index ('DdlTypeK table name rename cols : types) =
'NewK index table name rename cols : NewKs (index + 1) types
type family MkMigrationAction (old :: OldK) (check :: [NewK]) (other :: [NewK]) :: (ActionK, [NewK]) where
MkMigrationAction _ '[] other =
'( 'UnusedK, other)
MkMigrationAction ('OldK table name _) ('NewK index table name 'Nothing _ : news) other =
'( 'ActionK 'KeepK index, news ++ other)
MkMigrationAction ('OldK table oldName _) ('NewK index table _ ('Just oldName) _ : news) other =
'( 'ActionK 'RenameK index, news ++ other)
MkMigrationAction old (new : news) other =
MkMigrationAction old news (new : other)
type family NewMigrationActions (cols :: [NewK]) :: [ActionK] where
NewMigrationActions '[] = '[]
NewMigrationActions ('NewK index 'False _ 'Nothing _ : news) =
'ActionK 'AddK index : NewMigrationActions news
NewMigrationActions cols = TypeError ("type NewMigrationActions:" % cols)
type family MigrationActionsCont (cur :: (ActionK, [NewK])) (old :: [OldK]) :: [ActionK] where
MigrationActionsCont '(cur, new) old = cur : MigrationActions old new
type family MigrationActions (old :: [OldK]) (new :: [NewK]) :: [ActionK] where
MigrationActions '[] rest =
NewMigrationActions rest
MigrationActions (old : olds) new =
MigrationActionsCont (MkMigrationAction old new '[]) olds
type ReifyKeepAction :: Bool -> DdlTypeK -> DdlTypeK -> Constraint
class ReifyKeepAction table old new where
reifyKeepAction :: DdlType old -> DdlType new -> TypeAction table
instance (
ColumnsChanges colsOld colsNew
) => ReifyKeepAction table ('DdlTypeK table tname renameOld colsOld) ('DdlTypeK table tname renameNew colsNew) where
reifyKeepAction :: DdlType ('DdlTypeK table tname renameOld colsOld)
-> DdlType ('DdlTypeK table tname renameNew colsNew)
-> TypeAction table
reifyKeepAction (DdlType PgTypeName table
name NP DdlColumn cols
colsOld) (DdlType PgTypeName table
_ NP DdlColumn cols
colsNew) =
forall (table :: Bool).
PgTypeName table -> [ColumnAction] -> TypeAction table
ModifyAction PgTypeName table
name (forall (old :: [DdlColumnK]) (new :: [DdlColumnK]).
ColumnsChanges old new =>
NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
columnsChanges NP DdlColumn cols
colsOld NP DdlColumn cols
colsNew)
type family ReifyModResult (table :: Bool) :: Type where
ReifyModResult 'False =
[(PgCompName, CompAction)]
ReifyModResult 'True =
TypeAction 'True
type ReifyModAction :: Bool -> ModK -> DdlTypeK -> DdlTypeK -> Constraint
class ReifyModAction table action old new where
reifyModAction :: DdlType old -> DdlType new -> ReifyModResult table
instance (
ReifyKeepAction 'True old new
) => ReifyModAction 'True 'KeepK old new where
reifyModAction :: DdlType old -> DdlType new -> ReifyModResult 'True
reifyModAction DdlType old
old DdlType new
new =
forall (table :: Bool) (old :: DdlTypeK) (new :: DdlTypeK).
ReifyKeepAction table old new =>
DdlType old -> DdlType new -> TypeAction table
reifyKeepAction @'True DdlType old
old DdlType new
new
instance (
ReifyKeepAction 'False ('DdlTypeK 'False tname renameOld colsOld) new
) => ReifyModAction 'False 'KeepK ('DdlTypeK 'False tname renameOld colsOld) new where
reifyModAction :: DdlType ('DdlTypeK 'False tname renameOld colsOld)
-> DdlType new -> ReifyModResult 'False
reifyModAction old :: DdlType ('DdlTypeK 'False tname renameOld colsOld)
old@(DdlType PgTypeName table
name NP DdlColumn cols
_) DdlType new
new =
[(PgTypeName table
name, forall (table :: Bool) (old :: DdlTypeK) (new :: DdlTypeK).
ReifyKeepAction table old new =>
DdlType old -> DdlType new -> TypeAction table
reifyKeepAction @'False DdlType ('DdlTypeK 'False tname renameOld colsOld)
old DdlType new
new)]
instance (
ColumnsChanges colsOld colsNew
) => ReifyModAction 'False 'RenameK ('DdlTypeK 'False name renameOld colsOld) ('DdlTypeK 'False nameNew ('Just name) colsNew) where
reifyModAction :: DdlType ('DdlTypeK 'False name renameOld colsOld)
-> DdlType ('DdlTypeK 'False nameNew ('Just name) colsNew)
-> ReifyModResult 'False
reifyModAction (DdlType PgTypeName table
nameOld NP DdlColumn cols
colsOld) (DdlType PgTypeName table
nameNew NP DdlColumn cols
colsNew) =
[(PgTypeName table
nameOld, PgCompName -> [ColumnAction] -> CompAction
RenameAction PgTypeName table
nameNew (forall (old :: [DdlColumnK]) (new :: [DdlColumnK]).
ColumnsChanges old new =>
NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
columnsChanges NP DdlColumn cols
colsOld NP DdlColumn cols
colsNew))]
type ReifyOldAction :: Bool -> ActionK -> DdlTypeK -> [DdlTypeK] -> Constraint
class ReifyOldAction table action old new where
reifyOldAction :: DdlType old -> NP DdlType new -> ReifyModResult table
instance (
ColIndex index news new,
ReifyModAction table mod old new
) => ReifyOldAction table ('ActionK mod index) old news where
reifyOldAction :: DdlType old -> NP DdlType news -> ReifyModResult table
reifyOldAction DdlType old
old NP DdlType news
news =
forall (table :: Bool) (action :: ModK) (old :: DdlTypeK)
(new :: DdlTypeK).
ReifyModAction table action old new =>
DdlType old -> DdlType new -> ReifyModResult table
reifyModAction @table @mod DdlType old
old (forall {k} {k1} (index :: k) (cols :: [k1]) (col :: k1)
(f :: k1 -> *).
ColIndex index cols col =>
NP f cols -> f col
colIndex @index NP DdlType news
news)
instance ReifyOldAction 'False 'UnusedK ('DdlTypeK 'False name renameOld colsOld) new where
reifyOldAction :: DdlType ('DdlTypeK 'False name renameOld colsOld)
-> NP DdlType new -> ReifyModResult 'False
reifyOldAction DdlType ('DdlTypeK 'False name renameOld colsOld)
_ NP DdlType new
_ = []
type ReifyNewAction :: ActionK -> [DdlTypeK] -> Constraint
class ReifyNewAction action new where
reifyNewAction :: NP DdlType new -> (PgCompName, CompAction)
instance (
SListI cols,
ColIndex index news ('DdlTypeK 'False name rename cols)
) => ReifyNewAction ('ActionK 'AddK index) news where
reifyNewAction :: NP DdlType news -> (PgCompName, CompAction)
reifyNewAction NP DdlType news
news =
let
DdlType PgTypeName table
PgCompName
name NP DdlColumn cols
NP DdlColumn cols
ddlCols = forall {k} {k1} (index :: k) (cols :: [k1]) (col :: k1)
(f :: k1 -> *).
ColIndex index cols col =>
NP f cols -> f col
colIndex @index NP DdlType news
news
cols :: NP DdlColumn cols -> [PgColumn]
cols = forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) m (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HTraverse_ h, AllN h c xs, Monoid m) =>
proxy c -> (forall (a :: k). c a => f a -> m) -> h f xs -> m
hcfoldMap (forall {k} (t :: k). Proxy t
Proxy @Top) \ (DdlColumn (Proxy name
Proxy :: Proxy n) ColumnType
t Mods p
_) ->
[PgColumnName -> ColumnType -> PgColumn
PgColumn (Text -> PgColumnName
pgColumnName (forall (name :: Symbol). KnownSymbol name => Text
symbolText @n)) ColumnType
t]
in (PgCompName
name, PgColumns -> CompAction
AddAction ([PgColumn] -> PgColumns
PgColumns (NP DdlColumn cols -> [PgColumn]
cols NP DdlColumn cols
ddlCols)))
type ReifyActions :: [ActionK] -> [DdlTypeK] -> [DdlTypeK] -> Constraint
class ReifyActions actions old new where
reifyActions :: NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
instance ReifyActions '[] '[] new where
reifyActions :: NP DdlType '[] -> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions NP DdlType '[]
_ NP DdlType new
_ =
forall a. Monoid a => a
mempty
instance (
ReifyNewAction action new,
ReifyActions actions '[] new
) => ReifyActions (action : actions) '[] new where
reifyActions :: NP DdlType '[] -> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions NP DdlType '[]
Nil NP DdlType new
new =
forall (action :: ActionK) (new :: [DdlTypeK]).
ReifyNewAction action new =>
NP DdlType new -> (PgCompName, CompAction)
reifyNewAction @action NP DdlType new
new forall a. a -> [a] -> [a]
: forall (actions :: [ActionK]) (old :: [DdlTypeK])
(new :: [DdlTypeK]).
ReifyActions actions old new =>
NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions @actions forall {k} (a :: k -> *). NP a '[]
Nil NP DdlType new
new
instance (
ReifyOldAction 'False action o new,
ReifyActions actions old new
) => ReifyActions (action : actions) (o : old) new where
reifyActions :: NP DdlType (o : old)
-> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions (DdlType x
o :* NP DdlType xs
old) NP DdlType new
new =
forall (table :: Bool) (action :: ActionK) (old :: DdlTypeK)
(new :: [DdlTypeK]).
ReifyOldAction table action old new =>
DdlType old -> NP DdlType new -> ReifyModResult table
reifyOldAction @'False @action DdlType x
o NP DdlType new
new forall a. Semigroup a => a -> a -> a
<> forall (actions :: [ActionK]) (old :: [DdlTypeK])
(new :: [DdlTypeK]).
ReifyActions actions old new =>
NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions @actions NP DdlType xs
old NP DdlType new
new
type TypeChanges :: [DdlTypeK] -> [DdlTypeK] -> Constraint
class TypeChanges old new where
typeChanges :: NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
instance (
actions ~ MigrationActions (OldKs 0 old) (NewKs 0 new),
ReifyActions actions old new
) => TypeChanges old new where
typeChanges :: NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
typeChanges = forall (actions :: [ActionK]) (old :: [DdlTypeK])
(new :: [DdlTypeK]).
ReifyActions actions old new =>
NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
reifyActions @actions
type TableChange :: DdlTypeK -> DdlTypeK -> Constraint
class TableChange old new where
tableChange :: DdlType old -> DdlType new -> TableAction
instance (
'[oldk] ~ OldKs 0 '[old],
'(action, '[]) ~ MkMigrationAction oldk (NewKs 0 '[new]) '[],
ReifyOldAction 'True action old '[new]
) => TableChange old new where
tableChange :: DdlType old -> DdlType new -> TableAction
tableChange DdlType old
old DdlType new
new =
forall (table :: Bool) (action :: ActionK) (old :: DdlTypeK)
(new :: [DdlTypeK]).
ReifyOldAction table action old new =>
DdlType old -> NP DdlType new -> ReifyModResult table
reifyOldAction @'True @action DdlType old
old (DdlType new
new forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil)