{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Beam.Migrate.Actions
(
DatabaseStateSource(..)
, DatabaseState(..)
, PotentialAction(..)
, ActionProvider(..)
, ActionProviderFn
, ensuringNot_
, justOne_
, createTableActionProvider
, dropTableActionProvider
, addColumnProvider
, addColumnNullProvider
, dropColumnNullProvider
, defaultActionProvider
, Solver(..), FinalSolution(..)
, finalSolution
, heuristicSolver
) where
import Database.Beam.Backend.SQL
import Database.Beam.Migrate.Checks
import Database.Beam.Migrate.SQL
import Database.Beam.Migrate.Types
import Database.Beam.Migrate.Types.Predicates (qnameAsText, qnameAsTableName)
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Parallel.Strategies
import Data.Foldable
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.PQueue.Min as PQ
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup
#endif
import GHC.Generics
data DatabaseStateSource
= DatabaseStateSourceOriginal
| DatabaseStateSourceDerived
deriving (Int -> DatabaseStateSource -> ShowS
[DatabaseStateSource] -> ShowS
DatabaseStateSource -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DatabaseStateSource] -> ShowS
$cshowList :: [DatabaseStateSource] -> ShowS
show :: DatabaseStateSource -> String
$cshow :: DatabaseStateSource -> String
showsPrec :: Int -> DatabaseStateSource -> ShowS
$cshowsPrec :: Int -> DatabaseStateSource -> ShowS
Show, DatabaseStateSource -> DatabaseStateSource -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c/= :: DatabaseStateSource -> DatabaseStateSource -> Bool
== :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c== :: DatabaseStateSource -> DatabaseStateSource -> Bool
Eq, Eq DatabaseStateSource
DatabaseStateSource -> DatabaseStateSource -> Bool
DatabaseStateSource -> DatabaseStateSource -> Ordering
DatabaseStateSource -> DatabaseStateSource -> DatabaseStateSource
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DatabaseStateSource -> DatabaseStateSource -> DatabaseStateSource
$cmin :: DatabaseStateSource -> DatabaseStateSource -> DatabaseStateSource
max :: DatabaseStateSource -> DatabaseStateSource -> DatabaseStateSource
$cmax :: DatabaseStateSource -> DatabaseStateSource -> DatabaseStateSource
>= :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c>= :: DatabaseStateSource -> DatabaseStateSource -> Bool
> :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c> :: DatabaseStateSource -> DatabaseStateSource -> Bool
<= :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c<= :: DatabaseStateSource -> DatabaseStateSource -> Bool
< :: DatabaseStateSource -> DatabaseStateSource -> Bool
$c< :: DatabaseStateSource -> DatabaseStateSource -> Bool
compare :: DatabaseStateSource -> DatabaseStateSource -> Ordering
$ccompare :: DatabaseStateSource -> DatabaseStateSource -> Ordering
Ord, Int -> DatabaseStateSource
DatabaseStateSource -> Int
DatabaseStateSource -> [DatabaseStateSource]
DatabaseStateSource -> DatabaseStateSource
DatabaseStateSource -> DatabaseStateSource -> [DatabaseStateSource]
DatabaseStateSource
-> DatabaseStateSource
-> DatabaseStateSource
-> [DatabaseStateSource]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DatabaseStateSource
-> DatabaseStateSource
-> DatabaseStateSource
-> [DatabaseStateSource]
$cenumFromThenTo :: DatabaseStateSource
-> DatabaseStateSource
-> DatabaseStateSource
-> [DatabaseStateSource]
enumFromTo :: DatabaseStateSource -> DatabaseStateSource -> [DatabaseStateSource]
$cenumFromTo :: DatabaseStateSource -> DatabaseStateSource -> [DatabaseStateSource]
enumFromThen :: DatabaseStateSource -> DatabaseStateSource -> [DatabaseStateSource]
$cenumFromThen :: DatabaseStateSource -> DatabaseStateSource -> [DatabaseStateSource]
enumFrom :: DatabaseStateSource -> [DatabaseStateSource]
$cenumFrom :: DatabaseStateSource -> [DatabaseStateSource]
fromEnum :: DatabaseStateSource -> Int
$cfromEnum :: DatabaseStateSource -> Int
toEnum :: Int -> DatabaseStateSource
$ctoEnum :: Int -> DatabaseStateSource
pred :: DatabaseStateSource -> DatabaseStateSource
$cpred :: DatabaseStateSource -> DatabaseStateSource
succ :: DatabaseStateSource -> DatabaseStateSource
$csucc :: DatabaseStateSource -> DatabaseStateSource
Enum, DatabaseStateSource
forall a. a -> a -> Bounded a
maxBound :: DatabaseStateSource
$cmaxBound :: DatabaseStateSource
minBound :: DatabaseStateSource
$cminBound :: DatabaseStateSource
Bounded, forall x. Rep DatabaseStateSource x -> DatabaseStateSource
forall x. DatabaseStateSource -> Rep DatabaseStateSource x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DatabaseStateSource x -> DatabaseStateSource
$cfrom :: forall x. DatabaseStateSource -> Rep DatabaseStateSource x
Generic)
instance NFData DatabaseStateSource
data DatabaseState be
= DatabaseState
{ forall be.
DatabaseState be
-> HashMap SomeDatabasePredicate DatabaseStateSource
dbStateCurrentState :: !(HM.HashMap SomeDatabasePredicate DatabaseStateSource)
, forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey :: !(HS.HashSet SomeDatabasePredicate)
, forall be. DatabaseState be -> Seq (MigrationCommand be)
dbStateCmdSequence :: !(Seq.Seq (MigrationCommand be))
}
deriving instance Show (BeamSqlBackendSyntax be) => Show (DatabaseState be)
instance NFData (DatabaseState cmd) where
rnf :: DatabaseState cmd -> ()
rnf d :: DatabaseState cmd
d@DatabaseState{} = DatabaseState cmd
d seq :: forall a b. a -> b -> b
`seq` ()
data MeasuredDatabaseState be
= MeasuredDatabaseState {-# UNPACK #-} !Int {-# UNPACK #-} !Int (DatabaseState be)
deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall be x.
Rep (MeasuredDatabaseState be) x -> MeasuredDatabaseState be
forall be x.
MeasuredDatabaseState be -> Rep (MeasuredDatabaseState be) x
$cto :: forall be x.
Rep (MeasuredDatabaseState be) x -> MeasuredDatabaseState be
$cfrom :: forall be x.
MeasuredDatabaseState be -> Rep (MeasuredDatabaseState be) x
Generic
deriving instance Show (BeamSqlBackendSyntax be) => Show (MeasuredDatabaseState be)
instance NFData (MeasuredDatabaseState cmd)
instance Eq (MeasuredDatabaseState cmd) where
MeasuredDatabaseState cmd
a == :: MeasuredDatabaseState cmd -> MeasuredDatabaseState cmd -> Bool
== MeasuredDatabaseState cmd
b = forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
a forall a. Eq a => a -> a -> Bool
== forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
b
instance Ord (MeasuredDatabaseState cmd) where
compare :: MeasuredDatabaseState cmd -> MeasuredDatabaseState cmd -> Ordering
compare MeasuredDatabaseState cmd
a MeasuredDatabaseState cmd
b = forall a. Ord a => a -> a -> Ordering
compare (forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
a) (forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
b)
measure :: MeasuredDatabaseState cmd -> Int
measure :: forall cmd. MeasuredDatabaseState cmd -> Int
measure (MeasuredDatabaseState Int
cmdLength Int
estGoalDistance DatabaseState cmd
_) = Int
cmdLength forall a. Num a => a -> a -> a
+ Int
100 forall a. Num a => a -> a -> a
* Int
estGoalDistance
measuredDbState :: MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState :: forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState (MeasuredDatabaseState Int
_ Int
_ DatabaseState cmd
s) = DatabaseState cmd
s
measureDb' :: HS.HashSet SomeDatabasePredicate
-> HS.HashSet SomeDatabasePredicate
-> Int
-> DatabaseState cmd
-> MeasuredDatabaseState cmd
measureDb' :: forall cmd.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Int
-> DatabaseState cmd
-> MeasuredDatabaseState cmd
measureDb' HashSet SomeDatabasePredicate
_ HashSet SomeDatabasePredicate
post Int
cmdLength st :: DatabaseState cmd
st@(DatabaseState HashMap SomeDatabasePredicate DatabaseStateSource
_ HashSet SomeDatabasePredicate
repr Seq (MigrationCommand cmd)
_) =
forall be.
Int -> Int -> DatabaseState be -> MeasuredDatabaseState be
MeasuredDatabaseState Int
cmdLength Int
distToGoal DatabaseState cmd
st
where
distToGoal :: Int
distToGoal = forall a. HashSet a -> Int
HS.size ((HashSet SomeDatabasePredicate
repr forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
post) forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.union`
(HashSet SomeDatabasePredicate
post forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
repr))
data PotentialAction be
= PotentialAction
{ forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions :: !(HS.HashSet SomeDatabasePredicate)
, forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions :: !(HS.HashSet SomeDatabasePredicate)
, forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands :: !(Seq.Seq (MigrationCommand be))
, forall be. PotentialAction be -> Text
actionEnglish :: !Text
, forall be. PotentialAction be -> Int
actionScore :: {-# UNPACK #-} !Int
}
instance Semigroup (PotentialAction be) where
<> :: PotentialAction be -> PotentialAction be -> PotentialAction be
(<>) = forall a. Monoid a => a -> a -> a
mappend
instance Monoid (PotentialAction be) where
mempty :: PotentialAction be
mempty = forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Text
"" Int
0
mappend :: PotentialAction be -> PotentialAction be -> PotentialAction be
mappend PotentialAction be
a PotentialAction be
b =
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
a forall a. Semigroup a => a -> a -> a
<> forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
b)
(forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
a forall a. Semigroup a => a -> a -> a
<> forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
b)
(forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
a forall a. Semigroup a => a -> a -> a
<> forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
b)
(if Text -> Bool
T.null (forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a) then forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b
else if Text -> Bool
T.null (forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b) then forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a
else forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a forall a. Semigroup a => a -> a -> a
<> Text
"; " forall a. Semigroup a => a -> a -> a
<> forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b)
(forall be. PotentialAction be -> Int
actionScore PotentialAction be
a forall a. Num a => a -> a -> a
+ forall be. PotentialAction be -> Int
actionScore PotentialAction be
b)
type ActionProviderFn be =
(forall preCondition. Typeable preCondition => [ preCondition ])
-> (forall postCondition. Typeable postCondition => [ postCondition ])
-> [ PotentialAction be ]
newtype ActionProvider be
= ActionProvider { forall be. ActionProvider be -> ActionProviderFn be
getPotentialActions :: ActionProviderFn be }
instance Semigroup (ActionProvider be) where
<> :: ActionProvider be -> ActionProvider be -> ActionProvider be
(<>) = forall a. Monoid a => a -> a -> a
mappend
instance Monoid (ActionProvider be) where
mempty :: ActionProvider be
mempty = forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (\forall preCondition. Typeable preCondition => [preCondition]
_ forall preCondition. Typeable preCondition => [preCondition]
_ -> [])
mappend :: ActionProvider be -> ActionProvider be -> ActionProvider be
mappend (ActionProvider (forall preCondition. Typeable preCondition => [preCondition])
-> (forall preCondition. Typeable preCondition => [preCondition])
-> [PotentialAction be]
a) (ActionProvider (forall preCondition. Typeable preCondition => [preCondition])
-> (forall preCondition. Typeable preCondition => [preCondition])
-> [PotentialAction be]
b) =
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post ->
let aRes :: [PotentialAction be]
aRes = (forall preCondition. Typeable preCondition => [preCondition])
-> (forall preCondition. Typeable preCondition => [preCondition])
-> [PotentialAction be]
a forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post
bRes :: [PotentialAction be]
bRes = (forall preCondition. Typeable preCondition => [preCondition])
-> (forall preCondition. Typeable preCondition => [preCondition])
-> [PotentialAction be]
b forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post
in forall a. Strategy a -> a -> a
withStrategy (forall a. Strategy a -> Strategy a
rparWith (forall a. Strategy a -> Strategy [a]
parList forall a. Strategy a
rseq)) [PotentialAction be]
aRes seq :: forall a b. a -> b -> b
`seq`
forall a. Strategy a -> a -> a
withStrategy (forall a. Strategy a -> Strategy a
rparWith (forall a. Strategy a -> Strategy [a]
parList forall a. Strategy a
rseq)) [PotentialAction be]
bRes seq :: forall a b. a -> b -> b
`seq`
[PotentialAction be]
aRes forall a. [a] -> [a] -> [a]
++ [PotentialAction be]
bRes
createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
createTableWeight :: Int
createTableWeight = Int
500
dropTableWeight :: Int
dropTableWeight = Int
100
addColumnWeight :: Int
addColumnWeight = Int
1
dropColumnWeight :: Int
dropColumnWeight = Int
1
ensuringNot_ :: Alternative m => [ a ] -> m ()
ensuringNot_ :: forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensuringNot_ [a]
_ = forall (f :: * -> *) a. Alternative f => f a
empty
justOne_ :: [ a ] -> [ a ]
justOne_ :: forall a. [a] -> [a]
justOne_ [a
x] = [a
x]
justOne_ [a]
_ = []
createTableActionProvider :: forall be
. ( Typeable be, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
createTableActionProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
createTableActionProvider =
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
findPostConditions =
do tblP :: TableExistsPredicate
tblP@(TableExistsPredicate QualifiedName
postTblNm) <- forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ forall a b. (a -> b) -> a -> b
$
do TableExistsPredicate QualifiedName
preTblNm <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
preTblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)
([[SomeDatabasePredicate]]
columnsP, [(Text,
Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
[Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
columns) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
do columnP :: TableHasColumn be
columnP@(TableHasColumn QualifiedName
tblNm Text
colNm Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
schema :: TableHasColumn be) <-
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm Bool -> Bool -> Bool
&& forall dataType.
HasDataTypeCreatedCheck dataType =>
dataType
-> (forall preCondition. Typeable preCondition => [preCondition])
-> Bool
dataTypeHasBeenCreated Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
schema forall preCondition. Typeable preCondition => [preCondition]
findPreConditions)
([SomeDatabasePredicate]
constraintsP, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints) <-
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ do
constraintP :: TableColumnHasConstraint be
constraintP@(TableColumnHasConstraint QualifiedName
tblNm' Text
colNm' Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c :: TableColumnHasConstraint be) <-
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
postTblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
colNm forall a. Eq a => a -> a -> Bool
== Text
colNm')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableColumnHasConstraint be
constraintP, Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableHasColumn be
columnPforall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
constraintsP, (Text
colNm, Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
schema, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints))
(TableHasPrimaryKey
primaryKeyP, [Text]
primaryKey) <- forall a. [a] -> [a]
justOne_ forall a b. (a -> b) -> a -> b
$ do
primaryKeyP :: TableHasPrimaryKey
primaryKeyP@(TableHasPrimaryKey QualifiedName
tblNm [Text]
primaryKey) <-
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableHasPrimaryKey
primaryKeyP, [Text]
primaryKey)
let postConditions :: [SomeDatabasePredicate]
postConditions = [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableExistsPredicate
tblP, forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableHasPrimaryKey
primaryKeyP ] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SomeDatabasePredicate]]
columnsP
cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandCreateTableSyntax syntax -> syntax
createTableCmd (forall syntax.
IsSql92CreateTableSyntax syntax =>
Maybe (Sql92CreateTableOptionsSyntax syntax)
-> Sql92CreateTableTableNameSyntax syntax
-> [(Text, Sql92CreateTableColumnSchemaSyntax syntax)]
-> [Sql92CreateTableTableConstraintSyntax syntax]
-> syntax
createTableSyntax forall a. Maybe a
Nothing (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
postTblNm) [(Text,
Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
colsSyntax [Sql92CreateTableTableConstraintSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))]
tblConstraints)
tblConstraints :: [Sql92CreateTableTableConstraintSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))]
tblConstraints = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
primaryKey then [] else [ forall constraint.
IsSql92TableConstraintSyntax constraint =>
[Text] -> constraint
primaryKeyConstraintSyntax [Text]
primaryKey ]
colsSyntax :: [(Text,
Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
colsSyntax = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
colNm, Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
type_, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
cs) -> (Text
colNm, forall columnSchema.
IsSql92ColumnSchemaSyntax columnSchema =>
Sql92ColumnSchemaColumnTypeSyntax columnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema]
-> Maybe Text
-> columnSchema
columnSchemaSyntax Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
type_ forall a. Maybe a
Nothing [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
cs forall a. Maybe a
Nothing)) [(Text,
Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
[Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
columns
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction forall a. Monoid a => a
mempty (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
postConditions)
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
(Text
"Create the table " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
postTblNm) Int
createTableWeight)
dropTableActionProvider :: forall be
. BeamMigrateOnlySqlBackend be
=> ActionProvider be
dropTableActionProvider :: forall be. BeamMigrateOnlySqlBackend be => ActionProvider be
dropTableActionProvider =
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
findPostConditions =
do tblP :: TableExistsPredicate
tblP@(TableExistsPredicate QualifiedName
preTblNm) <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ forall a b. (a -> b) -> a -> b
$
do TableExistsPredicate QualifiedName
postTblNm <- forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
preTblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)
[SomeDatabasePredicate]
relatedPreds <-
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do p' :: SomeDatabasePredicate
p'@(SomeDatabasePredicate p
pred') <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (p
pred' forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` TableExistsPredicate
tblP)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeDatabasePredicate
p'
let cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandDropTableSyntax syntax -> syntax
dropTableCmd (forall syntax.
IsSql92DropTableSyntax syntax =>
Sql92DropTableTableNameSyntax syntax -> syntax
dropTableSyntax (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
preTblNm))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableExistsPredicate
tblPforall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
relatedPreds)) forall a. Monoid a => a
mempty
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationLosesData))
(Text
"Drop table " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
preTblNm) Int
dropTableWeight)
addColumnProvider :: forall be
. ( Typeable be, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
addColumnProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnProvider =
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
findPostConditions =
do colP :: TableHasColumn be
colP@(TableHasColumn QualifiedName
tblNm Text
colNm Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
colType :: TableHasColumn be)
<- forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
TableExistsPredicate QualifiedName
tblNm' <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm' forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm Bool -> Bool -> Bool
&& forall dataType.
HasDataTypeCreatedCheck dataType =>
dataType
-> (forall preCondition. Typeable preCondition => [preCondition])
-> Bool
dataTypeHasBeenCreated Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
colType forall preCondition. Typeable preCondition => [preCondition]
findPreConditions)
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ forall a b. (a -> b) -> a -> b
$ do
TableHasColumn QualifiedName
tblNm'' Text
colNm' Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
_ :: TableHasColumn be <-
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm'' forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm Bool -> Bool -> Bool
&& Text
colNm forall a. Eq a => a -> a -> Bool
== Text
colNm')
([SomeDatabasePredicate]
constraintsP, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints) <-
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ do
constraintP :: TableColumnHasConstraint be
constraintP@(TableColumnHasConstraint QualifiedName
tblNm'' Text
colNm' Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c :: TableColumnHasConstraint be) <-
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'')
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
colNm forall a. Eq a => a -> a -> Bool
== Text
colNm')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableColumnHasConstraint be
constraintP, Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c)
let cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableColumnSchemaSyntax syntax -> syntax
addColumnSyntax Text
colNm Sql92AlterTableColumnSchemaSyntax
(Sql92AlterTableAlterTableActionSyntax
(Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
schema))
schema :: Sql92AlterTableColumnSchemaSyntax
(Sql92AlterTableAlterTableActionSyntax
(Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
schema = forall columnSchema.
IsSql92ColumnSchemaSyntax columnSchema =>
Sql92ColumnSchemaColumnTypeSyntax columnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema]
-> Maybe Text
-> columnSchema
columnSchemaSyntax Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
colType forall a. Maybe a
Nothing [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction forall a. Monoid a => a
mempty (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableHasColumn be
colP] forall a. [a] -> [a] -> [a]
++ [SomeDatabasePredicate]
constraintsP))
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
(Text
"Add column " forall a. Semigroup a => a -> a -> a
<> Text
colNm forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm)
(Int
addColumnWeight forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length (QualifiedName -> Text
qnameAsText QualifiedName
tblNm) forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
colNm)))
dropColumnProvider :: forall be
. ( Typeable be, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
dropColumnProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnProvider = forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
_ =
do colP :: TableHasColumn be
colP@(TableHasColumn QualifiedName
tblNm Text
colNm Sql92ColumnSchemaColumnTypeSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
_ :: TableHasColumn be)
<- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
[SomeDatabasePredicate]
relatedPreds <-
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do p' :: SomeDatabasePredicate
p'@(SomeDatabasePredicate p
pred') <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (p
pred' forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` TableHasColumn be
colP)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeDatabasePredicate
p'
let cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> syntax
dropColumnSyntax Text
colNm))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableHasColumn be
colPforall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
relatedPreds)) forall a. Monoid a => a
mempty
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationLosesData))
(Text
"Drop column " forall a. Semigroup a => a -> a -> a
<> Text
colNm forall a. Semigroup a => a -> a -> a
<> Text
" from " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm)
(Int
dropColumnWeight forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length (QualifiedName -> Text
qnameAsText QualifiedName
tblNm) forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
colNm)))
addColumnNullProvider :: forall be
. ( Typeable be, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
addColumnNullProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnNullProvider = forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
findPostConditions =
do colP :: TableColumnHasConstraint be
colP@(TableColumnHasConstraint QualifiedName
tblNm Text
colNm Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
_ :: TableColumnHasConstraint be)
<- forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
TableExistsPredicate QualifiedName
tblNm' <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')
TableHasColumn QualifiedName
tblNm'' Text
colNm' BeamMigrateSqlBackendDataTypeSyntax be
_ :: TableHasColumn be <-
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'' Bool -> Bool -> Bool
&& Text
colNm forall a. Eq a => a -> a -> Bool
== Text
colNm')
let cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableAlterColumnActionSyntax syntax -> syntax
alterColumnSyntax Text
colNm forall syntax. IsSql92AlterColumnActionSyntax syntax => syntax
setNotNullSyntax))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction forall a. Monoid a => a
mempty (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableColumnHasConstraint be
colP])
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
(Text
"Add not null constraint to " forall a. Semigroup a => a -> a -> a
<> Text
colNm forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int
100)
dropColumnNullProvider :: forall be
. ( Typeable be, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
dropColumnNullProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnNullProvider = forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
where
provider :: ActionProviderFn be
provider :: ActionProviderFn be
provider forall preCondition. Typeable preCondition => [preCondition]
findPreConditions forall preCondition. Typeable preCondition => [preCondition]
_ =
do colP :: TableColumnHasConstraint be
colP@(TableColumnHasConstraint QualifiedName
tblNm Text
colNm Sql92ColumnSchemaColumnConstraintDefinitionSyntax
(Sql92CreateTableColumnSchemaSyntax
(Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
_ :: TableColumnHasConstraint be)
<- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
TableExistsPredicate QualifiedName
tblNm' <- forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')
TableHasColumn QualifiedName
tblNm'' Text
colNm' BeamMigrateSqlBackendDataTypeSyntax be
_ :: TableHasColumn be <-
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'' Bool -> Bool -> Bool
&& Text
colNm forall a. Eq a => a -> a -> Bool
== Text
colNm')
let cmd :: BeamSqlBackendSyntax be
cmd = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableAlterColumnActionSyntax syntax -> syntax
alterColumnSyntax Text
colNm forall syntax. IsSql92AlterColumnActionSyntax syntax => syntax
setNullSyntax))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableColumnHasConstraint be
colP]) forall a. Monoid a => a
mempty
(forall a. a -> Seq a
Seq.singleton (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
(Text
"Drop not null constraint for " forall a. Semigroup a => a -> a -> a
<> Text
colNm forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int
100)
defaultActionProvider :: ( Typeable be
, BeamMigrateOnlySqlBackend be )
=> ActionProvider be
defaultActionProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
defaultActionProvider =
forall a. Monoid a => [a] -> a
mconcat
[ forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
createTableActionProvider
, forall be. BeamMigrateOnlySqlBackend be => ActionProvider be
dropTableActionProvider
, forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnProvider
, forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnProvider
, forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnNullProvider
, forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnNullProvider ]
data Solver cmd where
ProvideSolution :: [ MigrationCommand cmd ] -> Solver cmd
SearchFailed :: [ DatabaseState cmd ] -> Solver cmd
ChooseActions :: { forall cmd. Solver cmd -> DatabaseState cmd
choosingActionsAtState :: !(DatabaseState cmd)
, ()
getPotentialActionChoice :: f -> PotentialAction cmd
, ()
potentialActionChoices :: [ f ]
, ()
continueSearch :: [ f ] -> Solver cmd
} -> Solver cmd
data FinalSolution be
= Solved [ MigrationCommand be ]
| Candidates [ DatabaseState be ]
deriving instance Show (BeamSqlBackendSyntax be) => Show (FinalSolution be)
solvedState :: HS.HashSet SomeDatabasePredicate -> DatabaseState be -> Bool
solvedState :: forall be.
HashSet SomeDatabasePredicate -> DatabaseState be -> Bool
solvedState HashSet SomeDatabasePredicate
goal (DatabaseState HashMap SomeDatabasePredicate DatabaseStateSource
_ HashSet SomeDatabasePredicate
cur Seq (MigrationCommand be)
_) = HashSet SomeDatabasePredicate
goal forall a. Eq a => a -> a -> Bool
== HashSet SomeDatabasePredicate
cur
finalSolution :: Solver be -> FinalSolution be
finalSolution :: forall be. Solver be -> FinalSolution be
finalSolution (SearchFailed [DatabaseState be]
sts) = forall be. [DatabaseState be] -> FinalSolution be
Candidates [DatabaseState be]
sts
finalSolution (ProvideSolution [MigrationCommand be]
cmds) = forall be. [MigrationCommand be] -> FinalSolution be
Solved [MigrationCommand be]
cmds
finalSolution (ChooseActions DatabaseState be
_ f -> PotentialAction be
_ [f]
actions [f] -> Solver be
next) =
forall be. Solver be -> FinalSolution be
finalSolution ([f] -> Solver be
next [f]
actions)
{-# INLINE heuristicSolver #-}
heuristicSolver :: ActionProvider be
-> [ SomeDatabasePredicate ]
-> [ SomeDatabasePredicate ]
-> Solver be
heuristicSolver :: forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
provider [SomeDatabasePredicate]
preConditionsL [SomeDatabasePredicate]
postConditionsL =
MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' MinQueue (MeasuredDatabaseState be)
initQueue forall a. Monoid a => a
mempty forall a. MinQueue a
PQ.empty
where
rejectedCount :: Int
rejectedCount = Int
10
postConditions :: HashSet SomeDatabasePredicate
postConditions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
postConditionsL
preConditions :: HashSet SomeDatabasePredicate
preConditions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
preConditionsL
allToFalsify :: HashSet SomeDatabasePredicate
allToFalsify = HashSet SomeDatabasePredicate
preConditions forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
postConditions
measureDb :: Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb = forall cmd.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Int
-> DatabaseState cmd
-> MeasuredDatabaseState cmd
measureDb' HashSet SomeDatabasePredicate
allToFalsify HashSet SomeDatabasePredicate
postConditions
initQueue :: MinQueue (MeasuredDatabaseState be)
initQueue = forall a. a -> MinQueue a
PQ.singleton (Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb Int
0 DatabaseState be
initDbState)
initDbState :: DatabaseState be
initDbState = forall be.
HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
DatabaseState (DatabaseStateSource
DatabaseStateSourceOriginal forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. HashSet a -> HashMap a ()
HS.toMap HashSet SomeDatabasePredicate
preConditions)
HashSet SomeDatabasePredicate
preConditions
forall a. Monoid a => a
mempty
findPredicate :: forall predicate. Typeable predicate
=> SomeDatabasePredicate
-> [ predicate ] -> [ predicate ]
findPredicate :: forall predicate.
Typeable predicate =>
SomeDatabasePredicate -> [predicate] -> [predicate]
findPredicate
| Just (predicate :~: SomeDatabasePredicate
Refl :: predicate :~: SomeDatabasePredicate) <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT =
(:)
| Bool
otherwise =
\(SomeDatabasePredicate p
pred') [predicate]
ps ->
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [predicate]
ps (forall a. a -> [a] -> [a]
:[predicate]
ps) (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
pred')
findPredicates :: forall predicate f. (Typeable predicate, Foldable f)
=> f SomeDatabasePredicate -> [ predicate ]
findPredicates :: forall predicate (f :: * -> *).
(Typeable predicate, Foldable f) =>
f SomeDatabasePredicate -> [predicate]
findPredicates = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall predicate.
Typeable predicate =>
SomeDatabasePredicate -> [predicate] -> [predicate]
findPredicate []
heuristicSolver' :: MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' !MinQueue (MeasuredDatabaseState be)
q !HashSet (HashSet SomeDatabasePredicate)
visited !MinQueue (MeasuredDatabaseState be)
bestRejected =
case forall a. Ord a => MinQueue a -> Maybe (a, MinQueue a)
PQ.minView MinQueue (MeasuredDatabaseState be)
q of
Maybe
(MeasuredDatabaseState be, MinQueue (MeasuredDatabaseState be))
Nothing -> forall cmd. [DatabaseState cmd] -> Solver cmd
SearchFailed (forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => MinQueue a -> [a]
PQ.toList MinQueue (MeasuredDatabaseState be)
bestRejected)
Just (mdbState :: MeasuredDatabaseState be
mdbState@(MeasuredDatabaseState Int
_ Int
_ DatabaseState be
dbState), MinQueue (MeasuredDatabaseState be)
q')
| forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (HashSet SomeDatabasePredicate)
visited -> MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' MinQueue (MeasuredDatabaseState be)
q' HashSet (HashSet SomeDatabasePredicate)
visited MinQueue (MeasuredDatabaseState be)
bestRejected
| forall be.
HashSet SomeDatabasePredicate -> DatabaseState be -> Bool
solvedState HashSet SomeDatabasePredicate
postConditions (forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState MeasuredDatabaseState be
mdbState) ->
forall cmd. [MigrationCommand cmd] -> Solver cmd
ProvideSolution (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall be. DatabaseState be -> Seq (MigrationCommand be)
dbStateCmdSequence DatabaseState be
dbState))
| Bool
otherwise ->
let steps :: [PotentialAction be]
steps = forall be. ActionProvider be -> ActionProviderFn be
getPotentialActions
ActionProvider be
provider
(forall predicate (f :: * -> *).
(Typeable predicate, Foldable f) =>
f SomeDatabasePredicate -> [predicate]
findPredicates (forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState))
(forall predicate (f :: * -> *).
(Typeable predicate, Foldable f) =>
f SomeDatabasePredicate -> [predicate]
findPredicates [SomeDatabasePredicate]
postConditionsL)
steps' :: [(PotentialAction be, MeasuredDatabaseState be)]
steps' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (HashSet SomeDatabasePredicate)
visited) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
forall a. Strategy a -> a -> a
withStrategy (forall a. Strategy a -> Strategy [a]
parList forall a. Strategy a
rseq) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\PotentialAction be
step -> let dbState' :: MeasuredDatabaseState be
dbState' = PotentialAction be
-> MeasuredDatabaseState be -> MeasuredDatabaseState be
applyStep PotentialAction be
step MeasuredDatabaseState be
mdbState
in MeasuredDatabaseState be
dbState' seq :: forall a b. a -> b -> b
`seq` (PotentialAction be
step, MeasuredDatabaseState be
dbState')) [PotentialAction be]
steps
applyStep :: PotentialAction be
-> MeasuredDatabaseState be -> MeasuredDatabaseState be
applyStep PotentialAction be
step (MeasuredDatabaseState Int
score Int
_ DatabaseState be
dbState') =
let dbState'' :: DatabaseState be
dbState'' = forall {be}.
DatabaseState be -> PotentialAction be -> DatabaseState be
dbStateAfterAction DatabaseState be
dbState' PotentialAction be
step
in Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb (Int
score forall a. Num a => a -> a -> a
+ Int
1) DatabaseState be
dbState''
in case [(PotentialAction be, MeasuredDatabaseState be)]
steps' of
[] -> MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' MinQueue (MeasuredDatabaseState be)
q' HashSet (HashSet SomeDatabasePredicate)
visited (forall cmd.
MeasuredDatabaseState cmd
-> MinQueue (MeasuredDatabaseState cmd)
-> MinQueue (MeasuredDatabaseState cmd)
reject MeasuredDatabaseState be
mdbState MinQueue (MeasuredDatabaseState be)
bestRejected)
[(PotentialAction be, MeasuredDatabaseState be)]
_ -> forall cmd f.
DatabaseState cmd
-> (f -> PotentialAction cmd)
-> [f]
-> ([f] -> Solver cmd)
-> Solver cmd
ChooseActions DatabaseState be
dbState forall a b. (a, b) -> a
fst [(PotentialAction be, MeasuredDatabaseState be)]
steps' forall a b. (a -> b) -> a -> b
$ \[(PotentialAction be, MeasuredDatabaseState be)]
chosenSteps ->
let q'' :: MinQueue (MeasuredDatabaseState be)
q'' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(PotentialAction be
_, MeasuredDatabaseState be
dbState') -> forall a. Ord a => a -> MinQueue a -> MinQueue a
PQ.insert MeasuredDatabaseState be
dbState') MinQueue (MeasuredDatabaseState be)
q' [(PotentialAction be, MeasuredDatabaseState be)]
chosenSteps
visited' :: HashSet (HashSet SomeDatabasePredicate)
visited' = forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert (forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState) HashSet (HashSet SomeDatabasePredicate)
visited
in forall a. Strategy a -> a -> a
withStrategy (forall a. Strategy a -> Strategy a
rparWith forall a. Strategy a
rseq) MinQueue (MeasuredDatabaseState be)
q'' seq :: forall a b. a -> b -> b
`seq` MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' MinQueue (MeasuredDatabaseState be)
q'' HashSet (HashSet SomeDatabasePredicate)
visited' MinQueue (MeasuredDatabaseState be)
bestRejected
reject :: MeasuredDatabaseState cmd -> PQ.MinQueue (MeasuredDatabaseState cmd)
-> PQ.MinQueue (MeasuredDatabaseState cmd)
reject :: forall cmd.
MeasuredDatabaseState cmd
-> MinQueue (MeasuredDatabaseState cmd)
-> MinQueue (MeasuredDatabaseState cmd)
reject MeasuredDatabaseState cmd
mdbState MinQueue (MeasuredDatabaseState cmd)
q =
let q' :: MinQueue (MeasuredDatabaseState cmd)
q' = forall a. Ord a => a -> MinQueue a -> MinQueue a
PQ.insert MeasuredDatabaseState cmd
mdbState MinQueue (MeasuredDatabaseState cmd)
q
in forall a. [a] -> MinQueue a
PQ.fromAscList (forall a. Ord a => Int -> MinQueue a -> [a]
PQ.take Int
rejectedCount MinQueue (MeasuredDatabaseState cmd)
q')
dbStateAfterAction :: DatabaseState be -> PotentialAction be -> DatabaseState be
dbStateAfterAction (DatabaseState HashMap SomeDatabasePredicate DatabaseStateSource
curState HashSet SomeDatabasePredicate
_ Seq (MigrationCommand be)
cmds) PotentialAction be
action =
let curState' :: HashMap SomeDatabasePredicate DatabaseStateSource
curState' = ((HashMap SomeDatabasePredicate DatabaseStateSource
curState forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HM.difference` forall a. HashSet a -> HashMap a ()
HS.toMap (forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
action))
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` (DatabaseStateSource
DatabaseStateSourceDerived forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. HashSet a -> HashMap a ()
HS.toMap (forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
action)))
in forall be.
HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
DatabaseState HashMap SomeDatabasePredicate DatabaseStateSource
curState' (forall a. HashMap a () -> HashSet a
HS.fromMap (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HashMap SomeDatabasePredicate DatabaseStateSource
curState'))
(Seq (MigrationCommand be)
cmds forall a. Semigroup a => a -> a -> a
<> forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
action)