{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Database.Beam.Migrate.Types
(
CheckedDatabaseSettings
, IsCheckedDatabaseEntity(..)
, CheckedDatabaseEntityDescriptor(..)
, CheckedDatabaseEntity(..)
, unCheckDatabase, collectChecks
, renameCheckedEntity
, CheckedFieldModification
, checkedFieldNamed
, modifyCheckedTable
, checkedTableModification
, DatabasePredicate(..)
, SomeDatabasePredicate(..)
, PredicateSpecificity(..)
, QualifiedName(..)
, p
, TableCheck(..), DomainCheck(..)
, FieldCheck(..)
, MigrationStep(..), MigrationSteps(..)
, Migration, MigrationF(..)
, MigrationCommand(..), MigrationDataLoss(..)
, runMigrationSteps, runMigrationSilenced
, executeMigration, eraseMigrationType, migrationStep
, upDown, migrationDataLoss
, migrateScript, evaluateDatabase, stepNames ) where
import Database.Beam.Backend.SQL
import Database.Beam.Migrate.Types.CheckedEntities
import Database.Beam.Migrate.Types.Predicates
import Control.Monad.Free.Church
import Control.Arrow
import Control.Category (Category)
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup
#endif
import Data.Text (Text)
data MigrationStep be next where
MigrationStep :: Text -> Migration be a -> (a -> next) -> MigrationStep be next
deriving instance Functor (MigrationStep be)
newtype MigrationSteps be from to = MigrationSteps (Kleisli (F (MigrationStep be)) from to)
deriving ((forall a. MigrationSteps be a a)
-> (forall b c a.
MigrationSteps be b c
-> MigrationSteps be a b -> MigrationSteps be a c)
-> Category (MigrationSteps be)
forall a. MigrationSteps be a a
forall be a. MigrationSteps be a a
forall b c a.
MigrationSteps be b c
-> MigrationSteps be a b -> MigrationSteps be a c
forall be b c a.
MigrationSteps be b c
-> MigrationSteps be a b -> MigrationSteps be a c
forall {k} (cat :: k -> k -> *).
(forall (a :: k). cat a a)
-> (forall (b :: k) (c :: k) (a :: k).
cat b c -> cat a b -> cat a c)
-> Category cat
. :: forall b c a.
MigrationSteps be b c
-> MigrationSteps be a b -> MigrationSteps be a c
$c. :: forall be b c a.
MigrationSteps be b c
-> MigrationSteps be a b -> MigrationSteps be a c
id :: forall a. MigrationSteps be a a
$cid :: forall be a. MigrationSteps be a a
Category, Category (MigrationSteps be)
Category (MigrationSteps be)
-> (forall b c. (b -> c) -> MigrationSteps be b c)
-> (forall b c d.
MigrationSteps be b c -> MigrationSteps be (b, d) (c, d))
-> (forall b c d.
MigrationSteps be b c -> MigrationSteps be (d, b) (d, c))
-> (forall b c b' c'.
MigrationSteps be b c
-> MigrationSteps be b' c' -> MigrationSteps be (b, b') (c, c'))
-> (forall b c c'.
MigrationSteps be b c
-> MigrationSteps be b c' -> MigrationSteps be b (c, c'))
-> Arrow (MigrationSteps be)
forall be. Category (MigrationSteps be)
forall b c. (b -> c) -> MigrationSteps be b c
forall b c d.
MigrationSteps be b c -> MigrationSteps be (b, d) (c, d)
forall b c d.
MigrationSteps be b c -> MigrationSteps be (d, b) (d, c)
forall b c c'.
MigrationSteps be b c
-> MigrationSteps be b c' -> MigrationSteps be b (c, c')
forall be b c. (b -> c) -> MigrationSteps be b c
forall be b c d.
MigrationSteps be b c -> MigrationSteps be (b, d) (c, d)
forall be b c d.
MigrationSteps be b c -> MigrationSteps be (d, b) (d, c)
forall be b c c'.
MigrationSteps be b c
-> MigrationSteps be b c' -> MigrationSteps be b (c, c')
forall b c b' c'.
MigrationSteps be b c
-> MigrationSteps be b' c' -> MigrationSteps be (b, b') (c, c')
forall be b c b' c'.
MigrationSteps be b c
-> MigrationSteps be b' c' -> MigrationSteps be (b, b') (c, c')
forall (a :: * -> * -> *).
Category a
-> (forall b c. (b -> c) -> a b c)
-> (forall b c d. a b c -> a (b, d) (c, d))
-> (forall b c d. a b c -> a (d, b) (d, c))
-> (forall b c b' c'. a b c -> a b' c' -> a (b, b') (c, c'))
-> (forall b c c'. a b c -> a b c' -> a b (c, c'))
-> Arrow a
&&& :: forall b c c'.
MigrationSteps be b c
-> MigrationSteps be b c' -> MigrationSteps be b (c, c')
$c&&& :: forall be b c c'.
MigrationSteps be b c
-> MigrationSteps be b c' -> MigrationSteps be b (c, c')
*** :: forall b c b' c'.
MigrationSteps be b c
-> MigrationSteps be b' c' -> MigrationSteps be (b, b') (c, c')
$c*** :: forall be b c b' c'.
MigrationSteps be b c
-> MigrationSteps be b' c' -> MigrationSteps be (b, b') (c, c')
second :: forall b c d.
MigrationSteps be b c -> MigrationSteps be (d, b) (d, c)
$csecond :: forall be b c d.
MigrationSteps be b c -> MigrationSteps be (d, b) (d, c)
first :: forall b c d.
MigrationSteps be b c -> MigrationSteps be (b, d) (c, d)
$cfirst :: forall be b c d.
MigrationSteps be b c -> MigrationSteps be (b, d) (c, d)
arr :: forall b c. (b -> c) -> MigrationSteps be b c
$carr :: forall be b c. (b -> c) -> MigrationSteps be b c
Arrow)
data MigrationF be next where
MigrationRunCommand
:: { forall be next. MigrationF be next -> BeamSqlBackendSyntax be
_migrationUpCommand :: BeamSqlBackendSyntax be
, forall be next.
MigrationF be next -> Maybe (BeamSqlBackendSyntax be)
_migrationDownCommand :: Maybe (BeamSqlBackendSyntax be)
, forall be next. MigrationF be next -> next
_migrationNext :: next }
-> MigrationF be next
deriving instance Functor (MigrationF be)
type Migration be = F (MigrationF be)
data MigrationDataLoss
= MigrationLosesData
| MigrationKeepsData
deriving Int -> MigrationDataLoss -> ShowS
[MigrationDataLoss] -> ShowS
MigrationDataLoss -> String
(Int -> MigrationDataLoss -> ShowS)
-> (MigrationDataLoss -> String)
-> ([MigrationDataLoss] -> ShowS)
-> Show MigrationDataLoss
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationDataLoss] -> ShowS
$cshowList :: [MigrationDataLoss] -> ShowS
show :: MigrationDataLoss -> String
$cshow :: MigrationDataLoss -> String
showsPrec :: Int -> MigrationDataLoss -> ShowS
$cshowsPrec :: Int -> MigrationDataLoss -> ShowS
Show
instance Semigroup MigrationDataLoss where
<> :: MigrationDataLoss -> MigrationDataLoss -> MigrationDataLoss
(<>) = MigrationDataLoss -> MigrationDataLoss -> MigrationDataLoss
forall a. Monoid a => a -> a -> a
mappend
instance Monoid MigrationDataLoss where
mempty :: MigrationDataLoss
mempty = MigrationDataLoss
MigrationKeepsData
mappend :: MigrationDataLoss -> MigrationDataLoss -> MigrationDataLoss
mappend MigrationDataLoss
MigrationLosesData MigrationDataLoss
_ = MigrationDataLoss
MigrationLosesData
mappend MigrationDataLoss
_ MigrationDataLoss
MigrationLosesData = MigrationDataLoss
MigrationLosesData
mappend MigrationDataLoss
MigrationKeepsData MigrationDataLoss
MigrationKeepsData = MigrationDataLoss
MigrationKeepsData
data MigrationCommand be
= MigrationCommand
{ forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand :: BeamSqlBackendSyntax be
, forall be. MigrationCommand be -> MigrationDataLoss
migrationCommandDataLossPossible :: MigrationDataLoss
}
deriving instance Show (BeamSqlBackendSyntax be) => Show (MigrationCommand be)
runMigrationSteps :: Monad m
=> Int
-> Maybe Int
-> MigrationSteps be () a
-> (forall a'. Int -> Text -> Migration be a' -> m a')
-> m a
runMigrationSteps :: forall (m :: * -> *) be a.
Monad m =>
Int
-> Maybe Int
-> MigrationSteps be () a
-> (forall a'. Int -> Text -> Migration be a' -> m a')
-> m a
runMigrationSteps Int
firstIdx Maybe Int
lastIdx (MigrationSteps Kleisli (F (MigrationStep be)) () a
steps) forall a'. Int -> Text -> Migration be a' -> m a'
runMigration =
F (MigrationStep be) a
-> forall r. (a -> r) -> (MigrationStep be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (Kleisli (F (MigrationStep be)) () a -> () -> F (MigrationStep be) a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (F (MigrationStep be)) () a
steps ()) a -> Int -> m a
forall {f :: * -> *} {a} {p}. Applicative f => a -> p -> f a
finish MigrationStep be (Int -> m a) -> Int -> m a
step Int
0
where finish :: a -> p -> f a
finish a
x p
_ = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
step :: MigrationStep be (Int -> m a) -> Int -> m a
step (MigrationStep Text
nm Migration be a
doStep a -> Int -> m a
next) Int
i =
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
firstIdx Bool -> Bool -> Bool
&& Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) Maybe Int
lastIdx
then Int -> Text -> Migration be a -> m a
forall a'. Int -> Text -> Migration be a' -> m a'
runMigration Int
i Text
nm Migration be a
doStep m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> a -> Int -> m a
next a
x (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
else a -> Int -> m a
next (Migration be a -> a
forall be a. Migration be a -> a
runMigrationSilenced Migration be a
doStep) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
runMigrationSilenced :: Migration be a -> a
runMigrationSilenced :: forall be a. Migration be a -> a
runMigrationSilenced Migration be a
m = Migration be a -> forall r. (a -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a
m a -> a
forall a. a -> a
id MigrationF be a -> a
forall be next. MigrationF be next -> next
step
where
step :: MigrationF be next -> next
step (MigrationRunCommand BeamSqlBackendSyntax be
_ Maybe (BeamSqlBackendSyntax be)
_ next
next) = next
next
eraseMigrationType :: a -> MigrationSteps be a a' -> MigrationSteps be () ()
eraseMigrationType :: forall a be a'.
a -> MigrationSteps be a a' -> MigrationSteps be () ()
eraseMigrationType a
a (MigrationSteps Kleisli (F (MigrationStep be)) a a'
steps) = Kleisli (F (MigrationStep be)) () () -> MigrationSteps be () ()
forall be from to.
Kleisli (F (MigrationStep be)) from to -> MigrationSteps be from to
MigrationSteps ((() -> a) -> Kleisli (F (MigrationStep be)) () a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a -> () -> a
forall a b. a -> b -> a
const a
a) Kleisli (F (MigrationStep be)) () a
-> Kleisli (F (MigrationStep be)) a ()
-> Kleisli (F (MigrationStep be)) () ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Kleisli (F (MigrationStep be)) a a'
steps Kleisli (F (MigrationStep be)) a a'
-> Kleisli (F (MigrationStep be)) a' ()
-> Kleisli (F (MigrationStep be)) a ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a' -> ()) -> Kleisli (F (MigrationStep be)) a' ()
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> a' -> ()
forall a b. a -> b -> a
const ()))
migrationStep :: Text -> (a -> Migration be a') -> MigrationSteps be a a'
migrationStep :: forall a be a'.
Text -> (a -> Migration be a') -> MigrationSteps be a a'
migrationStep Text
stepName a -> Migration be a'
migration =
Kleisli (F (MigrationStep be)) a a' -> MigrationSteps be a a'
forall be from to.
Kleisli (F (MigrationStep be)) from to -> MigrationSteps be from to
MigrationSteps ((a -> F (MigrationStep be) a')
-> Kleisli (F (MigrationStep be)) a a'
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (\a
a -> MigrationStep be a' -> F (MigrationStep be) a'
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (Text -> Migration be a' -> (a' -> a') -> MigrationStep be a'
forall be a next.
Text -> Migration be a -> (a -> next) -> MigrationStep be next
MigrationStep Text
stepName (a -> Migration be a'
migration a
a) a' -> a'
forall a. a -> a
id)))
upDown :: BeamSqlBackendSyntax be -> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown :: forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown BeamSqlBackendSyntax be
up Maybe (BeamSqlBackendSyntax be)
down = MigrationF be () -> F (MigrationF be) ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> () -> MigrationF be ()
forall be next.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> next -> MigrationF be next
MigrationRunCommand BeamSqlBackendSyntax be
up Maybe (BeamSqlBackendSyntax be)
down ())
migrateScript :: forall be m a. (Monoid m, Semigroup m, BeamSqlBackend be)
=> (Text -> m)
-> (BeamSqlBackendSyntax be -> m)
-> MigrationSteps be () a
-> m
migrateScript :: forall be m a.
(Monoid m, Semigroup m, BeamSqlBackend be) =>
(Text -> m)
-> (BeamSqlBackendSyntax be -> m) -> MigrationSteps be () a -> m
migrateScript Text -> m
renderMigrationHeader BeamSqlBackendSyntax be -> m
renderMigrationSyntax (MigrationSteps Kleisli (F (MigrationStep be)) () a
steps) =
F (MigrationStep be) a
-> forall r. (a -> r) -> (MigrationStep be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (Kleisli (F (MigrationStep be)) () a -> () -> F (MigrationStep be) a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (F (MigrationStep be)) () a
steps ()) (\a
_ m
x -> m
x)
(\(MigrationStep Text
header Migration be a
migration a -> m -> m
next) m
x ->
let (a
res, m
script) = Migration be a -> m -> (a, m)
forall a'. Migration be a' -> m -> (a', m)
renderMigration Migration be a
migration m
forall a. Monoid a => a
mempty
in a -> m -> m
next a
res (m
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> Text -> m
renderMigrationHeader Text
header m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
script)) m
forall a. Monoid a => a
mempty
where
renderMigration :: forall a'. Migration be a' -> m -> (a', m)
renderMigration :: forall a'. Migration be a' -> m -> (a', m)
renderMigration Migration be a'
migrationSteps =
Migration be a'
-> forall r. (a' -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a'
migrationSteps (,)
(\(MigrationRunCommand BeamSqlBackendSyntax be
a Maybe (BeamSqlBackendSyntax be)
_ m -> (a', m)
next) m
x -> m -> (a', m)
next (m
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> BeamSqlBackendSyntax be -> m
renderMigrationSyntax BeamSqlBackendSyntax be
a))
executeMigration :: Applicative m => (BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a
executeMigration :: forall (m :: * -> *) be a.
Applicative m =>
(BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a
executeMigration BeamSqlBackendSyntax be -> m ()
runSyntax Migration be a
go = Migration be a -> forall r. (a -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a
go a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationF be (m a) -> m a
doStep
where
doStep :: MigrationF be (m a) -> m a
doStep (MigrationRunCommand BeamSqlBackendSyntax be
cmd Maybe (BeamSqlBackendSyntax be)
_ m a
next) =
BeamSqlBackendSyntax be -> m ()
runSyntax BeamSqlBackendSyntax be
cmd m () -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
next
migrationDataLoss :: Migration be a -> MigrationDataLoss
migrationDataLoss :: forall be a. Migration be a -> MigrationDataLoss
migrationDataLoss Migration be a
go = Migration be a -> forall r. (a -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a
go (\a
_ -> MigrationDataLoss
MigrationKeepsData)
(\(MigrationRunCommand BeamSqlBackendSyntax be
_ Maybe (BeamSqlBackendSyntax be)
x MigrationDataLoss
next) ->
case Maybe (BeamSqlBackendSyntax be)
x of
Maybe (BeamSqlBackendSyntax be)
Nothing -> MigrationDataLoss
MigrationLosesData
Maybe (BeamSqlBackendSyntax be)
_ -> MigrationDataLoss
next)
evaluateDatabase :: forall be a. MigrationSteps be () a -> a
evaluateDatabase :: forall be a. MigrationSteps be () a -> a
evaluateDatabase (MigrationSteps Kleisli (F (MigrationStep be)) () a
f) = F (MigrationStep be) a
-> forall r. (a -> r) -> (MigrationStep be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (Kleisli (F (MigrationStep be)) () a -> () -> F (MigrationStep be) a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (F (MigrationStep be)) () a
f ()) a -> a
forall a. a -> a
id (\(MigrationStep Text
_ Migration be a
migration a -> a
next) -> a -> a
next (Migration be a -> a
forall a'. Migration be a' -> a'
runMigration Migration be a
migration))
where
runMigration :: forall a'. Migration be a' -> a'
runMigration :: forall a'. Migration be a' -> a'
runMigration Migration be a'
migration = Migration be a'
-> forall r. (a' -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a'
migration a' -> a'
forall a. a -> a
id (\(MigrationRunCommand BeamSqlBackendSyntax be
_ Maybe (BeamSqlBackendSyntax be)
_ a'
next) -> a'
next)
stepNames :: forall be a. MigrationSteps be () a -> [Text]
stepNames :: forall be a. MigrationSteps be () a -> [Text]
stepNames (MigrationSteps Kleisli (F (MigrationStep be)) () a
f) = F (MigrationStep be) a
-> forall r. (a -> r) -> (MigrationStep be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (Kleisli (F (MigrationStep be)) () a -> () -> F (MigrationStep be) a
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Kleisli (F (MigrationStep be)) () a
f ()) (\a
_ [Text]
x -> [Text]
x) (\(MigrationStep Text
nm Migration be a
migration a -> [Text] -> [Text]
next) [Text]
x -> a -> [Text] -> [Text]
next (Migration be a -> a
forall a'. Migration be a' -> a'
runMigration Migration be a
migration) ([Text]
x [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
nm])) []
where
runMigration :: forall a'. Migration be a' -> a'
runMigration :: forall a'. Migration be a' -> a'
runMigration Migration be a'
migration = Migration be a'
-> forall r. (a' -> r) -> (MigrationF be r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF Migration be a'
migration a' -> a'
forall a. a -> a
id (\(MigrationRunCommand BeamSqlBackendSyntax be
_ Maybe (BeamSqlBackendSyntax be)
_ a'
next) -> a'
next)