module Sqel.Data.Migration where

import Exon (exon)
import Generics.SOP (NP (Nil, (:*)))
import Hasql.Encoders (Params)

import Sqel.Data.Dd ((:>) ((:>)))
import Sqel.Data.PgType (ColumnType, PgColumnName, PgColumns, PgTable)
import Sqel.Data.PgTypeName (PgCompName, PgTableName, PgTypeName)

data ColumnAction where
  AddColumn :: PgColumnName -> ColumnType -> Maybe (a, Params a) -> ColumnAction
  RemoveColumn :: PgColumnName -> ColumnType -> ColumnAction
  RenameColumn :: PgColumnName -> PgColumnName -> ColumnAction
  RenameColumnType :: PgColumnName -> PgCompName -> ColumnAction

instance Show ColumnAction where
  showsPrec :: Int -> ColumnAction -> ShowS
showsPrec Int
d =
    Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      AddColumn PgColumnName
name ColumnType
tpe Maybe (a, Params a)
_ ->
        [exon|AddColumn #{showsPrec 11 name} #{showsPrec 11 tpe}|]
      RemoveColumn PgColumnName
name ColumnType
tpe ->
        [exon|RemoveColumn #{showsPrec 11 name} #{showsPrec 11 tpe}|]
      RenameColumn PgColumnName
old PgColumnName
new ->
        [exon|RenameColumn #{showsPrec 11 old} #{showsPrec 11 new}|]
      RenameColumnType PgColumnName
name PgCompName
new ->
        [exon|RenameColumnType #{showsPrec 11 name} #{showsPrec 11 new}|]

data TypeAction (table :: Bool) where
  ModifyAction :: PgTypeName table -> [ColumnAction] -> TypeAction table
  RenameAction :: PgCompName -> [ColumnAction] -> TypeAction 'False
  AddAction :: PgColumns -> TypeAction 'False

type TableAction = TypeAction 'True
type CompAction = TypeAction 'False

data MigrationActions ext =
  AutoActions {
    forall ext. MigrationActions ext -> TableAction
table :: TableAction,
    forall ext. MigrationActions ext -> Map PgCompName CompAction
types :: Map PgCompName CompAction
  }
  |
  CustomActions ext
  deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ext x. Rep (MigrationActions ext) x -> MigrationActions ext
forall ext x. MigrationActions ext -> Rep (MigrationActions ext) x
$cto :: forall ext x. Rep (MigrationActions ext) x -> MigrationActions ext
$cfrom :: forall ext x. MigrationActions ext -> Rep (MigrationActions ext) x
Generic)

data Mig =
  Mig {
    Mig -> *
from :: Type,
    Mig -> *
to :: Type,
    Mig -> * -> *
effect :: Type -> Type,
    Mig -> *
ext :: Type
  }

type Migration :: Mig -> Type
data Migration t where
  Migration :: {
    forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable from
tableFrom :: PgTable from,
    forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable to
tableTo :: PgTable to,
    forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> MigrationActions ext
actions :: MigrationActions ext
  } -> Migration ('Mig from to m ext)

type family MigFrom (mig :: Mig) :: Type where
  MigFrom ('Mig from _ _ _) = from

type family MigTo (mig :: Mig) :: Type where
  MigTo ('Mig _ to _ _) = to

type family MigEff (mig :: Mig) :: Type -> Type where
  MigEff ('Mig _ _ m _) = m

type family MigExt (mig :: Mig) :: Type where
  MigExt ('Mig _ _ _ ext) = ext

type UniMigList :: (Type -> Type) -> Type -> [Type] -> [Mig]
type family UniMigList m ext as where
  UniMigList _ _ '[] = '[]
  UniMigList m ext [new, old] = '[ 'Mig old new m ext]
  UniMigList m ext (new : old : as) = 'Mig old new m ext : UniMigList m ext (old : as)

type UniMigs :: (Type -> Type) -> Type -> [Type] -> Type -> [Mig]
type family UniMigs m ext old cur where
  UniMigs _ _ '[] _ = '[]
  UniMigs m ext '[o] cur = '[ 'Mig o cur m ext]
  UniMigs m ext (o : os) cur = 'Mig o cur m ext : UniMigList m ext (o : os)

type Migrations :: (Type -> Type) -> [Mig] -> Type
newtype Migrations m migs =
  Migrations { forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> NP Migration migs
unMigrations :: NP Migration migs }

type UniMigrations m ext old cur =
  Migrations m (UniMigs m ext old cur)

type AutoMigrations m old cur =
  UniMigrations m Void old cur

class MkMigrations arg migs | arg -> migs, migs -> arg where
  mkMigrations :: arg -> NP Migration migs

instance (
    MkMigrations old (mig1 : migs)
  ) => MkMigrations (Migration ('Mig from to m ext) :> old) ('Mig from to m ext : mig1 : migs) where
    mkMigrations :: (Migration ('Mig from to m ext) :> old)
-> NP Migration ('Mig from to m ext : mig1 : migs)
mkMigrations (Migration ('Mig from to m ext)
next :> old
old) =
      Migration ('Mig from to m ext)
next forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall arg (migs :: [Mig]).
MkMigrations arg migs =>
arg -> NP Migration migs
mkMigrations old
old

instance MkMigrations (Migration ('Mig from to m ext)) '[ 'Mig from to m ext] where
  mkMigrations :: Migration ('Mig from to m ext)
-> NP Migration '[ 'Mig from to m ext]
mkMigrations Migration ('Mig from to m ext)
next =
    Migration ('Mig from to m ext)
next forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil

migrate ::
  MkMigrations arg migs =>
  arg ->
  Migrations m migs
migrate :: forall arg (migs :: [Mig]) (m :: * -> *).
MkMigrations arg migs =>
arg -> Migrations m migs
migrate =
  forall (m :: * -> *) (migs :: [Mig]).
NP Migration migs -> Migrations m migs
Migrations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall arg (migs :: [Mig]).
MkMigrations arg migs =>
arg -> NP Migration migs
mkMigrations

noMigrations :: Migrations m '[]
noMigrations :: forall (m :: * -> *). Migrations m '[]
noMigrations =
  forall (m :: * -> *) (migs :: [Mig]).
NP Migration migs -> Migrations m migs
Migrations forall {k} (a :: k -> *). NP a '[]
Nil

class CustomMigration m mig where
  customTypeKeys :: MigExt mig -> m (Set (PgCompName, Bool))
  customMigration :: PgTableName -> Set PgCompName -> MigExt mig -> m ()

instance CustomMigration m ('Mig from to m Void) where
  customTypeKeys :: MigExt ('Mig from to m Void) -> m (Set (PgCompName, Bool))
customTypeKeys = MigExt ('Mig from to m Void) -> m (Set (PgCompName, Bool))
\case
  customMigration :: PgTableName
-> Set PgCompName -> MigExt ('Mig from to m Void) -> m ()
customMigration PgTableName
_ Set PgCompName
_ = MigExt ('Mig from to m Void) -> m ()
\case

class HoistMigration m n ext ext' | m n ext -> ext' where
  hoistMigration :: (∀ x . m x -> n x) -> ext -> ext'

instance HoistMigration m n Void Void where
  hoistMigration :: (forall (x :: k). m x -> n x) -> Void -> Void
hoistMigration forall (x :: k). m x -> n x
_ = Void -> Void
\case

class HoistMigrations m n migs migs' | m n migs -> migs' where
  hoistMigrations :: (∀ x . m x -> n x) -> Migrations m migs -> Migrations n migs'

instance HoistMigrations m n '[] '[] where
  hoistMigrations :: (forall x. m x -> n x) -> Migrations m '[] -> Migrations n '[]
hoistMigrations forall x. m x -> n x
_ Migrations {NP Migration '[]
unMigrations :: NP Migration '[]
$sel:unMigrations:Migrations :: forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> NP Migration migs
..} = Migrations {NP Migration '[]
unMigrations :: NP Migration '[]
$sel:unMigrations:Migrations :: NP Migration '[]
..}

instance (
    HoistMigration m n ext ext',
    HoistMigrations m n migs migs'
  ) => HoistMigrations m n ('Mig from to m ext : migs) ('Mig from to n ext' : migs') where
  hoistMigrations :: (forall x. m x -> n x)
-> Migrations m ('Mig from to m ext : migs)
-> Migrations n ('Mig from to n ext' : migs')
hoistMigrations forall x. m x -> n x
f (Migrations (Migration {PgTable from
PgTable to
MigrationActions ext
actions :: MigrationActions ext
tableTo :: PgTable to
tableFrom :: PgTable from
$sel:actions:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> MigrationActions ext
$sel:tableTo:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable to
$sel:tableFrom:Migration :: forall from to ext (m :: * -> *).
Migration ('Mig from to m ext) -> PgTable from
..} :* NP Migration xs
migs)) =
    forall (m :: * -> *) (migs :: [Mig]).
NP Migration migs -> Migrations m migs
Migrations (Migration {$sel:actions:Migration :: MigrationActions ext'
actions = MigrationActions ext -> MigrationActions ext'
hoistAction MigrationActions ext
actions, PgTable from
PgTable to
tableTo :: PgTable to
tableFrom :: PgTable from
$sel:tableTo:Migration :: PgTable to
$sel:tableFrom:Migration :: PgTable from
..} forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall (m :: * -> *) (migs :: [Mig]).
Migrations m migs -> NP Migration migs
unMigrations (forall (m :: * -> *) (n :: * -> *) (migs :: [Mig])
       (migs' :: [Mig]).
HoistMigrations m n migs migs' =>
(forall x. m x -> n x) -> Migrations m migs -> Migrations n migs'
hoistMigrations forall x. m x -> n x
f (forall (m :: * -> *) (migs :: [Mig]).
NP Migration migs -> Migrations m migs
Migrations NP Migration xs
migs)))
    where
      hoistAction :: MigrationActions ext -> MigrationActions ext'
hoistAction = \case
        CustomActions ext
ext -> forall ext. ext -> MigrationActions ext
CustomActions (forall {k} (m :: k -> *) (n :: k -> *) ext ext'.
HoistMigration m n ext ext' =>
(forall (x :: k). m x -> n x) -> ext -> ext'
hoistMigration forall x. m x -> n x
f ext
ext)
        AutoActions {Map PgCompName CompAction
TableAction
types :: Map PgCompName CompAction
table :: TableAction
$sel:types:AutoActions :: forall ext. MigrationActions ext -> Map PgCompName CompAction
$sel:table:AutoActions :: forall ext. MigrationActions ext -> TableAction
..} -> AutoActions {Map PgCompName CompAction
TableAction
types :: Map PgCompName CompAction
table :: TableAction
$sel:types:AutoActions :: Map PgCompName CompAction
$sel:table:AutoActions :: TableAction
..}