beam-migrate 0.3.2.2 → 0.4.0.0

raw patch · 19 files changed

+817/−775 lines, 19 filesdep +microlensdep ~beam-coredep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: microlens

Dependency ranges changed: beam-core, haskell-src-exts

API changes (from Hackage documentation)

Files

• Database/Beam/Haskell/Syntax.hs +77/−54
• Database/Beam/Migrate/Actions.hs +97/−84
• Database/Beam/Migrate/Backend.hs +33/−34
• Database/Beam/Migrate/Checks.hs +39/−39
• Database/Beam/Migrate/Generics.hs +5/−5
• Database/Beam/Migrate/Generics/Tables.hs +97/−129
• Database/Beam/Migrate/Generics/Types.hs +12/−13
• Database/Beam/Migrate/Log.hs +55/−53
• Database/Beam/Migrate/SQL/BeamExtensions.hs +4/−4
• Database/Beam/Migrate/SQL/Builder.hs +9/−4
• Database/Beam/Migrate/SQL/SQL92.hs +18/−13
• Database/Beam/Migrate/SQL/Tables.hs +91/−176
• Database/Beam/Migrate/SQL/Types.hs +62/−14
• Database/Beam/Migrate/Serialization.hs +39/−41
• Database/Beam/Migrate/Simple.hs +43/−35
• Database/Beam/Migrate/Types.hs +36/−31
• Database/Beam/Migrate/Types/CheckedEntities.hs +52/−37
• Database/Beam/Migrate/Types/Predicates.hs +43/−6
• beam-migrate.cabal +5/−3

@@ -14,8 +14,11 @@  import           Database.Beam import           Database.Beam.Backend.SQL+import           Database.Beam.Backend.SQL.AST import           Database.Beam.Backend.SQL.Builder+import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import           Database.Beam.Migrate.SQL.SQL92+import           Database.Beam.Migrate.SQL.Types import           Database.Beam.Migrate.Serialization  import           Data.Char (toLower, toUpper)@@ -89,6 +92,8 @@   hashWithSalt salt (HsDataType mig ty _) = hashWithSalt salt (mig, ty) instance Sql92DisplaySyntax HsDataType where   displaySyntax = show+instance HasDataTypeCreatedCheck HsDataType where+  dataTypeHasBeenCreated _ _ = True -- TODO make this more robust  data HsType   = HsType@@ -164,7 +169,6 @@ data HsEntity     = HsEntity     { hsEntityBackend :: HsBeamBackend HsExpr-    , hsEntitySyntax  :: HsBeamBackend ()      , hsEntityName    :: HsEntityName @@ -255,17 +259,10 @@                                      (buildHsDbField (hsEntityDbDecl entity) $                                       Hs.TyVar () (Hs.Ident () "entity")) -migrationTypeDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> [Hs.Type ()] -> Hs.Decl ()-migrationTypeDecl be syntax inputs =+migrationTypeDecl :: HsBeamBackend HsExpr -> [Hs.Type ()] -> Hs.Decl ()+migrationTypeDecl be inputs =   Hs.TypeSig () [Hs.Ident () "migration"] migrationType   where-    (syntaxAssts, syntaxVar) =-      case syntax of-        HsBeamBackendNone -> error "No syntax matches"-        HsBeamBackendSingle ty _ -> ([], hsTypeSyntax ty)-        HsBeamBackendConstrained cs ->-          ( map (flip buildHsBackendConstraint syntaxVar) cs-          , tyVarNamed "syntax" )     (beAssts, beVar) =       case be of         HsBeamBackendNone -> error "No backend matches"@@ -275,7 +272,7 @@           , tyVarNamed "be" )      resultType = tyApp (tyConNamed "Migration")-                       [ syntaxVar+                       [ beVar                        , tyApp (tyConNamed "CheckedDatabaseSettings")                                [ beVar                                , tyConNamed "Db" ] ]@@ -284,7 +281,7 @@       | [] <- inputs = resultType       | otherwise    = functionTy (tyTuple inputs) resultType -    constraints = nub (syntaxAssts ++ beAssts)+    constraints = nub beAssts     migrationType       | [] <- constraints  = migrationUnconstrainedType       | [c] <- constraints = Hs.TyForall () Nothing (Just (Hs.CxSingle () c)) migrationUnconstrainedType@@ -304,17 +301,19 @@     finalReturn = hsApp (hsVar "pure")                         [ hsRecCon "Db" (map (\e -> (fromString (entityDbFieldName e), hsEntityExp e)) entities) ] -dbTypeDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> Hs.Decl ()-dbTypeDecl be syntax =+dbTypeDecl :: HsBeamBackend HsExpr -> Hs.Decl ()+dbTypeDecl be =   Hs.TypeSig () [ Hs.Ident () "db" ] dbType   where     unconstrainedDbType = tyApp (tyConNamed "DatabaseSettings")                                 [ beVar, tyConNamed "Db" ]     dbType+      | []  <- constraints, [] <- bindings = unconstrainedDbType+      | []  <- constraints  = Hs.TyForall () (Just bindings) Nothing unconstrainedDbType       | [c] <- constraints = Hs.TyForall () (Just bindings) (Just (Hs.CxSingle () c)) unconstrainedDbType       | otherwise          = Hs.TyForall () (Just bindings) (Just (Hs.CxTuple () constraints)) unconstrainedDbType -    constraints = monadBeamConstraint:nub (beAssts ++ syntaxAssts)+    constraints = nub beAssts     (bindings, beAssts, beVar) =       case be of         HsBeamBackendNone -> error "No backend matches"@@ -324,34 +323,23 @@           , map (flip buildHsBackendConstraint beVar) cs           , tyVarNamed "be" ) -    (standardBindings, syntaxAssts, syntaxVar) =-      case syntax of-        HsBeamBackendNone -> error "No syntax matches"-        HsBeamBackendSingle ty _ -> ( [tyVarBind "hdl", tyVarBind "m"]-                                    , []-                                    , hsTypeSyntax ty )-        HsBeamBackendConstrained cs ->-          ( [tyVarBind "syntax", tyVarBind "hdl", tyVarBind "m"]-          , map (flip buildHsBackendConstraint syntaxVar) cs-          , tyVarNamed "syntax" )+    standardBindings = []      tyVarBind nm = Hs.UnkindedVar () (Hs.Ident () nm) -    monadBeamConstraint = Hs.ClassA () (Hs.UnQual () (Hs.Ident () "MonadBeam")) [ syntaxVar, beVar, tyVarNamed "hdl", tyVarNamed "m" ]--dbDecl :: HsBeamBackend HsExpr -> HsBeamBackend () -> [HsExpr] -> Hs.Decl ()-dbDecl _ syntax params =+dbDecl :: HsBeamBackend HsExpr -> [HsExpr] -> Hs.Decl ()+dbDecl backend params =   Hs.FunBind () [ Hs.Match () (Hs.Ident () "db") [] (Hs.UnGuardedRhs () body) Nothing ]   where-    syntaxVar = case syntax of-                  HsBeamBackendNone -> error "No syntax matches"-                  HsBeamBackendSingle ty _ -> hsTypeSyntax ty-                  HsBeamBackendConstrained _ -> tyVarNamed "syntax"+    backendVar = case backend of+                   HsBeamBackendNone -> error "No syntax matches"+                   HsBeamBackendSingle ty _ -> hsTypeSyntax ty+                   HsBeamBackendConstrained _ -> tyVarNamed "be"      body = hsExprSyntax $            hsApp (hsVar "unCheckDatabase")                  [ hsApp (hsVarFrom "runMigrationSilenced" "Database.Beam.Migrate")-                   [ hsApp (hsVisibleTyApp (hsVar "migration") syntaxVar) $+                   [ hsApp (hsVisibleTyApp (hsVar "migration") backendVar) $                      case params of                        [] -> []                        _  -> [ hsTuple params ]@@ -375,13 +363,16 @@                                           , Hs.Ident () "FlexibleInstances"                                           , Hs.Ident () "DeriveGeneric"                                           , Hs.Ident () "TypeSynonymInstances"-                                          , Hs.Ident () "ExplicitNamespaces "] ]+                                          , Hs.Ident () "ExplicitNamespaces"+                                          , Hs.Ident () "TypeApplications"+                                          , Hs.Ident () "TypeFamilies"+                                          , Hs.Ident () "OverloadedStrings" ] ]        HsImports importedModules = foldMap (\e -> foldMap hsDeclImports (hsEntityDecls e) <>                                                  hsExprImports (hsEntityExp e)) entities <>                                   foldMap (hsExprImports . snd) migrations <>                                   importSome "Database.Beam.Migrate" [ importTyNamed "CheckedDatabaseSettings", importTyNamed "Migration"-                                                                     , importTyNamed "Sql92SaneDdlCommandSyntax"+                                                                     , importTyNamed "BeamMigrateSqlBackend"                                                                      , importVarNamed "runMigrationSilenced"                                                                      , importVarNamed "unCheckDatabase" ]       imports = commonImports <>@@ -398,7 +389,6 @@                       , Hs.ImportDecl () (Hs.ModuleName () "Control.Applicative") False False False Nothing Nothing Nothing ]        backend = foldMap hsEntityBackend entities-      syntax  = foldMap hsEntitySyntax entities        backendHs = case backend of                     HsBeamBackendNone -> error "Can't instantiate Database instance: No backend matches"@@ -408,13 +398,13 @@       decls = foldMap (map hsDeclSyntax . hsEntityDecls) entities ++               [ databaseTypeDecl entities -              , migrationTypeDecl backend syntax []+              , migrationTypeDecl backend []               , migrationDecl backend [] migrations entities                , hsInstance "Database" [ backendHs, tyConNamed "Db" ] [] -              , dbTypeDecl backend syntax-              , dbDecl backend syntax [] ]+              , dbTypeDecl backend+              , dbDecl backend [] ]    in Right (render (Hs.prettyPrim hsMod)) @@ -429,6 +419,27 @@   mempty = HsNone   mappend _ _ = HsNone +data HsMigrateBackend = HsMigrateBackend++instance BeamMigrateOnlySqlBackend HsMigrateBackend+type instance BeamSqlBackendSyntax HsMigrateBackend = HsAction++hsMkTableName :: (Char -> Char) -> TableName -> String+hsMkTableName toNameCase (TableName sch nm) =+  case sch of+    Nothing ->+      case T.unpack nm of+        [] -> error "No name for table"+        x:xs -> toNameCase x:xs+    Just schNm ->+      case T.unpack schNm of+        [] -> error "Empty schema name"+        x:xs -> toNameCase x:xs ++ "_" ++ T.unpack nm++hsTableVarName, hsTableTypeName :: TableName -> String+hsTableVarName = hsMkTableName toLower+hsTableTypeName = hsMkTableName toUpper+ instance IsSql92DdlCommandSyntax HsAction where   type Sql92DdlCommandCreateTableSyntax HsAction = HsAction   type Sql92DdlCommandAlterTableSyntax HsAction = HsAction@@ -439,6 +450,7 @@   alterTableCmd = id  instance IsSql92AlterTableSyntax HsAction where+  type Sql92AlterTableTableNameSyntax HsAction = TableName   type Sql92AlterTableAlterTableActionSyntax HsAction = HsNone    alterTableSyntax _ _ = error "alterTableSyntax"@@ -458,11 +470,14 @@   setNotNullSyntax = HsNone  instance IsSql92DropTableSyntax HsAction where+  type Sql92DropTableTableNameSyntax HsAction = TableName+   dropTableSyntax nm = HsAction [ (Nothing, dropTable) ] []     where-      dropTable = hsApp (hsVar "dropTable") [ hsVar ("_" <> nm) ]+      dropTable = hsApp (hsVar "dropTable") [ hsVar (fromString (hsTableVarName nm)) ]  instance IsSql92CreateTableSyntax HsAction where+  type Sql92CreateTableTableNameSyntax HsAction = TableName   type Sql92CreateTableOptionsSyntax HsAction = HsNone   type Sql92CreateTableTableConstraintSyntax HsAction = HsTableConstraint   type Sql92CreateTableColumnSchemaSyntax HsAction = HsColumnSchema@@ -473,10 +488,7 @@              [ entity ]     where       (varName, tyName, tyConName) =-        case T.unpack nm of-          [] -> error "No name for table"-          x:xs -> let tyName' = toUpper x:xs-                  in ( toLower x:xs, tyName' ++ "T", tyName')+        ( hsTableVarName nm, hsTableTypeName nm ++ "T", hsTableTypeName nm )        mkHsFieldName fieldNm = "_" ++ varName ++                               case T.unpack fieldNm of@@ -490,19 +502,18 @@        migration =         hsApp (hsVarFrom "createTable" "Database.Beam.Migrate")-              [ hsStr nm+              [ hsStr (fromString (hsTableVarName nm))               , hsApp (hsTyCon (fromString tyConName))                       (map (\(fieldNm, ty) -> mkHsColumnSchema ty fieldNm) fields) ]       entity = HsEntity-             { hsEntityBackend = HsBeamBackendConstrained []-             , hsEntitySyntax = HsBeamBackendConstrained [ sql92SaneDdlCommandSyntax ]+             { hsEntityBackend = HsBeamBackendConstrained [ beamMigrateSqlBackend ]               , hsEntityName    = HsEntityName varName              , hsEntityDecls   = [ HsDecl tblDecl imports                                           [ Hs.EThingWith () (Hs.EWildcard () 0) (unqual tyName) [] ]                                  , HsDecl tblBeamable imports [] -                                 , HsDecl tblPun imports [ Hs.EVar () (unqual tyName) ]+                                 , HsDecl tblPun imports [ Hs.EVar () (unqual tyConName) ]                                   , HsDecl tblShowInstance imports []                                  , HsDecl tblEqInstance imports []@@ -609,6 +620,14 @@   referentialActionSetDefaultSyntax = HsNone   referentialActionSetNullSyntax = HsNone +instance IsSql92ExtractFieldSyntax HsExpr where+  secondsField = hsVar "secondsField"+  minutesField = hsVar "minutesField"+  hourField    = hsVar "hourField"+  yearField    = hsVar "yearField"+  monthField   = hsVar "monthField"+  dayField     = hsVar "dayField"+ instance IsSql92ExpressionSyntax HsExpr where   type Sql92ExpressionFieldNameSyntax HsExpr = HsExpr   type Sql92ExpressionSelectSyntax HsExpr = SqlSyntaxBuilder@@ -760,7 +779,7 @@   dateType = HsDataType (hsVarFrom "date" "Database.Beam.Migrate")                         (HsType (tyConNamed "Day") (importSome "Data.Time" [ importTyNamed "Day" ])) dateType -  timeType p False = HsDataType (hsVarFrom "time" "Database.Beam.Migrate")+  timeType p False = HsDataType (hsApp (hsVarFrom "time" "Database.Beam.Migrate") [ hsMaybe Nothing ] )                                 (HsType (tyConNamed "TimeOfDay") (importSome "Data.Time" [ importTyNamed "TimeOfDay" ]))                                 (timeType p False)   timeType _ _ = error "timeType"@@ -932,11 +951,13 @@ inst :: String -> Hs.InstRule () inst = Hs.IRule () Nothing Nothing . Hs.IHCon () . Hs.UnQual () . Hs.Ident () -sql92SaneDdlCommandSyntax :: HsBackendConstraint-sql92SaneDdlCommandSyntax =-  HsBackendConstraint $ \syntaxTy ->-  Hs.ClassA () (Hs.UnQual () (Hs.Ident () "Sql92SaneDdlCommandSyntax")) [ syntaxTy ]+beamMigrateSqlBackend :: HsBackendConstraint+beamMigrateSqlBackend =+  HsBackendConstraint $ \beTy ->+  Hs.ClassA () (Hs.UnQual () (Hs.Ident () "BeamMigrateSqlBackend")) [ beTy ] ++ -- * Orphans  instance Hashable (Hs.Exp ())@@ -949,7 +970,9 @@ instance Hashable (Hs.Type ()) instance Hashable (Hs.QOp ()) instance Hashable (Hs.TyVarBind ())+#if !MIN_VERSION_haskell_src_exts(1, 21, 0) instance Hashable (Hs.Kind ())+#endif instance Hashable (Hs.Context ()) instance Hashable (Hs.SpecialCon ()) instance Hashable (Hs.Pat ())

@@ -5,6 +5,7 @@ {-# 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.@@ -89,9 +90,11 @@   , heuristicSolver   ) where -import           Database.Beam.Migrate.Types+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@@ -123,25 +126,27 @@ instance NFData DatabaseStateSource  -- | Represents the state of a database as a migration is being generated-data DatabaseState cmd+data DatabaseState be   = DatabaseState   { 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)   , dbStateKey                :: !(HS.HashSet SomeDatabasePredicate)     -- ^ HS.fromMap of 'dbStateCurrentState', for maximal sharing-  , dbStateCmdSequence        :: !(Seq.Seq (MigrationCommand cmd))+  , dbStateCmdSequence        :: !(Seq.Seq (MigrationCommand be))     -- ^ The current sequence of commands we've committed to in this state-  } deriving Show+  }+deriving instance Show (BeamSqlBackendSyntax be) => Show (DatabaseState be)  instance NFData (DatabaseState cmd) where   rnf d@DatabaseState {..} = d `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 cmd-  = MeasuredDatabaseState {-# UNPACK #-} !Int {-# UNPACK #-} !Int (DatabaseState cmd)-  deriving (Show, Generic)+data MeasuredDatabaseState be+  = MeasuredDatabaseState {-# UNPACK #-} !Int {-# UNPACK #-} !Int (DatabaseState be)+  deriving Generic+deriving instance Show (BeamSqlBackendSyntax be) => Show (MeasuredDatabaseState be) instance NFData (MeasuredDatabaseState cmd) instance Eq (MeasuredDatabaseState cmd) where   a == b = measure a == measure b@@ -171,13 +176,13 @@ -- 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 cmd+data PotentialAction be   = PotentialAction   { actionPreConditions  :: !(HS.HashSet SomeDatabasePredicate)     -- ^ Preconditions that will no longer apply   , actionPostConditions :: !(HS.HashSet SomeDatabasePredicate)     -- ^ Conditions that will apply after we're done-  , actionCommands :: !(Seq.Seq (MigrationCommand cmd))+  , 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.@@ -188,14 +193,14 @@     -- path through the graph.   } -instance Semigroup (PotentialAction cmd) where+instance Semigroup (PotentialAction be) where   (<>) = 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 cmd) where+instance Monoid (PotentialAction be) where   mempty = PotentialAction mempty mempty mempty  "" 0   mappend a b =     PotentialAction (actionPreConditions a <> actionPreConditions b)@@ -207,10 +212,10 @@                     (actionScore a + actionScore b)  -- | See 'ActionProvider'-type ActionProviderFn cmd =+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 cmd ]  {- A list of actions that we could perform -}+  -> [ PotentialAction be ]  {- A list of actions that we could perform -}  -- | Edge discovery mechanism. A newtype wrapper over 'ActionProviderFn'. --@@ -245,13 +250,13 @@ -- 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 cmd-  = ActionProvider { getPotentialActions :: ActionProviderFn cmd }+newtype ActionProvider be+  = ActionProvider { getPotentialActions :: ActionProviderFn be } -instance Semigroup (ActionProvider cmd) where+instance Semigroup (ActionProvider be) where   (<>) = mappend -instance Monoid (ActionProvider cmd) where+instance Monoid (ActionProvider be) where   mempty = ActionProvider (\_ _ -> [])   mappend (ActionProvider a) (ActionProvider b) =     ActionProvider $ \pre post ->@@ -281,14 +286,13 @@ justOne_ _ = []  -- | Action provider for SQL92 @CREATE TABLE@ actions.-createTableActionProvider :: forall cmd-                           . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                             , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-                          => ActionProvider cmd+createTableActionProvider :: forall be+                           . ( Typeable be, BeamMigrateOnlySqlBackend be )+                          => ActionProvider be createTableActionProvider =   ActionProvider provider   where-    provider :: ActionProviderFn cmd+    provider :: ActionProviderFn be     provider findPreConditions findPostConditions =       do tblP@(TableExistsPredicate postTblNm) <- findPostConditions          -- Make sure there's no corresponding predicate in the precondition@@ -298,16 +302,15 @@           (columnsP, columns) <- pure . unzip $            do columnP@-                (TableHasColumn tblNm colNm schema-                 :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd)) <-+                (TableHasColumn tblNm colNm schema :: TableHasColumn be) <-                 findPostConditions-              guard (tblNm == postTblNm)+              guard (tblNm == postTblNm && dataTypeHasBeenCreated schema findPreConditions)                (constraintsP, constraints) <-                 pure . unzip $ do                 constraintP@                   (TableColumnHasConstraint tblNm' colNm' c-                   :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd)) <-+                   :: TableColumnHasConstraint be) <-                   findPostConditions                 guard (postTblNm == tblNm')                 guard (colNm == colNm')@@ -322,23 +325,22 @@            pure (primaryKeyP, primaryKey)           let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP-             cmd = createTableCmd (createTableSyntax Nothing postTblNm colsSyntax tblConstraints)+             cmd = createTableCmd (createTableSyntax Nothing (qnameAsTableName postTblNm) colsSyntax tblConstraints)              tblConstraints = if null primaryKey then [] else [ primaryKeyConstraintSyntax primaryKey ]              colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns          pure (PotentialAction mempty (HS.fromList postConditions)                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))-                               ("Create the table " <> postTblNm) createTableWeight)+                               ("Create the table " <> qnameAsText postTblNm) createTableWeight)  -- | Action provider for SQL92 @DROP TABLE@ actions-dropTableActionProvider :: forall cmd-                        . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                          , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-                        => ActionProvider cmd+dropTableActionProvider :: forall be+                         . BeamMigrateOnlySqlBackend be+                        => ActionProvider be dropTableActionProvider =  ActionProvider provider  where    -- Look for tables that exist as a precondition but not a post condition-   provider :: ActionProviderFn cmd+   provider :: ActionProviderFn be    provider findPreConditions findPostConditions =      do tblP@(TableExistsPredicate preTblNm) <- findPreConditions         ensuringNot_ $@@ -351,48 +353,57 @@                     pure p'          -- Now, collect all preconditions that may be related to the dropped table-        let cmd = dropTableCmd (dropTableSyntax preTblNm)+        let cmd = dropTableCmd (dropTableSyntax (qnameAsTableName preTblNm))         pure ({-trace ("Dropping table " <> show preTblNm <> " would drop " <> show relatedPreds) $ -}               PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty                               (Seq.singleton (MigrationCommand cmd MigrationLosesData))-                              ("Drop table " <> preTblNm) dropTableWeight)+                              ("Drop table " <> qnameAsText preTblNm) dropTableWeight)  -- | Action provider for SQL92 @ALTER TABLE ... ADD COLUMN ...@ actions-addColumnProvider :: forall cmd-                   . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                     , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-                   => ActionProvider cmd+addColumnProvider :: forall be+                   . ( Typeable be, BeamMigrateOnlySqlBackend be )+                  => ActionProvider be addColumnProvider =   ActionProvider provider   where-    provider :: ActionProviderFn cmd+    provider :: ActionProviderFn be     provider findPreConditions findPostConditions =-      do colP@(TableHasColumn tblNm colNm colType :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd))+      do colP@(TableHasColumn tblNm colNm colType :: TableHasColumn be)            <- findPostConditions          TableExistsPredicate tblNm' <- findPreConditions-         guard (tblNm' == tblNm)+         guard (tblNm'  == tblNm && dataTypeHasBeenCreated colType findPreConditions)          ensuringNot_ $ do-           TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <-+           TableHasColumn tblNm'' colNm' _ :: TableHasColumn be <-              findPreConditions            guard (tblNm'' == tblNm && colNm == colNm') -- This column exists as a different type -         let cmd = alterTableCmd (alterTableSyntax tblNm (addColumnSyntax colNm schema))-             schema = columnSchemaSyntax colType Nothing [] Nothing-         pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP])+         (constraintsP, constraints) <-+           pure . unzip $ do+           constraintP@+             (TableColumnHasConstraint tblNm'' colNm' c+              :: TableColumnHasConstraint be) <-+             findPostConditions+           guard (tblNm == tblNm'')+           guard (colNm == colNm')++           pure (p constraintP, c)++         let cmd = alterTableCmd (alterTableSyntax (qnameAsTableName tblNm) (addColumnSyntax colNm schema))+             schema = columnSchemaSyntax colType Nothing constraints Nothing+         pure (PotentialAction mempty (HS.fromList ([SomeDatabasePredicate colP] ++ constraintsP))                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))-                               ("Add column " <> colNm <> " to " <> tblNm)-                (addColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))+                               ("Add column " <> colNm <> " to " <> qnameAsText tblNm)+                (addColumnWeight + fromIntegral (T.length (qnameAsText tblNm) + T.length colNm)))  -- | Action provider for SQL92 @ALTER TABLE ... DROP COLUMN ...@ actions-dropColumnProvider :: forall cmd-                    . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                      , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-                   => ActionProvider cmd+dropColumnProvider :: forall be+                    . ( Typeable be, BeamMigrateOnlySqlBackend be )+                   => ActionProvider be dropColumnProvider = ActionProvider provider   where-    provider :: ActionProviderFn cmd+    provider :: ActionProviderFn be     provider findPreConditions _ =-      do colP@(TableHasColumn tblNm colNm _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd))+      do colP@(TableHasColumn tblNm colNm _ :: TableHasColumn be)            <- findPreConditions  --         TableExistsPredicate tblNm' <- trace ("COnsider drop " <> show tblNm <> " " <> show colNm)  findPreConditions@@ -407,57 +418,59 @@                      guard (pred' `predicateCascadesDropOn` colP)                      pure p' -         let cmd = alterTableCmd (alterTableSyntax tblNm (dropColumnSyntax colNm))+         let cmd = alterTableCmd (alterTableSyntax (qnameAsTableName tblNm) (dropColumnSyntax colNm))          pure (PotentialAction (HS.fromList (SomeDatabasePredicate colP:relatedPreds)) mempty                                (Seq.singleton (MigrationCommand cmd MigrationLosesData))-                               ("Drop column " <> colNm <> " from " <> tblNm)-                (dropColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))+                               ("Drop column " <> colNm <> " from " <> qnameAsText tblNm)+                (dropColumnWeight + fromIntegral (T.length (qnameAsText tblNm) + T.length colNm)))  -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NULL@-addColumnNullProvider :: forall cmd-                       . Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                      => ActionProvider cmd+addColumnNullProvider :: forall be+                       . ( Typeable be, BeamMigrateOnlySqlBackend be )+                      => ActionProvider be addColumnNullProvider = ActionProvider provider   where-    provider :: ActionProviderFn cmd+    provider :: ActionProviderFn be     provider findPreConditions findPostConditions =-      do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd))+      do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint be)            <- findPostConditions -- TODO         guard (c == notNullConstraintSyntax)           TableExistsPredicate tblNm' <- findPreConditions          guard (tblNm == tblNm') -         TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <- findPreConditions+         TableHasColumn tblNm'' colNm' _ :: TableHasColumn be <-+           findPreConditions          guard (tblNm == tblNm'' && colNm == colNm') -         let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNotNullSyntax))+         let cmd = alterTableCmd (alterTableSyntax (qnameAsTableName tblNm) (alterColumnSyntax colNm setNotNullSyntax))          pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP])                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))-                               ("Add not null constraint to " <> colNm <> " on " <> tblNm) 100)+                               ("Add not null constraint to " <> colNm <> " on " <> qnameAsText tblNm) 100)  -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET  NOT NULL@-dropColumnNullProvider :: forall cmd-                        . Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                       => ActionProvider cmd+dropColumnNullProvider :: forall be+                        . ( Typeable be, BeamMigrateOnlySqlBackend be )+                       => ActionProvider be dropColumnNullProvider = ActionProvider provider   where-    provider :: ActionProviderFn cmd+    provider :: ActionProviderFn be     provider findPreConditions _ =-      do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd))+      do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint be)            <- findPreConditions -- TODO         guard (c == notNullConstraintSyntax)           TableExistsPredicate tblNm' <- findPreConditions          guard (tblNm == tblNm') -         TableHasColumn tblNm'' colNm' _ :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <- findPreConditions+         TableHasColumn tblNm'' colNm' _ :: TableHasColumn be <-+           findPreConditions          guard (tblNm == tblNm'' && colNm == colNm') -         let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNullSyntax))+         let cmd = alterTableCmd (alterTableSyntax (qnameAsTableName tblNm) (alterColumnSyntax colNm setNullSyntax))          pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))-                               ("Drop not null constraint for " <> colNm <> " on " <> tblNm) 100)+                               ("Drop not null constraint for " <> colNm <> " on " <> qnameAsText tblNm) 100)  -- | Default action providers for any SQL92 compliant syntax. --@@ -468,9 +481,9 @@ --  * ALTER TABLE ... ADD COLUMN ... --  * ALTER TABLE ... DROP COLUMN ... --  * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL-defaultActionProvider :: ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd-                         , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-                      => ActionProvider cmd+defaultActionProvider :: ( Typeable be+                         , BeamMigrateOnlySqlBackend be )+                      => ActionProvider be defaultActionProvider =   mconcat   [ createTableActionProvider@@ -522,23 +535,23 @@                      } -> Solver cmd  -- | Represents the final results of a search-data FinalSolution cmd-  = Solved [ MigrationCommand cmd ]+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 cmd ]+  | 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 Show+deriving instance Show (BeamSqlBackendSyntax be) => Show (FinalSolution be)  -- | Returns 'True' if the state has been solved-solvedState :: HS.HashSet SomeDatabasePredicate -> DatabaseState cmd -> Bool+solvedState :: HS.HashSet SomeDatabasePredicate -> DatabaseState be -> Bool solvedState goal (DatabaseState _ cur _) = goal == 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 cmd -> FinalSolution cmd+finalSolution :: Solver be -> FinalSolution be finalSolution (SearchFailed sts)     = Candidates sts finalSolution (ProvideSolution cmds) = Solved cmds finalSolution (ChooseActions _ _ actions next) =@@ -552,10 +565,10 @@ -- -- See the documentation on 'Solver' for more information on how to consume the -- result.-heuristicSolver :: ActionProvider cmd        -- ^ Edge discovery function+heuristicSolver :: ActionProvider be         -- ^ Edge discovery function                 -> [ SomeDatabasePredicate ] -- ^ Source database state                 -> [ SomeDatabasePredicate ] -- ^ Destination database state-                -> Solver cmd+                -> Solver be heuristicSolver provider preConditionsL postConditionsL =    heuristicSolver' initQueue mempty PQ.empty

@@ -39,7 +39,7 @@   , trivialHsConverter, hsPredicateConverter    -- * For tooling authors-  , SomeBeamMigrationBackend(..) )+  , SomeBeamMigrationBackend(..), SomeCheckedDatabaseSettings(..) ) where  import           Database.Beam@@ -49,14 +49,12 @@ import           Database.Beam.Migrate.Serialization import           Database.Beam.Migrate.SQL import           Database.Beam.Migrate.Types-  ( SomeDatabasePredicate(..), MigrationSteps )+  ( SomeDatabasePredicate(..), CheckedDatabaseSettings )  import           Database.Beam.Haskell.Syntax  import           Control.Applicative --import qualified Data.ByteString.Lazy as BL #if ! MIN_VERSION_base(4,11,0) import           Data.Semigroup #endif@@ -72,41 +70,42 @@ -- | Backends should create a value of this type and export it in an exposed -- module under the name 'migrationBackend'. See the module documentation for -- more details.-data BeamMigrationBackend commandSyntax be hdl m where+data BeamMigrationBackend be m where   BeamMigrationBackend ::-    ( MonadBeam commandSyntax be hdl m-    , Typeable be-    , HasQBuilder (Sql92SelectSyntax commandSyntax)-    , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) LocalTime-    , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) (Maybe LocalTime)-    , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) Text-    , HasSqlValueSyntax (Sql92ValueSyntax commandSyntax) SqlNull-    , IsSql92Syntax commandSyntax-    , Sql92SanityCheck commandSyntax, Sql92SaneDdlCommandSyntax commandSyntax-    , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax commandSyntax)+    ( MonadBeam be m+    , HasQBuilder be+    , BeamMigrateSqlBackend be+    , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+    , BeamSqlBackendCanSerialize be LocalTime+    , BeamSqlBackendCanSerialize be (Maybe LocalTime)+    , BeamSqlBackendCanSerialize be Text+    , BeamSqlBackendCanSerialize be SqlNull     , Sql92ReasonableMarshaller be ) =>     { backendName :: String     , backendConnStringExplanation :: String-    , backendRenderSteps :: forall a. MigrationSteps commandSyntax () a -> BL.ByteString     , backendGetDbConstraints :: m [ SomeDatabasePredicate ]-    , backendPredicateParsers :: BeamDeserializers commandSyntax-    , backendRenderSyntax :: commandSyntax -> String+    , backendPredicateParsers :: BeamDeserializers be+    , backendRenderSyntax :: BeamSqlBackendSyntax be -> String     , backendFileExtension :: String     , backendConvertToHaskell :: HaskellPredicateConverter-    , backendActionProvider :: ActionProvider commandSyntax+    , backendActionProvider :: ActionProvider be     , backendTransact :: forall a. String -> m a -> IO (Either DdlError a)-    } -> BeamMigrationBackend commandSyntax be hdl m+    } -> BeamMigrationBackend be m  -- | Monomorphic wrapper for use with plugin loaders that cannot handle -- polymorphism data SomeBeamMigrationBackend where-  SomeBeamMigrationBackend :: ( Typeable commandSyntax-                              , IsSql92DdlCommandSyntax commandSyntax-                              , IsSql92Syntax commandSyntax-                              , Sql92SanityCheck commandSyntax ) =>-                              BeamMigrationBackend commandSyntax be hdl m+  SomeBeamMigrationBackend :: ( BeamMigrateSqlBackend be+                              , Typeable be )+                           => BeamMigrationBackend be m                            -> SomeBeamMigrationBackend +-- | Monomorphic wrapper to use when interpreting a module which+-- exports a 'CheckedDatabaseSettings'.+data SomeCheckedDatabaseSettings where+  SomeCheckedDatabaseSettings :: Database be db => CheckedDatabaseSettings be db+                              -> SomeCheckedDatabaseSettings+ -- | In order to support Haskell schema generation, backends need to provide a -- way to convert arbitrary 'DatabasePredicate's generated by the backend's -- 'backendGetDbConstraints' function into appropriate predicates in the Haskell@@ -127,25 +126,25 @@ -- | Converters for the 'TableExistsPredicate', 'TableHasPrimaryKey', and -- 'TableHasColumn' (when supplied with a function to convert a backend data -- type to a haskell one).-sql92HsPredicateConverters :: forall columnSchemaSyntax-                             . Typeable columnSchemaSyntax-                            => (Sql92ColumnSchemaColumnTypeSyntax columnSchemaSyntax -> Maybe HsDataType)+sql92HsPredicateConverters :: forall fromBe+                             . Typeable fromBe+                            => (BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType)                             -> HaskellPredicateConverter sql92HsPredicateConverters convType =   trivialHsConverter @TableExistsPredicate <>   trivialHsConverter @TableHasPrimaryKey   <>-  hasColumnConverter @columnSchemaSyntax convType+  hasColumnConverter @fromBe convType  -- | Converter for 'TableHasColumn', when given a function to convert backend -- data type to a haskell one.-hasColumnConverter :: forall columnSchemaSyntax-                    . Typeable columnSchemaSyntax-                   => (Sql92ColumnSchemaColumnTypeSyntax columnSchemaSyntax -> Maybe HsDataType)+hasColumnConverter :: forall fromBe+                    . Typeable fromBe+                   => (BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType)                    -> HaskellPredicateConverter hasColumnConverter convType =   hsPredicateConverter $-  \(TableHasColumn tbl col ty :: TableHasColumn columnSchemaSyntax) ->-    fmap SomeDatabasePredicate (TableHasColumn tbl col <$> convType ty :: Maybe (TableHasColumn HsColumnSchema))+  \(TableHasColumn tbl col ty :: TableHasColumn fromBe) ->+    fmap SomeDatabasePredicate (TableHasColumn tbl col <$> convType ty :: Maybe (TableHasColumn HsMigrateBackend))  -- | Some predicates have no dependence on a backend. For example, 'TableExistsPredicate' has no parameters that -- depend on the backend. It can be converted straightforwardly:

@@ -5,9 +5,11 @@ -- | Defines common 'DatabasePredicate's that are shared among backends module Database.Beam.Migrate.Checks where +import Database.Beam.Backend.SQL.SQL92+import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.SQL.Types import Database.Beam.Migrate.Serialization import Database.Beam.Migrate.Types.Predicates-import Database.Beam.Migrate.SQL.SQL92  import Data.Aeson ((.:), (.=), withObject, object) import Data.Aeson.Types (Parser, Value)@@ -15,16 +17,15 @@ import Data.Text (Text) import Data.Typeable (Typeable, cast) #if !MIN_VERSION_base(4, 11, 0)-import           Data.Semigroup+import Data.Semigroup #endif  import GHC.Generics (Generic) - -- * Table checks  -- | Asserts that a table with the given name exists in a database-data TableExistsPredicate = TableExistsPredicate Text {-^ Table name -}+data TableExistsPredicate = TableExistsPredicate QualifiedName {-^ Table name -}   deriving (Show, Eq, Ord, Typeable, Generic) instance Hashable TableExistsPredicate instance DatabasePredicate TableExistsPredicate where@@ -36,27 +37,30 @@    predicateSpecificity _ = PredicateSpecificityAllBackends +-- | A class that can check whether a particular data type is present+-- in a set of preconditions.+class HasDataTypeCreatedCheck dataType where+  dataTypeHasBeenCreated :: dataType -> (forall preCondition. Typeable preCondition => [ preCondition ]) -> Bool+ -- | Asserts that the table specified has a column with the given data type. The -- type paramater @syntax@ should be an instance of 'IsSql92ColumnSchemaSyntax'.-data TableHasColumn syntax where+data TableHasColumn be where   TableHasColumn-    :: Typeable (Sql92ColumnSchemaColumnTypeSyntax syntax)-    => { hasColumn_table  :: Text {-^ Table name -}+    :: ( HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )+    => { hasColumn_table  :: QualifiedName {-^ Table name -}        , hasColumn_column :: Text {-^ Column name -}-       , hasColumn_type   ::  Sql92ColumnSchemaColumnTypeSyntax syntax {-^ Data type -}+       , hasColumn_type   :: BeamMigrateSqlBackendDataTypeSyntax be {-^ Data type -}        }-    -> TableHasColumn syntax-instance Hashable (Sql92ColumnSchemaColumnTypeSyntax syntax) => Hashable (TableHasColumn syntax) where+    -> TableHasColumn be+instance Hashable (BeamMigrateSqlBackendDataTypeSyntax be) => Hashable (TableHasColumn be) where   hashWithSalt salt (TableHasColumn t c s) = hashWithSalt salt (t, c, s)-instance Eq (Sql92ColumnSchemaColumnTypeSyntax syntax) => Eq (TableHasColumn syntax) where+instance Eq (BeamMigrateSqlBackendDataTypeSyntax be) => Eq (TableHasColumn be) where   TableHasColumn aTbl aCol aDt == TableHasColumn bTbl bCol bDt =     aTbl == bTbl && aCol == bCol && aDt == bDt-instance ( Typeable syntax-         , Sql92SerializableDataTypeSyntax (Sql92ColumnSchemaColumnTypeSyntax syntax)-         , Hashable (Sql92ColumnSchemaColumnTypeSyntax syntax)-         , Sql92DisplaySyntax (Sql92ColumnSchemaColumnTypeSyntax syntax)-         , Eq (Sql92ColumnSchemaColumnTypeSyntax syntax) ) =>-  DatabasePredicate (TableHasColumn syntax) where+instance ( Typeable be+         , BeamMigrateOnlySqlBackend be+         , Hashable (BeamMigrateSqlBackendDataTypeSyntax be) ) =>+  DatabasePredicate (TableHasColumn be) where   englishDescription (TableHasColumn tbl col type_) =     "Table " <> show tbl <> " must have a column " <> show col <> " of " <> displaySyntax type_ @@ -72,20 +76,17 @@  -- | Asserts that a particular column of a table has a given constraint. The -- @syntax@ type parameter should be an instance of 'IsSql92ColumnSchemaSyntax'-data TableColumnHasConstraint syntax+data TableColumnHasConstraint be   = TableColumnHasConstraint-  { hasConstraint_table  :: Text {-^ Table name -}+  { hasConstraint_table  :: QualifiedName {-^ Table name -}   , hasConstraint_column :: Text {-^ Column name -}-  , hasConstraint_defn   :: Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax {-^ Constraint definition -}+  , hasConstraint_defn   :: BeamSqlBackendColumnConstraintDefinitionSyntax be {-^ Constraint definition -}   } deriving Generic-instance Hashable (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) => Hashable (TableColumnHasConstraint syntax)-deriving instance Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) => Eq (TableColumnHasConstraint syntax)-instance ( Typeable syntax-         , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)-         , Hashable (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)-         , Sql92DisplaySyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)-         , Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) ) =>-         DatabasePredicate (TableColumnHasConstraint syntax) where+instance Hashable (BeamSqlBackendColumnConstraintDefinitionSyntax be) => Hashable (TableColumnHasConstraint be)+deriving instance Eq (BeamSqlBackendColumnConstraintDefinitionSyntax be) => Eq (TableColumnHasConstraint be)+instance ( Typeable be, BeamMigrateOnlySqlBackend be+         , Hashable (BeamSqlBackendColumnConstraintDefinitionSyntax be) ) =>+         DatabasePredicate (TableColumnHasConstraint be) where   englishDescription (TableColumnHasConstraint tbl col cns) =     "Column " <> show tbl <> "." <> show col <> " has constraint " <> displaySyntax cns @@ -96,14 +97,14 @@    predicateCascadesDropOn (TableColumnHasConstraint tblNm colNm _) p'     | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm-    | Just (TableHasColumn tblNm' colNm' _ :: TableHasColumn syntax) <- cast p' = tblNm' == tblNm && colNm' == colNm+    | Just (TableHasColumn tblNm' colNm' _ :: TableHasColumn be) <- cast p' = tblNm' == tblNm && colNm' == colNm     | otherwise = False  -- | Asserts that the given table has a primary key made of the given columns. -- The order of the columns is significant. data TableHasPrimaryKey   = TableHasPrimaryKey-  { hasPrimaryKey_table :: Text   {-^ Table name -}+  { hasPrimaryKey_table :: QualifiedName   {-^ Table name -}   , hasPrimaryKey_cols  :: [Text] {-^ Column names -}   } deriving (Show, Eq, Generic) instance Hashable TableHasPrimaryKey@@ -125,11 +126,10 @@  -- | 'BeamDeserializers' for all the predicates defined in this module beamCheckDeserializers-  :: forall cmd-   . ( IsSql92DdlCommandSyntax cmd-     , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-     , Sql92SerializableConstraintDefinitionSyntax (Sql92DdlCommandConstraintDefinitionSyntax cmd) )-  => BeamDeserializers cmd+  :: forall be+   . ( Typeable be, BeamMigrateOnlySqlBackend be+     , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )+  => BeamDeserializers be beamCheckDeserializers = mconcat   [ beamDeserializer (const deserializeTableExistsPredicate)   , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate)@@ -149,24 +149,24 @@       (withObject "TableHasPrimaryKey" $ \v' ->        SomeDatabasePredicate <$> (TableHasPrimaryKey <$> v' .: "table" <*> v' .: "columns")) -    deserializeTableHasColumnPredicate :: BeamDeserializers cmd'+    deserializeTableHasColumnPredicate :: BeamDeserializers be'                                        -> Value -> Parser SomeDatabasePredicate     deserializeTableHasColumnPredicate d =       withObject "TableHasColumn" $ \v ->       v .: "has-column" >>=       (withObject "TableHasColumn" $ \v' ->        SomeDatabasePredicate <$>-       fmap (id @(TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd)))+       fmap (id @(TableHasColumn be))          (TableHasColumn <$> v' .: "table" <*> v' .: "column"                          <*> (beamDeserialize d =<< v' .: "type"))) -    deserializeTableColumnHasConstraintPredicate :: BeamDeserializers cmd'+    deserializeTableColumnHasConstraintPredicate :: BeamDeserializers be'                                                  -> Value -> Parser SomeDatabasePredicate     deserializeTableColumnHasConstraintPredicate d =       withObject "TableColumnHasConstraint" $ \v ->       v .: "has-column-constraint" >>=       (withObject "TableColumnHasConstraint" $ \v' ->        SomeDatabasePredicate <$>-       fmap (id @(TableColumnHasConstraint (Sql92DdlCommandColumnSchemaSyntax cmd)))+       fmap (id @(TableColumnHasConstraint be))          (TableColumnHasConstraint <$> v' .: "table" <*> v' .: "column"                                    <*> (beamDeserialize d =<< v' .: "constraint")))

@@ -10,8 +10,8 @@    defaultMigratableDbSettings   -- * Extending the defaulting sytem- , HasDefaultSqlDataType(..), HasDefaultSqlDataTypeConstraints(..)- , Sql92HasDefaultDataType+ , HasDefaultSqlDataType(..)+ , HasNullableConstraint, NullableStatus  ) where  import Database.Beam.Migrate.Types@@ -27,10 +27,10 @@ -- See <http://tathougies.github.io/beam/schema-guide/migrations/ the manual> -- for more information on the defaults. defaultMigratableDbSettings-  :: forall syntax be db.+  :: forall be db.    ( Generic (CheckedDatabaseSettings be db)-   , GAutoMigratableDb syntax (Rep (CheckedDatabaseSettings be db)) )+   , GAutoMigratableDb be (Rep (CheckedDatabaseSettings be db)) )   => CheckedDatabaseSettings be db defaultMigratableDbSettings =-  to (defaultMigratableDbSettings' (Proxy @syntax) :: Rep (CheckedDatabaseSettings be db) ())+  to (defaultMigratableDbSettings' (Proxy @be) :: Rep (CheckedDatabaseSettings be db) ()) 

@@ -5,18 +5,18 @@ module Database.Beam.Migrate.Generics.Tables   ( -- * Field data type defaulting     HasDefaultSqlDataType(..)-  , HasDefaultSqlDataTypeConstraints(..)-  , Sql92HasDefaultDataType    -- * Internal   , GMigratableTableSettings(..)++  , HasNullableConstraint, NullableStatus   ) where  import Database.Beam-import Database.Beam.Backend.SQL.Types-import Database.Beam.Backend.SQL.SQL2003+import Database.Beam.Backend.SQL  import Database.Beam.Migrate.Types.Predicates+import Database.Beam.Migrate.SQL.Types import Database.Beam.Migrate.SQL.SQL92 import Database.Beam.Migrate.Checks @@ -32,51 +32,50 @@  import GHC.Generics -class IsSql92DdlCommandSyntax syntax => GMigratableTableSettings syntax (i :: * -> *) fieldCheck where-  gDefaultTblSettingsChecks :: Proxy syntax -> Proxy i -> Bool -> fieldCheck ()+class BeamMigrateSqlBackend be => GMigratableTableSettings be (i :: * -> *) fieldCheck where+  gDefaultTblSettingsChecks :: Proxy be -> Proxy i -> Bool -> fieldCheck () -instance (IsSql92DdlCommandSyntax syntax, GMigratableTableSettings syntax xId fieldCheckId) =>-  GMigratableTableSettings syntax (M1 t s xId) (M1 t s fieldCheckId) where-  gDefaultTblSettingsChecks syntax Proxy embedded =-    M1 (gDefaultTblSettingsChecks syntax (Proxy @xId) embedded)+instance (BeamMigrateSqlBackend be, GMigratableTableSettings be xId fieldCheckId) =>+  GMigratableTableSettings be (M1 t s xId) (M1 t s fieldCheckId) where+  gDefaultTblSettingsChecks be Proxy embedded =+    M1 (gDefaultTblSettingsChecks be (Proxy @xId) embedded) -instance ( IsSql92DdlCommandSyntax syntax-         , GMigratableTableSettings syntax aId aFieldCheck-         , GMigratableTableSettings syntax bId bFieldCheck ) =>-  GMigratableTableSettings syntax (aId :*: bId) (aFieldCheck :*: bFieldCheck) where-  gDefaultTblSettingsChecks syntax Proxy embedded =-    gDefaultTblSettingsChecks syntax (Proxy @aId) embedded :*:-    gDefaultTblSettingsChecks syntax (Proxy @bId) embedded+instance ( BeamMigrateSqlBackend be+         , GMigratableTableSettings be aId aFieldCheck+         , GMigratableTableSettings be bId bFieldCheck ) =>+  GMigratableTableSettings be (aId :*: bId) (aFieldCheck :*: bFieldCheck) where+  gDefaultTblSettingsChecks be Proxy embedded =+    gDefaultTblSettingsChecks be (Proxy @aId) embedded :*:+    gDefaultTblSettingsChecks be (Proxy @bId) embedded -instance ( HasDefaultSqlDataType (Sql92DdlCommandDataTypeSyntax syntax) haskTy-         , HasDefaultSqlDataTypeConstraints (Sql92DdlCommandColumnSchemaSyntax syntax) haskTy-         , HasNullableConstraint (NullableStatus haskTy) (Sql92DdlCommandColumnSchemaSyntax syntax)+instance ( HasDefaultSqlDataType be haskTy+         , HasNullableConstraint (NullableStatus haskTy) be -         , IsSql92DdlCommandSyntax syntax-         , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax syntax) ) =>-  GMigratableTableSettings syntax (Rec0 haskTy) (Rec0 (Const [FieldCheck] haskTy)) where+         , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+         , Typeable be, BeamMigrateSqlBackend be ) =>+  GMigratableTableSettings be (Rec0 haskTy) (Rec0 (Const [FieldCheck] haskTy)) where    gDefaultTblSettingsChecks _ _ embedded =-    K1 (Const (nullableConstraint (Proxy @(NullableStatus haskTy)) (Proxy @(Sql92DdlCommandColumnSchemaSyntax syntax)) ++-               defaultSqlDataTypeConstraints (Proxy @haskTy) (Proxy @(Sql92DdlCommandColumnSchemaSyntax syntax)) embedded ++-               [ FieldCheck (\tblNm nm -> p (TableHasColumn tblNm nm (defaultSqlDataType (Proxy @haskTy) embedded)-                                              :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax syntax))) ]))+    K1 (Const (nullableConstraint (Proxy @(NullableStatus haskTy)) (Proxy @be) +++               defaultSqlDataTypeConstraints (Proxy @haskTy) (Proxy @be) embedded +++               [ FieldCheck (\tblNm nm -> p (TableHasColumn tblNm nm (defaultSqlDataType (Proxy @haskTy) (Proxy @be) embedded)+                                              :: TableHasColumn be )) ]))  instance ( Generic (embeddedTbl (Const [FieldCheck]))-         , IsSql92DdlCommandSyntax syntax-         , GMigratableTableSettings syntax (Rep (embeddedTbl Identity)) (Rep (embeddedTbl (Const [FieldCheck]))) ) =>-  GMigratableTableSettings syntax (Rec0 (embeddedTbl Identity)) (Rec0 (embeddedTbl (Const [FieldCheck]))) where+         , BeamMigrateSqlBackend be+         , GMigratableTableSettings be (Rep (embeddedTbl Identity)) (Rep (embeddedTbl (Const [FieldCheck]))) ) =>+  GMigratableTableSettings be (Rec0 (embeddedTbl Identity)) (Rec0 (embeddedTbl (Const [FieldCheck]))) where -  gDefaultTblSettingsChecks syntax _ _ =-    K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl Identity))) True))+  gDefaultTblSettingsChecks be _ _ =+    K1 (to (gDefaultTblSettingsChecks be (Proxy :: Proxy (Rep (embeddedTbl Identity))) True))  instance ( Generic (embeddedTbl (Nullable (Const [FieldCheck])))-         , IsSql92DdlCommandSyntax syntax-         , GMigratableTableSettings syntax (Rep (embeddedTbl (Nullable Identity))) (Rep (embeddedTbl (Nullable (Const [FieldCheck])))) ) =>-  GMigratableTableSettings syntax (Rec0 (embeddedTbl (Nullable Identity))) (Rec0 (embeddedTbl (Nullable (Const [FieldCheck])))) where+         , BeamMigrateSqlBackend be+         , GMigratableTableSettings be (Rep (embeddedTbl (Nullable Identity))) (Rep (embeddedTbl (Nullable (Const [FieldCheck])))) ) =>+  GMigratableTableSettings be (Rec0 (embeddedTbl (Nullable Identity))) (Rec0 (embeddedTbl (Nullable (Const [FieldCheck])))) where -  gDefaultTblSettingsChecks syntax _ _ =-    K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl (Nullable Identity)))) True))+  gDefaultTblSettingsChecks be _ _ =+    K1 (to (gDefaultTblSettingsChecks be (Proxy :: Proxy (Rep (embeddedTbl (Nullable Identity)))) True))  -- * Nullability check @@ -84,123 +83,92 @@   NullableStatus (Maybe x) = 'True   NullableStatus x = 'False -class IsSql92ColumnSchemaSyntax syntax => HasNullableConstraint (x :: Bool) syntax where-  nullableConstraint :: Proxy x -> Proxy syntax -> [ FieldCheck ]+class BeamMigrateSqlBackend be => HasNullableConstraint (x :: Bool) be where+  nullableConstraint :: Proxy x -> Proxy be -> [ FieldCheck ] -instance ( IsSql92ColumnSchemaSyntax syntax-         , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax) ) =>-  HasNullableConstraint 'False syntax where+instance ( Typeable be, BeamMigrateSqlBackend be ) =>+  HasNullableConstraint 'False be where   nullableConstraint _ _ =     let c = constraintDefinitionSyntax Nothing notNullConstraintSyntax Nothing-    in [ FieldCheck $ \tblNm colNm -> p (TableColumnHasConstraint tblNm colNm c :: TableColumnHasConstraint syntax) ]-instance IsSql92ColumnSchemaSyntax syntax =>-  HasNullableConstraint 'True syntax where+    in [ FieldCheck $ \tblNm colNm -> p (TableColumnHasConstraint tblNm colNm c :: TableColumnHasConstraint be) ]+instance BeamMigrateSqlBackend be =>+  HasNullableConstraint 'True be where   nullableConstraint _ _ = []  -- * Default data types --- | Certain data types also come along with constraints. For example, @SERIAL@--- types in Postgres generate an automatic @DEFAULT@ constraint.------ You need an instance of this class for any type for which you want beam to be--- able to infer the SQL data type. If your data type does not have any--- constraint requirements, you can just declare an empty instance-class IsSql92ColumnSchemaSyntax columnSchemaSyntax =>-  HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty where--  -- | Provide arbitrary constraints on a field of the requested type. See-  -- 'FieldCheck' for more information on the formatting of constraints.-  defaultSqlDataTypeConstraints-    :: Proxy ty                 -- ^ Concrete representation of the type-    -> Proxy columnSchemaSyntax -- ^ Concrete representation of the syntax-    -> Bool                     -- ^ 'True' if this field is embedded in a-                                --   foreign key, 'False' otherwise. For-                                --   example, @SERIAL@ types in postgres get a-                                --   @DEFAULT@ constraint, but @SERIAL@ types in-                                --   a foreign key do not.-    -> [ FieldCheck ]-  defaultSqlDataTypeConstraints _ _ _ = []- -- | Used to define a default SQL data type for a haskell type in a particular--- data type syntax.+-- backend, as well as any constraints that are needed ----- Beam defines instances for several standard SQL types, which are polymorphic--- over any standard data type syntax. Backends or extensions which provide--- custom types should instantiate instances of this class and--- 'HasDefaultSqlDataTypeConstraints' for any types they provide for which they--- would like checked schema migrations-class IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax ty where+-- Beam defines instances for several standard SQL types, which are+-- polymorphic over any standard data type syntax. Backends or+-- extensions which provide custom types should instantiate instances+-- of this class for any types they provide for which they would like+-- checked schema migrations+class BeamMigrateSqlBackend be => HasDefaultSqlDataType be ty where    -- | Provide a data type for the given type   defaultSqlDataType :: Proxy ty       -- ^ Concrete representation of the type+                     -> Proxy be       -- ^ Concrete representation of the backend                      -> Bool           -- ^ 'True' if this field is in an embedded                                        --   key or table, 'False' otherwise-                     -> dataTypeSyntax+                     -> BeamSqlBackendDataTypeSyntax be -instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) =>-  HasDefaultSqlDataType dataTypeSyntax (Maybe ty) where+  -- | Provide arbitrary constraints on a field of the requested type. See+  -- 'FieldCheck' for more information on the formatting of constraints.+  defaultSqlDataTypeConstraints+    :: Proxy ty -- ^ Concrete representation of the type+    -> Proxy be -- ^ Concrete representation of the backend+    -> Bool     -- ^ 'True' if this field is embedded in a+                --   foreign key, 'False' otherwise. For+                --   example, @SERIAL@ types in postgres get a+                --   @DEFAULT@ constraint, but @SERIAL@ types in+                --   a foreign key do not.+    -> [ FieldCheck ]+  defaultSqlDataTypeConstraints _ _ _ = []++instance (BeamMigrateSqlBackend be, HasDefaultSqlDataType be ty) =>+  HasDefaultSqlDataType be (Maybe ty) where   defaultSqlDataType _ = defaultSqlDataType (Proxy @ty)-instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) =>-  HasDefaultSqlDataTypeConstraints columnSchemaSyntax (Maybe ty) where   defaultSqlDataTypeConstraints _ = defaultSqlDataTypeConstraints (Proxy @ty)  -- TODO Not sure if individual databases will want to customize these types -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int where-  defaultSqlDataType _ _ = intType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int32 where-  defaultSqlDataType _ _ = intType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int32-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int16 where-  defaultSqlDataType _ _ = intType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int16-instance IsSql2008BigIntDataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Int64 where-    defaultSqlDataType _ _ = bigIntType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Int64+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int where+  defaultSqlDataType _ _ _ = intType+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int32 where+  defaultSqlDataType _ _ _ = intType+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int16 where+  defaultSqlDataType _ _ _ = intType+instance ( BeamMigrateSqlBackend be, BeamSqlT071Backend be ) => HasDefaultSqlDataType be Int64 where+    defaultSqlDataType _ _ _ = bigIntType -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word where-  defaultSqlDataType _ _ = numericType (Just (10, Nothing))-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word where+  defaultSqlDataType _ _ _ = numericType (Just (10, Nothing)) -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word16 where-  defaultSqlDataType _ _ = numericType (Just (5, Nothing))-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word16-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word32 where-  defaultSqlDataType _ _ = numericType (Just (10, Nothing))-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word32-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Word64 where-  defaultSqlDataType _ _ = numericType (Just (20, Nothing))-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Word64+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word16 where+  defaultSqlDataType _ _ _ = numericType (Just (5, Nothing))+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word32 where+  defaultSqlDataType _ _ _ = numericType (Just (10, Nothing))+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word64 where+  defaultSqlDataType _ _ _ = numericType (Just (20, Nothing)) -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Text where-  defaultSqlDataType _ _ = varCharType Nothing Nothing-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Text-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax SqlBitString where-  defaultSqlDataType _ _ = varBitType Nothing-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax SqlBitString+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Text where+  defaultSqlDataType _ _ _ = varCharType Nothing Nothing+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be SqlBitString where+  defaultSqlDataType _ _ _ = varBitType Nothing -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Double where-  defaultSqlDataType _ _ = doubleType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Double-instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Scientific where-  defaultSqlDataType _ _ = numericType (Just (20, Just 10))-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Scientific+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Double where+  defaultSqlDataType _ _ _ = doubleType -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Day where-  defaultSqlDataType _ _ = dateType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Day+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Scientific where+  defaultSqlDataType _ _ _ = numericType (Just (20, Just 10)) -instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax TimeOfDay where-  defaultSqlDataType _ _ = timeType Nothing False-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax TimeOfDay+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Day where+  defaultSqlDataType _ _ _ = dateType -instance IsSql99DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Bool where-  defaultSqlDataType _ _ = booleanType-instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Bool+instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be TimeOfDay where+  defaultSqlDataType _ _ _ = timeType Nothing False --- | Constraint synonym to use if you want to assert that a particular--- 'IsSql92Syntax' syntax supports defaulting for a particular data type-type Sql92HasDefaultDataType syntax ty =-  ( HasDefaultSqlDataType (Sql92DdlCommandDataTypeSyntax syntax) ty-  , HasDefaultSqlDataTypeConstraints (Sql92DdlCommandColumnSchemaSyntax syntax) ty )+instance BeamMigrateSql99Backend be => HasDefaultSqlDataType be Bool where+  defaultSqlDataType _ _ _ = booleanType

@@ -1,5 +1,4 @@ {-# LANGUAGE UndecidableInstances #-}- module Database.Beam.Migrate.Generics.Types where  import           Database.Beam.Migrate.Types@@ -9,22 +8,22 @@  import           GHC.Generics -class GAutoMigratableDb syntax x where-  defaultMigratableDbSettings' :: Proxy syntax -> x ()+class GAutoMigratableDb be x where+  defaultMigratableDbSettings' :: Proxy be -> x () -instance GAutoMigratableDb syntax x => GAutoMigratableDb syntax (D1 f x) where-  defaultMigratableDbSettings' syntax = M1 $ defaultMigratableDbSettings' syntax+instance GAutoMigratableDb be x => GAutoMigratableDb be (D1 f x) where+  defaultMigratableDbSettings' be = M1 $ defaultMigratableDbSettings' be -instance GAutoMigratableDb syntax x => GAutoMigratableDb syntax (C1 f x) where-  defaultMigratableDbSettings' syntax = M1 $ defaultMigratableDbSettings' syntax+instance GAutoMigratableDb be x => GAutoMigratableDb be (C1 f x) where+  defaultMigratableDbSettings' be = M1 $ defaultMigratableDbSettings' be -instance (GAutoMigratableDb syntax x, GAutoMigratableDb syntax y) =>-  GAutoMigratableDb syntax (x :*: y) where-  defaultMigratableDbSettings' syntax = defaultMigratableDbSettings' syntax :*: defaultMigratableDbSettings' syntax+instance (GAutoMigratableDb be x, GAutoMigratableDb be y) =>+  GAutoMigratableDb be (x :*: y) where+  defaultMigratableDbSettings' be = defaultMigratableDbSettings' be :*: defaultMigratableDbSettings' be  instance ( Selector f, IsCheckedDatabaseEntity be x-         , CheckedDatabaseEntityDefaultRequirements be x syntax ) =>-  GAutoMigratableDb syntax (S1 f (Rec0 (CheckedDatabaseEntity be db x))) where+         , CheckedDatabaseEntityDefaultRequirements be x ) =>+  GAutoMigratableDb be (S1 f (Rec0 (CheckedDatabaseEntity be db x))) where -  defaultMigratableDbSettings' syntax = M1 (K1 (CheckedDatabaseEntity (checkedDbEntityAuto syntax name) []))+  defaultMigratableDbSettings' _ = M1 (K1 (CheckedDatabaseEntity (checkedDbEntityAuto name) []))     where name = T.pack (selName (undefined :: S1 f (Rec0 (CheckedDatabaseEntity be db x)) ()))

@@ -7,6 +7,7 @@ import Database.Beam.Backend.SQL import Database.Beam.Migrate import Database.Beam.Migrate.Backend+import Database.Beam.Migrate.Types.Predicates (QualifiedName(..))  import Control.Monad (when) @@ -14,6 +15,7 @@ import Data.Text (Text) import Data.Time (LocalTime) import Data.UUID.Types (UUID)+import Data.Maybe (fromMaybe)  data LogEntryT f   = LogEntry@@ -64,25 +66,25 @@  instance Database be BeamMigrateDb -beamMigratableDb :: forall cmd be hdl m-                  . ( Sql92SaneDdlCommandSyntax cmd-                    , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-                    , MonadBeam cmd be hdl m )+beamMigratableDb :: forall be m+                  . ( BeamMigrateSqlBackend be+                    , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+                    , MonadBeam be m )                  => CheckedDatabaseSettings be BeamMigrateDb-beamMigratableDb = runMigrationSilenced $ beamMigrateDbMigration @cmd @be @hdl @m+beamMigratableDb = runMigrationSilenced $ beamMigrateDbMigration @be @m -beamMigrateDb :: forall be cmd hdl m-               . ( Sql92SaneDdlCommandSyntax cmd-                 , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-                 , MonadBeam cmd be hdl m )+beamMigrateDb :: forall be m+               . ( BeamMigrateSqlBackend be+                 , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+                 , MonadBeam be m )                => DatabaseSettings be BeamMigrateDb-beamMigrateDb = unCheckDatabase $ beamMigratableDb @cmd @be @hdl @m+beamMigrateDb = unCheckDatabase $ beamMigratableDb @be @m -beamMigrateDbMigration ::  forall cmd be hdl m-                        . ( Sql92SaneDdlCommandSyntax cmd-                          , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-                          , MonadBeam cmd be hdl m )-                       => Migration cmd (CheckedDatabaseSettings be BeamMigrateDb)+beamMigrateDbMigration ::  forall be m+                        . ( BeamMigrateSqlBackend be+                          , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+                          , MonadBeam be m )+                       => Migration be (CheckedDatabaseSettings be BeamMigrateDb) beamMigrateDbMigration =   BeamMigrateDb <$> createTable "beam_version"                       (BeamMigrateVersion (field "version" int notNull))@@ -93,41 +95,39 @@ beamMigrateSchemaVersion :: Int beamMigrateSchemaVersion = 1 -getLatestLogEntry :: forall be cmd hdl m-                   . ( IsSql92Syntax cmd-                     , HasQBuilder (Sql92SelectSyntax cmd)-                     , Sql92ReasonableMarshaller be-                     , Sql92SanityCheck cmd-                     , Sql92SaneDdlCommandSyntax cmd-                     , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-                     , MonadBeam cmd be hdl m )+getLatestLogEntry :: forall be m+                   . ( BeamMigrateSqlBackend be+                     , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+                     , BeamSqlBackendCanDeserialize be Int+                     , BeamSqlBackendCanDeserialize be LocalTime+                     , BeamSqlBackendSupportsDataType be Text+                     , HasQBuilder be+                     , MonadBeam be m )                   => m (Maybe LogEntry) getLatestLogEntry =   runSelectReturningOne (select $                          limit_ 1 $                          orderBy_ (desc_ . _logEntryId) $-                         all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)))+                         all_ (_beamMigrateLogEntries (beamMigrateDb @be @m))) -updateSchemaToCurrent :: forall be cmd hdl m-                       . ( IsSql92Syntax cmd-                         , Sql92SanityCheck cmd-                         , Sql92ReasonableMarshaller be-                         , Sql92SaneDdlCommandSyntax cmd-                         , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-                         , MonadBeam cmd be hdl m )++updateSchemaToCurrent :: forall be m+                       . ( BeamMigrateSqlBackend be+                         , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+                         , BeamSqlBackendCanSerialize be Text+                         , MonadBeam be m )                       => m () updateSchemaToCurrent =-  runInsert (insert (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m)) (insertValues [BeamMigrateVersion beamMigrateSchemaVersion]))+  runInsert (insert (_beamMigrateVersionTbl (beamMigrateDb @be @m)) (insertValues [BeamMigrateVersion beamMigrateSchemaVersion])) -recordCommit :: forall be cmd hdl m-             . ( IsSql92Syntax cmd-               , Sql92SanityCheck cmd-               , Sql92SaneDdlCommandSyntax cmd-               , HasQBuilder (Sql92SelectSyntax cmd)-               , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)-               , HasSqlValueSyntax (Sql92ValueSyntax cmd) Text-               , Sql92ReasonableMarshaller be-               , MonadBeam cmd be hdl m )+recordCommit :: forall be m+             . ( BeamMigrateSqlBackend be+               , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)+               , BeamSqlBackendSupportsDataType be Text+               , BeamSqlBackendCanDeserialize be Int+               , BeamSqlBackendCanDeserialize be LocalTime+               , HasQBuilder be+               , MonadBeam be m )              => UUID -> m () recordCommit commitId = do   let commitIdTxt = fromString (show commitId)@@ -135,15 +135,16 @@   logEntry <- getLatestLogEntry   let nextLogEntryId = maybe 0 (succ . _logEntryId) logEntry -  runInsert (insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))+  runInsert (insert (_beamMigrateLogEntries (beamMigrateDb @be @m))                     (insertExpressions                      [ LogEntry (val_ nextLogEntryId)                                 (val_ commitIdTxt)                                 currentTimestamp_]))  -- Ensure the backend tables exist-ensureBackendTables :: forall be cmd hdl m-                     . BeamMigrationBackend cmd be hdl m+ensureBackendTables :: forall be m+                     . BeamSqlBackendCanSerialize be Text+                    => BeamMigrationBackend be m                     -> m () ensureBackendTables be@BeamMigrationBackend { backendGetDbConstraints = getCs } =   do backendSchemaBuilt <- checkForBackendTables be@@ -158,7 +159,7 @@       maxVersion <-         runSelectReturningOne $ select $         aggregate_ (\v -> max_ (_beamMigrateVersion v)) $-        all_ (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m))+        all_ (_beamMigrateVersionTbl (beamMigrateDb @be @m))        case maxVersion of         Nothing -> cleanAndCreateSchema@@ -172,25 +173,26 @@      cleanAndCreateSchema = do       cs <- getCs-      let migrationLogExists = any (== p (TableExistsPredicate "beam_migration")) cs+      let migrationLogExists = any (== p (TableExistsPredicate (QualifiedName Nothing "beam_migration"))) cs        when migrationLogExists $ do-        Just totalCnt <-+        totalCnt <-+          fmap (fromMaybe 0) $ -- Should never return 'Nothing', but this prevents an irrefutable pattern match           runSelectReturningOne $ select $           aggregate_ (\_ -> as_ @Int countAll_) $-          all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))+          all_ (_beamMigrateLogEntries (beamMigrateDb @be @m))         when (totalCnt > 0) (fail "beam-migrate: No versioning information, but log entries present")-        runNoReturn (dropTableCmd (dropTableSyntax "beam_migration"))+        runNoReturn (dropTableCmd (dropTableSyntax (tableName Nothing "beam_migration"))) -      runNoReturn (dropTableCmd (dropTableSyntax "beam_version"))+      runNoReturn (dropTableCmd (dropTableSyntax (tableName Nothing "beam_version")))        createSchema      createSchema = do-      _ <- executeMigration doStep (beamMigrateDbMigration @cmd @be @hdl @m)+      _ <- executeMigration doStep (beamMigrateDbMigration @be @m)       updateSchemaToCurrent -checkForBackendTables :: BeamMigrationBackend cmd be hdl m -> m Bool+checkForBackendTables :: BeamMigrationBackend be m -> m Bool checkForBackendTables BeamMigrationBackend { backendGetDbConstraints = getCs } =   do cs <- getCs-     pure (any (== p (TableExistsPredicate "beam_version")) cs)+     pure (any (== p (TableExistsPredicate (QualifiedName Nothing "beam_version"))) cs)

@@ -6,7 +6,7 @@ module Database.Beam.Migrate.SQL.BeamExtensions where  import Database.Beam.Backend.SQL-import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Migrate.SQL.Types import Database.Beam.Migrate.SQL.Tables  import Data.Text (Text)@@ -29,6 +29,6 @@ --   'genericSerial' may appear and may fail at run-time if these conditions --   aren't met. Please refer to the backend of your choice for more --   information.-class IsSql92ColumnSchemaSyntax syntax =>-  IsBeamSerialColumnSchemaSyntax syntax where-  genericSerial :: FieldReturnType 'True 'False syntax (SqlSerial Int) a => Text -> a+class BeamMigrateSqlBackend be =>+  BeamSqlBackendHasSerial be where+  genericSerial :: FieldReturnType 'True 'False be (SqlSerial Int) a => Text -> a

@@ -4,6 +4,7 @@ -- | DDL syntax instances for 'SqlSyntaxBuilder' module Database.Beam.Migrate.SQL.Builder where +import           Database.Beam.Backend.SQL import           Database.Beam.Backend.SQL.Builder import           Database.Beam.Migrate.SQL import           Database.Beam.Migrate.Serialization@@ -36,16 +37,19 @@   dropTableCmd = id  instance IsSql92DropTableSyntax SqlSyntaxBuilder where+  type Sql92DropTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder+   dropTableSyntax tblNm =     SqlSyntaxBuilder $-    byteString "DROP TABLE " <> quoteSql tblNm+    byteString "DROP TABLE " <> buildSql tblNm  instance IsSql92AlterTableSyntax SqlSyntaxBuilder where+  type Sql92AlterTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder   type Sql92AlterTableAlterTableActionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder    alterTableSyntax tblNm action =     SqlSyntaxBuilder $-    byteString "ALTER TABLE " <> quoteSql tblNm <> byteString " " <> buildSql action+    byteString "ALTER TABLE " <> buildSql tblNm <> byteString " " <> buildSql action  instance IsSql92AlterTableActionSyntax SqlSyntaxBuilder where   type Sql92AlterTableAlterColumnActionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder@@ -74,17 +78,18 @@   setNullSyntax = SqlSyntaxBuilder (byteString "DROP NOT NULL")  instance IsSql92CreateTableSyntax SqlSyntaxBuilder where+  type Sql92CreateTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder   type Sql92CreateTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder   type Sql92CreateTableTableConstraintSyntax SqlSyntaxBuilder = SqlSyntaxBuilder   type Sql92CreateTableOptionsSyntax SqlSyntaxBuilder = SqlSyntaxBuilderCreateTableOptions -  createTableSyntax tableOptions tableName fieldSchemas constraints =+  createTableSyntax tableOptions tblName fieldSchemas constraints =       SqlSyntaxBuilder $       byteString "CREATE " <>       maybe mempty (\b -> buildSql b <> byteString " ") beforeOptions <>       byteString " TABLE " <> -      quoteSql tableName <>+      buildSql tblName <>        byteString "(" <>       buildSepBy (byteString ", ")

@@ -24,6 +24,8 @@ -- including equalities between beam-migrate and beam-core types. type Sql92SaneDdlCommandSyntax cmd =   ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd+  , Sql92ExpressionCastTargetSyntax (Sql92ExpressionSyntax cmd) ~+      Sql92DdlCommandDataTypeSyntax cmd   , Sql92ColumnSchemaExpressionSyntax (Sql92DdlCommandColumnSchemaSyntax cmd) ~       Sql92ExpressionSyntax cmd ) @@ -57,13 +59,6 @@ type Sql92DdlCommandAlterTableActionSyntax syntax =   Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax) --- | Type classes for syntaxes which can be displayed-class Sql92DisplaySyntax syntax where--  -- | Render the syntax as a 'String', representing the SQL expression it-  -- stands for-  displaySyntax :: syntax -> String- class ( IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax)       , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax)       , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) =>@@ -77,25 +72,35 @@   alterTableCmd  :: Sql92DdlCommandAlterTableSyntax syntax -> syntax  class ( IsSql92TableConstraintSyntax (Sql92CreateTableTableConstraintSyntax syntax)-      , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax) ) =>+      , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax)+      , IsSql92TableNameSyntax (Sql92CreateTableTableNameSyntax syntax) ) =>     IsSql92CreateTableSyntax syntax where++  type Sql92CreateTableTableNameSyntax syntax :: *   type Sql92CreateTableColumnSchemaSyntax syntax :: *   type Sql92CreateTableTableConstraintSyntax syntax :: *   type Sql92CreateTableOptionsSyntax syntax :: *    createTableSyntax :: Maybe (Sql92CreateTableOptionsSyntax syntax)-                    -> Text+                    -> Sql92CreateTableTableNameSyntax syntax                     -> [ (Text, Sql92CreateTableColumnSchemaSyntax syntax) ]                     -> [ Sql92CreateTableTableConstraintSyntax syntax ]                     -> syntax -class IsSql92DropTableSyntax syntax where-  dropTableSyntax :: Text -> syntax+class IsSql92TableNameSyntax (Sql92DropTableTableNameSyntax syntax) =>+  IsSql92DropTableSyntax syntax where -class IsSql92AlterTableActionSyntax (Sql92AlterTableAlterTableActionSyntax syntax) =>+  type Sql92DropTableTableNameSyntax syntax :: *+  dropTableSyntax :: Sql92DropTableTableNameSyntax syntax -> syntax++class ( IsSql92TableNameSyntax (Sql92AlterTableTableNameSyntax syntax),+        IsSql92AlterTableActionSyntax (Sql92AlterTableAlterTableActionSyntax syntax) ) =>   IsSql92AlterTableSyntax syntax where++  type Sql92AlterTableTableNameSyntax syntax :: *   type Sql92AlterTableAlterTableActionSyntax syntax :: *-  alterTableSyntax :: Text -> Sql92AlterTableAlterTableActionSyntax syntax++  alterTableSyntax :: Sql92AlterTableTableNameSyntax syntax -> Sql92AlterTableAlterTableActionSyntax syntax                    -> syntax  class ( IsSql92ColumnSchemaSyntax (Sql92AlterTableColumnSchemaSyntax syntax)

@@ -20,20 +20,12 @@   , addColumn, dropColumn      -- * Field specification-  , DefaultValue, Constraint(..)+  , DefaultValue, Constraint(..), NotNullConstraint    , field    , defaultTo_, notNull, unique-  , int, smallint, bigint-  , char, varchar, double-  , characterLargeObject, binaryLargeObject, array-  , boolean, numeric, date, time-  , timestamp, timestamptz-  , binary, varbinary -  , maybeType-     -- ** Internal classes     --    Provided without documentation for use in type signatures   , FieldReturnType(..)@@ -42,6 +34,8 @@ import Database.Beam import Database.Beam.Schema.Tables import Database.Beam.Backend.SQL+import Database.Beam.Backend.SQL.AST (TableName(..))+import Database.Beam.Query.Internal (tableNameFromEntity)  import Database.Beam.Migrate.Types import Database.Beam.Migrate.Checks@@ -54,15 +48,13 @@ import Control.Monad.State  import Data.Text (Text)-import Data.Vector (Vector)-import Data.ByteString (ByteString) import Data.Typeable-import Data.Time (LocalTime, TimeOfDay)-import Data.Scientific (Scientific) import qualified Data.Kind as Kind (Constraint)  import GHC.TypeLits +import Lens.Micro ((^.))+ -- * Table manipulation  -- | Add a @CREATE TABLE@ statement to this migration@@ -70,21 +62,21 @@ --   The first argument is the name of the table. -- --   The second argument is a table containing a 'FieldSchema' for each field.---   See documentation on the 'Field' command for more information.+--   See documentation on the 'Field' command for more information.c createTable :: ( Beamable table, Table table-               , IsSql92DdlCommandSyntax syntax ) =>-               Text -> TableSchema (Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax syntax)) table-            -> Migration syntax (CheckedDatabaseEntity be db (TableEntity table))+               , BeamMigrateSqlBackend be )+            => Text -> TableSchema be table+            -> Migration be (CheckedDatabaseEntity be db (TableEntity table)) createTable newTblName tblSettings =   do let pkFields = allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings)          tblConstraints = if null pkFields then [] else [ primaryKeyConstraintSyntax pkFields ]          createTableCommand =-           createTableSyntax Nothing newTblName+           createTableSyntax Nothing (tableName Nothing newTblName)                              (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings)                              tblConstraints          command = createTableCmd createTableCommand -         tbl' = changeBeamRep (\(Columnar' (TableFieldSchema name _ _)) -> Columnar' (TableField name)) tblSettings+         tbl' = changeBeamRep (\(Columnar' (TableFieldSchema name _ _)) -> Columnar' (TableField (pure name) name)) tblSettings           fieldChecks = changeBeamRep (\(Columnar' (TableFieldSchema _ _ cs)) -> Columnar' (Const cs)) tblSettings @@ -97,19 +89,19 @@              cols -> [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableHasPrimaryKey tblName cols)) ]       upDown command Nothing-     pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable newTblName tbl') tblChecks fieldChecks) [])+     pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable Nothing newTblName newTblName tbl') tblChecks fieldChecks) [])  -- | Add a @DROP TABLE@ statement to this migration.-dropTable :: IsSql92DdlCommandSyntax syntax+dropTable :: BeamMigrateSqlBackend be           => CheckedDatabaseEntity be db (TableEntity table)-          -> Migration syntax ()-dropTable (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm _) _ _) _) =-  let command = dropTableCmd (dropTableSyntax tblNm)+          -> Migration be ()+dropTable (CheckedDatabaseEntity (CheckedDatabaseTable dt _ _) _) =+  let command = dropTableCmd (dropTableSyntax (tableNameFromEntity dt))   in upDown command Nothing  -- | Copy a table schema from one database to another preserve :: CheckedDatabaseEntity be db e-         -> Migration syntax (CheckedDatabaseEntity be db' e)+         -> Migration be (CheckedDatabaseEntity be db' e) preserve (CheckedDatabaseEntity desc checks) = pure (CheckedDatabaseEntity desc checks)  -- * Alter table@@ -121,45 +113,46 @@   , columnMigrationFieldChecks :: [FieldCheck] }  -- | Monad representing a series of @ALTER TABLE@ statements-newtype TableMigration syntax a-  = TableMigration (WriterT [Sql92DdlCommandAlterTableSyntax syntax] (State (Text, [TableCheck])) a)+newtype TableMigration be a+  = TableMigration (WriterT [BeamSqlBackendAlterTableSyntax be] (State (TableName, [TableCheck])) a)   deriving (Monad, Applicative, Functor)  -- | @ALTER TABLE ... RENAME TO@ command-renameTableTo :: Sql92SaneDdlCommandSyntax syntax+renameTableTo :: BeamMigrateSqlBackend be               => Text -> table ColumnMigration-              -> TableMigration syntax (table ColumnMigration)+              -> TableMigration be (table ColumnMigration) renameTableTo newName oldTbl = TableMigration $ do-  (curNm, chks) <- get-  tell [ alterTableSyntax curNm (renameTableToSyntax newName) ]-  put (newName, chks)+  (TableName curSchema curNm, chks) <- get+  tell [ alterTableSyntax (tableName curSchema curNm) (renameTableToSyntax newName) ]+  put (TableName curSchema curNm, chks)   return oldTbl  -- | @ALTER TABLE ... RENAME COLUMN ... TO ...@ command-renameColumnTo :: Sql92SaneDdlCommandSyntax syntax+renameColumnTo :: BeamMigrateSqlBackend be                => Text -> ColumnMigration a-               -> TableMigration syntax (ColumnMigration a)+               -> TableMigration be (ColumnMigration a) renameColumnTo newName column = TableMigration $ do-  (curTblNm, _) <- get-  tell [ alterTableSyntax curTblNm+  (TableName curSchema curNm, _) <- get+  tell [ alterTableSyntax (tableName curSchema curNm)            (renameColumnToSyntax (columnMigrationFieldName column) newName) ]   pure column { columnMigrationFieldName = newName }  -- | @ALTER TABLE ... DROP COLUMN ...@ command-dropColumn :: Sql92SaneDdlCommandSyntax syntax-           => ColumnMigration a -> TableMigration syntax ()+dropColumn :: BeamMigrateSqlBackend be+           => ColumnMigration a -> TableMigration be () dropColumn column = TableMigration $ do-  (curTblNm, _)<- get-  tell [ alterTableSyntax curTblNm (dropColumnSyntax (columnMigrationFieldName column)) ]+  (TableName curSchema curNm, _)<- get+  tell [ alterTableSyntax (tableName curSchema curNm)+           (dropColumnSyntax (columnMigrationFieldName column)) ]  -- | @ALTER TABLE ... ADD COLUMN ...@ command-addColumn :: Sql92SaneDdlCommandSyntax syntax-          => TableFieldSchema (Sql92DdlCommandColumnSchemaSyntax syntax) a-          -> TableMigration syntax (ColumnMigration a)+addColumn :: BeamMigrateSqlBackend be+          => TableFieldSchema be a+          -> TableMigration be (ColumnMigration a) addColumn (TableFieldSchema nm (FieldSchema fieldSchemaSyntax) checks) =   TableMigration $-  do (curTblNm, _) <- get-     tell [ alterTableSyntax curTblNm (addColumnSyntax nm fieldSchemaSyntax) ]+  do (TableName curSchema curNm, _) <- get+     tell [ alterTableSyntax (tableName curSchema curNm) (addColumnSyntax nm fieldSchemaSyntax) ]      pure (ColumnMigration nm checks)  -- | Compose a series of @ALTER TABLE@ commands@@ -185,31 +178,39 @@ -- ALTER TABLE "NewTableName" ADD COLUMN "ANewColumn" SMALLINT NOT NULL DEFAULT 0; -- @ ---alterTable :: forall be db db' table table' syntax-            . (Table table', IsSql92DdlCommandSyntax syntax)+alterTable :: forall be db db' table table'+            . (Table table', BeamMigrateSqlBackend be)            => CheckedDatabaseEntity be db (TableEntity table)-           -> (table ColumnMigration -> TableMigration syntax (table' ColumnMigration))-           -> Migration syntax (CheckedDatabaseEntity be db' (TableEntity table'))-alterTable (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm tbl) tblChecks tblFieldChecks) entityChecks) alterColumns =+           -> (table ColumnMigration -> TableMigration be (table' ColumnMigration))+           -> Migration be (CheckedDatabaseEntity be db' (TableEntity table'))+alterTable (CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks tblFieldChecks) entityChecks) alterColumns =  let initialTbl = runIdentity $                   zipBeamFieldsM-                      (\(Columnar' (TableField nm) :: Columnar' (TableField table) x)+                      (\(Columnar' fd :: Columnar' (TableField table) x)                         (Columnar' (Const checks) :: Columnar' (Const [FieldCheck]) x) ->-                         pure (Columnar' (ColumnMigration nm checks)+                         pure (Columnar' (ColumnMigration (fd ^. fieldName) checks)                                :: Columnar' ColumnMigration x))-                      tbl tblFieldChecks+                      (dbTableSettings dt) tblFieldChecks       TableMigration alterColumns' = alterColumns initialTbl-     ((newTbl, cmds), (tblNm', tblChecks')) = runState (runWriterT alterColumns') (tblNm, tblChecks)+     ((newTbl, cmds), (TableName tblSchema' tblNm', tblChecks')) =+       runState (runWriterT alterColumns')+                ( TableName (dbTableSchema dt) (dbTableCurrentName dt)+                , tblChecks )       fieldChecks' = changeBeamRep (\(Columnar' (ColumnMigration _ checks) :: Columnar' ColumnMigration a) ->                                      Columnar' (Const checks) :: Columnar' (Const [FieldCheck]) a)                                   newTbl++     tbl' :: TableSettings table'      tbl' = changeBeamRep (\(Columnar' (ColumnMigration nm _) :: Columnar' ColumnMigration a) ->-                              Columnar' (TableField nm) :: Columnar' (TableField table') a)+                              Columnar' (TableField (pure nm) nm) :: Columnar' (TableField table') a)                           newTbl  in forM_ cmds (\cmd -> upDown (alterTableCmd cmd) Nothing) >>-    pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable tblNm' tbl') tblChecks' fieldChecks') entityChecks)+    pure (CheckedDatabaseEntity (CheckedDatabaseTable+                                  (DatabaseTable tblSchema' (dbTableOrigName dt)+                                     tblNm' tbl')+                                   tblChecks' fieldChecks') entityChecks)  -- * Fields @@ -232,7 +233,7 @@ -- -- instance Table Employee where --    data PrimaryKey Employee f = EmployeeKey (C f Text) (C f Text) deriving Generic---    primaryKey = EmployeeKey <$> _firstName <*> _lastName+--    primaryKey = EmployeeKey \<$\> _firstName \<*\> _lastName -- -- instance Beamable PrimaryKey Employee f --@@ -249,171 +250,85 @@ --                            (field "hiredDate" (maybeType timestamp))) --   return (EmployeeDb employees) -- @-field :: ( IsSql92ColumnSchemaSyntax syntax ) =>-  FieldReturnType 'False 'False syntax resTy a => Text -> DataType (Sql92ColumnSchemaColumnTypeSyntax syntax) resTy -> a+field :: ( BeamMigrateSqlBackend be+         , FieldReturnType 'False 'False be resTy a )+      => Text -> DataType be resTy -> a field name (DataType ty) = field' (Proxy @'False) (Proxy @'False) name ty Nothing Nothing []  -- ** Default values  -- | Represents the default value of a field with a given column schema syntax and type-newtype DefaultValue syntax a = DefaultValue (Sql92ColumnSchemaExpressionSyntax syntax)+newtype DefaultValue be a = DefaultValue (BeamSqlBackendExpressionSyntax be)  -- | Build a 'DefaultValue' from a 'QExpr'. GHC will complain if you supply more -- than one default value.-defaultTo_ :: IsSql92ExpressionSyntax (Sql92ColumnSchemaExpressionSyntax syntax) =>-              (forall s. QExpr (Sql92ColumnSchemaExpressionSyntax syntax) s a)-           -> DefaultValue syntax a+defaultTo_ :: BeamMigrateSqlBackend be+           => (forall s. QExpr be s a)+           -> DefaultValue be a defaultTo_ (QExpr e) =   DefaultValue (e "t")  -- ** Constraints  -- | Represents a constraint in the given column schema syntax-newtype Constraint syntax-  = Constraint (Sql92ColumnConstraintDefinitionConstraintSyntax-                (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax))+newtype Constraint be+  = Constraint (BeamSqlBackendConstraintSyntax be) -newtype NotNullConstraint syntax-  = NotNullConstraint (Constraint syntax)+newtype NotNullConstraint be+  = NotNullConstraint (Constraint be)  -- | The SQL92 @NOT NULL@ constraint-notNull :: IsSql92ColumnSchemaSyntax syntax => NotNullConstraint syntax+notNull :: BeamMigrateSqlBackend be => NotNullConstraint be notNull = NotNullConstraint (Constraint notNullConstraintSyntax)  -- | SQL @UNIQUE@ constraint-unique :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax+unique :: BeamMigrateSqlBackend be => Constraint be unique = Constraint uniqueColumnConstraintSyntax --- ** Data types---- | SQL92 @INTEGER@ data type-int :: (IsSql92DataTypeSyntax syntax, Integral a) => DataType syntax a-int = DataType intType---- | SQL92 @SMALLINT@ data type-smallint :: (IsSql92DataTypeSyntax syntax, Integral a) => DataType syntax a-smallint = DataType smallIntType---- | SQL2008 Optional @BIGINT@ data type-bigint :: (IsSql2008BigIntDataTypeSyntax syntax, Integral a) => DataType syntax a-bigint = DataType bigIntType---- TODO is Integer the right type to use here?--- | SQL2003 Optional @BINARY@ data type-binary :: IsSql2003BinaryAndVarBinaryDataTypeSyntax syntax-       => Maybe Word -> DataType syntax Integer-binary prec = DataType (binaryType prec)---- | SQL2003 Optional @VARBINARY@ data type-varbinary :: IsSql2003BinaryAndVarBinaryDataTypeSyntax syntax-          => Maybe Word -> DataType syntax Integer-varbinary prec = DataType (varBinaryType prec)---- TODO should this be Day or something?--- | SQL92 @DATE@ data type-date :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime-date = DataType dateType---- | SQL92 @CHAR@ data type-char :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax Text-char prec = DataType (charType prec Nothing)---- | SQL92 @VARCHAR@ data type-varchar :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax Text-varchar prec = DataType (varCharType prec Nothing)---- | SQL92 @DOUBLE@ data type-double :: IsSql92DataTypeSyntax syntax => DataType syntax Double-double = DataType doubleType---- | SQL92 @NUMERIC@ data type-numeric :: IsSql92DataTypeSyntax syntax => Maybe (Word, Maybe Word) -> DataType syntax Scientific-numeric x = DataType (numericType x)---- | SQL92 @TIMESTAMP WITH TIME ZONE@ data type-timestamptz :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime-timestamptz = DataType (timestampType Nothing True)---- | SQL92 @TIMESTAMP WITHOUT TIME ZONE@ data type-timestamp :: IsSql92DataTypeSyntax syntax => DataType syntax LocalTime-timestamp = DataType (timestampType Nothing False)---- | SQL92 @TIME@ data type-time :: IsSql92DataTypeSyntax syntax => Maybe Word -> DataType syntax TimeOfDay-time prec = DataType (timeType prec False)---- | SQL99 @BOOLEAN@ data type-boolean :: IsSql99DataTypeSyntax syntax => DataType syntax Bool-boolean = DataType booleanType---- | SQL99 @CLOB@ data type-characterLargeObject :: IsSql99DataTypeSyntax syntax => DataType syntax Text-characterLargeObject = DataType characterLargeObjectType---- | SQL99 @BLOB@ data type-binaryLargeObject :: IsSql99DataTypeSyntax syntax => DataType syntax ByteString-binaryLargeObject = DataType binaryLargeObjectType---- | SQL99 array data types-array :: (Typeable a, IsSql99DataTypeSyntax syntax)-      => DataType syntax a -> Int-      -> DataType syntax (Vector a)-array (DataType ty) sz = DataType (arrayType ty sz)---- | Haskell requires 'DataType's to match exactly. Use this function to convert--- a 'DataType' that expects a concrete value to one expecting a 'Maybe'-maybeType :: DataType syntax a -> DataType syntax (Maybe a)-maybeType (DataType sqlTy) = DataType sqlTy- -- ** 'field' variable arity classes -class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) syntax resTy a | a -> syntax resTy where-  field' :: IsSql92ColumnSchemaSyntax syntax =>-            Proxy defaultGiven -> Proxy collationGiven+class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a | a -> be resTy where+  field' :: BeamMigrateSqlBackend be+         => Proxy defaultGiven -> Proxy collationGiven          -> Text-         -> Sql92ColumnSchemaColumnTypeSyntax syntax-         -> Maybe (Sql92ColumnSchemaExpressionSyntax syntax)-         -> Maybe Text -> [ Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax ]+         -> BeamMigrateSqlBackendDataTypeSyntax be+         -> Maybe (BeamSqlBackendExpressionSyntax be)+         -> Maybe Text -> [ BeamSqlBackendColumnConstraintDefinitionSyntax be ]          -> a -instance FieldReturnType 'True collationGiven syntax resTy a =>-  FieldReturnType 'False collationGiven syntax resTy (DefaultValue syntax resTy -> a) where+instance FieldReturnType 'True collationGiven be resTy a =>+  FieldReturnType 'False collationGiven be resTy (DefaultValue be resTy -> a) where   field' _ collationGiven nm ty _ collation constraints (DefaultValue e) =     field' (Proxy @'True) collationGiven nm ty (Just e) collation constraints -instance FieldReturnType defaultGiven collationGiven syntax resTy a =>-  FieldReturnType defaultGiven collationGiven syntax resTy (Constraint syntax -> a) where+instance FieldReturnType defaultGiven collationGiven be resTy a =>+  FieldReturnType defaultGiven collationGiven be resTy (Constraint be -> a) where   field' defaultGiven collationGiven nm ty default_' collation constraints (Constraint e) =     field' defaultGiven collationGiven nm ty default_' collation (constraints ++ [ constraintDefinitionSyntax Nothing e Nothing ]) -instance ( FieldReturnType defaultGiven collationGiven syntax resTy (Constraint syntax -> a)+instance ( FieldReturnType defaultGiven collationGiven be resTy (Constraint be -> a)          , IsNotNull resTy ) =>-  FieldReturnType defaultGiven collationGiven syntax resTy (NotNullConstraint syntax -> a) where+  FieldReturnType defaultGiven collationGiven be resTy (NotNullConstraint be -> a) where   field' defaultGiven collationGiven nm ty default_' collation constraints (NotNullConstraint c) =     field' defaultGiven collationGiven nm ty default_' collation constraints c -instance ( FieldReturnType 'True collationGiven syntax resTy a+instance ( FieldReturnType 'True collationGiven be resTy a          , TypeError ('Text "Only one DEFAULT clause can be given per 'field' invocation") ) =>-  FieldReturnType 'True collationGiven syntax resTy (DefaultValue syntax resTy -> a) where+  FieldReturnType 'True collationGiven be resTy (DefaultValue be resTy -> a) where    field' = error "Unreachable because of GHC Custom Type Errors" -instance ( FieldReturnType defaultGiven collationGiven syntax resTy a+instance ( FieldReturnType defaultGiven collationGiven be resTy a          , TypeError ('Text "Only one type declaration allowed per 'field' invocation")) =>-  FieldReturnType defaultGiven collationGiven syntax resTy (DataType syntax' x -> a) where+  FieldReturnType defaultGiven collationGiven be resTy (DataType be' x -> a) where   field' = error "Unreachable because of GHC Custom Type Errors" -instance ( Typeable syntax, Typeable (Sql92ColumnSchemaColumnTypeSyntax syntax)-         , Sql92DisplaySyntax (Sql92ColumnSchemaColumnTypeSyntax syntax), Eq (Sql92ColumnSchemaColumnTypeSyntax syntax)-         , Sql92DisplaySyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax), Eq (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)-         , IsSql92ColumnSchemaSyntax syntax-         , Sql92SerializableConstraintDefinitionSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)-         , Sql92SerializableDataTypeSyntax (Sql92ColumnSchemaColumnTypeSyntax syntax) ) =>-  FieldReturnType defaultGiven collationGiven syntax resTy (TableFieldSchema syntax resTy) where+instance ( BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) ) =>+  FieldReturnType defaultGiven collationGiven be resTy (TableFieldSchema be resTy) where   field' _ _ nm ty default_' collation constraints =     TableFieldSchema nm (FieldSchema (columnSchemaSyntax ty default_' constraints collation)) checks-    where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn syntax)) ] ++-                   map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint syntax))) constraints+    where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn be)) ] +++                   map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint be))) constraints  type family IsNotNull (x :: *) :: Kind.Constraint where   IsNotNull (Maybe x) = TypeError ('Text "You used Database.Beam.Migrate.notNull on a column with type" ':$$:

@@ -1,32 +1,80 @@+{-# LANGUAGE ConstraintKinds #-}+ -- | Some common SQL data types module Database.Beam.Migrate.SQL.Types   ( TableSchema, TableFieldSchema(..)-  , FieldSchema(..), DataType(..)+  , FieldSchema(..)++  , BeamMigrateOnlySqlBackend+  , BeamMigrateSqlBackend+  , BeamMigrateSql99Backend+  , BeamSqlBackendConstraintSyntax+  , BeamSqlBackendColumnConstraintDefinitionSyntax+  , BeamMigrateSqlBackendDataTypeSyntax+  , BeamSqlBackendColumnSchemaSyntax+  , BeamSqlBackendAlterTableSyntax+  , BeamSqlBackendMatchTypeSyntax+  , BeamSqlBackendReferentialActionSyntax+  , BeamSqlBackendConstraintAttributesSyntax   ) where  import Database.Beam.Migrate.Types.Predicates import Database.Beam.Migrate.SQL.SQL92+import Database.Beam.Backend.SQL  import Data.Text (Text)+import Data.Typeable (Typeable)  -- | A table schema, produced by 'createTable'-type TableSchema fieldSchemaSyntax tbl =-    tbl (TableFieldSchema fieldSchemaSyntax)+type TableSchema be tbl =+    tbl (TableFieldSchema be)  -- | A schema for a field within a given table-data TableFieldSchema fieldSchemaSyntax a-    = TableFieldSchema Text (FieldSchema fieldSchemaSyntax a) [FieldCheck]+data TableFieldSchema be a+    = TableFieldSchema Text (FieldSchema be a) [FieldCheck]  -- | A schema for a field which hasn't been named yet-newtype FieldSchema syntax a = FieldSchema syntax-  deriving (Show, Eq)+newtype FieldSchema be a = FieldSchema (BeamSqlBackendColumnSchemaSyntax be)+deriving instance BeamMigrateOnlySqlBackend be => Eq (FieldSchema be a) --- | A data type in a given 'IsSql92DataTypeSyntax' which describes a SQL type--- mapping to the Haskell type @a@-newtype DataType syntax a = DataType syntax+class ( Typeable (BeamSqlBackendSyntax be)+      , IsSql92DdlCommandSyntax (BeamSqlBackendSyntax be)+      , Sql92SaneDdlCommandSyntaxMigrateOnly (BeamSqlBackendSyntax be) -instance Sql92DisplaySyntax syntax => Show (DataType syntax a) where-  show (DataType syntax) = "DataType (" ++ displaySyntax syntax ++ ")"+      , Sql92DisplaySyntax (BeamMigrateSqlBackendDataTypeSyntax be)+      , Eq (BeamMigrateSqlBackendDataTypeSyntax be)+      , Typeable (BeamMigrateSqlBackendDataTypeSyntax be)+      , Sql92SerializableDataTypeSyntax (BeamMigrateSqlBackendDataTypeSyntax be) -instance Eq syntax => Eq (DataType syntax a) where-  DataType a == DataType b = a == b+      , Sql92SerializableConstraintDefinitionSyntax (BeamSqlBackendColumnConstraintDefinitionSyntax be)+      , Sql92DisplaySyntax (BeamSqlBackendColumnConstraintDefinitionSyntax be)+      , Eq (BeamSqlBackendColumnConstraintDefinitionSyntax be)++      , Typeable be+      ) => BeamMigrateOnlySqlBackend be++type BeamMigrateSqlBackend be =+    ( BeamMigrateOnlySqlBackend be+    , Sql92SaneDdlCommandSyntax (BeamSqlBackendSyntax be)+    , BeamSqlBackend be )++type BeamMigrateSql99Backend be =+  ( BeamMigrateSqlBackend be+  , IsSql99DataTypeSyntax (BeamSqlBackendDataTypeSyntax be))++type BeamSqlBackendConstraintSyntax be+  = Sql92DdlCommandColumnConstraintSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendColumnConstraintDefinitionSyntax be+  = Sql92DdlCommandConstraintDefinitionSyntax (BeamSqlBackendSyntax be)+type BeamMigrateSqlBackendDataTypeSyntax be+  = Sql92DdlCommandDataTypeSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendColumnSchemaSyntax be+  = Sql92DdlCommandColumnSchemaSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendAlterTableSyntax be+  = Sql92DdlCommandAlterTableSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendMatchTypeSyntax be+  = Sql92DdlCommandMatchTypeSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendReferentialActionSyntax be+  = Sql92DdlCommandReferentialActionSyntax (BeamSqlBackendSyntax be)+type BeamSqlBackendConstraintAttributesSyntax be+  = Sql92DdlCommandConstraintAttributesSyntax (BeamSqlBackendSyntax be)

@@ -33,6 +33,7 @@  import           Database.Beam.Backend.SQL import           Database.Beam.Migrate.SQL.SQL92+import           Database.Beam.Migrate.SQL.Types  import           Control.Applicative import           Control.Monad@@ -231,29 +232,29 @@ -- ** Data types  newtype BeamDeserializer syntax-  = BeamDeserializer (forall cmd. BeamDeserializers cmd -> Value -> Parser syntax)+  = BeamDeserializer (forall be. BeamDeserializers be -> Value -> Parser syntax)  -- | Provides a collection of deserializers from aeson 'Value's for arbitrary -- types. The @cmd@ type parameter is a phantom type parameter. Notionally, all -- deserializers within this 'BeamDeserializers' relate to the @cmd@ syntax.-newtype BeamDeserializers cmd+newtype BeamDeserializers be   = BeamDeserializers   { beamArbitraryDeserializers :: D.DMap BeamDeserializerLabel BeamDeserializer   } -instance Semigroup (BeamDeserializer cmd) where+instance Semigroup (BeamDeserializer be) where   (<>) = mappend -instance Monoid (BeamDeserializer cmd) where+instance Monoid (BeamDeserializer be) where   mempty = BeamDeserializer (const (const mzero))   mappend (BeamDeserializer a) (BeamDeserializer b) =     BeamDeserializer $ \d o ->     a d o <|> b d o -instance Semigroup (BeamDeserializers cmd) where+instance Semigroup (BeamDeserializers be) where   (<>) = mappend -instance Monoid (BeamDeserializers cmd) where+instance Monoid (BeamDeserializers be) where   mempty = BeamDeserializers mempty   mappend (BeamDeserializers a) (BeamDeserializers b) =     BeamDeserializers (D.unionWithKey (const mappend) a b)@@ -266,7 +267,7 @@ -- @ -- beamDeserializeMaybe :: Typeable a-                     => BeamDeserializers cmd+                     => BeamDeserializers be                      -> Maybe Value                      -> Parser (Maybe a) beamDeserializeMaybe _ Nothing = pure Nothing@@ -274,8 +275,8 @@   Just <$> beamDeserialize d v  -- | Deserialize the requested type from the given deserializers and aeson 'Value'.-beamDeserialize :: forall a cmd. Typeable a-                => BeamDeserializers cmd -> Value+beamDeserialize :: forall a be. Typeable a+                => BeamDeserializers be -> Value                 -> Parser a beamDeserialize allD@(BeamDeserializers d) v =   case D.lookup (BeamDeserializerLabel :: BeamDeserializerLabel a) d of@@ -303,15 +304,15 @@           EQ -> error "Impossible"  beamDeserializer :: Typeable ty-                 => (forall cmd'. BeamDeserializers cmd' -> Value -> Parser ty)-                 -> BeamDeserializers cmd+                 => (forall be'. BeamDeserializers be' -> Value -> Parser ty)+                 -> BeamDeserializers be beamDeserializer parse =   BeamDeserializers (D.singleton BeamDeserializerLabel (BeamDeserializer parse))  -- | Deserializers for SQL92 syntaxes-sql92Deserializers :: forall cmd-                    . IsSql92DdlCommandSyntax cmd-                   => BeamDeserializers cmd+sql92Deserializers :: forall be+                    . BeamMigrateSqlBackend be+                   => BeamDeserializers be sql92Deserializers = mconcat                    [ beamDeserializer deserializeSql92DataType                    , beamDeserializer deserializeSql92ConstraintDefinition@@ -323,8 +324,8 @@     parseSub nm o key parse =       withObject (unpack (nm <> "." <> key)) parse =<< o .: key -    deserializeSql92DataType :: BeamDeserializers cmd' -> Value-                             -> Parser (Sql92DdlCommandDataTypeSyntax cmd)+    deserializeSql92DataType :: BeamDeserializers be' -> Value+                             -> Parser (BeamSqlBackendDataTypeSyntax be)     deserializeSql92DataType _ o =       deserializeSql92DataTypeObject o <|>       deserializeSql92DataTypeScalar o@@ -368,16 +369,16 @@                 ((,Nothing) <$> o .: "prec")) <|>       pure Nothing -    deserializeSql92ConstraintDefinition :: BeamDeserializers cmd' -> Value-                                         -> Parser (Sql92DdlCommandConstraintDefinitionSyntax cmd)+    deserializeSql92ConstraintDefinition :: BeamDeserializers be' -> Value+                                         -> Parser (BeamSqlBackendColumnConstraintDefinitionSyntax be)     deserializeSql92ConstraintDefinition d =       withObject "Sql92ColumnConstraintDefinition" $ \o ->       constraintDefinitionSyntax <$> o .: "name"                                  <*> (beamDeserialize d =<< o .: "constraint")                                  <*> (beamDeserializeMaybe d =<< o .: "attributes") -    deserializeSql92Constraint :: BeamDeserializers cmd' -> Value-                               -> Parser (Sql92DdlCommandColumnConstraintSyntax cmd)+    deserializeSql92Constraint :: BeamDeserializers be' -> Value+                               -> Parser (BeamSqlBackendConstraintSyntax be)     deserializeSql92Constraint d o =       case o of         "not-null" -> pure notNullConstraintSyntax@@ -393,16 +394,16 @@                                             <*> (beamDeserializeMaybe d =<< v' .: "on-update")                                             <*> (beamDeserializeMaybe d =<< v' .: "on-delete")) -    deserializeSql92MatchType :: BeamDeserializers cmd' -> Value-                              -> Parser (Sql92DdlCommandMatchTypeSyntax cmd)+    deserializeSql92MatchType :: BeamDeserializers be' -> Value+                              -> Parser (BeamSqlBackendMatchTypeSyntax be)     deserializeSql92MatchType _ v =       case v of         "full" -> pure fullMatchSyntax         "partial" -> pure partialMatchSyntax         _ -> mzero -    deserializeSql92ReferentialAction :: BeamDeserializers cmd' -> Value-                                      -> Parser (Sql92DdlCommandReferentialActionSyntax cmd)+    deserializeSql92ReferentialAction :: BeamDeserializers be' -> Value+                                      -> Parser (BeamSqlBackendReferentialActionSyntax be)     deserializeSql92ReferentialAction _ v =       case v of         "cascade" -> pure referentialActionCascadeSyntax@@ -411,8 +412,8 @@         "nothing" -> pure referentialActionNoActionSyntax         _ -> mzero -    deserializeSql92Attributes :: BeamDeserializers cmd' -> Value-                               -> Parser (Sql92DdlCommandConstraintAttributesSyntax cmd)+    deserializeSql92Attributes :: BeamDeserializers be' -> Value+                               -> Parser (BeamSqlBackendConstraintAttributesSyntax be)     deserializeSql92Attributes _ =       withArray "Sql92Attributes" $ \a ->       pure (foldr (\o accum ->@@ -426,13 +427,12 @@  -- | Deserializes data types that are instances of 'IsSql99DataTypeSyntax' sql99DataTypeDeserializers-  :: forall cmd-   . ( IsSql92DdlCommandSyntax cmd-     , IsSql99DataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-  => BeamDeserializers cmd+  :: forall be+   . BeamMigrateSql99Backend be+  => BeamDeserializers be sql99DataTypeDeserializers =   beamDeserializer $ \d v ->-  fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+  fmap (id @(BeamSqlBackendDataTypeSyntax be)) $   case v of     "clob" -> pure characterLargeObjectType     "blob" -> pure binaryLargeObjectType@@ -449,13 +449,12 @@  -- | Deserialize data types that are instances of 'IsSql2003BinaryAndVarBinaryDataTypeSyntax' sql2003BinaryAndVarBinaryDataTypeDeserializers-  :: forall cmd-   . ( IsSql92DdlCommandSyntax cmd-     , IsSql2003BinaryAndVarBinaryDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-  => BeamDeserializers cmd+  :: forall be+   . ( BeamMigrateSqlBackend be, BeamSqlT021Backend be )+  => BeamDeserializers be sql2003BinaryAndVarBinaryDataTypeDeserializers =   beamDeserializer $ \_ v ->-  fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+  fmap (id @(BeamSqlBackendDataTypeSyntax be)) $   withObject "Sql2003DataType"     (\o -> (binaryType <$> o .: "binary") <|>            (varBinaryType <$> o .: "varbinary"))@@ -463,13 +462,12 @@  -- | Deserialize data types that are instance of 'IsSql2008BigIntDataTypeSyntax' sql2008BigIntDataTypeDeserializers-  :: forall cmd-   . ( IsSql92DdlCommandSyntax cmd-     , IsSql2008BigIntDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )-  => BeamDeserializers cmd+  :: forall be+   . ( BeamMigrateSqlBackend be, BeamSqlT071Backend be )+  => BeamDeserializers be sql2008BigIntDataTypeDeserializers =   beamDeserializer $ \_ v ->-  fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $+  fmap (id @(BeamSqlBackendDataTypeSyntax be)) $   case v of     "bigint" -> pure bigIntType     _ -> fail "Sql2008DataType.bigint: expected 'bigint'"

@@ -24,12 +24,14 @@ import           Prelude hiding (log)  import           Database.Beam-import           Database.Beam.Backend.SQL-import           Database.Beam.Migrate.Backend-import           Database.Beam.Migrate.Types+import           Database.Beam.Backend+import           Database.Beam.Haskell.Syntax import           Database.Beam.Migrate.Actions+import           Database.Beam.Migrate.Backend+import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck) import           Database.Beam.Migrate.Log-import           Database.Beam.Haskell.Syntax+import           Database.Beam.Migrate.SQL (BeamMigrateSqlBackendDataTypeSyntax)+import           Database.Beam.Migrate.Types  import           Control.Monad.Cont import           Control.Monad.Writer@@ -91,9 +93,10 @@ -- -- Tries to bring the database up to date, using the database log and the given -- 'MigrationSteps'. Fails if the migration is irreversible, or an error occurs.-bringUpToDate :: Database be db-              => BeamMigrationBackend cmd be hdl m-              -> MigrationSteps cmd () (CheckedDatabaseSettings be db)+bringUpToDate :: ( Database be db+                 , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )+              => BeamMigrationBackend be m+              -> MigrationSteps be () (CheckedDatabaseSettings be db)               -> m (Maybe (CheckedDatabaseSettings be db)) bringUpToDate be@BeamMigrationBackend {} =   bringUpToDateWithHooks defaultUpToDateHooks be@@ -105,18 +108,19 @@ -- Accepts a set of hooks that can be used to customize behavior. See the -- documentation for 'BringUpToDateHooks' for more information. Calling this -- with 'defaultUpToDateHooks' is the same as using 'bringUpToDate'.-bringUpToDateWithHooks :: forall db cmd be hdl m-                        . Database be db+bringUpToDateWithHooks :: forall db be m+                        . ( Database be db+                          , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )                        => BringUpToDateHooks m-                       -> BeamMigrationBackend cmd be hdl m-                       -> MigrationSteps cmd () (CheckedDatabaseSettings be db)+                       -> BeamMigrationBackend be m+                       -> MigrationSteps be () (CheckedDatabaseSettings be db)                        -> m (Maybe (CheckedDatabaseSettings be db)) bringUpToDateWithHooks hooks be@(BeamMigrationBackend { backendRenderSyntax = renderSyntax' }) steps = do   ensureBackendTables be    entries <- runSelectReturningList $ select $-             all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))-  let verifyMigration :: Int -> T.Text -> Migration cmd a -> StateT [LogEntry] (WriterT (Max Int) m) a+             all_ (_beamMigrateLogEntries (beamMigrateDb @be @m))+  let verifyMigration :: Int -> T.Text -> Migration be a -> StateT [LogEntry] (WriterT (Max Int) m) a       verifyMigration stepIx stepNm step =         do log <- get            case log of@@ -161,7 +165,7 @@                          runNoReturn cmd)                      step -                 runInsert $ insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) $+                 runInsert $ insert (_beamMigrateLogEntries (beamMigrateDb @be @m)) $                    insertExpressions [ LogEntry (val_ stepIx) (val_ stepName) currentTimestamp_ ]                  endStepHook hooks stepIx stepName @@ -173,9 +177,9 @@ -- you have chosen the wrong 'ActionProvider', or the backend you're using is -- buggy. simpleSchema :: Database be db-             => ActionProvider cmd+             => ActionProvider be              -> CheckedDatabaseSettings be db-             -> Maybe [cmd]+             -> Maybe [BeamSqlBackendSyntax be] simpleSchema provider settings =   let allChecks = collectChecks settings       solver    = heuristicSolver provider [] allChecks@@ -188,7 +192,7 @@ -- -- May 'fail' if we cannot find a schema createSchema :: Database be db-             => BeamMigrationBackend cmd be hdl m+             => BeamMigrationBackend be m              -> CheckedDatabaseSettings be db              -> m () createSchema BeamMigrationBackend { backendActionProvider = actions } db =@@ -202,7 +206,7 @@ -- 'fail') if this involves an irreversible migration (one that may result in -- data loss). autoMigrate :: Database be db-            => BeamMigrationBackend cmd be hdl m+            => BeamMigrationBackend be m             -> CheckedDatabaseSettings be db             -> m () autoMigrate BeamMigrationBackend { backendActionProvider = actions@@ -224,15 +228,16 @@ -- -- 'BeamMigrationBackend's can usually be found in a module named -- @Database.Beam.<Backend>.Migrate@ with the name@migrationBackend@-simpleMigration :: ( MonadBeam cmd be handle m+simpleMigration :: ( MonadBeam be m                  ,   Database be db )-                => BeamMigrationBackend cmd be handle m+                => (forall a. handle -> m a -> IO a)+                -> BeamMigrationBackend be m                 -> handle                 -> CheckedDatabaseSettings be db-                -> IO (Maybe [cmd])-simpleMigration BeamMigrationBackend { backendGetDbConstraints = getCs-                                     , backendActionProvider = action } hdl db = do-  pre <- withDatabase hdl getCs+                -> IO (Maybe [BeamSqlBackendSyntax be])+simpleMigration runner BeamMigrationBackend { backendGetDbConstraints = getCs+                                            , backendActionProvider = action } hdl db = do+  pre <- runner hdl getCs    let post = collectChecks db       solver = heuristicSolver action pre post@@ -250,8 +255,8 @@ -- | Verify that the given, beam database matches the actual -- schema. On success, returns 'VerificationSucceeded', on failure, -- returns 'VerificationFailed' and a list of missing predicates.-verifySchema :: ( Database be db, MonadBeam cmd be handle m )-             => BeamMigrationBackend cmd be handle m+verifySchema :: ( Database be db, MonadBeam be m )+             => BeamMigrationBackend be m              -> CheckedDatabaseSettings be db              -> m VerificationResult verifySchema BeamMigrationBackend { backendGetDbConstraints = getConstraints } db =@@ -263,16 +268,19 @@        else pure (VerificationFailed (HS.toList missingPredicates))  -- | Run a sequence of commands on a database-runSimpleMigration :: forall cmd be hdl m . MonadBeam cmd be hdl m-                   => hdl -> [cmd] -> IO ()-runSimpleMigration hdl =-  withDatabase @cmd @be @hdl @m hdl . mapM_ runNoReturn +runSimpleMigration :: MonadBeam be m+                   => (forall a. hdl -> m a -> IO a)+                   -> hdl -> [BeamSqlBackendSyntax be] -> IO ()+runSimpleMigration runner hdl =+  runner hdl . mapM_ runNoReturn+ -- | Given a function to convert a command to a 'String', produce a script that -- will execute the given migration. Usually, the function you provide -- eventually calls 'displaySyntax' to rendere the command.-backendMigrationScript :: (cmd -> String)-                       -> Migration cmd a+backendMigrationScript :: BeamSqlBackend be+                       => (BeamSqlBackendSyntax be -> String)+                       -> Migration be a                        -> String backendMigrationScript render mig =   migrateScript ((++"\n") . T.unpack) ((++"\n") . render) (migrationStep "Migration Script" (\() -> mig))@@ -293,15 +301,15 @@ -- -- Backends that have a migration backend typically export it under the module -- name @Database.Beam./Backend/.Migrate@.-haskellSchema :: MonadBeam cmd be hdl m-              => BeamMigrationBackend cmd be handle m+haskellSchema :: MonadBeam be m+              => BeamMigrationBackend be m               -> m String haskellSchema BeamMigrationBackend { backendGetDbConstraints = getCs                                    , backendConvertToHaskell = HaskellPredicateConverter conv2Hs } = do   constraints <- getCs   let hsConstraints = [ hsConstraint | c <- constraints, Just hsConstraint <- [ conv2Hs c ] ] -      solver = heuristicSolver (defaultActionProvider @HsAction) [] hsConstraints+      solver = heuristicSolver (defaultActionProvider @HsMigrateBackend) [] hsConstraints    case finalSolution solver of     Solved cmds   ->

@@ -13,6 +13,7 @@   , CheckedDatabaseEntity(..)    , unCheckDatabase, collectChecks+  , renameCheckedEntity      -- ** Modifyinging checked entities     --@@ -27,6 +28,7 @@   , DatabasePredicate(..)   , SomeDatabasePredicate(..)   , PredicateSpecificity(..)+  , QualifiedName(..)    , p @@ -46,9 +48,9 @@    , 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)@@ -61,27 +63,29 @@ -- * Migration types  -- | Represents a particular step in a migration-data MigrationStep syntax next where-    MigrationStep :: Text -> Migration syntax a -> (a -> next) -> MigrationStep syntax next-deriving instance Functor (MigrationStep syntax)+data MigrationStep be next where+    MigrationStep :: Text -> Migration be a -> (a -> next) -> MigrationStep be next+deriving instance Functor (MigrationStep be)  -- | A series of 'MigrationStep's that take a database from the schema in @from@ -- to the one in @to@. Use the 'migrationStep' function and the arrow interface -- to sequence 'MigrationSteps'.-newtype MigrationSteps syntax from to = MigrationSteps (Kleisli (F (MigrationStep syntax)) from to)+newtype MigrationSteps be from to = MigrationSteps (Kleisli (F (MigrationStep be)) from to)   deriving (Category, Arrow)  -- | Free monadic function for 'Migration's-data MigrationF syntax next where+data MigrationF be next where   MigrationRunCommand-    :: { _migrationUpCommand   :: syntax {-^ What to execute when applying the migration -}-       , _migrationDownCommand :: Maybe syntax {-^ What to execute when unapplying the migration -}+    :: { _migrationUpCommand   :: BeamSqlBackendSyntax be+       -- ^ What to execute when applying the migration+       , _migrationDownCommand :: Maybe (BeamSqlBackendSyntax be)+       -- ^ What to execute when unapplying the migration        , _migrationNext :: next }-    -> MigrationF syntax next-deriving instance Functor (MigrationF syntax)+    -> MigrationF be next+deriving instance Functor (MigrationF be)  -- | A sequence of potentially reversible schema update commands-type Migration syntax = F (MigrationF syntax)+type Migration be = F (MigrationF be)  -- | Information on whether a 'MigrationCommand' loses data. You can -- monoidally combine these to get the potential data loss for a@@ -102,21 +106,22 @@     mappend _ MigrationLosesData = MigrationLosesData     mappend MigrationKeepsData MigrationKeepsData = MigrationKeepsData --- | A migration command along with metadata on wheth-data MigrationCommand cmd+-- | A migration command along with metadata on whether the command can lose data+data MigrationCommand be   = MigrationCommand-  { migrationCommand :: cmd+  { migrationCommand :: BeamSqlBackendSyntax be     -- ^ The command to run   , migrationCommandDataLossPossible :: MigrationDataLoss     -- ^ Information on whether the migration loses data-  } deriving Show+  }+deriving instance Show (BeamSqlBackendSyntax be) => Show (MigrationCommand be)  -- | Run the migration steps between the given indices, using a custom execution function. runMigrationSteps :: Monad m                   => Int -- ^ Zero-based index of the first step to run                   -> Maybe Int -- ^ Index of the last step to run, or 'Nothing' to run every step-                  -> MigrationSteps syntax () a -- ^ The set of steps to run-                  -> (forall a'. Int -> Text -> Migration syntax a' -> m a')+                  -> MigrationSteps be () a -- ^ The set of steps to run+                  -> (forall a'. Int -> Text -> Migration be a' -> m a')                   -- ^ Callback for each step. Called with the step index, the                   -- step description and the migration.                   -> m a@@ -129,34 +134,34 @@           else next (runMigrationSilenced doStep) (i + 1)  -- | Get the result of a migration, without running any steps-runMigrationSilenced :: Migration syntax a -> a+runMigrationSilenced :: Migration be a -> a runMigrationSilenced m = runF m id step   where     step (MigrationRunCommand _ _ next) = next  -- | Remove the explicit source and destination schemas from a 'MigrationSteps' object-eraseMigrationType :: a -> MigrationSteps syntax a a' -> MigrationSteps syntax () ()+eraseMigrationType :: a -> MigrationSteps be a a' -> MigrationSteps be () () eraseMigrationType a (MigrationSteps steps) = MigrationSteps (arr (const a) >>> steps >>> arr (const ()))  -- | Create a 'MigrationSteps' from the given description and migration function.-migrationStep :: Text -> (a -> Migration syntax a') -> MigrationSteps syntax a a'+migrationStep :: Text -> (a -> Migration be a') -> MigrationSteps be a a' migrationStep stepName migration =     MigrationSteps (Kleisli (\a -> liftF (MigrationStep stepName (migration a) id)))  -- | Given a command in the forward direction, and an optional one in the -- reverse direction, construct a 'Migration' that performs the given -- command. Multiple commands can be sequenced monadically.-upDown :: syntax -> Maybe syntax -> Migration syntax ()+upDown :: BeamSqlBackendSyntax be -> Maybe (BeamSqlBackendSyntax be) -> Migration be () upDown up down = liftF (MigrationRunCommand up down ())  -- | Given functions to render a migration step description and the underlying -- syntax, create a script for the given 'MigrationSteps'.-migrateScript :: forall syntax m a. (Monoid m, Semigroup m)+migrateScript :: forall be m a. (Monoid m, Semigroup m, BeamSqlBackend be)               => (Text -> m)               -- ^ Called at the beginning of each 'MigrationStep' with the step description-              -> (syntax -> m)+              -> (BeamSqlBackendSyntax be -> m)               -- ^ Called for each command in the migration step-              -> MigrationSteps syntax () a+              -> MigrationSteps be () a               -- ^ The set of steps to run               -> m migrateScript renderMigrationHeader renderMigrationSyntax (MigrationSteps steps) =@@ -165,21 +170,21 @@        let (res, script) = renderMigration migration mempty        in next res (x <> renderMigrationHeader header <> script)) mempty   where-    renderMigration :: forall a'. Migration syntax a' -> m -> (a', m)+    renderMigration :: forall a'. Migration be a' -> m -> (a', m)     renderMigration migrationSteps =       runF migrationSteps (,)            (\(MigrationRunCommand a _ next) x -> next (x <> renderMigrationSyntax a))  -- | Execute a given migration, provided a command to execute arbitrary syntax. --   You usually use this with 'runNoReturn'.-executeMigration :: Applicative m => (syntax -> m ()) -> Migration syntax a -> m a+executeMigration :: Applicative m => (BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a executeMigration runSyntax go = runF go pure doStep   where     doStep (MigrationRunCommand cmd _ next) =       runSyntax cmd *> next  -- | Given a migration, get the potential data loss, if it's run top-down-migrationDataLoss :: Migration syntax a -> MigrationDataLoss+migrationDataLoss :: Migration be a -> MigrationDataLoss migrationDataLoss go = runF go (\_ -> MigrationKeepsData)                          (\(MigrationRunCommand _ x next) ->                             case x of@@ -188,16 +193,16 @@  -- | Run a 'MigrationSteps' without executing any of the commands against a -- database.-evaluateDatabase :: forall syntax a. MigrationSteps syntax () a -> a+evaluateDatabase :: forall be a. MigrationSteps be () a -> a evaluateDatabase (MigrationSteps f) = runF (runKleisli f ()) id (\(MigrationStep _ migration next) -> next (runMigration migration))   where-    runMigration :: forall a'. Migration syntax a' -> a'+    runMigration :: forall a'. Migration be a' -> a'     runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next)  -- | Collect the names of all steps in hte given 'MigrationSteps'-stepNames :: forall syntax a. MigrationSteps syntax () a -> [Text]+stepNames :: forall be a. MigrationSteps be () a -> [Text] stepNames (MigrationSteps f) = runF (runKleisli f ()) (\_ x -> x) (\(MigrationStep nm migration next) x -> next (runMigration migration) (x ++ [nm])) []   where-    runMigration :: forall a'. Migration syntax a' -> a'+    runMigration :: forall a'. Migration be a' -> a'     runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next) 

@@ -4,12 +4,12 @@ module Database.Beam.Migrate.Types.CheckedEntities where  import Database.Beam+import Database.Beam.Backend.SQL import Database.Beam.Schema.Tables -import Database.Beam.Migrate.Types.Predicates-import Database.Beam.Migrate.Generics.Tables-import Database.Beam.Migrate.SQL.SQL92 import Database.Beam.Migrate.Checks+import Database.Beam.Migrate.Generics.Tables+import Database.Beam.Migrate.Types.Predicates  import Control.Applicative import Control.Monad.Writer@@ -22,6 +22,8 @@ import GHC.Types import GHC.Generics +import Lens.Micro (Lens', (&), (^.), (.~), (%~))+ -- * Checked Database Entities  -- | Like 'IsDatabaseEntity' in @beam-core@, but for entities against which we@@ -35,18 +37,22 @@   data CheckedDatabaseEntityDescriptor be entity :: *    -- | Like 'DatabaseEntityDefaultRequirements' but for checked entities-  type CheckedDatabaseEntityDefaultRequirements be entity syntax :: Constraint+  type CheckedDatabaseEntityDefaultRequirements be entity :: Constraint -  -- | Produce the corresponding 'DatabaseEntityDescriptior'+  -- | Produce the corresponding 'DatabaseEntityDescriptor'   unCheck :: CheckedDatabaseEntityDescriptor be entity -> DatabaseEntityDescriptor be entity+  unCheck d = d ^. unChecked +  -- | A lens to access the internal unchecked descriptor+  unChecked :: Lens' (CheckedDatabaseEntityDescriptor be entity) (DatabaseEntityDescriptor be entity)+   -- | Produce the set of 'DatabasePredicate's that apply to this entity   collectEntityChecks :: CheckedDatabaseEntityDescriptor be entity -> [ SomeDatabasePredicate ]    -- | Like 'dbEntityAuto' but for checked databases. Most often, this wraps   -- 'dbEntityAuto' and provides some means to generate 'DatabasePredicate's-  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements be entity syntax-                      => Proxy syntax -> Text -> CheckedDatabaseEntityDescriptor be entity+  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements be entity+                      => Text -> CheckedDatabaseEntityDescriptor be entity  -- | Like 'DatabaseEntity' but for checked databases data CheckedDatabaseEntity be (db :: (* -> *) -> *) entityType where@@ -61,6 +67,10 @@ -- predicates. type CheckedDatabaseSettings be db = db (CheckedDatabaseEntity be db) +renameCheckedEntity :: (Text -> Text) -> EntityModification (CheckedDatabaseEntity be db) be ent+renameCheckedEntity renamer =+  EntityModification (Endo (\(CheckedDatabaseEntity desc checks) -> (CheckedDatabaseEntity (desc & unChecked . dbEntityName %~ renamer) checks)))+ -- | Convert a 'CheckedDatabaseSettings' to a regular 'DatabaseSettings'. The -- return value is suitable for use in any regular beam query or DML statement. unCheckDatabase :: forall be db. Database be db => CheckedDatabaseSettings be db -> DatabaseSettings be db@@ -82,13 +92,13 @@   data CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty) =     CheckedDatabaseDomainType (DatabaseEntityDescriptor be (DomainTypeEntity ty))                               [ DomainCheck ]-  type CheckedDatabaseEntityDefaultRequirements be (DomainTypeEntity ty) syntax =+  type CheckedDatabaseEntityDefaultRequirements be (DomainTypeEntity ty) =     DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) -  unCheck (CheckedDatabaseDomainType x _) = x-  collectEntityChecks (CheckedDatabaseDomainType (DatabaseDomainType domName) domainChecks) =-    map (\(DomainCheck mkCheck) -> mkCheck domName) domainChecks-  checkedDbEntityAuto _ domTypeName =+  unChecked f (CheckedDatabaseDomainType x cks) = fmap (\x' -> CheckedDatabaseDomainType x' cks) (f x)+  collectEntityChecks (CheckedDatabaseDomainType dt domainChecks) =+    map (\(DomainCheck mkCheck) -> mkCheck (qname dt)) domainChecks+  checkedDbEntityAuto domTypeName =     CheckedDatabaseDomainType (dbEntityAuto domTypeName) []  instance Beamable tbl => IsCheckedDatabaseEntity be (TableEntity tbl) where@@ -99,29 +109,28 @@                          -> tbl (Const [FieldCheck])                          -> CheckedDatabaseEntityDescriptor be (TableEntity tbl) -  type CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl) syntax =+  type CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl)  =     ( DatabaseEntityDefaultRequirements be (TableEntity tbl)     , Generic (tbl (Const [FieldCheck]))-    , GMigratableTableSettings syntax (Rep (tbl Identity)) (Rep (tbl (Const [FieldCheck])))-    , IsSql92DdlCommandSyntax syntax )--  unCheck (CheckedDatabaseTable x _ _) = x+    , GMigratableTableSettings be (Rep (tbl Identity)) (Rep (tbl (Const [FieldCheck])))+    , BeamSqlBackend be ) -  collectEntityChecks (CheckedDatabaseTable (DatabaseTable tbl tblFields) tblChecks tblFieldChecks) =-    map (\(TableCheck mkCheck) -> mkCheck tbl tblFields) tblChecks <>-    execWriter (zipBeamFieldsM (\(Columnar' (TableField fieldNm)) c@(Columnar' (Const fieldChecks)) ->-                                    tell (map (\(FieldCheck mkCheck) -> mkCheck tbl fieldNm) fieldChecks) >>+  unChecked f (CheckedDatabaseTable x cks fcks) = fmap (\x' -> CheckedDatabaseTable x' cks fcks) (f x)+  collectEntityChecks (CheckedDatabaseTable dt tblChecks tblFieldChecks) =+    map (\(TableCheck mkCheck) -> mkCheck (qname dt) (dbTableSettings dt)) tblChecks <>+    execWriter (zipBeamFieldsM (\(Columnar' fd) c@(Columnar' (Const fieldChecks)) ->+                                    tell (map (\(FieldCheck mkCheck) -> mkCheck (qname dt) (fd ^. fieldName)) fieldChecks) >>                                     pure c)-                               tblFields tblFieldChecks)+                               (dbTableSettings dt) tblFieldChecks) -  checkedDbEntityAuto syntax tblTypeName =+  checkedDbEntityAuto tblTypeName =     let tblChecks =           [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableExistsPredicate tblName))           , TableCheck (\tblName tblFields ->-                           let pkFields = allBeamValues (\(Columnar' (TableField x)) -> x) (primaryKey tblFields)+                           let pkFields = allBeamValues (\(Columnar' fd) -> fd ^. fieldName) (primaryKey tblFields)                            in SomeDatabasePredicate (TableHasPrimaryKey tblName pkFields)) ] -        fieldChecks = to (gDefaultTblSettingsChecks syntax (Proxy @(Rep (tbl Identity))) False)+        fieldChecks = to (gDefaultTblSettingsChecks (Proxy @be) (Proxy @(Rep (tbl Identity))) False)     in CheckedDatabaseTable (dbEntityAuto tblTypeName) tblChecks fieldChecks  -- | Purposefully opaque type describing how to modify a table field. Used to@@ -134,10 +143,10 @@       ([FieldCheck] -> [FieldCheck])  checkedFieldNamed :: Text -> CheckedFieldModification tbl a-checkedFieldNamed t = CheckedFieldModification (\_ -> TableField t) id+checkedFieldNamed t = CheckedFieldModification (fieldName .~ t) id  instance IsString (CheckedFieldModification tbl a) where-  fromString s = CheckedFieldModification (const . TableField . fromString $ s) id+  fromString = checkedFieldNamed . fromString  instance Beamable tbl => RenamableWithRule (tbl (CheckedFieldModification tbl)) where   renamingFields renamer =@@ -179,16 +188,22 @@   -> tbl (CheckedFieldModification tbl)   -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl) modifyCheckedTable renamer modFields =-  EntityModification (\(CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable nm fields) tblChecks fieldChecks) extraChecks) ->-                          let fields' = runIdentity $-                                        zipBeamFieldsM (\(Columnar' (CheckedFieldModification fieldMod _)) (Columnar' field) ->-                                                           pure $ Columnar' (fieldMod field))-                                                       modFields fields-                              fieldChecks' = runIdentity $-                                             zipBeamFieldsM (\(Columnar' (CheckedFieldModification _ csMod)) (Columnar' (Const cs)) ->-                                                                pure $ Columnar' (Const (csMod cs)))-                                                            modFields fieldChecks-                          in CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable (renamer nm) fields') tblChecks fieldChecks') extraChecks)+  EntityModification $ Endo $+  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) ->+    let fields' =+          runIdentity $+          zipBeamFieldsM (\(Columnar' (CheckedFieldModification fieldMod _)) (Columnar' field) ->+                             pure $ Columnar' (fieldMod field))+                         modFields (dbTableSettings dt)+        fieldChecks' =+          runIdentity $+          zipBeamFieldsM (\(Columnar' (CheckedFieldModification _ csMod)) (Columnar' (Const cs)) ->+                             pure $ Columnar' (Const (csMod cs)))+                         modFields fieldChecks+    in CheckedDatabaseEntity (CheckedDatabaseTable+                                (dt { dbTableCurrentName = renamer (dbTableCurrentName dt)+                                    , dbTableSettings = fields'})+                                tblChecks fieldChecks') extraChecks  -- | Produce a table field modification that does nothing --

@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-}+ -- | Common 'DatabasePredicate's used for defining schemas module Database.Beam.Migrate.Types.Predicates where  import Database.Beam+import Database.Beam.Backend.SQL.SQL92 (IsSql92TableNameSyntax(..))+import Database.Beam.Schema.Tables  import Control.DeepSeq @@ -10,6 +14,12 @@ import Data.Hashable import Data.Typeable +#if !MIN_VERSION_base(4, 11, 0)+import           Data.Semigroup+#endif++import Lens.Micro ((^.))+ -- * Predicates  -- | A predicate is a type that describes some condition that the database@@ -45,8 +55,8 @@ -- 'DatabasePredicate'. We often want to store these in lists and sets, so we -- need a monomorphic container that can store these polymorphic values. data SomeDatabasePredicate where-  SomeDatabasePredicate :: DatabasePredicate p =>-                           p -> SomeDatabasePredicate+  SomeDatabasePredicate :: DatabasePredicate p+                        => p -> SomeDatabasePredicate  instance NFData SomeDatabasePredicate where   rnf p' = p' `seq` ()@@ -90,11 +100,38 @@ --   changes. The following types represent predicates whose names have not yet --   been determined. +-- | A name in a schema+data QualifiedName = QualifiedName (Maybe Text) Text+  deriving (Show, Eq, Ord)++instance ToJSON QualifiedName where+  toJSON (QualifiedName Nothing t) = toJSON t+  toJSON (QualifiedName (Just s) t) = object [ "schema" .= s, "name" .= t ]++instance FromJSON QualifiedName where+  parseJSON s@(String {}) = QualifiedName Nothing <$> parseJSON s+  parseJSON (Object o) = QualifiedName <$> o .: "schema" <*> o .: "name"+  parseJSON _ = fail "QualifiedName: expects either string or {schema: ..., name: ...}"++instance Hashable QualifiedName where+  hashWithSalt s (QualifiedName sch t) =+    hashWithSalt s (sch, t)++qname :: IsDatabaseEntity be entity => DatabaseEntityDescriptor be entity -> QualifiedName+qname e = QualifiedName (e ^. dbEntitySchema) (e ^. dbEntityName)++qnameAsText :: QualifiedName -> Text+qnameAsText (QualifiedName Nothing tbl) = tbl+qnameAsText (QualifiedName (Just sch) tbl) = sch <> "." <> tbl++qnameAsTableName :: IsSql92TableNameSyntax syntax => QualifiedName -> syntax+qnameAsTableName (QualifiedName sch t) = tableName sch t+ -- | A predicate that depends on the name of a table as well as its fields-newtype TableCheck = TableCheck (forall tbl. Table tbl => Text -> tbl (TableField tbl) -> SomeDatabasePredicate)+newtype TableCheck = TableCheck (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> SomeDatabasePredicate)  -- | A predicate that depends on the name of a domain type-newtype DomainCheck = DomainCheck (Text -> SomeDatabasePredicate)+newtype DomainCheck = DomainCheck (QualifiedName -> SomeDatabasePredicate) --- | A predicate that depedns on the name of a table and one of its fields-newtype FieldCheck = FieldCheck (Text -> Text -> SomeDatabasePredicate)+-- | A predicate that depends on the name of a table and one of its fields+newtype FieldCheck = FieldCheck (QualifiedName -> Text -> SomeDatabasePredicate)

@@ -1,5 +1,5 @@ name:                beam-migrate-version:             0.3.2.2+version:             0.4.0.0 synopsis:            SQL DDL support and migrations support library for Beam description:         This package provides type classes to allow backends to implement                      SQL DDL support for beam. This allows you to use beam syntax to@@ -60,7 +60,7 @@                        Database.Beam.Migrate.Types.Predicates    build-depends:       base                 >=4.9     && <5.0,-                       beam-core            >=0.7     && <0.8,+                       beam-core            >=0.8     && <0.9,                        text                 >=1.2     && <1.3,                        aeson                >=0.11    && <1.5,                        bytestring           >=0.10    && <0.11,@@ -69,13 +69,15 @@                        mtl                  >=2.2     && <2.3,                        scientific           >=0.3     && <0.4,                        vector               >=0.11    && <0.13,+                       containers           >=0.5     && <0.7,                        unordered-containers >=0.2     && <0.3,                        hashable             >=1.2     && <1.3,+                       microlens            >=0.4     && <0.5,                        parallel             >=3.2     && <3.3,                        deepseq              >=1.4     && <1.5,                        ghc-prim             >=0.5     && <0.6,                        containers           >=0.5     && <0.7,-                       haskell-src-exts     >=1.18    && <1.21,+                       haskell-src-exts     >=1.18    && <1.22,                        pretty               >=1.1     && <1.2,                        dependent-map        >=0.2     && <0.3,                        dependent-sum        >=0.4     && <0.5,