{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | This helper module is intended for use by the backend creators
module Database.Groundhog.Generic.Migration
  ( Column (..),
    Reference (..),
    QualifiedName,
    TableInfo (..),
    UniqueDefInfo,
    AlterColumn (..),
    AlterTable (..),
    AlterDB (..),
    MigrationPack (..),
    SchemaAnalyzer (..),
    migrateRecursively,
    migrateSchema,
    migrateEntity,
    migrateList,
    getAlters,
    defaultMigConstr,
    showReferenceAction,
    readReferenceAction,
  )
where

import Control.Arrow ((&&&), (***))
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (gets, modify)
import Data.Either (lefts)
import Data.Function (on)
import Data.List (group, intercalate)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.Generic.Sql (flatten, mainTableName, tableName)

data Column = Column
  { Column -> String
colName :: String,
    Column -> Bool
colNull :: Bool,
    Column -> DbTypePrimitive
colType :: DbTypePrimitive,
    Column -> Maybe String
colDefault :: Maybe String
  }
  deriving (Column -> Column -> Bool
(Column -> Column -> Bool)
-> (Column -> Column -> Bool) -> Eq Column
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Column -> Column -> Bool
$c/= :: Column -> Column -> Bool
== :: Column -> Column -> Bool
$c== :: Column -> Column -> Bool
Eq, Int -> Column -> ShowS
[Column] -> ShowS
Column -> String
(Int -> Column -> ShowS)
-> (Column -> String) -> ([Column] -> ShowS) -> Show Column
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Column] -> ShowS
$cshowList :: [Column] -> ShowS
show :: Column -> String
$cshow :: Column -> String
showsPrec :: Int -> Column -> ShowS
$cshowsPrec :: Int -> Column -> ShowS
Show)

data Reference = Reference
  { Reference -> QualifiedName
referencedTableName :: QualifiedName,
    -- | child column, parent column
    Reference -> [(String, String)]
referencedColumns :: [(String, String)],
    Reference -> Maybe ReferenceActionType
referenceOnDelete :: Maybe ReferenceActionType,
    Reference -> Maybe ReferenceActionType
referenceOnUpdate :: Maybe ReferenceActionType
  }
  deriving (Int -> Reference -> ShowS
[Reference] -> ShowS
Reference -> String
(Int -> Reference -> ShowS)
-> (Reference -> String)
-> ([Reference] -> ShowS)
-> Show Reference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reference] -> ShowS
$cshowList :: [Reference] -> ShowS
show :: Reference -> String
$cshow :: Reference -> String
showsPrec :: Int -> Reference -> ShowS
$cshowsPrec :: Int -> Reference -> ShowS
Show)

-- | Schema-qualified name of a table of another database object
type QualifiedName = (Maybe String, String)

-- | Either column name or expression
type UniqueDefInfo = UniqueDef' String (Either String String)

data TableInfo = TableInfo
  { TableInfo -> [Column]
tableColumns :: [Column],
    TableInfo -> [UniqueDefInfo]
tableUniques :: [UniqueDefInfo],
    -- | constraint name and reference
    TableInfo -> [(Maybe String, Reference)]
tableReferences :: [(Maybe String, Reference)]
  }
  deriving (Int -> TableInfo -> ShowS
[TableInfo] -> ShowS
TableInfo -> String
(Int -> TableInfo -> ShowS)
-> (TableInfo -> String)
-> ([TableInfo] -> ShowS)
-> Show TableInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TableInfo] -> ShowS
$cshowList :: [TableInfo] -> ShowS
show :: TableInfo -> String
$cshow :: TableInfo -> String
showsPrec :: Int -> TableInfo -> ShowS
$cshowsPrec :: Int -> TableInfo -> ShowS
Show)

data AlterColumn
  = Type DbTypePrimitive
  | IsNull
  | NotNull
  | Default String
  | NoDefault
  | UpdateValue String
  deriving (Int -> AlterColumn -> ShowS
[AlterColumn] -> ShowS
AlterColumn -> String
(Int -> AlterColumn -> ShowS)
-> (AlterColumn -> String)
-> ([AlterColumn] -> ShowS)
-> Show AlterColumn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlterColumn] -> ShowS
$cshowList :: [AlterColumn] -> ShowS
show :: AlterColumn -> String
$cshow :: AlterColumn -> String
showsPrec :: Int -> AlterColumn -> ShowS
$cshowsPrec :: Int -> AlterColumn -> ShowS
Show)

data AlterTable
  = AddUnique UniqueDefInfo
  | DropConstraint String
  | DropIndex String
  | AddReference Reference
  | DropReference String
  | DropColumn String
  | AddColumn Column
  | AlterColumn Column [AlterColumn]
  deriving (Int -> AlterTable -> ShowS
[AlterTable] -> ShowS
AlterTable -> String
(Int -> AlterTable -> ShowS)
-> (AlterTable -> String)
-> ([AlterTable] -> ShowS)
-> Show AlterTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlterTable] -> ShowS
$cshowList :: [AlterTable] -> ShowS
show :: AlterTable -> String
$cshow :: AlterTable -> String
showsPrec :: Int -> AlterTable -> ShowS
$cshowsPrec :: Int -> AlterTable -> ShowS
Show)

data AlterDB
  = AddTable String
  | -- | Qualified table name, create statement, structure of table from DB, structure of table from datatype, alters
    AlterTable QualifiedName String TableInfo TableInfo [AlterTable]
  | -- | Qualified trigger name, qualified table name
    DropTrigger QualifiedName QualifiedName
  | -- | Qualified trigger name, qualified table name, body
    AddTriggerOnDelete QualifiedName QualifiedName String
  | -- | Qualified trigger name, qualified table name, field name, body
    AddTriggerOnUpdate QualifiedName QualifiedName (Maybe String) String
  | -- | Statement which creates the function
    CreateOrReplaceFunction String
  | -- | Qualified function name
    DropFunction QualifiedName
  | -- | Schema name, if not exists
    CreateSchema String Bool
  deriving (Int -> AlterDB -> ShowS
[AlterDB] -> ShowS
AlterDB -> String
(Int -> AlterDB -> ShowS)
-> (AlterDB -> String) -> ([AlterDB] -> ShowS) -> Show AlterDB
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlterDB] -> ShowS
$cshowList :: [AlterDB] -> ShowS
show :: AlterDB -> String
$cshow :: AlterDB -> String
showsPrec :: Int -> AlterDB -> ShowS
$cshowsPrec :: Int -> AlterDB -> ShowS
Show)

data MigrationPack conn = MigrationPack
  { MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool,
    MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool,
    MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool,
    MigrationPack conn -> String -> String -> Bool
compareDefaults :: String -> String -> Bool,
    MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action conn (Bool, [AlterDB]),
    MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action conn [(Bool, [AlterDB])],
    MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration),
    MigrationPack conn -> ShowS
escape :: String -> String,
    MigrationPack conn -> String
autoincrementedKeyTypeName :: String,
    MigrationPack conn -> String
mainTableId :: String,
    MigrationPack conn -> Int
defaultPriority :: Int,
    -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created
    MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable]),
    MigrationPack conn -> DbTypePrimitive -> String
showSqlType :: DbTypePrimitive -> String,
    MigrationPack conn -> Column -> String
showColumn :: Column -> String,
    MigrationPack conn -> AlterDB -> SingleMigration
showAlterDb :: AlterDB -> SingleMigration,
    MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType,
    MigrationPack conn -> ReferenceActionType
defaultReferenceOnUpdate :: ReferenceActionType
  }

mkColumns :: DbTypePrimitive -> (String, DbType) -> ([Column] -> [Column])
mkColumns :: DbTypePrimitive -> (String, DbType) -> [Column] -> [Column]
mkColumns DbTypePrimitive
listAutoKeyType = String -> (String, DbType) -> [Column] -> [Column]
go String
""
  where
    go :: String -> (String, DbType) -> [Column] -> [Column]
go String
prefix (String
fname, DbType
typ) [Column]
acc =
      case DbType
typ of
        DbEmbedded (EmbeddedDef Bool
flag [(String, DbType)]
ts) Maybe ParentTableReference
_ -> ((String, DbType) -> [Column] -> [Column])
-> [Column] -> [(String, DbType)] -> [Column]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> (String, DbType) -> [Column] -> [Column]
go String
prefix') [Column]
acc [(String, DbType)]
ts where prefix' :: String
prefix' = if Bool
flag then String
"" else String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
delim]
        DbList String
_ DbType
_ -> String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
fullName Bool
False DbTypePrimitive
listAutoKeyType Maybe String
forall a. Maybe a
Nothing Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: [Column]
acc
        DbTypePrimitive DbTypePrimitive
t Bool
nullable Maybe String
def Maybe ParentTableReference
_ -> String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
fullName Bool
nullable DbTypePrimitive
t Maybe String
def Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: [Column]
acc
      where
        fullName :: String
fullName = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname

mkReferences :: DbTypePrimitive -> (String, DbType) -> [Reference]
mkReferences :: DbTypePrimitive -> (String, DbType) -> [Reference]
mkReferences DbTypePrimitive
autoKeyType (String, DbType)
field = [[Reference]] -> [Reference]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Reference]] -> [Reference]) -> [[Reference]] -> [Reference]
forall a b. (a -> b) -> a -> b
$ (DbType -> [String] -> [Reference])
-> (String, DbType) -> [[Reference]]
forall a. (DbType -> [String] -> a) -> (String, DbType) -> [a]
traverseDbType DbType -> [String] -> [Reference]
f (String, DbType)
field
  where
    f :: DbType -> [String] -> [Reference]
f (DbEmbedded EmbeddedDef' String DbType
_ Maybe ParentTableReference
ref) [String]
cols = [Reference]
-> (ParentTableReference -> [Reference])
-> Maybe ParentTableReference
-> [Reference]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Reference -> [Reference]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference -> [Reference])
-> (ParentTableReference -> Reference)
-> ParentTableReference
-> [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ParentTableReference -> Reference
mkReference [String]
cols) Maybe ParentTableReference
ref
    f (DbList String
lName DbType
_) [String]
cols = [[String] -> ParentTableReference -> Reference
mkReference [String]
cols ((QualifiedName, [String])
-> Either (EntityDef, Maybe String) (QualifiedName, [String])
forall a b. b -> Either a b
Right ((Maybe String
forall a. Maybe a
Nothing, String
lName), [String
"id"]), Maybe ReferenceActionType
forall a. Maybe a
Nothing, Maybe ReferenceActionType
forall a. Maybe a
Nothing)]
    f (DbTypePrimitive DbTypePrimitive
_ Bool
_ Maybe String
_ Maybe ParentTableReference
ref) [String]
cols = [Reference]
-> (ParentTableReference -> [Reference])
-> Maybe ParentTableReference
-> [Reference]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Reference -> [Reference]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference -> [Reference])
-> (ParentTableReference -> Reference)
-> ParentTableReference
-> [Reference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ParentTableReference -> Reference
mkReference [String]
cols) Maybe ParentTableReference
ref
    mkReference :: [String] -> ParentTableReference -> Reference
    mkReference :: [String] -> ParentTableReference -> Reference
mkReference [String]
cols (Either (EntityDef, Maybe String) (QualifiedName, [String])
parent, Maybe ReferenceActionType
onDel, Maybe ReferenceActionType
onUpd) = case Either (EntityDef, Maybe String) (QualifiedName, [String])
parent of
      Left (EntityDef
e, Maybe String
Nothing) -> QualifiedName
-> [(String, String)]
-> Maybe ReferenceActionType
-> Maybe ReferenceActionType
-> Reference
Reference (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, EntityDef -> String
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e) ((String -> String -> (String, String))
-> [String] -> [String] -> [(String, String)]
forall t t a. (t -> t -> a) -> [t] -> [t] -> [a]
zipWith' (,) [String]
cols [String
keyName]) Maybe ReferenceActionType
onDel Maybe ReferenceActionType
onUpd
        where
          keyName :: String
keyName = case EntityDef -> [ConstructorDef]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors EntityDef
e of
            [ConstructorDef
cDef] -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
"mkReferences: autokey name is Nothing") (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ConstructorDef -> Maybe String
forall str dbType. ConstructorDef' str dbType -> Maybe str
constrAutoKeyName ConstructorDef
cDef
            [ConstructorDef]
_ -> String
"id"
      Left (EntityDef
e, Just String
uName) -> QualifiedName
-> [(String, String)]
-> Maybe ReferenceActionType
-> Maybe ReferenceActionType
-> Reference
Reference (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, EntityDef -> String
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e) ((String -> String -> (String, String))
-> [String] -> [String] -> [(String, String)]
forall t t a. (t -> t -> a) -> [t] -> [t] -> [a]
zipWith' (,) [String]
cols ((Column -> String) -> [Column] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Column -> String
colName [Column]
parentColumns)) Maybe ReferenceActionType
onDel Maybe ReferenceActionType
onUpd
        where
          cDef :: ConstructorDef
cDef = case EntityDef -> [ConstructorDef]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors EntityDef
e of
            [ConstructorDef
cDef'] -> ConstructorDef
cDef'
            [ConstructorDef]
_ -> String -> ConstructorDef
forall a. HasCallStack => String -> a
error String
"mkReferences: datatype with unique key cannot have more than one constructor"
          uDef :: UniqueDef' String (Either (String, DbType) String)
uDef = String
-> (UniqueDef' String (Either (String, DbType) String)
    -> Maybe String)
-> Maybe String
-> [UniqueDef' String (Either (String, DbType) String)]
-> UniqueDef' String (Either (String, DbType) String)
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"unique" UniqueDef' String (Either (String, DbType) String) -> Maybe String
forall str field. UniqueDef' str field -> Maybe str
uniqueDefName (String -> Maybe String
forall a. a -> Maybe a
Just String
uName) ([UniqueDef' String (Either (String, DbType) String)]
 -> UniqueDef' String (Either (String, DbType) String))
-> [UniqueDef' String (Either (String, DbType) String)]
-> UniqueDef' String (Either (String, DbType) String)
forall a b. (a -> b) -> a -> b
$ ConstructorDef
-> [UniqueDef' String (Either (String, DbType) String)]
forall str dbType.
ConstructorDef' str dbType
-> [UniqueDef' str (Either (str, dbType) str)]
constrUniques ConstructorDef
cDef
          fields :: [(String, DbType)]
fields = ((String, DbType) -> (String, DbType))
-> [(String, DbType)] -> [(String, DbType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
fName, DbType
_) -> String
-> ((String, DbType) -> String)
-> String
-> [(String, DbType)]
-> (String, DbType)
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"field" (String, DbType) -> String
forall a b. (a, b) -> a
fst String
fName ([(String, DbType)] -> (String, DbType))
-> [(String, DbType)] -> (String, DbType)
forall a b. (a -> b) -> a -> b
$ ConstructorDef -> [(String, DbType)]
forall str dbType. ConstructorDef' str dbType -> [(str, dbType)]
constrParams ConstructorDef
cDef) ([(String, DbType)] -> [(String, DbType)])
-> [(String, DbType)] -> [(String, DbType)]
forall a b. (a -> b) -> a -> b
$ UniqueDef' String (Either (String, DbType) String)
-> [(String, DbType)]
forall str field. UniqueDef' str (Either field str) -> [field]
getUniqueFields UniqueDef' String (Either (String, DbType) String)
uDef
          parentColumns :: [Column]
parentColumns = ((String, DbType) -> [Column] -> [Column])
-> [Column] -> [(String, DbType)] -> [Column]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DbTypePrimitive -> (String, DbType) -> [Column] -> [Column]
mkColumns DbTypePrimitive
autoKeyType) [] [(String, DbType)]
fields
      Right (QualifiedName
parentTable, [String]
parentColumns) -> QualifiedName
-> [(String, String)]
-> Maybe ReferenceActionType
-> Maybe ReferenceActionType
-> Reference
Reference QualifiedName
parentTable ((String -> String -> (String, String))
-> [String] -> [String] -> [(String, String)]
forall t t a. (t -> t -> a) -> [t] -> [t] -> [a]
zipWith' (,) [String]
cols [String]
parentColumns) Maybe ReferenceActionType
onDel Maybe ReferenceActionType
onUpd
    zipWith' :: (t -> t -> a) -> [t] -> [t] -> [a]
zipWith' t -> t -> a
_ [] [] = []
    zipWith' t -> t -> a
g (t
x : [t]
xs) (t
y : [t]
ys) = t -> t -> a
g t
x t
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (t -> t -> a) -> [t] -> [t] -> [a]
zipWith' t -> t -> a
g [t]
xs [t]
ys
    zipWith' t -> t -> a
_ [t]
_ [t]
_ = String -> [a]
forall a. HasCallStack => String -> a
error String
"mkReferences: the lists have different length"

traverseDbType :: (DbType -> [String] -> a) -> (String, DbType) -> [a]
traverseDbType :: (DbType -> [String] -> a) -> (String, DbType) -> [a]
traverseDbType DbType -> [String] -> a
f (String, DbType)
field = ([String], [a]) -> [a]
forall a b. (a, b) -> b
snd (([String], [a]) -> [a]) -> ([String], [a]) -> [a]
forall a b. (a -> b) -> a -> b
$ String -> (String, DbType) -> ([String], [a])
go String
"" (String, DbType)
field
  where
    go :: String -> (String, DbType) -> ([String], [a])
go String
prefix (String
fname, DbType
typ) =
      case DbType
typ of
        t :: DbType
t@(DbEmbedded (EmbeddedDef Bool
flag [(String, DbType)]
ts) Maybe ParentTableReference
_) -> ([String]
cols, DbType -> [String] -> a
f DbType
t [String]
cols a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
          where
            prefix' :: String
prefix' = if Bool
flag then String
"" else String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
delim]
            ([String]
cols, [a]
xs) = ((String, DbType) -> ([String], [a]))
-> [(String, DbType)] -> ([String], [a])
forall a a a. (a -> ([a], [a])) -> [a] -> ([a], [a])
concatMap' (String -> (String, DbType) -> ([String], [a])
go String
prefix') [(String, DbType)]
ts
        t :: DbType
t@DbList {} -> ([String
name], [DbType -> [String] -> a
f DbType
t [String
name]])
        t :: DbType
t@DbTypePrimitive {} -> ([String
name], [DbType -> [String] -> a
f DbType
t [String
name]])
      where
        name :: String
name = String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fname
        concatMap' :: (a -> ([a], [a])) -> [a] -> ([a], [a])
concatMap' a -> ([a], [a])
g [a]
xs = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([[a]] -> [a]) -> ([[a]], [[a]]) -> ([a], [a])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[a]], [[a]]) -> ([a], [a])) -> ([[a]], [[a]]) -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ [([a], [a])] -> ([[a]], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([a], [a])] -> ([[a]], [[a]])) -> [([a], [a])] -> ([[a]], [[a]])
forall a b. (a -> b) -> a -> b
$ (a -> ([a], [a])) -> [a] -> [([a], [a])]
forall a b. (a -> b) -> [a] -> [b]
map a -> ([a], [a])
g [a]
xs

-- | Create migration for a given entity and all entities it depends on.
-- The stateful Map is used to avoid duplicate migrations when an entity type
-- occurs several times in a datatype
migrateRecursively ::
  (PersistBackend m, PersistEntity v) =>
  -- | migrate schema
  (String -> m SingleMigration) ->
  -- | migrate entity
  (EntityDef -> m SingleMigration) ->
  -- | migrate list
  (DbType -> m SingleMigration) ->
  -- | initial entity
  v ->
  Migration m
migrateRecursively :: (String -> m SingleMigration)
-> (EntityDef -> m SingleMigration)
-> (DbType -> m SingleMigration)
-> v
-> Migration m
migrateRecursively String -> m SingleMigration
migS EntityDef -> m SingleMigration
migE DbType -> m SingleMigration
migL v
v = Migration m
result
  where
    result :: Migration m
result = EntityDef -> Migration m
migEntity (EntityDef -> Migration m) -> EntityDef -> Migration m
forall a b. (a -> b) -> a -> b
$ Any (Conn m) -> v -> EntityDef
forall v db (proxy :: * -> *).
(PersistEntity v, DbDescriptor db) =>
proxy db -> v -> EntityDef
entityDef Any (Conn m)
proxy v
v
    proxy :: Any (Conn m)
proxy = (forall a. HasCallStack => a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a (proxy :: * -> *).
t m a -> proxy (Conn m)
undefined :: t m a -> proxy (Conn m)) Migration m
result
    go :: DbType -> Migration m
go l :: DbType
l@(DbList String
lName DbType
t) = String -> m SingleMigration -> Migration m -> Migration m
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
k -> m a -> StateT (Map k a) m () -> StateT (Map k a) m ()
f (String
"list " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lName) (DbType -> m SingleMigration
migL DbType
l) (DbType -> Migration m
go DbType
t)
    go (DbEmbedded (EmbeddedDef Bool
_ [(String, DbType)]
ts) Maybe ParentTableReference
ref) = ((String, DbType) -> Migration m)
-> [(String, DbType)] -> Migration m
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DbType -> Migration m
go (DbType -> Migration m)
-> ((String, DbType) -> DbType) -> (String, DbType) -> Migration m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, DbType) -> DbType
forall a b. (a, b) -> b
snd) [(String, DbType)]
ts Migration m -> Migration m -> Migration m
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ParentTableReference -> Migration m
migRef Maybe ParentTableReference
ref
    go (DbTypePrimitive DbTypePrimitive
_ Bool
_ Maybe String
_ Maybe ParentTableReference
ref) = Maybe ParentTableReference -> Migration m
migRef Maybe ParentTableReference
ref
    allSubtypes :: EntityDef' a b -> [b]
allSubtypes = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b])
-> (EntityDef' a b -> [(a, b)]) -> EntityDef' a b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorDef' a b -> [(a, b)])
-> [ConstructorDef' a b] -> [(a, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorDef' a b -> [(a, b)]
forall str dbType. ConstructorDef' str dbType -> [(str, dbType)]
constrParams ([ConstructorDef' a b] -> [(a, b)])
-> (EntityDef' a b -> [ConstructorDef' a b])
-> EntityDef' a b
-> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef' a b -> [ConstructorDef' a b]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors
    migRef :: Maybe ParentTableReference -> Migration m
migRef Maybe ParentTableReference
ref = case Maybe ParentTableReference
ref of
      Just (Left (EntityDef
e, Maybe String
_), Maybe ReferenceActionType
_, Maybe ReferenceActionType
_) -> EntityDef -> Migration m
migEntity EntityDef
e
      Maybe ParentTableReference
_ -> () -> Migration m
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    migEntity :: EntityDef -> Migration m
migEntity EntityDef
e = do
      case EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e of
        Just String
name -> String -> m SingleMigration -> Migration m -> Migration m
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
k -> m a -> StateT (Map k a) m () -> StateT (Map k a) m ()
f (String
"schema " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name) (String -> m SingleMigration
migS String
name) (() -> Migration m
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Maybe String
Nothing -> () -> Migration m
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      String -> m SingleMigration -> Migration m -> Migration m
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
k -> m a -> StateT (Map k a) m () -> StateT (Map k a) m ()
f (String
"entity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS -> EntityDef -> String
forall s. StringLike s => (s -> s) -> EntityDef -> s
mainTableName ShowS
forall a. a -> a
id EntityDef
e) (EntityDef -> m SingleMigration
migE EntityDef
e) ((DbType -> Migration m) -> [DbType] -> Migration m
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DbType -> Migration m
go (EntityDef -> [DbType]
forall a b. EntityDef' a b -> [b]
allSubtypes EntityDef
e))
    f :: k -> m a -> StateT (Map k a) m () -> StateT (Map k a) m ()
f k
name m a
mig StateT (Map k a) m ()
cont = do
      Maybe a
a <- (Map k a -> Maybe a) -> StateT (Map k a) m (Maybe a)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
name)
      Bool -> StateT (Map k a) m () -> StateT (Map k a) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
a) (StateT (Map k a) m () -> StateT (Map k a) m ())
-> StateT (Map k a) m () -> StateT (Map k a) m ()
forall a b. (a -> b) -> a -> b
$
        m a -> StateT (Map k a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
mig StateT (Map k a) m a
-> (a -> StateT (Map k a) m ()) -> StateT (Map k a) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Map k a -> Map k a) -> StateT (Map k a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Map k a -> Map k a) -> StateT (Map k a) m ())
-> (a -> Map k a -> Map k a) -> a -> StateT (Map k a) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
name StateT (Map k a) m ()
-> StateT (Map k a) m () -> StateT (Map k a) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT (Map k a) m ()
cont

migrateSchema :: SchemaAnalyzer conn => MigrationPack conn -> String -> Action conn SingleMigration
migrateSchema :: MigrationPack conn -> String -> Action conn SingleMigration
migrateSchema MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} String
schema = do
  Bool
x <- String -> ReaderT conn IO Bool
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
String -> m Bool
schemaExists String
schema
  SingleMigration -> Action conn SingleMigration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleMigration -> Action conn SingleMigration)
-> SingleMigration -> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$
    if Bool
x
      then [(Bool, Int, String)] -> SingleMigration
forall a b. b -> Either a b
Right []
      else AlterDB -> SingleMigration
showAlterDb (AlterDB -> SingleMigration) -> AlterDB -> SingleMigration
forall a b. (a -> b) -> a -> b
$ String -> Bool -> AlterDB
CreateSchema String
schema Bool
False

migrateEntity :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> Action conn SingleMigration
migrateEntity :: MigrationPack conn -> EntityDef -> Action conn SingleMigration
migrateEntity m :: MigrationPack conn
m@MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} EntityDef
e = do
  DbTypePrimitive
autoKeyType <- (Any conn -> DbTypePrimitive)
-> ReaderT conn IO (Any conn) -> ReaderT conn IO DbTypePrimitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any conn -> DbTypePrimitive
forall db (proxy :: * -> *).
DbDescriptor db =>
proxy db -> DbTypePrimitive
getDefaultAutoKeyType ReaderT conn IO (Any conn)
forall (m :: * -> *) (proxy :: * -> *).
PersistBackend m =>
m (proxy (Conn m))
phantomDb
  let name :: String
name = EntityDef -> String
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e
      constrs :: [ConstructorDef]
constrs = EntityDef -> [ConstructorDef]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors EntityDef
e
      mainTableQuery :: String
mainTableQuery = String
"CREATE TABLE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escape String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mainTableId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
autoincrementedKeyTypeName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", discr INTEGER NOT NULL)"
      expectedMainStructure :: TableInfo
expectedMainStructure = [Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo [String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
"id" Bool
False DbTypePrimitive
autoKeyType Maybe String
forall a. Maybe a
Nothing, String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
"discr" Bool
False DbTypePrimitive
forall str. DbTypePrimitive' str
DbInt32 Maybe String
forall a. Maybe a
Nothing] [Maybe String
-> UniqueType -> [Either String String] -> UniqueDefInfo
forall str field.
Maybe str -> UniqueType -> [field] -> UniqueDef' str field
UniqueDef Maybe String
forall a. Maybe a
Nothing (Bool -> UniqueType
UniquePrimary Bool
True) [String -> Either String String
forall a b. a -> Either a b
Left String
"id"]] []

  if [ConstructorDef] -> Bool
isSimple [ConstructorDef]
constrs
    then do
      Maybe TableInfo
x <- QualifiedName -> ReaderT conn IO (Maybe TableInfo)
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
QualifiedName -> m (Maybe TableInfo)
analyzeTable (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, String
name)
      -- check whether the table was created for multiple constructors before
      case Maybe TableInfo
x of
        Just TableInfo
old
          | [AlterTable] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([AlterTable] -> Bool) -> [AlterTable] -> Bool
forall a b. (a -> b) -> a -> b
$ MigrationPack conn -> TableInfo -> TableInfo -> [AlterTable]
forall m. MigrationPack m -> TableInfo -> TableInfo -> [AlterTable]
getAlters MigrationPack conn
m TableInfo
old TableInfo
expectedMainStructure ->
            SingleMigration -> Action conn SingleMigration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleMigration -> Action conn SingleMigration)
-> SingleMigration -> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$
              [String] -> SingleMigration
forall a b. a -> Either a b
Left
                [String
"Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name]
        Maybe TableInfo
_ -> ((Bool, SingleMigration) -> SingleMigration)
-> Action conn (Bool, SingleMigration)
-> Action conn SingleMigration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, SingleMigration) -> SingleMigration
forall a b. (a, b) -> b
snd (Action conn (Bool, SingleMigration)
 -> Action conn SingleMigration)
-> Action conn (Bool, SingleMigration)
-> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$ EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migConstr EntityDef
e (ConstructorDef -> Action conn (Bool, SingleMigration))
-> ConstructorDef -> Action conn (Bool, SingleMigration)
forall a b. (a -> b) -> a -> b
$ [ConstructorDef] -> ConstructorDef
forall a. [a] -> a
head [ConstructorDef]
constrs
    else do
      Maybe TableInfo
mainStructure <- QualifiedName -> ReaderT conn IO (Maybe TableInfo)
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
QualifiedName -> m (Maybe TableInfo)
analyzeTable (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, String
name)
      let constrTable :: ConstructorDef -> String
constrTable ConstructorDef
c = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
delim] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConstructorDef -> String
forall str dbType. ConstructorDef' str dbType -> str
constrName ConstructorDef
c
      [(Bool, SingleMigration)]
res <- (ConstructorDef -> Action conn (Bool, SingleMigration))
-> [ConstructorDef] -> ReaderT conn IO [(Bool, SingleMigration)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migConstr EntityDef
e) [ConstructorDef]
constrs
      SingleMigration -> Action conn SingleMigration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleMigration -> Action conn SingleMigration)
-> SingleMigration -> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$ case Maybe TableInfo
mainStructure of
        Maybe TableInfo
Nothing ->
          -- no constructor tables can exist if there is no main data table
          let orphans :: [((Bool, SingleMigration), ConstructorDef)]
orphans = (((Bool, SingleMigration), ConstructorDef) -> Bool)
-> [((Bool, SingleMigration), ConstructorDef)]
-> [((Bool, SingleMigration), ConstructorDef)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool, SingleMigration) -> Bool
forall a b. (a, b) -> a
fst ((Bool, SingleMigration) -> Bool)
-> (((Bool, SingleMigration), ConstructorDef)
    -> (Bool, SingleMigration))
-> ((Bool, SingleMigration), ConstructorDef)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, SingleMigration), ConstructorDef)
-> (Bool, SingleMigration)
forall a b. (a, b) -> a
fst) ([((Bool, SingleMigration), ConstructorDef)]
 -> [((Bool, SingleMigration), ConstructorDef)])
-> [((Bool, SingleMigration), ConstructorDef)]
-> [((Bool, SingleMigration), ConstructorDef)]
forall a b. (a -> b) -> a -> b
$ [(Bool, SingleMigration)]
-> [ConstructorDef] -> [((Bool, SingleMigration), ConstructorDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Bool, SingleMigration)]
res [ConstructorDef]
constrs
           in if [((Bool, SingleMigration), ConstructorDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Bool, SingleMigration), ConstructorDef)]
orphans
                then [SingleMigration] -> SingleMigration
mergeMigrations ([SingleMigration] -> SingleMigration)
-> [SingleMigration] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ [(Bool, Int, String)] -> SingleMigration
forall a b. b -> Either a b
Right [(Bool
False, Int
defaultPriority, String
mainTableQuery)] SingleMigration -> [SingleMigration] -> [SingleMigration]
forall a. a -> [a] -> [a]
: ((Bool, SingleMigration) -> SingleMigration)
-> [(Bool, SingleMigration)] -> [SingleMigration]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, SingleMigration) -> SingleMigration
forall a b. (a, b) -> b
snd [(Bool, SingleMigration)]
res
                else [String] -> SingleMigration
forall a b. a -> Either a b
Left ([String] -> SingleMigration) -> [String] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ (((Bool, SingleMigration), ConstructorDef) -> String)
-> [((Bool, SingleMigration), ConstructorDef)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\((Bool, SingleMigration)
_, ConstructorDef
c) -> String
"Orphan constructor table found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConstructorDef -> String
constrTable ConstructorDef
c) [((Bool, SingleMigration), ConstructorDef)]
orphans
        Just TableInfo
mainStructure' ->
          if [AlterTable] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([AlterTable] -> Bool) -> [AlterTable] -> Bool
forall a b. (a -> b) -> a -> b
$ MigrationPack conn -> TableInfo -> TableInfo -> [AlterTable]
forall m. MigrationPack m -> TableInfo -> TableInfo -> [AlterTable]
getAlters MigrationPack conn
m TableInfo
mainStructure' TableInfo
expectedMainStructure
            then
              let -- the datatype had also many constructors before
                  -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end
                  updateDiscriminators :: [(Bool, Int, String)]
updateDiscriminators = Int -> [(Bool, Int)] -> [(Bool, Int, String)]
go Int
0 ([(Bool, Int)] -> [(Bool, Int, String)])
-> ([(Bool, SingleMigration)] -> [(Bool, Int)])
-> [(Bool, SingleMigration)]
-> [(Bool, Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> (Bool, Int)) -> [[Bool]] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ([Bool] -> Bool
forall a. [a] -> a
head ([Bool] -> Bool) -> ([Bool] -> Int) -> [Bool] -> (Bool, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[Bool]] -> [(Bool, Int)])
-> ([(Bool, SingleMigration)] -> [[Bool]])
-> [(Bool, SingleMigration)]
-> [(Bool, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [[Bool]]
forall a. Eq a => [a] -> [[a]]
group ([Bool] -> [[Bool]])
-> ([(Bool, SingleMigration)] -> [Bool])
-> [(Bool, SingleMigration)]
-> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, SingleMigration) -> Bool)
-> [(Bool, SingleMigration)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, SingleMigration) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, SingleMigration)] -> [(Bool, Int, String)])
-> [(Bool, SingleMigration)] -> [(Bool, Int, String)]
forall a b. (a -> b) -> a -> b
$ [(Bool, SingleMigration)]
res
                    where
                      go :: Int -> [(Bool, Int)] -> [(Bool, Int, String)]
go Int
acc ((Bool
False, Int
n) : (Bool
True, Int
n2) : [(Bool, Int)]
xs) = (Bool
False, Int
defaultPriority, String
"UPDATE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escape String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" SET discr = discr + " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" WHERE discr >= " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
acc) (Bool, Int, String)
-> [(Bool, Int, String)] -> [(Bool, Int, String)]
forall a. a -> [a] -> [a]
: Int -> [(Bool, Int)] -> [(Bool, Int, String)]
go (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) [(Bool, Int)]
xs
                      go Int
acc ((Bool
True, Int
n) : [(Bool, Int)]
xs) = Int -> [(Bool, Int)] -> [(Bool, Int, String)]
go (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) [(Bool, Int)]
xs
                      go Int
_ [(Bool, Int)]
_ = []
               in [SingleMigration] -> SingleMigration
mergeMigrations ([SingleMigration] -> SingleMigration)
-> [SingleMigration] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ [(Bool, Int, String)] -> SingleMigration
forall a b. b -> Either a b
Right [(Bool, Int, String)]
updateDiscriminators SingleMigration -> [SingleMigration] -> [SingleMigration]
forall a. a -> [a] -> [a]
: ((Bool, SingleMigration) -> SingleMigration)
-> [(Bool, SingleMigration)] -> [SingleMigration]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, SingleMigration) -> SingleMigration
forall a b. (a, b) -> b
snd [(Bool, SingleMigration)]
res
            else [String] -> SingleMigration
forall a b. a -> Either a b
Left [String
"Unexpected structure of main table for Datatype: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Table info: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TableInfo -> String
forall a. Show a => a -> String
show TableInfo
mainStructure']

migrateList :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> DbType -> Action conn SingleMigration
migrateList :: MigrationPack conn -> DbType -> Action conn SingleMigration
migrateList m :: MigrationPack conn
m@MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} (DbList String
mainName DbType
t) = do
  DbTypePrimitive
autoKeyType <- (Any conn -> DbTypePrimitive)
-> ReaderT conn IO (Any conn) -> ReaderT conn IO DbTypePrimitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any conn -> DbTypePrimitive
forall db (proxy :: * -> *).
DbDescriptor db =>
proxy db -> DbTypePrimitive
getDefaultAutoKeyType ReaderT conn IO (Any conn)
forall (m :: * -> *) (proxy :: * -> *).
PersistBackend m =>
m (proxy (Conn m))
phantomDb
  let valuesName :: String
valuesName = String
mainName String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
delim Char -> ShowS
forall a. a -> [a] -> [a]
: String
"values"
      ([Column]
valueCols, [Reference]
valueRefs) = ((([Column] -> [Column]) -> [Column] -> [Column]
forall a b. (a -> b) -> a -> b
$ []) (([Column] -> [Column]) -> [Column])
-> ((String, DbType) -> [Column] -> [Column])
-> (String, DbType)
-> [Column]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbTypePrimitive -> (String, DbType) -> [Column] -> [Column]
mkColumns DbTypePrimitive
autoKeyType) ((String, DbType) -> [Column])
-> ((String, DbType) -> [Reference])
-> (String, DbType)
-> ([Column], [Reference])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& DbTypePrimitive -> (String, DbType) -> [Reference]
mkReferences DbTypePrimitive
autoKeyType ((String, DbType) -> ([Column], [Reference]))
-> (String, DbType) -> ([Column], [Reference])
forall a b. (a -> b) -> a -> b
$ (String
"value", DbType
t)
      refs' :: [Reference]
refs' = QualifiedName
-> [(String, String)]
-> Maybe ReferenceActionType
-> Maybe ReferenceActionType
-> Reference
Reference (Maybe String
forall a. Maybe a
Nothing, String
mainName) [(String
"id", String
"id")] (ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
Cascade) Maybe ReferenceActionType
forall a. Maybe a
Nothing Reference -> [Reference] -> [Reference]
forall a. a -> [a] -> [a]
: [Reference]
valueRefs
      expectedMainStructure :: TableInfo
expectedMainStructure = [Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo [String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
"id" Bool
False DbTypePrimitive
autoKeyType Maybe String
forall a. Maybe a
Nothing] [Maybe String
-> UniqueType -> [Either String String] -> UniqueDefInfo
forall str field.
Maybe str -> UniqueType -> [field] -> UniqueDef' str field
UniqueDef Maybe String
forall a. Maybe a
Nothing (Bool -> UniqueType
UniquePrimary Bool
True) [String -> Either String String
forall a b. a -> Either a b
Left String
"id"]] []
      mainQuery :: String
mainQuery = String
"CREATE TABLE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escape String
mainName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
autoincrementedKeyTypeName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      ([String]
addInCreate, [AlterTable]
addInAlters) = [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
addUniquesReferences [] [Reference]
refs'
      expectedValuesStructure :: TableInfo
expectedValuesStructure = [Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo [Column]
valueColumns [] ((Reference -> (Maybe String, Reference))
-> [Reference] -> [(Maybe String, Reference)]
forall a b. (a -> b) -> [a] -> [b]
map (\Reference
x -> (Maybe String
forall a. Maybe a
Nothing, Reference
x)) [Reference]
refs')
      valueColumns :: [Column]
valueColumns = String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
"id" Bool
False DbTypePrimitive
autoKeyType Maybe String
forall a. Maybe a
Nothing Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
"ord" Bool
False DbTypePrimitive
forall str. DbTypePrimitive' str
DbInt32 Maybe String
forall a. Maybe a
Nothing Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: [Column]
valueCols
      valuesQuery :: String
valuesQuery = String
"CREATE TABLE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escape String
valuesName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Column -> String) -> [Column] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Column -> String
showColumn [Column]
valueColumns [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
addInCreate) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  -- TODO: handle case when outer entity has a schema
  Maybe TableInfo
mainStructure <- QualifiedName -> ReaderT conn IO (Maybe TableInfo)
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
QualifiedName -> m (Maybe TableInfo)
analyzeTable (Maybe String
forall a. Maybe a
Nothing, String
mainName)
  Maybe TableInfo
valuesStructure <- QualifiedName -> ReaderT conn IO (Maybe TableInfo)
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
QualifiedName -> m (Maybe TableInfo)
analyzeTable (Maybe String
forall a. Maybe a
Nothing, String
valuesName)
  let triggerMain :: [a]
triggerMain = []
  (Bool
_, [AlterDB]
triggerValues) <- QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
migTriggerOnDelete (Maybe String
forall a. Maybe a
Nothing, String
valuesName) ([(String, String)] -> Action conn (Bool, [AlterDB]))
-> [(String, String)] -> Action conn (Bool, [AlterDB])
forall a b. (a -> b) -> a -> b
$ ShowS -> (String, DbType) -> [(String, String)]
mkDeletes ShowS
escape (String
"value", DbType
t)
  SingleMigration -> Action conn SingleMigration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleMigration -> Action conn SingleMigration)
-> SingleMigration -> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$ case (Maybe TableInfo
mainStructure, Maybe TableInfo
valuesStructure) of
    (Maybe TableInfo
Nothing, Maybe TableInfo
Nothing) ->
      let rest :: [AlterDB]
rest = [QualifiedName
-> String -> TableInfo -> TableInfo -> [AlterTable] -> AlterDB
AlterTable (Maybe String
forall a. Maybe a
Nothing, String
valuesName) String
valuesQuery TableInfo
expectedValuesStructure TableInfo
expectedValuesStructure [AlterTable]
addInAlters]
       in [SingleMigration] -> SingleMigration
mergeMigrations ([SingleMigration] -> SingleMigration)
-> [SingleMigration] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ (AlterDB -> SingleMigration) -> [AlterDB] -> [SingleMigration]
forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> SingleMigration
showAlterDb ([AlterDB] -> [SingleMigration]) -> [AlterDB] -> [SingleMigration]
forall a b. (a -> b) -> a -> b
$ [String -> AlterDB
AddTable String
mainQuery, String -> AlterDB
AddTable String
valuesQuery] [AlterDB] -> [AlterDB] -> [AlterDB]
forall a. [a] -> [a] -> [a]
++ [AlterDB]
rest [AlterDB] -> [AlterDB] -> [AlterDB]
forall a. [a] -> [a] -> [a]
++ [AlterDB]
forall a. [a]
triggerMain [AlterDB] -> [AlterDB] -> [AlterDB]
forall a. [a] -> [a] -> [a]
++ [AlterDB]
triggerValues
    (Just TableInfo
mainStructure', Just TableInfo
valuesStructure') ->
      let f :: String -> TableInfo -> TableInfo -> [String]
f String
name TableInfo
a TableInfo
b =
            if [AlterTable] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([AlterTable] -> Bool) -> [AlterTable] -> Bool
forall a b. (a -> b) -> a -> b
$ MigrationPack conn -> TableInfo -> TableInfo -> [AlterTable]
forall m. MigrationPack m -> TableInfo -> TableInfo -> [AlterTable]
getAlters MigrationPack conn
m TableInfo
a TableInfo
b
              then []
              else [String
"List table " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" error. Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TableInfo -> String
forall a. Show a => a -> String
show TableInfo
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". Found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TableInfo -> String
forall a. Show a => a -> String
show TableInfo
a]
          errors :: [String]
errors = String -> TableInfo -> TableInfo -> [String]
f String
mainName TableInfo
mainStructure' TableInfo
expectedMainStructure [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> TableInfo -> TableInfo -> [String]
f String
valuesName TableInfo
valuesStructure' TableInfo
expectedValuesStructure
       in if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errors then [(Bool, Int, String)] -> SingleMigration
forall a b. b -> Either a b
Right [] else [String] -> SingleMigration
forall a b. a -> Either a b
Left [String]
errors
    (Maybe TableInfo
_, Maybe TableInfo
Nothing) -> [String] -> SingleMigration
forall a b. a -> Either a b
Left [String
"Found orphan main list table " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
mainName]
    (Maybe TableInfo
Nothing, Maybe TableInfo
_) -> [String] -> SingleMigration
forall a b. a -> Either a b
Left [String
"Found orphan list values table " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
valuesName]
migrateList MigrationPack conn
_ DbType
t = String -> Action conn SingleMigration
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action conn SingleMigration)
-> String -> Action conn SingleMigration
forall a b. (a -> b) -> a -> b
$ String
"migrateList: expected DbList, got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DbType -> String
forall a. Show a => a -> String
show DbType
t

getAlters ::
  MigrationPack m ->
  -- | From database
  TableInfo ->
  -- | From datatype
  TableInfo ->
  [AlterTable]
getAlters :: MigrationPack m -> TableInfo -> TableInfo -> [AlterTable]
getAlters m :: MigrationPack m
m@MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName -> [(String, String)] -> Action m [(Bool, [AlterDB])]
QualifiedName -> [(String, String)] -> Action m (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action m (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action m (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action m [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action m (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} (TableInfo [Column]
oldColumns [UniqueDefInfo]
oldUniques [(Maybe String, Reference)]
oldRefs) (TableInfo [Column]
newColumns [UniqueDefInfo]
newUniques [(Maybe String, Reference)]
newRefs) = [AlterTable]
tableAlters
  where
    ([Column]
oldOnlyColumns, [Column]
newOnlyColumns, [(Column, Column)]
commonColumns) = (Column -> Column -> Bool)
-> [Column] -> [Column] -> ([Column], [Column], [(Column, Column)])
forall a b.
Show a =>
(a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (Column -> String) -> Column -> Column -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Column -> String
colName) [Column]
oldColumns [Column]
newColumns
    ([UniqueDefInfo]
oldOnlyUniques, [UniqueDefInfo]
newOnlyUniques, [(UniqueDefInfo, UniqueDefInfo)]
commonUniques) = (UniqueDefInfo -> UniqueDefInfo -> Bool)
-> [UniqueDefInfo]
-> [UniqueDefInfo]
-> ([UniqueDefInfo], [UniqueDefInfo],
    [(UniqueDefInfo, UniqueDefInfo)])
forall a b.
Show a =>
(a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements UniqueDefInfo -> UniqueDefInfo -> Bool
compareUniqs [UniqueDefInfo]
oldUniques [UniqueDefInfo]
newUniques
    ([(Maybe String, Reference)]
oldOnlyRefs, [(Maybe String, Reference)]
newOnlyRefs, [((Maybe String, Reference), (Maybe String, Reference))]
_) = ((Maybe String, Reference) -> (Maybe String, Reference) -> Bool)
-> [(Maybe String, Reference)]
-> [(Maybe String, Reference)]
-> ([(Maybe String, Reference)], [(Maybe String, Reference)],
    [((Maybe String, Reference), (Maybe String, Reference))])
forall a b.
Show a =>
(a -> b -> Bool) -> [a] -> [b] -> ([a], [b], [(a, b)])
matchElements (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareRefs [(Maybe String, Reference)]
oldRefs [(Maybe String, Reference)]
newRefs
    primaryColumns :: [String]
primaryColumns = [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts ([Either String String] -> [String])
-> [Either String String] -> [String]
forall a b. (a -> b) -> a -> b
$ (UniqueDefInfo -> [Either String String])
-> [UniqueDefInfo] -> [Either String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UniqueDefInfo -> [Either String String]
forall str field. UniqueDef' str field -> [field]
uniqueDefFields ([UniqueDefInfo] -> [Either String String])
-> [UniqueDefInfo] -> [Either String String]
forall a b. (a -> b) -> a -> b
$ (UniqueDefInfo -> Bool) -> [UniqueDefInfo] -> [UniqueDefInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UniqueType -> UniqueType -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> UniqueType
UniquePrimary Bool
True) (UniqueType -> Bool)
-> (UniqueDefInfo -> UniqueType) -> UniqueDefInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqueDefInfo -> UniqueType
forall str field. UniqueDef' str field -> UniqueType
uniqueDefType) [UniqueDefInfo]
oldUniques

    colAlters :: [AlterTable]
colAlters = ((Column, Column) -> Maybe AlterTable)
-> [(Column, Column)] -> [AlterTable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Column
a, Column
b) -> Column -> [AlterColumn] -> Maybe AlterTable
mkAlterColumn Column
b ([AlterColumn] -> Maybe AlterTable)
-> [AlterColumn] -> Maybe AlterTable
forall a b. (a -> b) -> a -> b
$ MigrationPack m -> Column -> Column -> [AlterColumn]
forall m. MigrationPack m -> Column -> Column -> [AlterColumn]
migrateColumn MigrationPack m
m Column
a Column
b) (((Column, Column) -> Bool)
-> [(Column, Column)] -> [(Column, Column)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
primaryColumns) (String -> Bool)
-> ((Column, Column) -> String) -> (Column, Column) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> String
colName (Column -> String)
-> ((Column, Column) -> Column) -> (Column, Column) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Column, Column) -> Column
forall a b. (a, b) -> a
fst) [(Column, Column)]
commonColumns)
    mkAlterColumn :: Column -> [AlterColumn] -> Maybe AlterTable
mkAlterColumn Column
col [AlterColumn]
alters = if [AlterColumn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AlterColumn]
alters then Maybe AlterTable
forall a. Maybe a
Nothing else AlterTable -> Maybe AlterTable
forall a. a -> Maybe a
Just (AlterTable -> Maybe AlterTable) -> AlterTable -> Maybe AlterTable
forall a b. (a -> b) -> a -> b
$ Column -> [AlterColumn] -> AlterTable
AlterColumn Column
col [AlterColumn]
alters
    tableAlters :: [AlterTable]
tableAlters =
      (Column -> AlterTable) -> [Column] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AlterTable
DropColumn (String -> AlterTable)
-> (Column -> String) -> Column -> AlterTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> String
colName) [Column]
oldOnlyColumns
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ (Column -> AlterTable) -> [Column] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map Column -> AlterTable
AddColumn [Column]
newOnlyColumns
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ [AlterTable]
colAlters
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ (UniqueDefInfo -> AlterTable) -> [UniqueDefInfo] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map UniqueDefInfo -> AlterTable
dropUnique [UniqueDefInfo]
oldOnlyUniques
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ (UniqueDefInfo -> AlterTable) -> [UniqueDefInfo] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map UniqueDefInfo -> AlterTable
AddUnique [UniqueDefInfo]
newOnlyUniques
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ ((UniqueDefInfo, UniqueDefInfo) -> [AlterTable])
-> [(UniqueDefInfo, UniqueDefInfo)] -> [AlterTable]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((UniqueDefInfo -> UniqueDefInfo -> [AlterTable])
-> (UniqueDefInfo, UniqueDefInfo) -> [AlterTable]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UniqueDefInfo -> UniqueDefInfo -> [AlterTable]
migrateUniq) [(UniqueDefInfo, UniqueDefInfo)]
commonUniques
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ ((Maybe String, Reference) -> AlterTable)
-> [(Maybe String, Reference)] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AlterTable
DropReference (String -> AlterTable)
-> ((Maybe String, Reference) -> String)
-> (Maybe String, Reference)
-> AlterTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
"getAlters: old reference does not have name") (Maybe String -> String)
-> ((Maybe String, Reference) -> Maybe String)
-> (Maybe String, Reference)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, Reference) -> Maybe String
forall a b. (a, b) -> a
fst) [(Maybe String, Reference)]
oldOnlyRefs
        [AlterTable] -> [AlterTable] -> [AlterTable]
forall a. [a] -> [a] -> [a]
++ ((Maybe String, Reference) -> AlterTable)
-> [(Maybe String, Reference)] -> [AlterTable]
forall a b. (a -> b) -> [a] -> [b]
map (Reference -> AlterTable
AddReference (Reference -> AlterTable)
-> ((Maybe String, Reference) -> Reference)
-> (Maybe String, Reference)
-> AlterTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, Reference) -> Reference
forall a b. (a, b) -> b
snd) [(Maybe String, Reference)]
newOnlyRefs

-- from database, from datatype
migrateColumn :: MigrationPack m -> Column -> Column -> [AlterColumn]
migrateColumn :: MigrationPack m -> Column -> Column -> [AlterColumn]
migrateColumn MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName -> [(String, String)] -> Action m [(Bool, [AlterDB])]
QualifiedName -> [(String, String)] -> Action m (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action m (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action m (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName -> [(String, String)] -> Action m [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName -> [(String, String)] -> Action m (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} (Column String
_ Bool
isNull1 DbTypePrimitive
type1 Maybe String
def1) (Column String
_ Bool
isNull2 DbTypePrimitive
type2 Maybe String
def2) = [AlterColumn]
modDef [AlterColumn] -> [AlterColumn] -> [AlterColumn]
forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modNull [AlterColumn] -> [AlterColumn] -> [AlterColumn]
forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modType
  where
    modNull :: [AlterColumn]
modNull = case (Bool
isNull1, Bool
isNull2) of
      (Bool
False, Bool
True) -> [AlterColumn
IsNull]
      (Bool
True, Bool
False) -> case Maybe String
def2 of
        Maybe String
Nothing -> [AlterColumn
NotNull]
        Just String
s -> [String -> AlterColumn
UpdateValue String
s, AlterColumn
NotNull]
      (Bool, Bool)
_ -> []
    modType :: [AlterColumn]
modType = if DbTypePrimitive -> DbTypePrimitive -> Bool
compareTypes DbTypePrimitive
type1 DbTypePrimitive
type2 then [] else [DbTypePrimitive -> AlterColumn
Type DbTypePrimitive
type2]
    modDef :: [AlterColumn]
modDef = case (Maybe String
def1, Maybe String
def2) of
      (Maybe String
Nothing, Maybe String
Nothing) -> []
      (Just String
def1', Just String
def2') | String -> String -> Bool
compareDefaults String
def1' String
def2' -> []
      (Maybe String, Maybe String)
_ -> [AlterColumn
-> (String -> AlterColumn) -> Maybe String -> AlterColumn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AlterColumn
NoDefault String -> AlterColumn
Default Maybe String
def2]

-- from database, from datatype
migrateUniq :: UniqueDefInfo -> UniqueDefInfo -> [AlterTable]
migrateUniq :: UniqueDefInfo -> UniqueDefInfo -> [AlterTable]
migrateUniq u1 :: UniqueDefInfo
u1@(UniqueDef Maybe String
_ UniqueType
_ [Either String String]
cols1) u2 :: UniqueDefInfo
u2@(UniqueDef Maybe String
_ UniqueType
_ [Either String String]
cols2) =
  if (Either String String -> Either String String -> Bool)
-> [Either String String] -> [Either String String] -> Bool
forall a b. Show a => (a -> b -> Bool) -> [a] -> [b] -> Bool
haveSameElems Either String String -> Either String String -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Either String String]
cols1 [Either String String]
cols2
    then []
    else [UniqueDefInfo -> AlterTable
dropUnique UniqueDefInfo
u1, UniqueDefInfo -> AlterTable
AddUnique UniqueDefInfo
u2]

dropUnique :: UniqueDefInfo -> AlterTable
dropUnique :: UniqueDefInfo -> AlterTable
dropUnique (UniqueDef Maybe String
name UniqueType
typ [Either String String]
_) =
  case UniqueType
typ of
    UniqueType
UniqueConstraint -> String -> AlterTable
DropConstraint String
name'
    UniqueType
UniqueIndex -> String -> AlterTable
DropIndex String
name'
    UniquePrimary Bool
_ -> String -> AlterTable
DropConstraint String
name'
  where
    name' :: String
name' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
"dropUnique: constraint which should be dropped does not have a name") Maybe String
name

defaultMigConstr :: (SchemaAnalyzer conn, PersistBackendConn conn) => MigrationPack conn -> EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
defaultMigConstr :: MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
defaultMigConstr m :: MigrationPack conn
m@MigrationPack {Int
String
ReferenceActionType
ShowS
String -> String -> Bool
[UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
(Maybe String, Reference) -> (Maybe String, Reference) -> Bool
DbTypePrimitive -> String
DbTypePrimitive -> DbTypePrimitive -> Bool
UniqueDefInfo -> UniqueDefInfo -> Bool
EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
AlterDB -> SingleMigration
Column -> String
defaultReferenceOnUpdate :: ReferenceActionType
defaultReferenceOnDelete :: ReferenceActionType
showAlterDb :: AlterDB -> SingleMigration
showColumn :: Column -> String
showSqlType :: DbTypePrimitive -> String
addUniquesReferences :: [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: Int
mainTableId :: String
autoincrementedKeyTypeName :: String
escape :: ShowS
migConstr :: EntityDef -> ConstructorDef -> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
compareDefaults :: String -> String -> Bool
compareUniqs :: UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool
defaultReferenceOnUpdate :: forall conn. MigrationPack conn -> ReferenceActionType
defaultReferenceOnDelete :: forall conn. MigrationPack conn -> ReferenceActionType
showAlterDb :: forall conn. MigrationPack conn -> AlterDB -> SingleMigration
showColumn :: forall conn. MigrationPack conn -> Column -> String
showSqlType :: forall conn. MigrationPack conn -> DbTypePrimitive -> String
addUniquesReferences :: forall conn.
MigrationPack conn
-> [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
defaultPriority :: forall conn. MigrationPack conn -> Int
mainTableId :: forall conn. MigrationPack conn -> String
autoincrementedKeyTypeName :: forall conn. MigrationPack conn -> String
escape :: forall conn. MigrationPack conn -> ShowS
migConstr :: forall conn.
MigrationPack conn
-> EntityDef
-> ConstructorDef
-> Action conn (Bool, SingleMigration)
migTriggerOnUpdate :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn [(Bool, [AlterDB])]
migTriggerOnDelete :: forall conn.
MigrationPack conn
-> QualifiedName
-> [(String, String)]
-> Action conn (Bool, [AlterDB])
compareDefaults :: forall conn. MigrationPack conn -> String -> String -> Bool
compareUniqs :: forall conn.
MigrationPack conn -> UniqueDefInfo -> UniqueDefInfo -> Bool
compareRefs :: forall conn.
MigrationPack conn
-> (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareTypes :: forall conn.
MigrationPack conn -> DbTypePrimitive -> DbTypePrimitive -> Bool
..} EntityDef
e ConstructorDef
constr = do
  let simple :: Bool
simple = [ConstructorDef] -> Bool
isSimple ([ConstructorDef] -> Bool) -> [ConstructorDef] -> Bool
forall a b. (a -> b) -> a -> b
$ EntityDef -> [ConstructorDef]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors EntityDef
e
      name :: String
name = EntityDef -> String
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e
      qualifiedCName :: QualifiedName
qualifiedCName = (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, if Bool
simple then String
name else String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
delim] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConstructorDef -> String
forall str dbType. ConstructorDef' str dbType -> str
constrName ConstructorDef
constr)
  DbTypePrimitive
autoKeyType <- (Any conn -> DbTypePrimitive)
-> ReaderT conn IO (Any conn) -> ReaderT conn IO DbTypePrimitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any conn -> DbTypePrimitive
forall db (proxy :: * -> *).
DbDescriptor db =>
proxy db -> DbTypePrimitive
getDefaultAutoKeyType ReaderT conn IO (Any conn)
forall (m :: * -> *) (proxy :: * -> *).
PersistBackend m =>
m (proxy (Conn m))
phantomDb
  Maybe TableInfo
tableStructure <- QualifiedName -> ReaderT conn IO (Maybe TableInfo)
forall conn (m :: * -> *).
(SchemaAnalyzer conn, PersistBackend m, Conn m ~ conn) =>
QualifiedName -> m (Maybe TableInfo)
analyzeTable QualifiedName
qualifiedCName
  let dels :: [(String, String)]
dels = ((String, DbType) -> [(String, String)])
-> [(String, DbType)] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ShowS -> (String, DbType) -> [(String, String)]
mkDeletes ShowS
escape) ([(String, DbType)] -> [(String, String)])
-> [(String, DbType)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ConstructorDef -> [(String, DbType)]
forall str dbType. ConstructorDef' str dbType -> [(str, dbType)]
constrParams ConstructorDef
constr
  (Bool
triggerExisted, [AlterDB]
delTrigger) <- QualifiedName
-> [(String, String)] -> Action conn (Bool, [AlterDB])
migTriggerOnDelete QualifiedName
qualifiedCName [(String, String)]
dels
  [AlterDB]
updTriggers <- ((Bool, [AlterDB]) -> [AlterDB])
-> [(Bool, [AlterDB])] -> [AlterDB]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool, [AlterDB]) -> [AlterDB]
forall a b. (a, b) -> b
snd ([(Bool, [AlterDB])] -> [AlterDB])
-> Action conn [(Bool, [AlterDB])] -> ReaderT conn IO [AlterDB]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualifiedName
-> [(String, String)] -> Action conn [(Bool, [AlterDB])]
migTriggerOnUpdate QualifiedName
qualifiedCName [(String, String)]
dels

  let (TableInfo
expectedTableStructure, (String
addTable, [AlterTable]
addInAlters)) =
        ( case ConstructorDef -> Maybe String
forall str dbType. ConstructorDef' str dbType -> Maybe str
constrAutoKeyName ConstructorDef
constr of
            Maybe String
Nothing -> ([Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo [Column]
columns [UniqueDefInfo]
uniques ([Reference] -> [(Maybe String, Reference)]
forall b a. [b] -> [(Maybe a, b)]
mkRefs [Reference]
refs), [String]
-> [Column]
-> [UniqueDefInfo]
-> [Reference]
-> (String, [AlterTable])
f [] [Column]
columns [UniqueDefInfo]
uniques [Reference]
refs)
            Just String
keyName ->
              let keyColumn :: Column
keyColumn = String -> Bool -> DbTypePrimitive -> Maybe String -> Column
Column String
keyName Bool
False DbTypePrimitive
autoKeyType Maybe String
forall a. Maybe a
Nothing
               in if Bool
simple
                    then
                      ( [Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo (Column
keyColumn Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: [Column]
columns) ([UniqueDefInfo]
uniques [UniqueDefInfo] -> [UniqueDefInfo] -> [UniqueDefInfo]
forall a. [a] -> [a] -> [a]
++ [Maybe String
-> UniqueType -> [Either String String] -> UniqueDefInfo
forall str field.
Maybe str -> UniqueType -> [field] -> UniqueDef' str field
UniqueDef Maybe String
forall a. Maybe a
Nothing (Bool -> UniqueType
UniquePrimary Bool
True) [String -> Either String String
forall a b. a -> Either a b
Left String
keyName]]) ([Reference] -> [(Maybe String, Reference)]
forall b a. [b] -> [(Maybe a, b)]
mkRefs [Reference]
refs),
                        [String]
-> [Column]
-> [UniqueDefInfo]
-> [Reference]
-> (String, [AlterTable])
f [ShowS
escape String
keyName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
autoincrementedKeyTypeName] [Column]
columns [UniqueDefInfo]
uniques [Reference]
refs
                      )
                    else
                      let columns' :: [Column]
columns' = Column
keyColumn Column -> [Column] -> [Column]
forall a. a -> [a] -> [a]
: [Column]
columns
                          refs' :: [Reference]
refs' = [Reference]
refs [Reference] -> [Reference] -> [Reference]
forall a. [a] -> [a] -> [a]
++ [QualifiedName
-> [(String, String)]
-> Maybe ReferenceActionType
-> Maybe ReferenceActionType
-> Reference
Reference (EntityDef -> Maybe String
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e, String
name) [(String
keyName, String
mainTableId)] (ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
Cascade) Maybe ReferenceActionType
forall a. Maybe a
Nothing]
                          uniques' :: [UniqueDefInfo]
uniques' = [UniqueDefInfo]
uniques [UniqueDefInfo] -> [UniqueDefInfo] -> [UniqueDefInfo]
forall a. [a] -> [a] -> [a]
++ [Maybe String
-> UniqueType -> [Either String String] -> UniqueDefInfo
forall str field.
Maybe str -> UniqueType -> [field] -> UniqueDef' str field
UniqueDef Maybe String
forall a. Maybe a
Nothing UniqueType
UniqueConstraint [String -> Either String String
forall a b. a -> Either a b
Left String
keyName]]
                       in ([Column]
-> [UniqueDefInfo] -> [(Maybe String, Reference)] -> TableInfo
TableInfo [Column]
columns' [UniqueDefInfo]
uniques' ([Reference] -> [(Maybe String, Reference)]
forall b a. [b] -> [(Maybe a, b)]
mkRefs [Reference]
refs'), [String]
-> [Column]
-> [UniqueDefInfo]
-> [Reference]
-> (String, [AlterTable])
f [] [Column]
columns' [UniqueDefInfo]
uniques' [Reference]
refs')
        )
        where
          ([Column]
columns, [Reference]
refs) = ((String, DbType) -> [Column] -> [Column])
-> [Column] -> [(String, DbType)] -> [Column]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DbTypePrimitive -> (String, DbType) -> [Column] -> [Column]
mkColumns DbTypePrimitive
autoKeyType) [] ([(String, DbType)] -> [Column])
-> ([(String, DbType)] -> [Reference])
-> [(String, DbType)]
-> ([Column], [Reference])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((String, DbType) -> [Reference])
-> [(String, DbType)] -> [Reference]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DbTypePrimitive -> (String, DbType) -> [Reference]
mkReferences DbTypePrimitive
autoKeyType) ([(String, DbType)] -> ([Column], [Reference]))
-> [(String, DbType)] -> ([Column], [Reference])
forall a b. (a -> b) -> a -> b
$ ConstructorDef -> [(String, DbType)]
forall str dbType. ConstructorDef' str dbType -> [(str, dbType)]
constrParams ConstructorDef
constr
          uniques :: [UniqueDefInfo]
uniques = (UniqueDef' String (Either (String, DbType) String)
 -> UniqueDefInfo)
-> [UniqueDef' String (Either (String, DbType) String)]
-> [UniqueDefInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\UniqueDef' String (Either (String, DbType) String)
u -> UniqueDef' String (Either (String, DbType) String)
u {uniqueDefFields :: [Either String String]
uniqueDefFields = (Either (String, DbType) String -> [Either String String])
-> [Either (String, DbType) String] -> [Either String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((String, DbType) -> [Either String String])
-> (String -> [Either String String])
-> Either (String, DbType) String
-> [Either String String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String -> Either String String)
-> [String] -> [Either String String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either String String
forall a b. a -> Either a b
Left ([String] -> [Either String String])
-> ((String, DbType) -> [String])
-> (String, DbType)
-> [Either String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ []) (([String] -> [String]) -> [String])
-> ((String, DbType) -> [String] -> [String])
-> (String, DbType)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (String, DbType) -> [String] -> [String]
forall s.
StringLike s =>
(s -> s) -> (String, DbType) -> [s] -> [s]
flatten ShowS
forall a. a -> a
id) (Either String String -> [Either String String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> [Either String String])
-> (String -> Either String String)
-> String
-> [Either String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. b -> Either a b
Right)) ([Either (String, DbType) String] -> [Either String String])
-> [Either (String, DbType) String] -> [Either String String]
forall a b. (a -> b) -> a -> b
$ UniqueDef' String (Either (String, DbType) String)
-> [Either (String, DbType) String]
forall str field. UniqueDef' str field -> [field]
uniqueDefFields UniqueDef' String (Either (String, DbType) String)
u}) ([UniqueDef' String (Either (String, DbType) String)]
 -> [UniqueDefInfo])
-> [UniqueDef' String (Either (String, DbType) String)]
-> [UniqueDefInfo]
forall a b. (a -> b) -> a -> b
$ ConstructorDef
-> [UniqueDef' String (Either (String, DbType) String)]
forall str dbType.
ConstructorDef' str dbType
-> [UniqueDef' str (Either (str, dbType) str)]
constrUniques ConstructorDef
constr
          f :: [String]
-> [Column]
-> [UniqueDefInfo]
-> [Reference]
-> (String, [AlterTable])
f [String]
autoKey [Column]
cols [UniqueDefInfo]
uniqs [Reference]
refs' = (String
addTable', [AlterTable]
addInAlters')
            where
              ([String]
addInCreate, [AlterTable]
addInAlters') = [UniqueDefInfo] -> [Reference] -> ([String], [AlterTable])
addUniquesReferences [UniqueDefInfo]
uniqs [Reference]
refs'
              items :: [String]
items = [String]
autoKey [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Column -> String) -> [Column] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Column -> String
showColumn [Column]
cols [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
addInCreate
              addTable' :: String
addTable' = String
"CREATE TABLE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS -> EntityDef -> ConstructorDef -> String
forall s.
StringLike s =>
(s -> s) -> EntityDef -> ConstructorDef -> s
tableName ShowS
escape EntityDef
e ConstructorDef
constr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
items String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
          mkRefs :: [b] -> [(Maybe a, b)]
mkRefs = (b -> (Maybe a, b)) -> [b] -> [(Maybe a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\b
r -> (Maybe a
forall a. Maybe a
Nothing, b
r))

      ([String]
migErrs, Bool
constrExisted, [AlterDB]
mig) = case Maybe TableInfo
tableStructure of
        Maybe TableInfo
Nothing ->
          let rest :: AlterDB
rest = QualifiedName
-> String -> TableInfo -> TableInfo -> [AlterTable] -> AlterDB
AlterTable QualifiedName
qualifiedCName String
addTable TableInfo
expectedTableStructure TableInfo
expectedTableStructure [AlterTable]
addInAlters
           in ([], Bool
False, [String -> AlterDB
AddTable String
addTable, AlterDB
rest])
        Just TableInfo
oldTableStructure ->
          let alters :: [AlterTable]
alters = MigrationPack conn -> TableInfo -> TableInfo -> [AlterTable]
forall m. MigrationPack m -> TableInfo -> TableInfo -> [AlterTable]
getAlters MigrationPack conn
m TableInfo
oldTableStructure TableInfo
expectedTableStructure
              alterTable :: [AlterDB]
alterTable =
                if [AlterTable] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AlterTable]
alters
                  then []
                  else [QualifiedName
-> String -> TableInfo -> TableInfo -> [AlterTable] -> AlterDB
AlterTable QualifiedName
qualifiedCName String
addTable TableInfo
oldTableStructure TableInfo
expectedTableStructure [AlterTable]
alters]
           in ([], Bool
True, [AlterDB]
alterTable)
      -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error
      allErrs :: [String]
allErrs =
        if Bool
constrExisted Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
triggerExisted Bool -> Bool -> Bool
|| (Bool
constrExisted Bool -> Bool -> Bool
&& [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
dels)
          then [String]
migErrs
          else (String
"Both trigger and constructor table must exist: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QualifiedName -> String
forall a. Show a => a -> String
show QualifiedName
qualifiedCName) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
migErrs
  (Bool, SingleMigration) -> Action conn (Bool, SingleMigration)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Bool
constrExisted,
      if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
allErrs
        then [SingleMigration] -> SingleMigration
mergeMigrations ([SingleMigration] -> SingleMigration)
-> [SingleMigration] -> SingleMigration
forall a b. (a -> b) -> a -> b
$ (AlterDB -> SingleMigration) -> [AlterDB] -> [SingleMigration]
forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> SingleMigration
showAlterDb ([AlterDB] -> [SingleMigration]) -> [AlterDB] -> [SingleMigration]
forall a b. (a -> b) -> a -> b
$ [AlterDB]
mig [AlterDB] -> [AlterDB] -> [AlterDB]
forall a. [a] -> [a] -> [a]
++ [AlterDB]
delTrigger [AlterDB] -> [AlterDB] -> [AlterDB]
forall a. [a] -> [a] -> [a]
++ [AlterDB]
updTriggers
        else [String] -> SingleMigration
forall a b. a -> Either a b
Left [String]
allErrs
    )

-- on delete removes all ephemeral data
-- returns column name and delete statement for the referenced table
mkDeletes :: (String -> String) -> (String, DbType) -> [(String, String)]
mkDeletes :: ShowS -> (String, DbType) -> [(String, String)]
mkDeletes ShowS
esc = [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(String, String)]] -> [(String, String)])
-> ((String, DbType) -> [[(String, String)]])
-> (String, DbType)
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DbType -> [String] -> [(String, String)])
-> (String, DbType) -> [[(String, String)]]
forall a. (DbType -> [String] -> a) -> (String, DbType) -> [a]
traverseDbType DbType -> [String] -> [(String, String)]
f
  where
    f :: DbType -> [String] -> [(String, String)]
f (DbList String
ref DbType
_) [String
col] = [(String
col, String
"DELETE FROM " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
ref String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" WHERE id=old." String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
col String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";")]
    f DbType
_ [String]
_ = []

showReferenceAction :: ReferenceActionType -> String
showReferenceAction :: ReferenceActionType -> String
showReferenceAction ReferenceActionType
NoAction = String
"NO ACTION"
showReferenceAction ReferenceActionType
Restrict = String
"RESTRICT"
showReferenceAction ReferenceActionType
Cascade = String
"CASCADE"
showReferenceAction ReferenceActionType
SetNull = String
"SET NULL"
showReferenceAction ReferenceActionType
SetDefault = String
"SET DEFAULT"

readReferenceAction :: String -> Maybe ReferenceActionType
readReferenceAction :: String -> Maybe ReferenceActionType
readReferenceAction String
c = case String
c of
  String
"NO ACTION" -> ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
NoAction
  String
"RESTRICT" -> ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
Restrict
  String
"CASCADE" -> ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
Cascade
  String
"SET NULL" -> ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
SetNull
  String
"SET DEFAULT" -> ReferenceActionType -> Maybe ReferenceActionType
forall a. a -> Maybe a
Just ReferenceActionType
SetDefault
  String
_ -> Maybe ReferenceActionType
forall a. Maybe a
Nothing

class PersistBackendConn conn => SchemaAnalyzer conn where
  schemaExists ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Schema name
    String ->
    m Bool
  getCurrentSchema :: (PersistBackend m, Conn m ~ conn) => m (Maybe String)
  listTables ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Schema name
    Maybe String ->
    m [String]
  listTableTriggers ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Qualified table name
    QualifiedName ->
    m [String]
  analyzeTable ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Qualified table name
    QualifiedName ->
    m (Maybe TableInfo)
  analyzeTrigger ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Qualified trigger name
    QualifiedName ->
    m (Maybe String)
  analyzeFunction ::
    (PersistBackend m, Conn m ~ conn) =>
    -- | Qualified function name
    QualifiedName ->
    -- | Argument types, return type, and body
    m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String))
  getMigrationPack :: (PersistBackend m, Conn m ~ conn) => m (MigrationPack conn)