{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Data types and functions to discover sequences of DDL commands to go from
-- one database state to another. Used for migration generation.
--
-- For our purposes, a database state is fully specified by the set of
-- predicates that apply to that database.
--
-- Migration generation is approached as a graph search problem over the
-- infinite graph of databases /G/. The nodes of /G/ are database states, which
-- (as said above) are simply sets of predicates (see 'DatabaseState' for the
-- realization of this concept in code). For two vertices /S1/ and /S2/ in /G/,
-- there is an edge between the two if and only if there is a DDL command that
-- can take a database at /S1/ to /S2/.
--
-- We generate migrations by exploring this graph, starting at the source state
-- and ending at the destination state. By default we use an optimizing solver
-- that weights each edge by the complexity of the particular command, and we
-- attempt to find the shortest path using Dijkstra's algorithm, although a user
-- may override this behavior and provide a custom edge selection mechanism (or
-- even defer this choice to the user).
--
-- In order to conduct the breadth-first search, we must know which edges lead
-- out of whichever vertex we're currently visiting. The solving algorithm thus
-- takes a set of 'ActionProvider's, which are means of discovering edges that
-- are incident to the current database state.
--
-- Conceptually, an 'ActionProvider' is a function of type 'ActionProviderFn',
-- which takes the current database state and produces a list of edges in the
-- form of 'PotentialAction' objects. For optimization purposes,
-- 'ActionProvider's also take in the desired destination state, which it can
-- use to select only edges that make sense. This does not affect the result,
-- just the amount of time it may take to get there.
--
-- Note that because the graph of database states is infinite, a breadth-first
-- search may easily end up continuing to explore when there is no chance of
-- reaching our goal. This would result in non-termination and is highly
-- undesirable. In order to prevent this, we limit ourselves to only exploring
-- edges that take us /closer/ to the destination state. Here, we measure
-- distance between two states as the number of elements in the symmetric
-- difference of two database states. Thus, every action we take must either
-- remove a predicate that doesn't exist in the destination state, or add a
-- predicate that does. If a potential action only adds predicates that do not
-- exist in the final state or removes predicates that do not exist in the
-- first, then we never explore that edge.
--
-- == A note on speed
--
-- There are some issues with this approach. Namely, if there is no solution, we
-- can end up exploring the entire action space, which may be quite a lot. While
-- @beam-migrate@ can solve all databases that can be made up of predicates in
-- this module, other beam backends may not make such strict guarantees
-- (although in practice, all do). Nevertheless, if you're hacking on this
-- module and notice what seems like an infinite loop, you may have accidentally
-- removed code that exposed the edge that leads to a solution to the migration.
--
--
module Database.Beam.Migrate.Actions
  (
  -- * Database state
    DatabaseStateSource(..)
  , DatabaseState(..)

  -- * Action generation
  , PotentialAction(..)

  , ActionProvider(..)
  , ActionProviderFn

  , ensuringNot_
  , justOne_

  , createTableActionProvider
  , dropTableActionProvider
  , addColumnProvider
  , addColumnNullProvider
  , dropColumnNullProvider
  , defaultActionProvider

  -- * Solver
  , 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

-- | Used to indicate whether a particular predicate is from the initial
-- database state, or due to a sequence of actions we've committed too. Used to
-- prevent runaway action generation based off of derived states.
data DatabaseStateSource
  = DatabaseStateSourceOriginal -- ^ Predicate is from the original set given by the user
  | DatabaseStateSourceDerived  -- ^ Predicate is from an action we've committed to in this action chain
  deriving (Int -> DatabaseStateSource -> ShowS
[DatabaseStateSource] -> ShowS
DatabaseStateSource -> String
(Int -> DatabaseStateSource -> ShowS)
-> (DatabaseStateSource -> String)
-> ([DatabaseStateSource] -> ShowS)
-> Show DatabaseStateSource
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
(DatabaseStateSource -> DatabaseStateSource -> Bool)
-> (DatabaseStateSource -> DatabaseStateSource -> Bool)
-> Eq DatabaseStateSource
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
Eq DatabaseStateSource
-> (DatabaseStateSource -> DatabaseStateSource -> Ordering)
-> (DatabaseStateSource -> DatabaseStateSource -> Bool)
-> (DatabaseStateSource -> DatabaseStateSource -> Bool)
-> (DatabaseStateSource -> DatabaseStateSource -> Bool)
-> (DatabaseStateSource -> DatabaseStateSource -> Bool)
-> (DatabaseStateSource
    -> DatabaseStateSource -> DatabaseStateSource)
-> (DatabaseStateSource
    -> DatabaseStateSource -> DatabaseStateSource)
-> Ord 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]
(DatabaseStateSource -> DatabaseStateSource)
-> (DatabaseStateSource -> DatabaseStateSource)
-> (Int -> DatabaseStateSource)
-> (DatabaseStateSource -> Int)
-> (DatabaseStateSource -> [DatabaseStateSource])
-> (DatabaseStateSource
    -> DatabaseStateSource -> [DatabaseStateSource])
-> (DatabaseStateSource
    -> DatabaseStateSource -> [DatabaseStateSource])
-> (DatabaseStateSource
    -> DatabaseStateSource
    -> DatabaseStateSource
    -> [DatabaseStateSource])
-> Enum 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
DatabaseStateSource
-> DatabaseStateSource -> Bounded DatabaseStateSource
forall a. a -> a -> Bounded a
maxBound :: DatabaseStateSource
$cmaxBound :: DatabaseStateSource
minBound :: DatabaseStateSource
$cminBound :: DatabaseStateSource
Bounded, (forall x. DatabaseStateSource -> Rep DatabaseStateSource x)
-> (forall x. Rep DatabaseStateSource x -> DatabaseStateSource)
-> Generic DatabaseStateSource
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

-- | Represents the state of a database as a migration is being generated
data DatabaseState be
  = DatabaseState
  { forall be.
DatabaseState be
-> HashMap SomeDatabasePredicate DatabaseStateSource
dbStateCurrentState       :: !(HM.HashMap SomeDatabasePredicate DatabaseStateSource)
    -- ^ The current set of predicates that apply to this database as well as
    -- their source (user or from previous actions)
  , forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey                :: !(HS.HashSet SomeDatabasePredicate)
    -- ^ HS.fromMap of 'dbStateCurrentState', for maximal sharing
  , forall be. DatabaseState be -> Seq (MigrationCommand be)
dbStateCmdSequence        :: !(Seq.Seq (MigrationCommand be))
    -- ^ The current sequence of commands we've committed to in this state
  }
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 DatabaseState cmd -> () -> ()
`seq` ()

-- | Wrapper for 'DatabaseState' that keeps track of the command sequence length
-- and goal distance. Used for sorting states when conducting the search.
data MeasuredDatabaseState be
  = MeasuredDatabaseState {-# UNPACK #-} !Int {-# UNPACK #-} !Int (DatabaseState be)
  deriving (forall x.
 MeasuredDatabaseState be -> Rep (MeasuredDatabaseState be) x)
-> (forall x.
    Rep (MeasuredDatabaseState be) x -> MeasuredDatabaseState be)
-> Generic (MeasuredDatabaseState be)
forall x.
Rep (MeasuredDatabaseState be) x -> MeasuredDatabaseState be
forall x.
MeasuredDatabaseState be -> Rep (MeasuredDatabaseState be) x
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 = MeasuredDatabaseState cmd -> Int
forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== MeasuredDatabaseState cmd -> Int
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 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MeasuredDatabaseState cmd -> Int
forall cmd. MeasuredDatabaseState cmd -> Int
measure MeasuredDatabaseState cmd
a) (MeasuredDatabaseState cmd -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100 Int -> Int -> Int
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)
_) =
  Int -> Int -> DatabaseState cmd -> MeasuredDatabaseState cmd
forall be.
Int -> Int -> DatabaseState be -> MeasuredDatabaseState be
MeasuredDatabaseState Int
cmdLength Int
distToGoal DatabaseState cmd
st
  where

    distToGoal :: Int
distToGoal = HashSet SomeDatabasePredicate -> Int
forall a. HashSet a -> Int
HS.size ((HashSet SomeDatabasePredicate
repr HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
post) HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.union`
                          (HashSet SomeDatabasePredicate
post HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
repr))

-- | Represents an edge (or a path) in the database graph.
--
-- Given a particular starting point, the destination database is the database
-- where each predicate in 'actionPreConditions' has been removed and each
-- predicate in 'actionPostConditions' has been added.
data PotentialAction be
  = PotentialAction
  { forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions  :: !(HS.HashSet SomeDatabasePredicate)
    -- ^ Preconditions that will no longer apply
  , forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions :: !(HS.HashSet SomeDatabasePredicate)
    -- ^ Conditions that will apply after we're done
  , forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands :: !(Seq.Seq (MigrationCommand be))
    -- ^ The sequence of commands that accomplish this movement in the database
    -- graph. For an edge, 'actionCommands' contains one command; for a path, it
    -- will contain more.
  , forall be. PotentialAction be -> Text
actionEnglish  :: !Text
    -- ^ An english description of the movement
  , forall be. PotentialAction be -> Int
actionScore    :: {-# UNPACK #-} !Int
    -- ^ A heuristic notion of complexity or weight; used to find the "easiest"
    -- path through the graph.
  }

instance Semigroup (PotentialAction be) where
  <> :: PotentialAction be -> PotentialAction be -> PotentialAction be
(<>) = PotentialAction be -> PotentialAction be -> PotentialAction be
forall a. Monoid a => a -> a -> a
mappend

-- | 'PotentialAction's can represent edges or paths. Monadically combining two
-- 'PotentialAction's results in the path between the source of the first and
-- the destination of the second. 'mempty' here returns the action that does
-- nothing (i.e., the edge going back to the same database state)
instance Monoid (PotentialAction be) where
  mempty :: PotentialAction be
mempty = HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty Seq (MigrationCommand be)
forall a. Monoid a => a
mempty  Text
"" Int
0
  mappend :: PotentialAction be -> PotentialAction be -> PotentialAction be
mappend PotentialAction be
a PotentialAction be
b =
    HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
a HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. Semigroup a => a -> a -> a
<> PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
b)
                    (PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
a HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. Semigroup a => a -> a -> a
<> PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
b)
                    (PotentialAction be -> Seq (MigrationCommand be)
forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
a Seq (MigrationCommand be)
-> Seq (MigrationCommand be) -> Seq (MigrationCommand be)
forall a. Semigroup a => a -> a -> a
<> PotentialAction be -> Seq (MigrationCommand be)
forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
b)
                    (if Text -> Bool
T.null (PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a) then PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b
                      else if Text -> Bool
T.null (PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b) then PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a
                           else PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PotentialAction be -> Text
forall be. PotentialAction be -> Text
actionEnglish PotentialAction be
b)
                    (PotentialAction be -> Int
forall be. PotentialAction be -> Int
actionScore PotentialAction be
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PotentialAction be -> Int
forall be. PotentialAction be -> Int
actionScore PotentialAction be
b)

-- | See 'ActionProvider'
type ActionProviderFn be =
     (forall preCondition.  Typeable preCondition  => [ preCondition ])             {- The list of preconditions -}
  -> (forall postCondition. Typeable postCondition => [ postCondition ])            {- The list of postconditions (used for guiding action selection) -}
  -> [ PotentialAction be ]  {- A list of actions that we could perform -}

-- | Edge discovery mechanism. A newtype wrapper over 'ActionProviderFn'.
--
-- An 'ActionProviderFn' takes two arguments. The first is the set of predicates
-- that exist in the current database.
--
-- The function should a set of edges from the database specified in the first
-- argument to possible destination databases. For optimization purposes, the
-- second argument is the set of predicates that ought to exist in the
-- destination database. This can be used to eliminate edges that will not lead
-- to a solution.
--
-- This second argument is just an optimization and doesn't change the final
-- result, although it can significantly impact the time it takes to get there.
--
-- Both the current database set and the destination database set are given as
-- polymorphic lists of predicates. When you instantiate the type, the current
-- database predicate set is queried for predicates of that type.
--
-- For example, 'dropTableActionProvider' provides a @DROP TABLE@ action edge
-- whenever it encounters a table that exists. In order to do this, it attempts
-- to find all 'TableExistsPredicate' that do not exist in the destination
-- database. Its 'ActionProviderFn' may be implemented like such:
--
-- > dropTableActionProvider preConditions postConditions = do
-- >     TableExistsPredicate srcTblNm <- preConditions
-- >     ensuringNot_ $ $
-- >       do TableExistsPredicate destTblNm <- postConditions
-- >          guard (srcTblNm == destTblNm)
--
-- 'ensuringNot_' is a function that causes the action provider to return no
-- results if there are any elements in the provided list. In this case, it's
-- used to stop @DROP TABLE@ action generation for tables which must be present
-- in the final database.
newtype ActionProvider be
  = ActionProvider { forall be. ActionProvider be -> ActionProviderFn be
getPotentialActions :: ActionProviderFn be }

instance Semigroup (ActionProvider be) where
  <> :: ActionProvider be -> ActionProvider be -> ActionProvider be
(<>) = ActionProvider be -> ActionProvider be -> ActionProvider be
forall a. Monoid a => a -> a -> a
mappend

instance Monoid (ActionProvider be) where
  mempty :: ActionProvider be
mempty = ActionProviderFn be -> ActionProvider be
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 ActionProviderFn be
a) (ActionProvider ActionProviderFn be
b) =
    ActionProviderFn be -> ActionProvider be
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (ActionProviderFn be -> ActionProvider be)
-> ActionProviderFn be -> ActionProvider be
forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post ->
    let aRes :: [PotentialAction be]
aRes = ActionProviderFn be
a forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post
        bRes :: [PotentialAction be]
bRes = ActionProviderFn be
b forall preCondition. Typeable preCondition => [preCondition]
pre forall preCondition. Typeable preCondition => [preCondition]
post

    in Strategy [PotentialAction be]
-> [PotentialAction be] -> [PotentialAction be]
forall a. Strategy a -> a -> a
withStrategy (Strategy [PotentialAction be] -> Strategy [PotentialAction be]
forall a. Strategy a -> Strategy a
rparWith (Strategy (PotentialAction be) -> Strategy [PotentialAction be]
forall a. Strategy a -> Strategy [a]
parList Strategy (PotentialAction be)
forall a. Strategy a
rseq)) [PotentialAction be]
aRes [PotentialAction be]
-> [PotentialAction be] -> [PotentialAction be]
`seq`
       Strategy [PotentialAction be]
-> [PotentialAction be] -> [PotentialAction be]
forall a. Strategy a -> a -> a
withStrategy (Strategy [PotentialAction be] -> Strategy [PotentialAction be]
forall a. Strategy a -> Strategy a
rparWith (Strategy (PotentialAction be) -> Strategy [PotentialAction be]
forall a. Strategy a -> Strategy [a]
parList Strategy (PotentialAction be)
forall a. Strategy a
rseq)) [PotentialAction be]
bRes [PotentialAction be]
-> [PotentialAction be] -> [PotentialAction be]
`seq`
       [PotentialAction be]
aRes [PotentialAction be]
-> [PotentialAction be] -> [PotentialAction be]
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

-- | Proceeds only if no predicate matches the given pattern. See the
-- implementation of 'dropTableActionProvider' for an example of usage.
ensuringNot_ :: Alternative m => [ a ] -> m ()
ensuringNot_ :: forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ [] = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ensuringNot_ [a]
_  = m ()
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Used to ensure that only one predicate matches the given pattern. See the
-- implementation of 'createTableActionProvider' for an example of usage.
justOne_ :: [ a ] -> [ a ]
justOne_ :: forall a. [a] -> [a]
justOne_ [a
x] = [a
x]
justOne_ [a]
_ = []

-- | Action provider for SQL92 @CREATE TABLE@ actions.
createTableActionProvider :: forall be
                           . ( Typeable be, BeamMigrateOnlySqlBackend be )
                          => ActionProvider be
createTableActionProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
createTableActionProvider =
  ActionProviderFn be -> ActionProvider be
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) <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
         -- Make sure there's no corresponding predicate in the precondition
         [()] -> [()]
forall (m :: * -> *) a. Alternative m => [a] -> m ()
ensuringNot_ ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$
           do TableExistsPredicate QualifiedName
preTblNm <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
preTblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)

         ([[SomeDatabasePredicate]]
columnsP, [(Text,
  Sql92ColumnSchemaColumnTypeSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
columns) <- ([[SomeDatabasePredicate]],
 [(Text,
   Sql92ColumnSchemaColumnTypeSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
   [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
-> [([[SomeDatabasePredicate]],
     [(Text,
       Sql92ColumnSchemaColumnTypeSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
       [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([[SomeDatabasePredicate]],
  [(Text,
    Sql92ColumnSchemaColumnTypeSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
    [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
 -> [([[SomeDatabasePredicate]],
      [(Text,
        Sql92ColumnSchemaColumnTypeSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
        [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
           (Sql92CreateTableColumnSchemaSyntax
              (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])])
-> ([([SomeDatabasePredicate],
      (Text,
       Sql92ColumnSchemaColumnTypeSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
       [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
    -> ([[SomeDatabasePredicate]],
        [(Text,
          Sql92ColumnSchemaColumnTypeSyntax
            (Sql92CreateTableColumnSchemaSyntax
               (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
          [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
             (Sql92CreateTableColumnSchemaSyntax
                (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]))
-> [([SomeDatabasePredicate],
     (Text,
      Sql92ColumnSchemaColumnTypeSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
-> [([[SomeDatabasePredicate]],
     [(Text,
       Sql92ColumnSchemaColumnTypeSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
       [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([SomeDatabasePredicate],
  (Text,
   Sql92ColumnSchemaColumnTypeSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
   [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
-> ([[SomeDatabasePredicate]],
    [(Text,
      Sql92ColumnSchemaColumnTypeSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([SomeDatabasePredicate],
   (Text,
    Sql92ColumnSchemaColumnTypeSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
    [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
 -> [([[SomeDatabasePredicate]],
      [(Text,
        Sql92ColumnSchemaColumnTypeSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
        [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
           (Sql92CreateTableColumnSchemaSyntax
              (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])])
-> [([SomeDatabasePredicate],
     (Text,
      Sql92ColumnSchemaColumnTypeSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
-> [([[SomeDatabasePredicate]],
     [(Text,
       Sql92ColumnSchemaColumnTypeSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
       [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
          (Sql92CreateTableColumnSchemaSyntax
             (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])]
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) <-
                [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm Bool -> Bool -> Bool
&& Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
-> (forall preCondition. Typeable preCondition => [preCondition])
-> 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) <-
                ([SomeDatabasePredicate],
 [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([SomeDatabasePredicate],
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
 -> [([SomeDatabasePredicate],
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
-> ([(SomeDatabasePredicate,
      Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
    -> ([SomeDatabasePredicate],
        [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
           (Sql92CreateTableColumnSchemaSyntax
              (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SomeDatabasePredicate,
  Sql92ColumnSchemaColumnConstraintDefinitionSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> ([SomeDatabasePredicate],
    [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(SomeDatabasePredicate,
   Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
 -> [([SomeDatabasePredicate],
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
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) <-
                  [TableColumnHasConstraint be]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
postTblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
colNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
colNm')

                (SomeDatabasePredicate,
 Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableColumnHasConstraint be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableColumnHasConstraint be
constraintP, Sql92ColumnSchemaColumnConstraintDefinitionSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c)

              ([SomeDatabasePredicate],
 (Text,
  Sql92ColumnSchemaColumnTypeSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))
-> [([SomeDatabasePredicate],
     (Text,
      Sql92ColumnSchemaColumnTypeSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableHasColumn be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableHasColumn be
columnPSomeDatabasePredicate
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
constraintsP, (Text
colNm, Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
schema, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints))
         (TableHasPrimaryKey
primaryKeyP, [Text]
primaryKey) <- [(TableHasPrimaryKey, [Text])] -> [(TableHasPrimaryKey, [Text])]
forall a. [a] -> [a]
justOne_ ([(TableHasPrimaryKey, [Text])] -> [(TableHasPrimaryKey, [Text])])
-> [(TableHasPrimaryKey, [Text])] -> [(TableHasPrimaryKey, [Text])]
forall a b. (a -> b) -> a -> b
$ do
           primaryKeyP :: TableHasPrimaryKey
primaryKeyP@(TableHasPrimaryKey QualifiedName
tblNm [Text]
primaryKey) <-
             [TableHasPrimaryKey]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
           Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)
           (TableHasPrimaryKey, [Text]) -> [(TableHasPrimaryKey, [Text])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableHasPrimaryKey
primaryKeyP, [Text]
primaryKey)

         let postConditions :: [SomeDatabasePredicate]
postConditions = [ TableExistsPredicate -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableExistsPredicate
tblP, TableHasPrimaryKey -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableHasPrimaryKey
primaryKeyP ] [SomeDatabasePredicate]
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. [a] -> [a] -> [a]
++ [[SomeDatabasePredicate]] -> [SomeDatabasePredicate]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SomeDatabasePredicate]]
columnsP
             cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandCreateTableSyntax syntax -> syntax
createTableCmd (Maybe
  (Sql92CreateTableOptionsSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
-> Sql92CreateTableTableNameSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
-> [(Text,
     Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
-> [Sql92CreateTableTableConstraintSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))]
-> Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92CreateTableSyntax syntax =>
Maybe (Sql92CreateTableOptionsSyntax syntax)
-> Sql92CreateTableTableNameSyntax syntax
-> [(Text, Sql92CreateTableColumnSchemaSyntax syntax)]
-> [Sql92CreateTableTableConstraintSyntax syntax]
-> syntax
createTableSyntax Maybe
  (Sql92CreateTableOptionsSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
forall a. Maybe a
Nothing (QualifiedName
-> Sql92CreateTableTableNameSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
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 [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
primaryKey then [] else [ [Text]
-> Sql92CreateTableTableConstraintSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
forall constraint.
IsSql92TableConstraintSyntax constraint =>
[Text] -> constraint
primaryKeyConstraintSyntax [Text]
primaryKey ]
             colsSyntax :: [(Text,
  Sql92CreateTableColumnSchemaSyntax
    (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
colsSyntax = ((Text,
  Sql92ColumnSchemaColumnTypeSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
 -> (Text,
     Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
-> [(Text,
     Sql92ColumnSchemaColumnTypeSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
-> [(Text,
     Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
colNm, Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
type_, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
cs) -> (Text
colNm, Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
-> Maybe
     (Sql92ColumnSchemaExpressionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
-> Maybe Text
-> Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
forall columnSchema.
IsSql92ColumnSchemaSyntax columnSchema =>
Sql92ColumnSchemaColumnTypeSyntax columnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema]
-> Maybe Text
-> columnSchema
columnSchemaSyntax Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
type_ Maybe
  (Sql92ColumnSchemaExpressionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
forall a. Maybe a
Nothing [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
cs Maybe Text
forall a. Maybe a
Nothing)) [(Text,
  Sql92ColumnSchemaColumnTypeSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))),
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
columns
         PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
postConditions)
                               (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
                               (Text
"Create the table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
postTblNm) Int
createTableWeight)

-- | Action provider for SQL92 @DROP TABLE@ actions
dropTableActionProvider :: forall be
                         . BeamMigrateOnlySqlBackend be
                        => ActionProvider be
dropTableActionProvider :: forall be. BeamMigrateOnlySqlBackend be => ActionProvider be
dropTableActionProvider =
 ActionProviderFn be -> ActionProvider be
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider ActionProviderFn be
provider
 where
   -- Look for tables that exist as a precondition but not a post condition
   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) <- [TableExistsPredicate]
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 <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
             Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
preTblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
postTblNm)

        [SomeDatabasePredicate]
relatedPreds <-
          [SomeDatabasePredicate] -> [[SomeDatabasePredicate]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SomeDatabasePredicate] -> [[SomeDatabasePredicate]])
-> [SomeDatabasePredicate] -> [[SomeDatabasePredicate]]
forall a b. (a -> b) -> a -> b
$ do p' :: SomeDatabasePredicate
p'@(SomeDatabasePredicate p
pred') <- [SomeDatabasePredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
                    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (p
pred' p -> TableExistsPredicate -> Bool
forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` TableExistsPredicate
tblP)
                    SomeDatabasePredicate -> [SomeDatabasePredicate]
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeDatabasePredicate
p'

        -- Now, collect all preconditions that may be related to the dropped table
        let cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandDropTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandDropTableSyntax syntax -> syntax
dropTableCmd (Sql92DropTableTableNameSyntax
  (Sql92DdlCommandDropTableSyntax (BeamSqlBackendSyntax be))
-> Sql92DdlCommandDropTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92DropTableSyntax syntax =>
Sql92DropTableTableNameSyntax syntax -> syntax
dropTableSyntax (QualifiedName
-> Sql92DropTableTableNameSyntax
     (Sql92DdlCommandDropTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
preTblNm))
        PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ({-trace ("Dropping table " <> show preTblNm <> " would drop " <> show relatedPreds) $ -}
              HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (TableExistsPredicate -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableExistsPredicate
tblPSomeDatabasePredicate
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
relatedPreds)) HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty
                              (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationLosesData))
                              (Text
"Drop table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
preTblNm) Int
dropTableWeight)

-- | Action provider for SQL92 @ALTER TABLE ... ADD COLUMN ...@ actions
addColumnProvider :: forall be
                   . ( Typeable be, BeamMigrateOnlySqlBackend be )
                  => ActionProvider be
addColumnProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnProvider =
  ActionProviderFn be -> ActionProvider be
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)
           <- [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
         TableExistsPredicate QualifiedName
tblNm' <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm'  QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm Bool -> Bool -> Bool
&& Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
-> (forall preCondition. Typeable preCondition => [preCondition])
-> 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 <-
             [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
           Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm'' QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm Bool -> Bool -> Bool
&& Text
colNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
colNm') -- This column exists as a different type

         ([SomeDatabasePredicate]
constraintsP, [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints) <-
           ([SomeDatabasePredicate],
 [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([SomeDatabasePredicate],
  [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
 -> [([SomeDatabasePredicate],
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
-> ([(SomeDatabasePredicate,
      Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
    -> ([SomeDatabasePredicate],
        [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
           (Sql92CreateTableColumnSchemaSyntax
              (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]))
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SomeDatabasePredicate,
  Sql92ColumnSchemaColumnConstraintDefinitionSyntax
    (Sql92CreateTableColumnSchemaSyntax
       (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> ([SomeDatabasePredicate],
    [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(SomeDatabasePredicate,
   Sql92ColumnSchemaColumnConstraintDefinitionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
 -> [([SomeDatabasePredicate],
      [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
         (Sql92CreateTableColumnSchemaSyntax
            (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])])
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
-> [([SomeDatabasePredicate],
     [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))])]
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) <-
             [TableColumnHasConstraint be]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
           Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'')
           Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
colNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
colNm')

           (SomeDatabasePredicate,
 Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
-> [(SomeDatabasePredicate,
     Sql92ColumnSchemaColumnConstraintDefinitionSyntax
       (Sql92CreateTableColumnSchemaSyntax
          (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableColumnHasConstraint be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p TableColumnHasConstraint be
constraintP, Sql92ColumnSchemaColumnConstraintDefinitionSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
c)

         let cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (Sql92AlterTableTableNameSyntax
  (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (QualifiedName
-> Sql92AlterTableTableNameSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (Text
-> Sql92AlterTableColumnSchemaSyntax
     (Sql92AlterTableAlterTableActionSyntax
        (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableColumnSchemaSyntax syntax -> syntax
addColumnSyntax Text
colNm Sql92AlterTableColumnSchemaSyntax
  (Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
schema))
             schema :: Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
schema = Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
-> Maybe
     (Sql92ColumnSchemaExpressionSyntax
        (Sql92CreateTableColumnSchemaSyntax
           (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
      (Sql92CreateTableColumnSchemaSyntax
         (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
-> Maybe Text
-> Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
forall columnSchema.
IsSql92ColumnSchemaSyntax columnSchema =>
Sql92ColumnSchemaColumnTypeSyntax columnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema]
-> Maybe Text
-> columnSchema
columnSchemaSyntax Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))
colType Maybe
  (Sql92ColumnSchemaExpressionSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))))
forall a. Maybe a
Nothing [Sql92ColumnSchemaColumnConstraintDefinitionSyntax
   (Sql92CreateTableColumnSchemaSyntax
      (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)))]
constraints Maybe Text
forall a. Maybe a
Nothing
         PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([TableHasColumn be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableHasColumn be
colP] [SomeDatabasePredicate]
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. [a] -> [a] -> [a]
++ [SomeDatabasePredicate]
constraintsP))
                               (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
                               (Text
"Add column " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm)
                (Int
addColumnWeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length (QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
colNm)))

-- | Action provider for SQL92 @ALTER TABLE ... DROP COLUMN ...@ actions
dropColumnProvider :: forall be
                    . ( Typeable be, BeamMigrateOnlySqlBackend be )
                   => ActionProvider be
dropColumnProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnProvider = ActionProviderFn be -> ActionProvider be
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)
           <- [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions

--         TableExistsPredicate tblNm' <- trace ("COnsider drop " <> show tblNm <> " " <> show colNm)  findPreConditions
--         guard (any (\(TableExistsPredicate tblNm') -> tblNm' == tblNm) findPreConditions) --tblNm' == tblNm)
--         ensuringNot_ $ do
--           TableHasColumn tblNm' colNm' colType' :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <-
--             findPostConditions
--           guard (tblNm' == tblNm && colNm == colNm' && colType == colType') -- This column exists as a different type

         [SomeDatabasePredicate]
relatedPreds <- --pure []
           [SomeDatabasePredicate] -> [[SomeDatabasePredicate]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SomeDatabasePredicate] -> [[SomeDatabasePredicate]])
-> [SomeDatabasePredicate] -> [[SomeDatabasePredicate]]
forall a b. (a -> b) -> a -> b
$ do p' :: SomeDatabasePredicate
p'@(SomeDatabasePredicate p
pred') <- [SomeDatabasePredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (p
pred' p -> TableHasColumn be -> Bool
forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` TableHasColumn be
colP)
                     SomeDatabasePredicate -> [SomeDatabasePredicate]
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeDatabasePredicate
p'

         let cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (Sql92AlterTableTableNameSyntax
  (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (QualifiedName
-> Sql92AlterTableTableNameSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (Text
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> syntax
dropColumnSyntax Text
colNm))
         PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (TableHasColumn be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableHasColumn be
colPSomeDatabasePredicate
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. a -> [a] -> [a]
:[SomeDatabasePredicate]
relatedPreds)) HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty
                               (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationLosesData))
                               (Text
"Drop column " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm)
                (Int
dropColumnWeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length (QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
colNm)))

-- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NULL@
addColumnNullProvider :: forall be
                       . ( Typeable be, BeamMigrateOnlySqlBackend be )
                      => ActionProvider be
addColumnNullProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnNullProvider = ActionProviderFn be -> ActionProvider be
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)
           <- [TableColumnHasConstraint be]
forall preCondition. Typeable preCondition => [preCondition]
findPostConditions
-- TODO         guard (c == notNullConstraintSyntax)

         TableExistsPredicate QualifiedName
tblNm' <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')

         TableHasColumn QualifiedName
tblNm'' Text
colNm' BeamMigrateSqlBackendDataTypeSyntax be
_ :: TableHasColumn be <-
           [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'' Bool -> Bool -> Bool
&& Text
colNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
colNm')

         let cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (Sql92AlterTableTableNameSyntax
  (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (QualifiedName
-> Sql92AlterTableTableNameSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (Text
-> Sql92AlterTableAlterColumnActionSyntax
     (Sql92AlterTableAlterTableActionSyntax
        (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableAlterColumnActionSyntax syntax -> syntax
alterColumnSyntax Text
colNm Sql92AlterTableAlterColumnActionSyntax
  (Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
forall syntax. IsSql92AlterColumnActionSyntax syntax => syntax
setNotNullSyntax))
         PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [TableColumnHasConstraint be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableColumnHasConstraint be
colP])
                               (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
                               (Text
"Add not null constraint to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int
100)

-- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET  NOT NULL@
dropColumnNullProvider :: forall be
                        . ( Typeable be, BeamMigrateOnlySqlBackend be )
                       => ActionProvider be
dropColumnNullProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnNullProvider = ActionProviderFn be -> ActionProvider be
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)
           <- [TableColumnHasConstraint be]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
-- TODO         guard (c == notNullConstraintSyntax)

         TableExistsPredicate QualifiedName
tblNm' <- [TableExistsPredicate]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm')

         TableHasColumn QualifiedName
tblNm'' Text
colNm' BeamMigrateSqlBackendDataTypeSyntax be
_ :: TableHasColumn be <-
           [TableHasColumn be]
forall preCondition. Typeable preCondition => [preCondition]
findPreConditions
         Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualifiedName
tblNm QualifiedName -> QualifiedName -> Bool
forall a. Eq a => a -> a -> Bool
== QualifiedName
tblNm'' Bool -> Bool -> Bool
&& Text
colNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
colNm')

         let cmd :: BeamSqlBackendSyntax be
cmd = Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
-> BeamSqlBackendSyntax be
forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd (Sql92AlterTableTableNameSyntax
  (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
-> Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)
forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (QualifiedName
-> Sql92AlterTableTableNameSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92TableNameSyntax syntax =>
QualifiedName -> syntax
qnameAsTableName QualifiedName
tblNm) (Text
-> Sql92AlterTableAlterColumnActionSyntax
     (Sql92AlterTableAlterTableActionSyntax
        (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
-> Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableAlterColumnActionSyntax syntax -> syntax
alterColumnSyntax Text
colNm Sql92AlterTableAlterColumnActionSyntax
  (Sql92AlterTableAlterTableActionSyntax
     (Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)))
forall syntax. IsSql92AlterColumnActionSyntax syntax => syntax
setNullSyntax))
         PotentialAction be -> [PotentialAction be]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [TableColumnHasConstraint be -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate TableColumnHasConstraint be
colP]) HashSet SomeDatabasePredicate
forall a. Monoid a => a
mempty
                               (MigrationCommand be -> Seq (MigrationCommand be)
forall a. a -> Seq a
Seq.singleton (BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand BeamSqlBackendSyntax be
cmd MigrationDataLoss
MigrationKeepsData))
                               (Text
"Drop not null constraint for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
colNm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedName -> Text
qnameAsText QualifiedName
tblNm) Int
100)

-- | Default action providers for any SQL92 compliant syntax.
--
-- In particular, this provides edges consisting of the following statements:
--
--  * CREATE TABLE
--  * DROP TABLE
--  * ALTER TABLE ... ADD COLUMN ...
--  * ALTER TABLE ... DROP COLUMN ...
--  * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL
defaultActionProvider :: ( Typeable be
                         , BeamMigrateOnlySqlBackend be )
                      => ActionProvider be
defaultActionProvider :: forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
defaultActionProvider =
  [ActionProvider be] -> ActionProvider be
forall a. Monoid a => [a] -> a
mconcat
  [ ActionProvider be
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
createTableActionProvider
  , ActionProvider be
forall be. BeamMigrateOnlySqlBackend be => ActionProvider be
dropTableActionProvider

  , ActionProvider be
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnProvider
  , ActionProvider be
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnProvider

  , ActionProvider be
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
addColumnNullProvider
  , ActionProvider be
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
dropColumnNullProvider ]

-- | Represents current state of a database graph search.
--
-- If 'ProvideSolution', the destination database has been reached, and the
-- given list of commands provides the path from the source database to the
-- destination.
--
-- If 'SearchFailed', the search has failed. The provided 'DatabaseState's
-- represent the closest we could make it to the destination database. By
-- default, only the best 10 are kept around (to avoid unbounded memory growth).
--
-- If 'ChooseActions', we are still searching. The caller is provided with the
-- current state as well as a list of actions, provided as an opaque type @f@.
-- The 'getPotentialActionChoice' function can be used to get the
-- 'PotentialAction' corresponding to any given @f@. The caller is free to cull
-- the set of potential actions according however they'd like (for example, by
-- prompting the user). The selected actions to explore should be passed to the
-- 'continueSearch' function.
--
-- Use of the @f@ existential type may seem obtuse, but it prevents the caller
-- from injecting arbitrary actions. Instead the caller is limited to choosing
-- only valid actions as provided by the suppled 'ActionProvider'.
data Solver cmd where
  ProvideSolution :: [ MigrationCommand cmd ] -> Solver cmd
  SearchFailed    :: [ DatabaseState cmd ] -> Solver cmd
  ChooseActions   :: { forall cmd. Solver cmd -> DatabaseState cmd
choosingActionsAtState :: !(DatabaseState cmd)
                       -- ^ The current node we're searching at
                     , ()
getPotentialActionChoice :: f -> PotentialAction cmd
                       -- ^ Convert the opaque @f@ type to a 'PotentialAction'.
                       -- This can be used to present the actions to the user or
                       -- to inspect the action to make a more informed choice
                       -- on exploration strategies.
                     , ()
potentialActionChoices :: [ f ]
                       -- ^ The possible actions that we can take, presented as
                       -- an opaque list. Use the 'getPotentialActionChoice'
                       -- function to get the corresponding 'PotentialAction'.
                     , ()
continueSearch :: [ f ] -> Solver cmd
                       -- ^ Continue the search and get the next 'Solver'
                     } -> Solver cmd

-- | Represents the final results of a search
data FinalSolution be
  = Solved [ MigrationCommand be ]
    -- ^ The search found a path from the source to the destination database,
    -- and has provided a set of commands that would work
  | Candidates [ DatabaseState be ]
    -- ^ The search failed, but provided a set of 'DatbaseState's it encountered
    -- that were the closest to the destination database. By default, only 10
    -- candidates are provided.
deriving instance Show (BeamSqlBackendSyntax be) => Show (FinalSolution be)

-- | Returns 'True' if the state has been solved
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 HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> Bool
forall a. Eq a => a -> a -> Bool
== HashSet SomeDatabasePredicate
cur

-- | An exhaustive solving strategy that simply continues the search, while
-- exploring every possible action. If there is a solution, this will find it.
finalSolution :: Solver be -> FinalSolution be
finalSolution :: forall be. Solver be -> FinalSolution be
finalSolution (SearchFailed [DatabaseState be]
sts)     = [DatabaseState be] -> FinalSolution be
forall be. [DatabaseState be] -> FinalSolution be
Candidates [DatabaseState be]
sts
finalSolution (ProvideSolution [MigrationCommand be]
cmds) = [MigrationCommand be] -> FinalSolution be
forall be. [MigrationCommand be] -> FinalSolution be
Solved [MigrationCommand be]
cmds
finalSolution (ChooseActions DatabaseState be
_ f -> PotentialAction be
_ [f]
actions [f] -> Solver be
next) =
  Solver be -> FinalSolution be
forall be. Solver be -> FinalSolution be
finalSolution ([f] -> Solver be
next [f]
actions)

{-# INLINE heuristicSolver #-}
-- | Conduct a breadth-first search of the database graph to find a path from
-- the source database to the destination database, using the given
-- 'ActionProvider' to discovere "edges" (i.e., DDL commands) between the
-- databases.
--
-- See the documentation on 'Solver' for more information on how to consume the
-- result.
heuristicSolver :: ActionProvider be         -- ^ Edge discovery function
                -> [ SomeDatabasePredicate ] -- ^ Source database state
                -> [ SomeDatabasePredicate ] -- ^ Destination database state
                -> 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 HashSet (HashSet SomeDatabasePredicate)
forall a. Monoid a => a
mempty MinQueue (MeasuredDatabaseState be)
forall a. MinQueue a
PQ.empty

  where
    -- Number of failed action chains to keep
    rejectedCount :: Int
rejectedCount = Int
10

    postConditions :: HashSet SomeDatabasePredicate
postConditions = [SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
postConditionsL
    preConditions :: HashSet SomeDatabasePredicate
preConditions = [SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [SomeDatabasePredicate]
preConditionsL
    allToFalsify :: HashSet SomeDatabasePredicate
allToFalsify = HashSet SomeDatabasePredicate
preConditions HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
postConditions
    measureDb :: Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb = HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Int
-> DatabaseState be
-> MeasuredDatabaseState be
forall cmd.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Int
-> DatabaseState cmd
-> MeasuredDatabaseState cmd
measureDb' HashSet SomeDatabasePredicate
allToFalsify HashSet SomeDatabasePredicate
postConditions

    initQueue :: MinQueue (MeasuredDatabaseState be)
initQueue = MeasuredDatabaseState be -> MinQueue (MeasuredDatabaseState be)
forall a. a -> MinQueue a
PQ.singleton (Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb Int
0 DatabaseState be
initDbState)
    initDbState :: DatabaseState be
initDbState = HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
forall be.
HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
DatabaseState (DatabaseStateSource
DatabaseStateSourceOriginal DatabaseStateSource
-> HashMap SomeDatabasePredicate ()
-> HashMap SomeDatabasePredicate DatabaseStateSource
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HashSet SomeDatabasePredicate -> HashMap SomeDatabasePredicate ()
forall a. HashSet a -> HashMap a ()
HS.toMap HashSet SomeDatabasePredicate
preConditions)
                                HashSet SomeDatabasePredicate
preConditions
                                Seq (MigrationCommand be)
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) <- Maybe (predicate :~: SomeDatabasePredicate)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT =
          (:)
      | Bool
otherwise =
          \(SomeDatabasePredicate p
pred') [predicate]
ps ->
              [predicate]
-> (predicate -> [predicate]) -> Maybe predicate -> [predicate]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [predicate]
ps (predicate -> [predicate] -> [predicate]
forall a. a -> [a] -> [a]
:[predicate]
ps) (p -> Maybe predicate
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 = (SomeDatabasePredicate -> [predicate] -> [predicate])
-> [predicate] -> f SomeDatabasePredicate -> [predicate]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SomeDatabasePredicate -> [predicate] -> [predicate]
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 MinQueue (MeasuredDatabaseState be)
-> Maybe
     (MeasuredDatabaseState be, MinQueue (MeasuredDatabaseState be))
forall a. Ord a => MinQueue a -> Maybe (a, MinQueue a)
PQ.minView MinQueue (MeasuredDatabaseState be)
q of
        Maybe
  (MeasuredDatabaseState be, MinQueue (MeasuredDatabaseState be))
Nothing -> [DatabaseState be] -> Solver be
forall cmd. [DatabaseState cmd] -> Solver cmd
SearchFailed (MeasuredDatabaseState be -> DatabaseState be
forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState (MeasuredDatabaseState be -> DatabaseState be)
-> [MeasuredDatabaseState be] -> [DatabaseState be]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MinQueue (MeasuredDatabaseState be) -> [MeasuredDatabaseState be]
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')
          | DatabaseState be -> HashSet SomeDatabasePredicate
forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState HashSet SomeDatabasePredicate
-> HashSet (HashSet SomeDatabasePredicate) -> Bool
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
          | HashSet SomeDatabasePredicate -> DatabaseState be -> Bool
forall be.
HashSet SomeDatabasePredicate -> DatabaseState be -> Bool
solvedState HashSet SomeDatabasePredicate
postConditions (MeasuredDatabaseState be -> DatabaseState be
forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState MeasuredDatabaseState be
mdbState) ->
              [MigrationCommand be] -> Solver be
forall cmd. [MigrationCommand cmd] -> Solver cmd
ProvideSolution (Seq (MigrationCommand be) -> [MigrationCommand be]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (DatabaseState be -> Seq (MigrationCommand be)
forall be. DatabaseState be -> Seq (MigrationCommand be)
dbStateCmdSequence DatabaseState be
dbState))
          | Bool
otherwise ->
              let steps :: [PotentialAction be]
steps = ActionProvider be -> ActionProviderFn be
forall be. ActionProvider be -> ActionProviderFn be
getPotentialActions
                              ActionProvider be
provider
                              (HashSet SomeDatabasePredicate -> [preCondition]
forall predicate (f :: * -> *).
(Typeable predicate, Foldable f) =>
f SomeDatabasePredicate -> [predicate]
findPredicates (DatabaseState be -> HashSet SomeDatabasePredicate
forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState))
                              ([SomeDatabasePredicate] -> [postCondition]
forall predicate (f :: * -> *).
(Typeable predicate, Foldable f) =>
f SomeDatabasePredicate -> [predicate]
findPredicates [SomeDatabasePredicate]
postConditionsL)

                  steps' :: [(PotentialAction be, MeasuredDatabaseState be)]
steps' = ((PotentialAction be, MeasuredDatabaseState be) -> Bool)
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> [(PotentialAction be, MeasuredDatabaseState be)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((PotentialAction be, MeasuredDatabaseState be) -> Bool)
-> (PotentialAction be, MeasuredDatabaseState be)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashSet SomeDatabasePredicate
-> HashSet (HashSet SomeDatabasePredicate) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (HashSet SomeDatabasePredicate)
visited) (HashSet SomeDatabasePredicate -> Bool)
-> ((PotentialAction be, MeasuredDatabaseState be)
    -> HashSet SomeDatabasePredicate)
-> (PotentialAction be, MeasuredDatabaseState be)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseState be -> HashSet SomeDatabasePredicate
forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey (DatabaseState be -> HashSet SomeDatabasePredicate)
-> ((PotentialAction be, MeasuredDatabaseState be)
    -> DatabaseState be)
-> (PotentialAction be, MeasuredDatabaseState be)
-> HashSet SomeDatabasePredicate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MeasuredDatabaseState be -> DatabaseState be
forall cmd. MeasuredDatabaseState cmd -> DatabaseState cmd
measuredDbState (MeasuredDatabaseState be -> DatabaseState be)
-> ((PotentialAction be, MeasuredDatabaseState be)
    -> MeasuredDatabaseState be)
-> (PotentialAction be, MeasuredDatabaseState be)
-> DatabaseState be
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PotentialAction be, MeasuredDatabaseState be)
-> MeasuredDatabaseState be
forall a b. (a, b) -> b
snd) ([(PotentialAction be, MeasuredDatabaseState be)]
 -> [(PotentialAction be, MeasuredDatabaseState be)])
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> [(PotentialAction be, MeasuredDatabaseState be)]
forall a b. (a -> b) -> a -> b
$
                           Strategy [(PotentialAction be, MeasuredDatabaseState be)]
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> [(PotentialAction be, MeasuredDatabaseState be)]
forall a. Strategy a -> a -> a
withStrategy (Strategy (PotentialAction be, MeasuredDatabaseState be)
-> Strategy [(PotentialAction be, MeasuredDatabaseState be)]
forall a. Strategy a -> Strategy [a]
parList Strategy (PotentialAction be, MeasuredDatabaseState be)
forall a. Strategy a
rseq) ([(PotentialAction be, MeasuredDatabaseState be)]
 -> [(PotentialAction be, MeasuredDatabaseState be)])
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> [(PotentialAction be, MeasuredDatabaseState be)]
forall a b. (a -> b) -> a -> b
$
                           (PotentialAction be
 -> (PotentialAction be, MeasuredDatabaseState be))
-> [PotentialAction be]
-> [(PotentialAction be, MeasuredDatabaseState be)]
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' MeasuredDatabaseState be
-> (PotentialAction be, MeasuredDatabaseState be)
-> (PotentialAction be, MeasuredDatabaseState be)
`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'' = DatabaseState be -> PotentialAction be -> DatabaseState be
forall {be}.
DatabaseState be -> PotentialAction be -> DatabaseState be
dbStateAfterAction DatabaseState be
dbState' PotentialAction be
step
                    in Int -> DatabaseState be -> MeasuredDatabaseState be
measureDb (Int
score Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) DatabaseState be
dbState''

              in case [(PotentialAction be, MeasuredDatabaseState be)]
steps' of
                   -- Since no steps were generated, this is a dead end. Add to the rejected queue
                   [] -> MinQueue (MeasuredDatabaseState be)
-> HashSet (HashSet SomeDatabasePredicate)
-> MinQueue (MeasuredDatabaseState be)
-> Solver be
heuristicSolver' MinQueue (MeasuredDatabaseState be)
q' HashSet (HashSet SomeDatabasePredicate)
visited (MeasuredDatabaseState be
-> MinQueue (MeasuredDatabaseState be)
-> MinQueue (MeasuredDatabaseState be)
forall cmd.
MeasuredDatabaseState cmd
-> MinQueue (MeasuredDatabaseState cmd)
-> MinQueue (MeasuredDatabaseState cmd)
reject MeasuredDatabaseState be
mdbState MinQueue (MeasuredDatabaseState be)
bestRejected)
                   [(PotentialAction be, MeasuredDatabaseState be)]
_ -> DatabaseState be
-> ((PotentialAction be, MeasuredDatabaseState be)
    -> PotentialAction be)
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> ([(PotentialAction be, MeasuredDatabaseState be)] -> Solver be)
-> Solver be
forall cmd f.
DatabaseState cmd
-> (f -> PotentialAction cmd)
-> [f]
-> ([f] -> Solver cmd)
-> Solver cmd
ChooseActions DatabaseState be
dbState (PotentialAction be, MeasuredDatabaseState be)
-> PotentialAction be
forall a b. (a, b) -> a
fst [(PotentialAction be, MeasuredDatabaseState be)]
steps' (([(PotentialAction be, MeasuredDatabaseState be)] -> Solver be)
 -> Solver be)
-> ([(PotentialAction be, MeasuredDatabaseState be)] -> Solver be)
-> Solver be
forall a b. (a -> b) -> a -> b
$ \[(PotentialAction be, MeasuredDatabaseState be)]
chosenSteps ->
                            let q'' :: MinQueue (MeasuredDatabaseState be)
q'' = ((PotentialAction be, MeasuredDatabaseState be)
 -> MinQueue (MeasuredDatabaseState be)
 -> MinQueue (MeasuredDatabaseState be))
-> MinQueue (MeasuredDatabaseState be)
-> [(PotentialAction be, MeasuredDatabaseState be)]
-> MinQueue (MeasuredDatabaseState be)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(PotentialAction be
_, MeasuredDatabaseState be
dbState') -> MeasuredDatabaseState be
-> MinQueue (MeasuredDatabaseState be)
-> MinQueue (MeasuredDatabaseState be)
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' = HashSet SomeDatabasePredicate
-> HashSet (HashSet SomeDatabasePredicate)
-> HashSet (HashSet SomeDatabasePredicate)
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert (DatabaseState be -> HashSet SomeDatabasePredicate
forall be. DatabaseState be -> HashSet SomeDatabasePredicate
dbStateKey DatabaseState be
dbState) HashSet (HashSet SomeDatabasePredicate)
visited
                            in Strategy (MinQueue (MeasuredDatabaseState be))
-> MinQueue (MeasuredDatabaseState be)
-> MinQueue (MeasuredDatabaseState be)
forall a. Strategy a -> a -> a
withStrategy (Strategy (MinQueue (MeasuredDatabaseState be))
-> Strategy (MinQueue (MeasuredDatabaseState be))
forall a. Strategy a -> Strategy a
rparWith Strategy (MinQueue (MeasuredDatabaseState be))
forall a. Strategy a
rseq) MinQueue (MeasuredDatabaseState be)
q'' MinQueue (MeasuredDatabaseState be) -> Solver be -> Solver be
`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' = MeasuredDatabaseState cmd
-> MinQueue (MeasuredDatabaseState cmd)
-> MinQueue (MeasuredDatabaseState cmd)
forall a. Ord a => a -> MinQueue a -> MinQueue a
PQ.insert MeasuredDatabaseState cmd
mdbState MinQueue (MeasuredDatabaseState cmd)
q
      in [MeasuredDatabaseState cmd] -> MinQueue (MeasuredDatabaseState cmd)
forall a. [a] -> MinQueue a
PQ.fromAscList (Int
-> MinQueue (MeasuredDatabaseState cmd)
-> [MeasuredDatabaseState cmd]
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 HashMap SomeDatabasePredicate DatabaseStateSource
-> HashMap SomeDatabasePredicate ()
-> HashMap SomeDatabasePredicate DatabaseStateSource
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HM.difference` HashSet SomeDatabasePredicate -> HashMap SomeDatabasePredicate ()
forall a. HashSet a -> HashMap a ()
HS.toMap (PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPreConditions PotentialAction be
action))
                     HashMap SomeDatabasePredicate DatabaseStateSource
-> HashMap SomeDatabasePredicate DatabaseStateSource
-> HashMap SomeDatabasePredicate DatabaseStateSource
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` (DatabaseStateSource
DatabaseStateSourceDerived DatabaseStateSource
-> HashMap SomeDatabasePredicate ()
-> HashMap SomeDatabasePredicate DatabaseStateSource
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HashSet SomeDatabasePredicate -> HashMap SomeDatabasePredicate ()
forall a. HashSet a -> HashMap a ()
HS.toMap (PotentialAction be -> HashSet SomeDatabasePredicate
forall be. PotentialAction be -> HashSet SomeDatabasePredicate
actionPostConditions PotentialAction be
action)))
      in HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
forall be.
HashMap SomeDatabasePredicate DatabaseStateSource
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> DatabaseState be
DatabaseState HashMap SomeDatabasePredicate DatabaseStateSource
curState' (HashMap SomeDatabasePredicate () -> HashSet SomeDatabasePredicate
forall a. HashMap a () -> HashSet a
HS.fromMap (() ()
-> HashMap SomeDatabasePredicate DatabaseStateSource
-> HashMap SomeDatabasePredicate ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HashMap SomeDatabasePredicate DatabaseStateSource
curState'))
                       (Seq (MigrationCommand be)
cmds Seq (MigrationCommand be)
-> Seq (MigrationCommand be) -> Seq (MigrationCommand be)
forall a. Semigroup a => a -> a -> a
<> PotentialAction be -> Seq (MigrationCommand be)
forall be. PotentialAction be -> Seq (MigrationCommand be)
actionCommands PotentialAction be
action)