Schema backend becomes associated datatype

src/Database/Persist/Schema.hs

@@ -22,6 +22,7 @@ module Database.Persist.Schema
     , Field (..)
     , Entity (..)
     , Unique (..)
+    , SchemaT
     , PersistSchema (..)
     )
 where
@@ -56,27 +57,38 @@ data Entity = Entity
     }
 
 data Unique = Unique
-    { uniqueEntity :: EntityName
-    , uniqueName   :: UniqueName
+    { uniqueName   :: UniqueName
     , uniqueFields :: [FieldName]
     }
 
+type SchemaT b m a = ReaderT (SchemaBackend b) (ReaderT b m) a
+
+-- | Ideally we'd make the @backend@ provide schema related specifics. The
+-- problem is that e.g. @SqlBackend@ is already defined in @persistent@ and
+-- I'll need a patch to get it updated. A patch that will take time to get
+-- accpted, if the maintainer likes it at all. So instead, I'm letting these
+-- specifics be specified in a separate, associated data type.
+--
+-- The only benefit I see for this approach is schema changes are separate from
+-- data manipulations. You can't mix them in a single transaction without
+-- explicitly specifying the schema backend and using 'lift' for data manip.
 class PersistSchema backend where
+    data SchemaBackend backend -- :: *
     addEntity
-        :: MonadIO m => Entity -> ReaderT backend m ()
+        :: MonadIO m => Entity -> SchemaT backend m ()
     removeEntity
-        :: MonadIO m => EntityName -> ReaderT backend m ()
+        :: MonadIO m => EntityName -> SchemaT backend m ()
     addField
-        :: MonadIO m => Field -> ReaderT backend m ()
+        :: MonadIO m => EntityName -> Field -> SchemaT backend m ()
     renameField
         :: MonadIO m
-        => EntityName -> FieldName -> FieldName -> ReaderT backend m ()
+        => EntityName -> FieldName -> FieldName -> SchemaT backend m ()
     removeField
-        :: MonadIO m => EntityName -> FieldName -> ReaderT backend m ()
+        :: MonadIO m => EntityName -> FieldName -> SchemaT backend m ()
     addUnique
-        :: MonadIO m => Unique -> ReaderT backend m ()
+        :: MonadIO m => EntityName -> Unique -> SchemaT backend m ()
     renameUnique
         :: MonadIO m
-        => EntityName -> UniqueName -> UniqueName -> ReaderT backend m ()
+        => EntityName -> UniqueName -> UniqueName -> SchemaT backend m ()
     removeUnique
-        :: MonadIO m => EntityName -> UniqueName -> ReaderT backend m ()
+        :: MonadIO m => EntityName -> UniqueName -> SchemaT backend m ()

src/Database/Persist/Schema/PostgreSQL.hs

@@ -14,13 +14,14 @@
  -}
 
 module Database.Persist.Schema.PostgreSQL
-    (
+    ( schemaBackend
     )
 where
 
 import Prelude
 
 import Data.Text (Text)
+import Database.Persist.Sql (SqlBackend)
 import Database.Persist.Types (SqlType (..))
 import Formatting
 
@@ -74,9 +75,10 @@ idCol = ColumnName "id"
 idSql :: Text
 idSql = "id SERIAL8 PRIMARY KEY UNIQUE"
 
-ssb :: SqlSchemaBackend
-ssb = SqlSchemaBackend
-    { ssbCreateTable = \ table columns -> mconcat
+schemaBackend :: SchemaBackend SqlBackend
+schemaBackend = SqlSchemaBackend
+    { ssbRefType = SqlInt64
+    , ssbCreateTable = \ table columns -> mconcat
         [ "CREATE TABLE ", table2sql table, " ("
         , idSql
         , if null columns then T.empty else ", "
@@ -133,6 +135,10 @@ ssb = SqlSchemaBackend
         , " FOREIGN KEY(", column2sql column
         , ") REFERENCES ", table2sql target, "(", column2sql idCol, ")"
         ]
+    , ssbRenameConstraint = \ _table old new -> mconcat
+        [ "ALTER INDEX ", constraint2sql old
+        , " RENAME TO ", constraint2sql new
+        ]
     , ssbDropConstraint = \ table constraint -> mconcat
         [ "ALTER TABLE ", table2sql table
         , " DROP CONSTRAINT ", constraint2sql constraint

src/Database/Persist/Schema/Sql.hs

@@ -20,16 +20,23 @@ module Database.Persist.Schema.Sql
     , ColumnName (..)
     , ConstraintName (..)
     , Column (..)
-    , SqlSchemaBackend (..)
+    , SchemaBackend (..)
     )
 where
 
 import Prelude
 
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ask)
+import Data.Char (isUpper, toLower)
+import Data.Foldable (traverse_)
 import Data.Text (Text)
-import Database.Persist.Sql (Sql)
+import Database.Persist.Sql (Sql, SqlBackend, rawExecute)
 import Database.Persist.Types (SqlType)
 
+import qualified Data.Text as T
+
 import Database.Persist.Schema
 
 newtype TableName = TableName { unTableName :: Text }
@@ -44,18 +51,110 @@ data Column = Column
     , colNull :: MaybeNull
     }
 
-data SqlSchemaBackend = SqlSchemaBackend
-    { ssbCreateTable    :: TableName -> [Column] -> Sql
-    , ssbRenameTable    :: TableName -> TableName -> Sql
-    , ssbDropTable      :: TableName -> Sql
-    , ssbAddColumn      :: TableName -> Column -> Sql
-    , ssbRenameColumn   :: TableName -> ColumnName -> ColumnName -> Sql
-    , ssbRetypeColumn   :: TableName -> ColumnName -> SqlType -> Sql
-    , ssbRenullColumn   :: TableName -> ColumnName -> MaybeNull -> Sql
-    , ssbUnnullColumn   :: TableName -> ColumnName -> Text -> Sql
-    , ssbDropColumn     :: TableName -> ColumnName -> Sql
-    , ssbAddUnique      :: TableName -> ConstraintName -> [ColumnName] -> Sql
-    , ssbAddForeignKey
-        :: TableName -> ConstraintName -> ColumnName -> TableName -> Sql
-    , ssbDropConstraint :: TableName -> ConstraintName -> Sql
+exec :: MonadIO m => Sql -> SchemaT SqlBackend m ()
+exec t = lift $ rawExecute t []
+
+camelWords :: Text -> [Text]
+camelWords ident =
+    let low = toLower
+        slow = T.singleton . toLower
+        go c t l =
+            let (x, y) = T.break isUpper t
+            in  case (T.null x, T.uncons y) of
+                    (True,  Nothing)     -> slow c : l
+                    (True,  Just (d, r)) -> go d r $ slow c : l
+                    (False, Nothing)     -> (low c `T.cons` x) : l
+                    (False, Just (d, r)) -> go d r $ (low c `T.cons` x) : l
+        (a, b) = T.break isUpper ident
+    in  reverse $ case (T.null a, T.uncons b) of
+            (True,  Nothing)     -> []
+            (True,  Just (c, r)) -> go c r []
+            (False, Nothing)     -> [a]
+            (False, Just (c, r)) -> go c r [a]
+
+dbname :: Text -> Text
+dbname = T.intercalate (T.singleton '_') . camelWords
+
+entity2table :: EntityName -> TableName
+entity2table (EntityName t) = TableName $ dbname t
+
+field2column :: FieldName -> ColumnName
+field2column (FieldName t) = ColumnName $ dbname t
+
+unique2constraint :: UniqueName -> ConstraintName
+unique2constraint (UniqueName t) = ConstraintName $ dbname t
+
+type2sql :: SchemaBackend SqlBackend -> FieldType -> SqlType
+type2sql _   (FTPrim t) = t
+type2sql ssb FTRef      = ssbRefType ssb
+
+mkcolumn :: SchemaBackend SqlBackend -> Field -> Column
+mkcolumn ssb (Field name typ mnull) = Column
+    { colName = field2column name
+    , colType = type2sql ssb typ
+    , colNull = mnull
     }
+
+instance PersistSchema SqlBackend where
+    data SchemaBackend SqlBackend = SqlSchemaBackend
+        { ssbRefType        :: SqlType
+        , ssbCreateTable    :: TableName -> [Column] -> Sql
+        , ssbRenameTable    :: TableName -> TableName -> Sql
+        , ssbDropTable      :: TableName -> Sql
+        , ssbAddColumn      :: TableName -> Column -> Sql
+        , ssbRenameColumn   :: TableName -> ColumnName -> ColumnName -> Sql
+        , ssbRetypeColumn   :: TableName -> ColumnName -> SqlType -> Sql
+        , ssbRenullColumn   :: TableName -> ColumnName -> MaybeNull -> Sql
+        , ssbUnnullColumn   :: TableName -> ColumnName -> Text -> Sql
+        , ssbDropColumn     :: TableName -> ColumnName -> Sql
+        , ssbAddUnique
+            :: TableName -> ConstraintName -> [ColumnName] -> Sql
+        , ssbAddForeignKey
+            :: TableName -> ConstraintName -> ColumnName -> TableName -> Sql
+        , ssbRenameConstraint
+            :: TableName -> ConstraintName -> ConstraintName -> Sql
+        , ssbDropConstraint :: TableName -> ConstraintName -> Sql
+        }
+    addEntity (Entity name fields uniques) = do
+        ssb <- ask
+        exec $
+            ssbCreateTable ssb (entity2table name) (map (mkcolumn ssb) fields)
+        traverse_ (addUnique name) uniques
+    removeEntity name = do
+        ssb <- ask
+        exec $ ssbDropTable ssb $ entity2table name
+    addField ent (Field name typ mnull) = do
+        ssb <- ask
+        exec $
+            ssbAddColumn ssb (entity2table ent) $
+            Column (field2column name) (type2sql ssb typ) mnull
+    renameField entity old new = do
+        ssb <- ask
+        exec $
+            ssbRenameColumn ssb
+                (entity2table entity)
+                (field2column old)
+                (field2column new)
+    removeField entity field = do
+        ssb <- ask
+        exec $ ssbDropColumn ssb (entity2table entity) (field2column field)
+    addUnique entity (Unique name fields) = do
+        ssb <- ask
+        exec $
+            ssbAddUnique ssb
+                (entity2table entity)
+                (unique2constraint name)
+                (map field2column fields)
+    renameUnique entity old new = do
+        ssb <- ask
+        exec $
+            ssbRenameConstraint ssb
+                (entity2table entity)
+                (unique2constraint old)
+                (unique2constraint new)
+    removeUnique entity name = do
+        ssb <- ask
+        exec $
+            ssbDropConstraint ssb
+                (entity2table entity)
+                (unique2constraint name)