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

-- TODO this reverses the other list every time
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

-- TODO removing could be done implicitly, given that only renaming really _necessitates_ explicit marking.
-- The only reason to not do that is to avoid mistakes, but that seems exaggerated since we use unit tests for checking
-- consistency anyway, and integration tests to ensure the tables work
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]

-- TODO error message when no migration default was specified for new column
-- TODO this encoder should be taken from the builder derivation
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]

-- -- TODO this has to check that new columns in composite types are
-- -- a) at the end of the list
-- -- b) Maybe
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