{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
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,
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)
type QualifiedName = (Maybe String, String)
type UniqueDefInfo = UniqueDef' String (Either String String)
data TableInfo = TableInfo
{ TableInfo -> [Column]
tableColumns :: [Column],
TableInfo -> [UniqueDefInfo]
tableUniques :: [UniqueDefInfo],
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
|
AlterTable QualifiedName String TableInfo TableInfo [AlterTable]
|
DropTrigger QualifiedName QualifiedName
|
AddTriggerOnDelete QualifiedName QualifiedName String
|
AddTriggerOnUpdate QualifiedName QualifiedName (Maybe String) String
|
CreateOrReplaceFunction String
|
DropFunction QualifiedName
|
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,
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
migrateRecursively ::
(PersistBackend m, PersistEntity v) =>
(String -> m SingleMigration) ->
(EntityDef -> m SingleMigration) ->
(DbType -> m SingleMigration) ->
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)
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 ->
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
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
")"
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 ->
TableInfo ->
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
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]
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)
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
)
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) =>
String ->
m Bool
getCurrentSchema :: (PersistBackend m, Conn m ~ conn) => m (Maybe String)
listTables ::
(PersistBackend m, Conn m ~ conn) =>
Maybe String ->
m [String]
listTableTriggers ::
(PersistBackend m, Conn m ~ conn) =>
QualifiedName ->
m [String]
analyzeTable ::
(PersistBackend m, Conn m ~ conn) =>
QualifiedName ->
m (Maybe TableInfo)
analyzeTrigger ::
(PersistBackend m, Conn m ~ conn) =>
QualifiedName ->
m (Maybe String)
analyzeFunction ::
(PersistBackend m, Conn m ~ conn) =>
QualifiedName ->
m (Maybe (Maybe [DbTypePrimitive], Maybe DbTypePrimitive, String))
getMigrationPack :: (PersistBackend m, Conn m ~ conn) => m (MigrationPack conn)