module Sqel.Migration.Column where
import Generics.SOP (NP (Nil, (:*)), hd, tl)
import qualified Hasql.Encoders as Encoders
import Sqel.Class.Mods (OptMod (optMod))
import Sqel.Codec (PrimColumn (primEncoder))
import Sqel.Data.Migration (ColumnAction (AddColumn, RemoveColumn, RenameColumn))
import Sqel.Data.MigrationParams (MigrationDefault (MigrationDefault))
import Sqel.Data.PgType (ColumnType, PgColumnName, pgColumnName)
import Sqel.Kind (type (++))
import Sqel.SOP.Constraint (symbolText)
import Sqel.Migration.Data.Ddl (DdlColumn (DdlColumn), DdlColumnK (DdlColumnK))
data OldK =
OldK {
OldK -> Symbol
name :: Symbol,
OldK -> Maybe Symbol
comp :: Maybe Symbol,
OldK -> Bool
delete :: Bool
}
data NewK =
NewK {
NewK -> Nat
index :: Nat,
NewK -> Symbol
name :: Symbol,
NewK -> Maybe Symbol
comp :: Maybe Symbol,
NewK -> Maybe Symbol
rename :: Maybe Symbol,
NewK -> Maybe Symbol
renameType :: Maybe Symbol
}
data ModK =
KeepK
|
AddK
|
RenameK
data ActionK =
ActionK {
ActionK -> ModK
mod :: ModK,
ActionK -> Nat
index :: Nat
}
|
RemoveK
type family OldKs (index :: Nat) (cols :: [DdlColumnK]) :: [OldK] where
OldKs _ '[] = '[]
OldKs index ('DdlColumnK name comp _ _ _ delete _ : cols) =
'OldK name comp delete : OldKs (index + 1) cols
type family NewKs (index :: Nat) (cols :: [DdlColumnK]) :: [NewK] where
NewKs _ '[] = '[]
NewKs index ('DdlColumnK name comp _ rename renameType _ _ : cols) =
'NewK index name comp rename renameType : NewKs (index + 1) cols
type family MkMigrationAction (old :: OldK) (check :: [NewK]) (other :: [NewK]) :: (ActionK, [NewK]) where
MkMigrationAction ('OldK _ _ 'True) '[] other =
'( 'RemoveK, other)
MkMigrationAction ('OldK name comp 'False) ('NewK index name comp 'Nothing 'Nothing : news) other =
'( 'ActionK 'KeepK index, news ++ other)
MkMigrationAction ('OldK oldName comp 'False) ('NewK index _ comp ('Just oldName) 'Nothing : news) other =
'( 'ActionK 'RenameK index, news ++ other)
MkMigrationAction ('OldK oldName ('Just oldComp) 'False) ('NewK index newName _ rename ('Just oldComp) : news) other =
MkMigrationAction ('OldK oldName ('Just oldComp) 'False) ('NewK index newName ('Just oldComp) rename 'Nothing : news) other
MkMigrationAction old (new : news) other =
MkMigrationAction old news (new : other)
MkMigrationAction old '[] other =
TypeError ("MkMigrationAction:" % old % other)
type family NewMigrationActions (cols :: [NewK]) :: [ActionK] where
NewMigrationActions '[] = '[]
NewMigrationActions ('NewK index _ _ 'Nothing 'Nothing : news) =
'ActionK 'AddK index : NewMigrationActions news
NewMigrationActions cols = TypeError ("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
class ColumnAddition (comp :: Maybe Symbol) (def :: Type) where
columnAddition :: def -> PgColumnName -> ColumnType -> [ColumnAction]
instance ColumnAddition ('Just tname) () where
columnAddition :: () -> PgColumnName -> ColumnType -> [ColumnAction]
columnAddition () PgColumnName
n ColumnType
t = [forall a.
PgColumnName -> ColumnType -> Maybe (a, Params a) -> ColumnAction
AddColumn PgColumnName
n ColumnType
t forall a. Maybe a
Nothing]
instance ColumnAddition 'Nothing () where
columnAddition :: () -> PgColumnName -> ColumnType -> [ColumnAction]
columnAddition () PgColumnName
n ColumnType
t = [forall a.
PgColumnName -> ColumnType -> Maybe (a, Params a) -> ColumnAction
AddColumn PgColumnName
n ColumnType
t forall a. Maybe a
Nothing]
instance (
PrimColumn a
) => ColumnAddition 'Nothing (MigrationDefault a) where
columnAddition :: MigrationDefault a -> PgColumnName -> ColumnType -> [ColumnAction]
columnAddition (MigrationDefault a
a) PgColumnName
n ColumnType
t =
[forall a.
PgColumnName -> ColumnType -> Maybe (a, Params a) -> ColumnAction
AddColumn PgColumnName
n ColumnType
t Maybe (a, Params a)
md]
where
md :: Maybe (a, Params a)
md = forall a. a -> Maybe a
Just (a
a, forall a. NullableOrNot Value a -> Params a
Encoders.param (forall (encoder :: * -> *) a. encoder a -> NullableOrNot encoder a
Encoders.nonNullable (forall a. PrimColumn a => Value a
primEncoder @a)))
class ColIndex index cols col | index cols -> col where
colIndex :: NP f cols -> f col
instance ColIndex 0 (col : cols) col where
colIndex :: forall (f :: k -> *). NP f (col : cols) -> f col
colIndex = forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd
instance {-# overlappable #-} (
ColIndex (n - 1) cols col
) => ColIndex n (c : cols) col where
colIndex :: forall (f :: k -> *). NP f (c : cols) -> f col
colIndex = forall {k} {k} (index :: k) (cols :: [k]) (col :: k) (f :: k -> *).
ColIndex index cols col =>
NP f cols -> f col
colIndex @(n - 1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
NP f (x : xs) -> NP f xs
tl
type ReifyModAction :: ModK -> DdlColumnK -> DdlColumnK -> Constraint
class ReifyModAction action old new where
reifyModAction :: DdlColumn old -> DdlColumn new -> [ColumnAction]
instance ReifyModAction 'KeepK old new where
reifyModAction :: DdlColumn old -> DdlColumn new -> [ColumnAction]
reifyModAction DdlColumn old
_ DdlColumn new
_ = []
instance ReifyModAction 'RenameK ('DdlColumnK name compOld modsOld renameOld renameTOld deleteOld typeOld) ('DdlColumnK nameNew compNew modsNew ('Just name) renameTNew delNew typeNew) where
reifyModAction :: DdlColumn
('DdlColumnK
name compOld modsOld renameOld renameTOld deleteOld typeOld)
-> DdlColumn
('DdlColumnK
nameNew compNew modsNew ('Just name) renameTNew delNew typeNew)
-> [ColumnAction]
reifyModAction (DdlColumn Proxy name
Proxy ColumnType
_ Mods p
_) (DdlColumn Proxy name
Proxy ColumnType
_ Mods p
_) =
[PgColumnName -> PgColumnName -> ColumnAction
RenameColumn (Text -> PgColumnName
pgColumnName (forall (name :: Symbol). KnownSymbol name => Text
symbolText @name)) (Text -> PgColumnName
pgColumnName (forall (name :: Symbol). KnownSymbol name => Text
symbolText @nameNew))]
type ReifyOldAction :: ActionK -> DdlColumnK -> [DdlColumnK] -> Constraint
class ReifyOldAction action old new where
reifyOldAction :: DdlColumn old -> NP DdlColumn new -> [ColumnAction]
instance (
ColIndex index news new,
ReifyModAction mod old new
) => ReifyOldAction ('ActionK mod index) old news where
reifyOldAction :: DdlColumn old -> NP DdlColumn news -> [ColumnAction]
reifyOldAction DdlColumn old
old NP DdlColumn news
news =
forall (action :: ModK) (old :: DdlColumnK) (new :: DdlColumnK).
ReifyModAction action old new =>
DdlColumn old -> DdlColumn new -> [ColumnAction]
reifyModAction @mod DdlColumn old
old DdlColumn new
new
where
new :: DdlColumn new
new = forall {k} {k} (index :: k) (cols :: [k]) (col :: k) (f :: k -> *).
ColIndex index cols col =>
NP f cols -> f col
colIndex @index NP DdlColumn news
news
instance ReifyOldAction 'RemoveK old new where
reifyOldAction :: DdlColumn old -> NP DdlColumn new -> [ColumnAction]
reifyOldAction (DdlColumn (Proxy name
Proxy :: Proxy name) ColumnType
t Mods p
_) NP DdlColumn new
_ =
[PgColumnName -> ColumnType -> ColumnAction
RemoveColumn (Text -> PgColumnName
pgColumnName (forall (name :: Symbol). KnownSymbol name => Text
symbolText @name)) ColumnType
t]
type ReifyNewAction :: ActionK -> [DdlColumnK] -> Constraint
class ReifyNewAction action new where
reifyNewAction :: NP DdlColumn new -> [ColumnAction]
instance (
ColIndex index news ('DdlColumnK name comp mods rename renameT delete tpe),
OptMod (MigrationDefault tpe) mods def,
ColumnAddition comp def
) => ReifyNewAction ('ActionK 'AddK index) news where
reifyNewAction :: NP DdlColumn news -> [ColumnAction]
reifyNewAction NP DdlColumn news
news =
case forall {k} {k} (index :: k) (cols :: [k]) (col :: k) (f :: k -> *).
ColIndex index cols col =>
NP f cols -> f col
colIndex @index NP DdlColumn news
news of
DdlColumn (Proxy name
Proxy :: Proxy name) ColumnType
t Mods p
mods ->
forall (comp :: Maybe Symbol) def.
ColumnAddition comp def =>
def -> PgColumnName -> ColumnType -> [ColumnAction]
columnAddition @comp @def (forall p (ps :: [*]) res. OptMod p ps res => Mods ps -> res
optMod @(MigrationDefault tpe) Mods p
mods) (Text -> PgColumnName
pgColumnName (forall (name :: Symbol). KnownSymbol name => Text
symbolText @name)) ColumnType
t
type ReifyActions :: [ActionK] -> [DdlColumnK] -> [DdlColumnK] -> Constraint
class ReifyActions actions old new where
reifyActions :: NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
instance ReifyActions '[] '[] new where
reifyActions :: NP DdlColumn '[] -> NP DdlColumn new -> [ColumnAction]
reifyActions NP DdlColumn '[]
_ NP DdlColumn new
_ =
forall a. Monoid a => a
mempty
instance (
ReifyNewAction action new,
ReifyActions actions '[] new
) => ReifyActions (action : actions) '[] new where
reifyActions :: NP DdlColumn '[] -> NP DdlColumn new -> [ColumnAction]
reifyActions NP DdlColumn '[]
Nil NP DdlColumn new
new =
forall (action :: ActionK) (new :: [DdlColumnK]).
ReifyNewAction action new =>
NP DdlColumn new -> [ColumnAction]
reifyNewAction @action NP DdlColumn new
new forall a. Semigroup a => a -> a -> a
<> forall (actions :: [ActionK]) (old :: [DdlColumnK])
(new :: [DdlColumnK]).
ReifyActions actions old new =>
NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
reifyActions @actions forall {k} (a :: k -> *). NP a '[]
Nil NP DdlColumn new
new
instance (
ReifyOldAction action o new,
ReifyActions actions old new
) => ReifyActions (action : actions) (o : old) new where
reifyActions :: NP DdlColumn (o : old) -> NP DdlColumn new -> [ColumnAction]
reifyActions (DdlColumn x
o :* NP DdlColumn xs
old) NP DdlColumn new
new =
forall (action :: ActionK) (old :: DdlColumnK)
(new :: [DdlColumnK]).
ReifyOldAction action old new =>
DdlColumn old -> NP DdlColumn new -> [ColumnAction]
reifyOldAction @action DdlColumn x
o NP DdlColumn new
new forall a. Semigroup a => a -> a -> a
<> forall (actions :: [ActionK]) (old :: [DdlColumnK])
(new :: [DdlColumnK]).
ReifyActions actions old new =>
NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
reifyActions @actions NP DdlColumn xs
old NP DdlColumn new
new
type ColumnsChanges :: [DdlColumnK] -> [DdlColumnK] -> Constraint
class ColumnsChanges old new where
columnsChanges :: NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
instance (
actions ~ MigrationActions (OldKs 0 old) (NewKs 0 new),
ReifyActions actions old new
) => ColumnsChanges old new where
columnsChanges :: NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
columnsChanges = forall (actions :: [ActionK]) (old :: [DdlColumnK])
(new :: [DdlColumnK]).
ReifyActions actions old new =>
NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]
reifyActions @actions