module Sqel.Migration.Transform where

import qualified Data.Map as Map
import Hasql.Statement (Statement)
import Lens.Micro ((^.))
import Sqel (MkTableSchema (tableSchema))
import Sqel.Class.MigrationEffect (MigrationEffect (runStatement, runStatement_))
import Sqel.Data.Dd (Dd, DdType)
import qualified Sqel.Data.Migration as Migration
import Sqel.Data.Migration (
  CompAction,
  CustomMigration (customMigration),
  Mig (Mig),
  Migration,
  MigrationActions (CustomActions),
  )
import Sqel.Data.PgTypeName (PgCompName, pattern PgTypeName)
import Sqel.Data.Sql (sql, toSql)
import Sqel.Data.SqlFragment (Insert (Insert), Select (Select))
import Sqel.Data.TableSchema (TableSchema)
import Sqel.ReifyDd (ReifyDd)
import Sqel.Sql.Type (createTable)
import Sqel.Statement (plain, prepared, unprepared)

import Sqel.Migration.Ddl (DdlTypes, ddTable)
import Sqel.Migration.Run (autoKeys, runTypesMigration)
import Sqel.Migration.Table (MigrationTables (withMigrationTables))
import Sqel.Migration.Type (TypeChanges (typeChanges))

data MigrateTransform m old new =
  MigrateTransform {
    forall (m :: * -> *) old new.
MigrateTransform m old new -> [old] -> m [new]
trans :: [old] -> m [new],
    forall (m :: * -> *) old new.
MigrateTransform m old new -> Map PgCompName CompAction
types :: Map PgCompName CompAction,
    forall (m :: * -> *) old new.
MigrateTransform m old new -> TableSchema old
schemaOld :: TableSchema old,
    forall (m :: * -> *) old new.
MigrateTransform m old new -> TableSchema new
schemaNew :: TableSchema new
  }

class MkMigrateTransform m old new where
  migrateTransform ::
    Dd old ->
    Dd new ->
    ([DdType old] -> m [DdType new]) ->
    Migration ('Mig (DdType old) (DdType new) m (MigrateTransform m (DdType old) (DdType new)))

instance (
    DdlTypes 'True old (oldTable : oldTypes),
    DdlTypes 'True new (newTable : newTypes),
    TypeChanges oldTypes newTypes,
    MkTableSchema old,
    MkTableSchema new,
    ReifyDd old,
    ReifyDd new
  ) => MkMigrateTransform m old new where
    migrateTransform :: Dd old
-> Dd new
-> ([DdType old] -> m [DdType new])
-> Migration
     ('Mig
        (DdType old)
        (DdType new)
        m
        (MigrateTransform m (DdType old) (DdType new)))
migrateTransform Dd old
old Dd new
new [DdType old] -> m [DdType new]
f =
      forall (m :: * -> *) (old :: DdK) (new :: DdK) ext.
MigrationTables m old new =>
MigrationActions ext
-> Dd old
-> Dd new
-> Migration ('Mig (DdType old) (DdType new) m ext)
withMigrationTables (forall ext. ext -> MigrationActions ext
CustomActions MigrateTransform m (DdType old) (DdType new)
actions) Dd old
old Dd new
new
      where
        actions :: MigrateTransform m (DdType old) (DdType new)
actions =
          MigrateTransform {
            $sel:trans:MigrateTransform :: [DdType old] -> m [DdType new]
trans = [DdType old] -> m [DdType new]
f,
            $sel:types:MigrateTransform :: Map PgCompName CompAction
types = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (old :: [DdlTypeK]) (new :: [DdlTypeK]).
TypeChanges old new =>
NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]
typeChanges NP DdlType oldTypes
oldTypes NP DdlType newTypes
newTypes),
            TableSchema (DdType old)
TableSchema (DdType new)
schemaNew :: TableSchema (DdType new)
schemaOld :: TableSchema (DdType old)
$sel:schemaNew:MigrateTransform :: TableSchema (DdType new)
$sel:schemaOld:MigrateTransform :: TableSchema (DdType old)
..
          }
        schemaOld :: TableSchema (DdType old)
schemaOld = forall (table :: DdK).
MkTableSchema table =>
Dd table -> TableSchema (DdType table)
tableSchema Dd old
old
        schemaNew :: TableSchema (DdType new)
schemaNew = forall (table :: DdK).
MkTableSchema table =>
Dd table -> TableSchema (DdType table)
tableSchema Dd new
new
        (DdlType oldTable
_, NP DdlType oldTypes
oldTypes) = forall (s :: DdK) (table :: DdlTypeK) (types :: [DdlTypeK]).
DdlTypes 'True s (table : types) =>
Dd s -> (DdlType table, NP DdlType types)
ddTable Dd old
old
        (DdlType newTable
_, NP DdlType newTypes
newTypes) = forall (s :: DdK) (table :: DdlTypeK) (types :: [DdlTypeK]).
DdlTypes 'True s (table : types) =>
Dd s -> (DdlType table, NP DdlType types)
ddTable Dd new
new

transformAndMigrate ::
  ∀ old new m .
  Monad m =>
  MigrationEffect m =>
  Set PgCompName ->
  MigrateTransform m old new ->
  m ()
transformAndMigrate :: forall old new (m :: * -> *).
(Monad m, MigrationEffect m) =>
Set PgCompName -> MigrateTransform m old new -> m ()
transformAndMigrate Set PgCompName
eligible MigrateTransform {Map PgCompName CompAction
TableSchema old
TableSchema new
[old] -> m [new]
schemaNew :: TableSchema new
schemaOld :: TableSchema old
types :: Map PgCompName CompAction
trans :: [old] -> m [new]
$sel:schemaNew:MigrateTransform :: forall (m :: * -> *) old new.
MigrateTransform m old new -> TableSchema new
$sel:schemaOld:MigrateTransform :: forall (m :: * -> *) old new.
MigrateTransform m old new -> TableSchema old
$sel:types:MigrateTransform :: forall (m :: * -> *) old new.
MigrateTransform m old new -> Map PgCompName CompAction
$sel:trans:MigrateTransform :: forall (m :: * -> *) old new.
MigrateTransform m old new -> [old] -> m [new]
..} = do
  [old]
oldRows <- forall (m :: * -> *) q a.
MigrationEffect m =>
q -> Statement q [a] -> m [a]
runStatement () Statement () [old]
fetchOld
  [new]
newRows <- [old] -> m [new]
trans [old]
oldRows
  forall (m :: * -> *).
(Monad m, MigrationEffect m) =>
Set PgCompName -> Map PgCompName CompAction -> m ()
runTypesMigration Set PgCompName
eligible Map PgCompName CompAction
types
  Sql -> m ()
runPlain [sql|alter table ##{schemaOld ^. #pg . #name} rename to "##{oldName}-migration-temp"|]
  Sql -> m ()
runPlain (forall {k} (a :: k). PgTable a -> Sql
createTable (TableSchema new
schemaNew forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "pg" a => a
#pg))
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [new]
newRows \ new
row -> forall (m :: * -> *) q.
MigrationEffect m =>
q -> Statement q () -> m ()
runStatement_ new
row Statement new ()
insertNew
  where
    PgTypeName Text
oldName = TableSchema old
schemaOld forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "pg" a => a
#pg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsLabel "name" a => a
#name
    runPlain :: Sql -> m ()
runPlain = forall (m :: * -> *) q.
MigrationEffect m =>
q -> Statement q () -> m ()
runStatement_ () forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sql -> Statement () ()
plain
    fetchOld :: Statement () [old]
    fetchOld :: Statement () [old]
fetchOld = forall result d p.
ResultShape d result =>
Sql -> Row d -> Params p -> Statement p result
unprepared [sql|##{Select schemaOld}|] (TableSchema old
schemaOld forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "decoder" a => a
#decoder) forall a. Monoid a => a
mempty
    insertNew :: Statement new ()
    insertNew :: Statement new ()
insertNew = forall d result p.
ResultShape d result =>
Sql -> Row d -> Params p -> Statement p result
prepared (forall a. ToSql a => a -> Sql
toSql (forall a. a -> Insert a
Insert (TableSchema new
schemaNew forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "pg" a => a
#pg))) forall (f :: * -> *). Applicative f => f ()
unit (TableSchema new
schemaNew forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "encoder" a => a
#encoder)

instance (
    Monad m,
    MigrationEffect m
  ) => CustomMigration m ('Mig old new m (MigrateTransform m old new)) where
    customMigration :: PgTypeName 'True
-> Set PgCompName
-> MigExt ('Mig old new m (MigrateTransform m old new))
-> m ()
customMigration PgTypeName 'True
_ =
      forall old new (m :: * -> *).
(Monad m, MigrationEffect m) =>
Set PgCompName -> MigrateTransform m old new -> m ()
transformAndMigrate

    customTypeKeys :: MigExt ('Mig old new m (MigrateTransform m old new))
-> m (Set (PgCompName, Bool))
customTypeKeys MigrateTransform {Map PgCompName CompAction
types :: Map PgCompName CompAction
$sel:types:MigrateTransform :: forall (m :: * -> *) old new.
MigrateTransform m old new -> Map PgCompName CompAction
types} =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PgCompName CompAction -> Set (PgCompName, Bool)
autoKeys Map PgCompName CompAction
types)