Added test case that Postgres database schemas are created and migrat…

…ed as expected

beam-core/Database/Beam/Backend/SQL/AST.hs

@@ -464,6 +464,12 @@ instance IsSql92GroupingSyntax Grouping where
 
   groupByExpressions = Grouping
 
+data SchemaName = SchemaName Text
+  deriving (Show, Eq, Ord)
+
+instance IsSql92SchemaNameSyntax SchemaName where
+  schemaName = SchemaName
+
 data TableName = TableName (Maybe Text) Text
   deriving (Show, Eq, Ord)
 

beam-core/Database/Beam/Backend/SQL/Builder.hs

@@ -405,6 +405,9 @@ instance IsSql92TableSourceSyntax SqlSyntaxBuilder where
                     buildSepBy (byteString ", ") (map buildSql vs) <>
                     byteString ")") vss)
 
+instance IsSql92SchemaNameSyntax SqlSyntaxBuilder where
+  schemaName = SqlSyntaxBuilder . quoteSql
+
 instance IsSql92TableNameSyntax SqlSyntaxBuilder where
   tableName Nothing t  = SqlSyntaxBuilder $ quoteSql t
   tableName (Just s) t = SqlSyntaxBuilder $ quoteSql s <> byteString "." <> quoteSql t

beam-core/Database/Beam/Backend/SQL/SQL92.hs

@@ -343,6 +343,10 @@ class IsSql92OrderingSyntax ord where
   ascOrdering, descOrdering
     :: Sql92OrderingExpressionSyntax ord -> ord
 
+class IsSql92SchemaNameSyntax schemaName where
+  schemaName :: Text {-^ Schema name -}
+             -> schemaName
+
 class IsSql92TableNameSyntax tblName where
   tableName :: Maybe Text {-^ Schema -}
             -> Text {-^ Table name -}

beam-migrate/Database/Beam/Haskell/Syntax.hs

@@ -431,15 +431,20 @@ hsMkTableName toNameCase (TableName sch nm) =
         [] -> error "Empty schema name"
         x:xs -> toNameCase x:xs ++ "_" ++ T.unpack nm
 
+hsSchemaName :: SchemaName -> String
+hsSchemaName (SchemaName nm) = T.unpack nm
+
 hsTableVarName, hsTableTypeName :: TableName -> String
 hsTableVarName = hsMkTableName toLower
 hsTableTypeName = hsMkTableName toUpper
 
 instance IsSql92DdlCommandSyntax HsAction where
+  type Sql92DdlCommandCreateSchemaSyntax HsAction = HsAction
   type Sql92DdlCommandCreateTableSyntax HsAction = HsAction
   type Sql92DdlCommandAlterTableSyntax HsAction = HsAction
   type Sql92DdlCommandDropTableSyntax HsAction = HsAction
 
+  createSchemaCmd = id
   createTableCmd = id
   dropTableCmd = id
   alterTableCmd = id
@@ -471,6 +476,12 @@ instance IsSql92DropTableSyntax HsAction where
     where
       dropTable = hsApp (hsVar "dropTable") [ hsVar (fromString (hsTableVarName nm)) ]
 
+instance IsSql92CreateSchemaSyntax HsAction where
+  type Sql92CreateSchemaSchemaNameSyntax HsAction = SchemaName
+  createSchemaSyntax (SchemaName nm) = HsAction [ (Nothing, createSchema) ] []
+    where
+      createSchema = hsApp (hsVar "createSchema") [ hsVar nm ]
+
 instance IsSql92CreateTableSyntax HsAction where
   type Sql92CreateTableTableNameSyntax HsAction = TableName
   type Sql92CreateTableOptionsSyntax HsAction = HsNone

beam-migrate/Database/Beam/Migrate/Actions.hs

@@ -77,6 +77,7 @@ module Database.Beam.Migrate.Actions
   , ensuringNot_
   , justOne_
 
+  , createSchemaActionProvider
   , createTableActionProvider
   , dropTableActionProvider
   , addColumnProvider
@@ -265,7 +266,8 @@ instance Semigroup (ActionProvider be) where
 instance Monoid (ActionProvider be) where
   mempty = ActionProvider (\_ _ -> [])
 
-createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
+createSchemaWeight, createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
+createSchemaWeight = 1000
 createTableWeight = 500
 dropTableWeight = 100
 addColumnWeight = 1
@@ -283,6 +285,30 @@ justOne_ :: [ a ] -> [ a ]
 justOne_ [x] = [x]
 justOne_ _ = []
 
+
+-- IsSql92CreateTableSyntax
+
+-- | Action provider for SQL92 @CREATE SCHEMA@ actions.
+createSchemaActionProvider :: forall be
+                           . ( Typeable be, BeamMigrateOnlySqlBackend be )
+                           => ActionProvider be
+createSchemaActionProvider =
+  ActionProvider provider
+  where
+    provider :: ActionProviderFn be
+    provider findPreConditions findPostConditions =
+      do schemaP@(SchemaExistsPredicate postSchemaName) <- findPostConditions
+         -- Make sure there's no corresponding predicate in the precondition
+         ensuringNot_ $
+           do SchemaExistsPredicate preSchemaName <- findPreConditions
+              guard (preSchemaName == postSchemaName)
+
+         let postConditions = [ p schemaP ]
+             cmd = createSchemaCmd (createSchemaSyntax (schemaName postSchemaName))
+         pure (PotentialAction mempty (HS.fromList postConditions)
+                               (Seq.singleton (MigrationCommand cmd MigrationKeepsData))
+                               ("Create the schema " <> postSchemaName) createSchemaWeight)
+
 -- | Action provider for SQL92 @CREATE TABLE@ actions.
 createTableActionProvider :: forall be
                            . ( Typeable be, BeamMigrateOnlySqlBackend be )
@@ -469,6 +495,7 @@ dropColumnNullProvider = ActionProvider provider
 --
 -- In particular, this provides edges consisting of the following statements:
 --
+--  * CREATE SCHEMA
 --  * CREATE TABLE
 --  * DROP TABLE
 --  * ALTER TABLE ... ADD COLUMN ...
@@ -479,14 +506,17 @@ defaultActionProvider :: ( Typeable be
                       => ActionProvider be
 defaultActionProvider =
   mconcat
-  [ createTableActionProvider
+  [ createSchemaActionProvider
+
+  , createTableActionProvider
   , dropTableActionProvider
 
   , addColumnProvider
   , dropColumnProvider
 
   , addColumnNullProvider
-  , dropColumnNullProvider ]
+  , dropColumnNullProvider 
+  ]
 
 -- | Represents current state of a database graph search.
 --

beam-migrate/Database/Beam/Migrate/Backend.hs

@@ -120,14 +120,15 @@ instance Semigroup HaskellPredicateConverter where
 instance Monoid HaskellPredicateConverter where
   mempty = HaskellPredicateConverter $ \_ -> Nothing
 
--- | Converters for the 'TableExistsPredicate', 'TableHasPrimaryKey', and
+-- | Converters for the 'SchemaExistsPredicate', 'TableExistsPredicate', 'TableHasPrimaryKey', and
 -- 'TableHasColumn' (when supplied with a function to convert a backend data
 -- type to a haskell one).
 sql92HsPredicateConverters :: forall fromBe
                              . Typeable fromBe
                             => (BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType)
                             -> HaskellPredicateConverter
 sql92HsPredicateConverters convType =
+  trivialHsConverter @SchemaExistsPredicate <>
   trivialHsConverter @TableExistsPredicate <>
   trivialHsConverter @TableHasPrimaryKey   <>
   hasColumnConverter @fromBe convType

beam-migrate/Database/Beam/Migrate/Checks.hs

@@ -22,6 +22,21 @@ import Data.Semigroup
 
 import GHC.Generics (Generic)
 
+-- * Schema checks
+
+-- | Asserts that a schema with the given name exists in a database
+data SchemaExistsPredicate = SchemaExistsPredicate Text {-^ Table name -}
+  deriving (Show, Eq, Ord, Typeable, Generic)
+instance Hashable SchemaExistsPredicate
+instance DatabasePredicate SchemaExistsPredicate where
+  englishDescription (SchemaExistsPredicate s) =
+    "Schema " <> show s <> " must exist"
+
+  serializePredicate (SchemaExistsPredicate s) =
+    object [ "schema-exists" .= s ]
+
+  predicateSpecificity _ = PredicateSpecificityAllBackends
+
 -- * Table checks
 
 -- | Asserts that a table with the given name exists in a database
@@ -131,12 +146,18 @@ beamCheckDeserializers
      , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )
   => BeamDeserializers be
 beamCheckDeserializers = mconcat
-  [ beamDeserializer (const deserializeTableExistsPredicate)
+  [ beamDeserializer (const deserializeSchemaExistsPredicate)
+  , beamDeserializer (const deserializeTableExistsPredicate)
   , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate)
   , beamDeserializer deserializeTableHasColumnPredicate
   , beamDeserializer deserializeTableColumnHasConstraintPredicate
   ]
   where
+    deserializeSchemaExistsPredicate :: Value -> Parser SomeDatabasePredicate
+    deserializeSchemaExistsPredicate =
+      withObject "SchemaExistsPredicate" $ \v ->
+      SomeDatabasePredicate <$> (SchemaExistsPredicate <$> v .: "schema-exists")
+
     deserializeTableExistsPredicate :: Value -> Parser SomeDatabasePredicate
     deserializeTableExistsPredicate =
       withObject "TableExistPredicate" $ \v ->

beam-migrate/Database/Beam/Migrate/SQL/Builder.hs

@@ -29,9 +29,11 @@ data SqlSyntaxBuilderCreateTableOptions
     deriving Eq
 
 instance IsSql92DdlCommandSyntax SqlSyntaxBuilder where
+  type Sql92DdlCommandCreateSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandCreateTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandDropTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandAlterTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
+  createSchemaCmd = id
   createTableCmd = id
   alterTableCmd = id
   dropTableCmd = id
@@ -77,6 +79,12 @@ instance IsSql92AlterColumnActionSyntax SqlSyntaxBuilder where
   setNotNullSyntax = SqlSyntaxBuilder (byteString "SET NOT NULL")
   setNullSyntax = SqlSyntaxBuilder (byteString "DROP NOT NULL")
 
+instance IsSql92CreateSchemaSyntax SqlSyntaxBuilder where
+  type Sql92CreateSchemaSchemaNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
+  createSchemaSyntax schName = 
+      SqlSyntaxBuilder $
+        byteString "CREATE SCHEMA " <> buildSql schName
+
 instance IsSql92CreateTableSyntax SqlSyntaxBuilder where
   type Sql92CreateTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92CreateTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder

beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs

@@ -60,17 +60,28 @@ type Sql92DdlCommandConstraintAttributesSyntax syntax =
 type Sql92DdlCommandAlterTableActionSyntax syntax =
   Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax)
 
-class ( IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax)
+class ( IsSql92CreateSchemaSyntax (Sql92DdlCommandCreateSchemaSyntax syntax)
+      , IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax)
       , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax)
       , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) =>
   IsSql92DdlCommandSyntax syntax where
+  type Sql92DdlCommandCreateSchemaSyntax syntax :: Type
   type Sql92DdlCommandCreateTableSyntax syntax :: Type
   type Sql92DdlCommandAlterTableSyntax syntax :: Type
   type Sql92DdlCommandDropTableSyntax syntax :: Type
 
-  createTableCmd :: Sql92DdlCommandCreateTableSyntax syntax -> syntax
-  dropTableCmd   :: Sql92DdlCommandDropTableSyntax syntax -> syntax
-  alterTableCmd  :: Sql92DdlCommandAlterTableSyntax syntax -> syntax
+  createSchemaCmd :: Sql92DdlCommandCreateSchemaSyntax syntax -> syntax
+  createTableCmd  :: Sql92DdlCommandCreateTableSyntax syntax -> syntax
+  dropTableCmd    :: Sql92DdlCommandDropTableSyntax syntax -> syntax
+  alterTableCmd   :: Sql92DdlCommandAlterTableSyntax syntax -> syntax
+
+class IsSql92SchemaNameSyntax (Sql92CreateSchemaSchemaNameSyntax syntax) => 
+    IsSql92CreateSchemaSyntax syntax where
+
+  type Sql92CreateSchemaSchemaNameSyntax syntax :: Type
+
+  createSchemaSyntax :: Sql92CreateSchemaSchemaNameSyntax syntax
+                     -> syntax
 
 class ( IsSql92TableConstraintSyntax (Sql92CreateTableTableConstraintSyntax syntax)
       , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax)

beam-migrate/Database/Beam/Migrate/SQL/Tables.hs

@@ -8,7 +8,9 @@ module Database.Beam.Migrate.SQL.Tables
   ( -- * Table manipulation
 
     -- ** Creation and deletion
-    createTable, createTableWithSchema, dropTable
+    createTable, createTableWithSchema 
+  , createDatabaseSchema
+  , dropTable
   , preserve
 
     -- ** @ALTER TABLE@
@@ -67,19 +69,33 @@ import Lens.Micro ((^.))
 --   The second argument is a table containing a 'FieldSchema' for each field.
 --   See documentation on the 'Field' command for more information.
 --
---   To create a table in a specific schema, see `createTableWithSchema`
+--   To create a table in a specific schema, see 'createTableWithSchema'.
 createTable :: ( Beamable table, Table table
                , BeamMigrateSqlBackend be )
             => Text -> TableSchema be table
             -> Migration be (CheckedDatabaseEntity be db (TableEntity table))
 createTable = createTableWithSchema Nothing
 
+-- * Schema manipulation
+
+-- | Add a @CREATE SCHEMA@ statement to this migration
+--
+--   To create a table in a specific schema, see 'createTableWithSchema'.
+createDatabaseSchema :: BeamMigrateSqlBackend be
+                     => Text
+                     -> Migration be ()
+createDatabaseSchema nm 
+  = upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing
+
 -- | Add a @CREATE TABLE@ statement to this migration, with an explicit schema
 --
 --   The first argument is the name of the schema, while the second 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.c
+--   See documentation on the 'Field' command for more information.
+--
+--   Note that the database schema is expected to exist; see 'createDatabaseSchema' to create
+--   a database schema.
 createTableWithSchema :: ( Beamable table, Table table
                          , BeamMigrateSqlBackend be )
                       => Maybe Text -- ^ Schema name, if any
@@ -98,17 +114,30 @@ createTableWithSchema maybeSchemaName newTblName tblSettings =
          tbl' = changeBeamRep (\(Columnar' (TableFieldSchema name _ _)) -> Columnar' (TableField (pure name) name)) tblSettings
 
          fieldChecks = changeBeamRep (\(Columnar' (TableFieldSchema _ _ cs)) -> Columnar' (Const cs)) tblSettings
-
+        
          tblChecks = [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableExistsPredicate tblName))) ] ++
                      primaryKeyCheck
 
          primaryKeyCheck =
            case allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings) of
              [] -> []
              cols -> [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableHasPrimaryKey tblName cols))) ]
+
+         -- If a schema has been defined explicitly, then it should be part of checks
+         schemaCheck = 
+            case maybeSchemaName of
+              Nothing -> []
+              Just sn -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] 
 
      upDown command Nothing
-     pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable Nothing newTblName newTblName tbl') tblChecks fieldChecks) [])
+     pure (CheckedDatabaseEntity 
+            (CheckedDatabaseTable 
+              (DatabaseTable maybeSchemaName newTblName newTblName tbl') 
+              tblChecks 
+              fieldChecks
+            ) 
+            schemaCheck
+          )
 
 -- | Add a @DROP TABLE@ statement to this migration.
 dropTable :: BeamMigrateSqlBackend be