diff --git a/Database/Beam/Haskell/Syntax.hs b/Database/Beam/Haskell/Syntax.hs --- a/Database/Beam/Haskell/Syntax.hs +++ b/Database/Beam/Haskell/Syntax.hs @@ -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 ()) diff --git a/Database/Beam/Migrate/Actions.hs b/Database/Beam/Migrate/Actions.hs --- a/Database/Beam/Migrate/Actions.hs +++ b/Database/Beam/Migrate/Actions.hs @@ -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 diff --git a/Database/Beam/Migrate/Backend.hs b/Database/Beam/Migrate/Backend.hs --- a/Database/Beam/Migrate/Backend.hs +++ b/Database/Beam/Migrate/Backend.hs @@ -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: diff --git a/Database/Beam/Migrate/Checks.hs b/Database/Beam/Migrate/Checks.hs --- a/Database/Beam/Migrate/Checks.hs +++ b/Database/Beam/Migrate/Checks.hs @@ -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"))) diff --git a/Database/Beam/Migrate/Generics.hs b/Database/Beam/Migrate/Generics.hs --- a/Database/Beam/Migrate/Generics.hs +++ b/Database/Beam/Migrate/Generics.hs @@ -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 -- 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) ()) diff --git a/Database/Beam/Migrate/Generics/Tables.hs b/Database/Beam/Migrate/Generics/Tables.hs --- a/Database/Beam/Migrate/Generics/Tables.hs +++ b/Database/Beam/Migrate/Generics/Tables.hs @@ -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 diff --git a/Database/Beam/Migrate/Generics/Types.hs b/Database/Beam/Migrate/Generics/Types.hs --- a/Database/Beam/Migrate/Generics/Types.hs +++ b/Database/Beam/Migrate/Generics/Types.hs @@ -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)) ())) diff --git a/Database/Beam/Migrate/Log.hs b/Database/Beam/Migrate/Log.hs --- a/Database/Beam/Migrate/Log.hs +++ b/Database/Beam/Migrate/Log.hs @@ -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) diff --git a/Database/Beam/Migrate/SQL/BeamExtensions.hs b/Database/Beam/Migrate/SQL/BeamExtensions.hs --- a/Database/Beam/Migrate/SQL/BeamExtensions.hs +++ b/Database/Beam/Migrate/SQL/BeamExtensions.hs @@ -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 diff --git a/Database/Beam/Migrate/SQL/Builder.hs b/Database/Beam/Migrate/SQL/Builder.hs --- a/Database/Beam/Migrate/SQL/Builder.hs +++ b/Database/Beam/Migrate/SQL/Builder.hs @@ -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 ", ") diff --git a/Database/Beam/Migrate/SQL/SQL92.hs b/Database/Beam/Migrate/SQL/SQL92.hs --- a/Database/Beam/Migrate/SQL/SQL92.hs +++ b/Database/Beam/Migrate/SQL/SQL92.hs @@ -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) diff --git a/Database/Beam/Migrate/SQL/Tables.hs b/Database/Beam/Migrate/SQL/Tables.hs --- a/Database/Beam/Migrate/SQL/Tables.hs +++ b/Database/Beam/Migrate/SQL/Tables.hs @@ -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" ':$$: diff --git a/Database/Beam/Migrate/SQL/Types.hs b/Database/Beam/Migrate/SQL/Types.hs --- a/Database/Beam/Migrate/SQL/Types.hs +++ b/Database/Beam/Migrate/SQL/Types.hs @@ -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) diff --git a/Database/Beam/Migrate/Serialization.hs b/Database/Beam/Migrate/Serialization.hs --- a/Database/Beam/Migrate/Serialization.hs +++ b/Database/Beam/Migrate/Serialization.hs @@ -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'" diff --git a/Database/Beam/Migrate/Simple.hs b/Database/Beam/Migrate/Simple.hs --- a/Database/Beam/Migrate/Simple.hs +++ b/Database/Beam/Migrate/Simple.hs @@ -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..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 -> diff --git a/Database/Beam/Migrate/Types.hs b/Database/Beam/Migrate/Types.hs --- a/Database/Beam/Migrate/Types.hs +++ b/Database/Beam/Migrate/Types.hs @@ -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) diff --git a/Database/Beam/Migrate/Types/CheckedEntities.hs b/Database/Beam/Migrate/Types/CheckedEntities.hs --- a/Database/Beam/Migrate/Types/CheckedEntities.hs +++ b/Database/Beam/Migrate/Types/CheckedEntities.hs @@ -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 -- diff --git a/Database/Beam/Migrate/Types/Predicates.hs b/Database/Beam/Migrate/Types/Predicates.hs --- a/Database/Beam/Migrate/Types/Predicates.hs +++ b/Database/Beam/Migrate/Types/Predicates.hs @@ -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) diff --git a/beam-migrate.cabal b/beam-migrate.cabal --- a/beam-migrate.cabal +++ b/beam-migrate.cabal @@ -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,