Make use of strong typing in schema manipulation

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

@@ -9,7 +9,6 @@ module Database.Beam.Migrate.SQL.Tables
 
     -- ** Creation and deletion
     createTable, createTableWithSchema 
-  , createDatabaseSchema, dropDatabaseSchema
   , dropTable
   , preserve
 
@@ -21,6 +20,9 @@ module Database.Beam.Migrate.SQL.Tables
   , renameTableTo, renameColumnTo
   , addColumn, dropColumn
 
+    -- * Schema manipulation
+  , createDatabaseSchema, dropDatabaseSchema, existingDatabaseSchema
+
     -- * Field specification
   , DefaultValue, Constraint(..), NotNullConstraint
 
@@ -51,7 +53,9 @@ import Control.Monad.Identity
 import Control.Monad.Writer.Strict
 import Control.Monad.State
 
+import Data.Coerce (coerce)
 import Data.Kind (Type)
+import Data.String (IsString)
 import Data.Text (Text)
 import Data.Typeable
 import qualified Data.Kind as Kind (Constraint)
@@ -78,27 +82,39 @@ createTable = createTableWithSchema Nothing
 
 -- * Schema manipulation
 
+-- | Represents a database schema. To create one, see 'createDatabaseSchema'.
+newtype DatabaseSchema 
+  = MkDatabaseSchema Text
+  deriving (Eq, Show, IsString)
+
 -- | Add a @CREATE SCHEMA@ statement to this migration
 --
 --   To create a table in a specific schema, see 'createTableWithSchema'.
 --   To drop a schema, see 'dropDatabaseSchema'.
+--   To materialize an existing schema for use in a migration, see 'existingDatabaseSchema'.
 createDatabaseSchema :: BeamMigrateSchemaSqlBackend be
                      => Text
-                     -> Migration be ()
-createDatabaseSchema nm 
-  = upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing
+                     -> Migration be DatabaseSchema
+createDatabaseSchema nm = do
+  upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing
+  pure $ MkDatabaseSchema nm
 
 -- | Add a @DROP SCHEMA@ statement to this migration.
 --
 --   Depending on the backend, this may fail if the schema is not empty. 
 --
 --   To create a schema, see 'createDatabaseSchema'.
+--   To materialize a 'DatabaseSchema', see 'existingDatabaseSchema
 dropDatabaseSchema :: BeamMigrateSchemaSqlBackend be
-                   => Text
+                   => DatabaseSchema
                    -> Migration be ()
-dropDatabaseSchema nm 
+dropDatabaseSchema (MkDatabaseSchema nm) 
   = upDown (dropSchemaCmd (dropSchemaSyntax (schemaName nm))) Nothing
 
+-- | Materialize a schema for use during a migration (for example, to drop it).
+existingDatabaseSchema :: Text -> Migration be DatabaseSchema
+existingDatabaseSchema = pure . MkDatabaseSchema
+
 -- | 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.
@@ -110,15 +126,15 @@ dropDatabaseSchema nm
 --   a database schema.
 createTableWithSchema :: ( Beamable table, Table table
                          , BeamMigrateSqlBackend be )
-                      => Maybe Text -- ^ Schema name, if any
+                      => Maybe DatabaseSchema -- ^ Schema name, if any
                       -> Text       -- ^ Table name 
                       -> TableSchema be table
                       -> Migration be (CheckedDatabaseEntity be db (TableEntity table))
 createTableWithSchema maybeSchemaName newTblName tblSettings =
   do let pkFields = allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings)
          tblConstraints = if null pkFields then [] else [ primaryKeyConstraintSyntax pkFields ]
          createTableCommand =
-           createTableSyntax Nothing (tableName maybeSchemaName newTblName)
+           createTableSyntax Nothing (tableName (coerce <$> maybeSchemaName) newTblName)
                              (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings)
                              tblConstraints
          command = createTableCmd createTableCommand
@@ -139,12 +155,12 @@ createTableWithSchema maybeSchemaName newTblName tblSettings =
          schemaCheck = 
             case maybeSchemaName of
               Nothing -> []
-              Just sn -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] 
+              Just (MkDatabaseSchema sn) -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] 
 
      upDown command Nothing
      pure (CheckedDatabaseEntity 
             (CheckedDatabaseTable 
-              (DatabaseTable maybeSchemaName newTblName newTblName tbl') 
+              (DatabaseTable (coerce <$> maybeSchemaName) newTblName newTblName tbl') 
               tblChecks 
               fieldChecks
             ) 

beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs

@@ -109,8 +109,8 @@ createTableWithSchemaWorks pgConn =
       withTestPostgres "create_table_with_schema" pgConn $ \conn -> do
         res <- runBeamPostgres conn $ do
           db <- executeMigration runNoReturn $ do
-                  createDatabaseSchema "internal_schema"
-                  (CharDb <$> createTableWithSchema (Just "internal_schema") "char_test"
+                  internalSchema <- createDatabaseSchema "internal_schema"
+                  (CharDb <$> createTableWithSchema (Just internalSchema) "char_test"
                                     (CharT (field "key" (varchar Nothing) notNull)))
 
           verifySchema migrationBackend db
@@ -127,11 +127,11 @@ dropSchemaWorks pgConn =
       withTestPostgres "drop_schema" pgConn $ \conn -> do
         runBeamPostgres conn $ do
           db <- executeMigration runNoReturn $ do
-                  createDatabaseSchema "internal_schema"
-                  createDatabaseSchema "will_be_dropped"
-                  db <- (CharDb <$> createTableWithSchema (Just "internal_schema") "char_test"
+                  internalSchema <- createDatabaseSchema "internal_schema"
+                  willBeDroppedSchema <- createDatabaseSchema "will_be_dropped"
+                  db <- (CharDb <$> createTableWithSchema (Just internalSchema) "char_test"
                                     (CharT (field "key" (varchar Nothing) notNull)))
-                  dropDatabaseSchema "will_be_dropped"
+                  dropDatabaseSchema willBeDroppedSchema
                   pure db
 
           verifySchema migrationBackend db >>= \case