{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Database.Beam.Migrate.SQL.Tables
  ( -- * Table manipulation

    -- ** Creation and deletion
    createTable, dropTable
  , preserve

    -- ** @ALTER TABLE@
  , TableMigration(..)
  , ColumnMigration(..)
  , alterTable

  , renameTableTo, renameColumnTo
  , addColumn, dropColumn

    -- * Field specification
  , DefaultValue, Constraint(..), NotNullConstraint

  , field

  , defaultTo_, notNull, unique

    -- ** Internal classes
    --    Provided without documentation for use in type signatures
  , FieldReturnType(..)
  , IsNotNull
  ) where

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
import Database.Beam.Migrate.SQL.Types
import Database.Beam.Migrate.SQL.SQL92

import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Writer.Strict
import Control.Monad.State

import Data.Text (Text)
import Data.Typeable
import qualified Data.Kind as Kind (Constraint)

import GHC.TypeLits

import Lens.Micro ((^.))

-- * Table manipulation

-- | Add a @CREATE TABLE@ statement to this migration
--
--   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.c
createTable :: ( Beamable table, Table table
               , BeamMigrateSqlBackend be )
            => Text -> TableSchema be table
            -> Migration be (CheckedDatabaseEntity be db (TableEntity table))
createTable :: forall (table :: (* -> *) -> *) be (db :: (* -> *) -> *).
(Beamable table, Table table, BeamMigrateSqlBackend be) =>
Text
-> TableSchema be table
-> Migration be (CheckedDatabaseEntity be db (TableEntity table))
createTable Text
newTblName TableSchema be table
tblSettings =
  do let pkFields :: [Text]
pkFields = forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' (TableFieldSchema Text
name FieldSchema be a
_ [FieldCheck]
_)) -> Text
name) (forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey TableSchema be table
tblSettings)
         tblConstraints :: [Sql92CreateTableTableConstraintSyntax
   (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))]
tblConstraints = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
pkFields then [] else [ forall constraint.
IsSql92TableConstraintSyntax constraint =>
[Text] -> constraint
primaryKeyConstraintSyntax [Text]
pkFields ]
         createTableCommand :: Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)
createTableCommand =
           forall syntax.
IsSql92CreateTableSyntax syntax =>
Maybe (Sql92CreateTableOptionsSyntax syntax)
-> Sql92CreateTableTableNameSyntax syntax
-> [(Text, Sql92CreateTableColumnSchemaSyntax syntax)]
-> [Sql92CreateTableTableConstraintSyntax syntax]
-> syntax
createTableSyntax forall a. Maybe a
Nothing (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName forall a. Maybe a
Nothing Text
newTblName)
                             (forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' (TableFieldSchema Text
name (FieldSchema Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
schema) [FieldCheck]
_)) -> (Text
name, Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
schema)) TableSchema be table
tblSettings)
                             [Sql92CreateTableTableConstraintSyntax
   (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))]
tblConstraints
         command :: BeamSqlBackendSyntax be
command = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandCreateTableSyntax syntax -> syntax
createTableCmd Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)
createTableCommand

         tbl' :: table (TableField table)
tbl' = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (TableFieldSchema Text
name FieldSchema be a
_ [FieldCheck]
_)) -> forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField (forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name) Text
name)) TableSchema be table
tblSettings

         fieldChecks :: table (Const [FieldCheck])
fieldChecks = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (TableFieldSchema Text
_ FieldSchema be a
_ [FieldCheck]
cs)) -> forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall {k} a (b :: k). a -> Const a b
Const [FieldCheck]
cs)) TableSchema be table
tblSettings

         tblChecks :: [TableCheck]
tblChecks = [ (forall (tbl :: (* -> *) -> *).
 Table tbl =>
 QualifiedName
 -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
TableCheck (\QualifiedName
tblName tbl (TableField tbl)
_ -> forall a. a -> Maybe a
Just (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (QualifiedName -> TableExistsPredicate
TableExistsPredicate QualifiedName
tblName))) ] forall a. [a] -> [a] -> [a]
++
                     [TableCheck]
primaryKeyCheck

         primaryKeyCheck :: [TableCheck]
primaryKeyCheck =
           case forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' (TableFieldSchema Text
name FieldSchema be a
_ [FieldCheck]
_)) -> Text
name) (forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey TableSchema be table
tblSettings) of
             [] -> []
             [Text]
cols -> [ (forall (tbl :: (* -> *) -> *).
 Table tbl =>
 QualifiedName
 -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
TableCheck (\QualifiedName
tblName tbl (TableField tbl)
_ -> forall a. a -> Maybe a
Just (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (QualifiedName -> [Text] -> TableHasPrimaryKey
TableHasPrimaryKey QualifiedName
tblName [Text]
cols))) ]

     forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown BeamSqlBackendSyntax be
command forall a. Maybe a
Nothing
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity (forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable (forall (tbl :: (* -> *) -> *) be.
Table tbl =>
Maybe Text
-> Text
-> Text
-> TableSettings tbl
-> DatabaseEntityDescriptor be (TableEntity tbl)
DatabaseTable forall a. Maybe a
Nothing Text
newTblName Text
newTblName table (TableField table)
tbl') [TableCheck]
tblChecks table (Const [FieldCheck])
fieldChecks) [])

-- | Add a @DROP TABLE@ statement to this migration.
dropTable :: BeamMigrateSqlBackend be
          => CheckedDatabaseEntity be db (TableEntity table)
          -> Migration be ()
dropTable :: forall be (db :: (* -> *) -> *) (table :: (* -> *) -> *).
BeamMigrateSqlBackend be =>
CheckedDatabaseEntity be db (TableEntity table) -> Migration be ()
dropTable (CheckedDatabaseEntity (CheckedDatabaseTable DatabaseEntityDescriptor be (TableEntity table)
dt [TableCheck]
_ table (Const [FieldCheck])
_) [SomeDatabasePredicate]
_) =
  let command :: BeamSqlBackendSyntax be
command = forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandDropTableSyntax syntax -> syntax
dropTableCmd (forall syntax.
IsSql92DropTableSyntax syntax =>
Sql92DropTableTableNameSyntax syntax -> syntax
dropTableSyntax (forall name be (tbl :: (* -> *) -> *).
IsSql92TableNameSyntax name =>
DatabaseEntityDescriptor be (TableEntity tbl) -> name
tableNameFromEntity DatabaseEntityDescriptor be (TableEntity table)
dt))
  in forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown BeamSqlBackendSyntax be
command forall a. Maybe a
Nothing

-- | Copy a table schema from one database to another
preserve :: CheckedDatabaseEntity be db e
         -> Migration be (CheckedDatabaseEntity be db' e)
preserve :: forall be (db :: (* -> *) -> *) e (db' :: (* -> *) -> *).
CheckedDatabaseEntity be db e
-> Migration be (CheckedDatabaseEntity be db' e)
preserve (CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be e
desc [SomeDatabasePredicate]
checks) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be e
desc [SomeDatabasePredicate]
checks)

-- * Alter table

-- | A column in the process of being altered
data ColumnMigration a
  = ColumnMigration
  { forall a. ColumnMigration a -> Text
columnMigrationFieldName :: Text
  , forall a. ColumnMigration a -> [FieldCheck]
columnMigrationFieldChecks :: [FieldCheck] }

-- | Monad representing a series of @ALTER TABLE@ statements
newtype TableMigration be a
  = TableMigration (WriterT [BeamSqlBackendAlterTableSyntax be] (State (TableName, [TableCheck])) a)
  deriving (forall {be}. Applicative (TableMigration be)
forall a. a -> TableMigration be a
forall be a. a -> TableMigration be a
forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
forall a b.
TableMigration be a
-> (a -> TableMigration be b) -> TableMigration be b
forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
forall be a b.
TableMigration be a
-> (a -> TableMigration be b) -> TableMigration be b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TableMigration be a
$creturn :: forall be a. a -> TableMigration be a
>> :: forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
$c>> :: forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
>>= :: forall a b.
TableMigration be a
-> (a -> TableMigration be b) -> TableMigration be b
$c>>= :: forall be a b.
TableMigration be a
-> (a -> TableMigration be b) -> TableMigration be b
Monad, forall {be}. Functor (TableMigration be)
forall a. a -> TableMigration be a
forall be a. a -> TableMigration be a
forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be a
forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
forall a b.
TableMigration be (a -> b)
-> TableMigration be a -> TableMigration be b
forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be a
forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
forall be a b.
TableMigration be (a -> b)
-> TableMigration be a -> TableMigration be b
forall a b c.
(a -> b -> c)
-> TableMigration be a
-> TableMigration be b
-> TableMigration be c
forall be a b c.
(a -> b -> c)
-> TableMigration be a
-> TableMigration be b
-> TableMigration be c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be a
$c<* :: forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be a
*> :: forall a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
$c*> :: forall be a b.
TableMigration be a -> TableMigration be b -> TableMigration be b
liftA2 :: forall a b c.
(a -> b -> c)
-> TableMigration be a
-> TableMigration be b
-> TableMigration be c
$cliftA2 :: forall be a b c.
(a -> b -> c)
-> TableMigration be a
-> TableMigration be b
-> TableMigration be c
<*> :: forall a b.
TableMigration be (a -> b)
-> TableMigration be a -> TableMigration be b
$c<*> :: forall be a b.
TableMigration be (a -> b)
-> TableMigration be a -> TableMigration be b
pure :: forall a. a -> TableMigration be a
$cpure :: forall be a. a -> TableMigration be a
Applicative, forall a b. a -> TableMigration be b -> TableMigration be a
forall a b. (a -> b) -> TableMigration be a -> TableMigration be b
forall be a b. a -> TableMigration be b -> TableMigration be a
forall be a b.
(a -> b) -> TableMigration be a -> TableMigration be b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TableMigration be b -> TableMigration be a
$c<$ :: forall be a b. a -> TableMigration be b -> TableMigration be a
fmap :: forall a b. (a -> b) -> TableMigration be a -> TableMigration be b
$cfmap :: forall be a b.
(a -> b) -> TableMigration be a -> TableMigration be b
Functor)

-- | @ALTER TABLE ... RENAME TO@ command
renameTableTo :: BeamMigrateSqlBackend be
              => Text -> table ColumnMigration
              -> TableMigration be (table ColumnMigration)
renameTableTo :: forall be (table :: (* -> *) -> *).
BeamMigrateSqlBackend be =>
Text
-> table ColumnMigration
-> TableMigration be (table ColumnMigration)
renameTableTo Text
newName table ColumnMigration
oldTbl = forall be a.
WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  a
-> TableMigration be a
TableMigration forall a b. (a -> b) -> a -> b
$ do
  (TableName Maybe Text
curSchema Text
curNm, [TableCheck]
chks) <- forall s (m :: * -> *). MonadState s m => m s
get
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
curSchema Text
curNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> syntax
renameTableToSyntax Text
newName) ]
  forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Text -> Text -> TableName
TableName Maybe Text
curSchema Text
curNm, [TableCheck]
chks)
  forall (m :: * -> *) a. Monad m => a -> m a
return table ColumnMigration
oldTbl

-- | @ALTER TABLE ... RENAME COLUMN ... TO ...@ command
renameColumnTo :: BeamMigrateSqlBackend be
               => Text -> ColumnMigration a
               -> TableMigration be (ColumnMigration a)
renameColumnTo :: forall be a.
BeamMigrateSqlBackend be =>
Text -> ColumnMigration a -> TableMigration be (ColumnMigration a)
renameColumnTo Text
newName ColumnMigration a
column = forall be a.
WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  a
-> TableMigration be a
TableMigration forall a b. (a -> b) -> a -> b
$ do
  (TableName Maybe Text
curSchema Text
curNm, [TableCheck]
_) <- forall s (m :: * -> *). MonadState s m => m s
get
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
curSchema Text
curNm)
           (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Text -> syntax
renameColumnToSyntax (forall a. ColumnMigration a -> Text
columnMigrationFieldName ColumnMigration a
column) Text
newName) ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ColumnMigration a
column { columnMigrationFieldName :: Text
columnMigrationFieldName = Text
newName }

-- | @ALTER TABLE ... DROP COLUMN ...@ command
dropColumn :: BeamMigrateSqlBackend be
           => ColumnMigration a -> TableMigration be ()
dropColumn :: forall be a.
BeamMigrateSqlBackend be =>
ColumnMigration a -> TableMigration be ()
dropColumn ColumnMigration a
column = forall be a.
WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  a
-> TableMigration be a
TableMigration forall a b. (a -> b) -> a -> b
$ do
  (TableName Maybe Text
curSchema Text
curNm, [TableCheck]
_)<- forall s (m :: * -> *). MonadState s m => m s
get
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
curSchema Text
curNm)
           (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> syntax
dropColumnSyntax (forall a. ColumnMigration a -> Text
columnMigrationFieldName ColumnMigration a
column)) ]

-- | @ALTER TABLE ... ADD COLUMN ...@ command
addColumn :: BeamMigrateSqlBackend be
          => TableFieldSchema be a
          -> TableMigration be (ColumnMigration a)
addColumn :: forall be a.
BeamMigrateSqlBackend be =>
TableFieldSchema be a -> TableMigration be (ColumnMigration a)
addColumn (TableFieldSchema Text
nm (FieldSchema Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
fieldSchemaSyntax) [FieldCheck]
checks) =
  forall be a.
WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  a
-> TableMigration be a
TableMigration forall a b. (a -> b) -> a -> b
$
  do (TableName Maybe Text
curSchema Text
curNm, [TableCheck]
_) <- forall s (m :: * -> *). MonadState s m => m s
get
     forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ forall syntax.
IsSql92AlterTableSyntax syntax =>
Sql92AlterTableTableNameSyntax syntax
-> Sql92AlterTableAlterTableActionSyntax syntax -> syntax
alterTableSyntax (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
curSchema Text
curNm) (forall syntax.
IsSql92AlterTableActionSyntax syntax =>
Text -> Sql92AlterTableColumnSchemaSyntax syntax -> syntax
addColumnSyntax Text
nm Sql92CreateTableColumnSchemaSyntax
  (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be))
fieldSchemaSyntax) ]
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Text -> [FieldCheck] -> ColumnMigration a
ColumnMigration Text
nm [FieldCheck]
checks)

-- | Compose a series of @ALTER TABLE@ commands
--
--   Example usage
--
-- @
-- migrate (OldDb oldTbl) = do
--   alterTable oldTbl $ \oldTbl' ->
--     field2 <- renameColumnTo "NewNameForField2" (_field2 oldTbl')
--     dropColumn (_field3 oldTbl')
--     renameTableTo "NewTableName"
--     field4 <- addColumn (field "ANewColumn" smallint notNull (defaultTo_ (val_ 0)))
--     return (NewTable (_field1 oldTbl') field2 field4)
-- @
--
--   The above would result in commands like:
--
-- @
-- ALTER TABLE <oldtable> RENAME COLUMN <field2> TO "NewNameForField2";
-- ALTER TABLE <oldtable> DROP COLUMN <field3>;
-- ALTER TABLE <oldtable> RENAME TO "NewTableName";
-- ALTER TABLE "NewTableName" ADD COLUMN "ANewColumn" SMALLINT NOT NULL DEFAULT 0;
-- @
--
alterTable :: forall be db db' table table'
            . (Table table', BeamMigrateSqlBackend be)
           => CheckedDatabaseEntity be db (TableEntity table)
           -> (table ColumnMigration -> TableMigration be (table' ColumnMigration))
           -> Migration be (CheckedDatabaseEntity be db' (TableEntity table'))
alterTable :: forall be (db :: (* -> *) -> *) (db' :: (* -> *) -> *)
       (table :: (* -> *) -> *) (table' :: (* -> *) -> *).
(Table table', BeamMigrateSqlBackend be) =>
CheckedDatabaseEntity be db (TableEntity table)
-> (table ColumnMigration
    -> TableMigration be (table' ColumnMigration))
-> Migration be (CheckedDatabaseEntity be db' (TableEntity table'))
alterTable (CheckedDatabaseEntity (CheckedDatabaseTable DatabaseEntityDescriptor be (TableEntity table)
dt [TableCheck]
tblChecks table (Const [FieldCheck])
tblFieldChecks) [SomeDatabasePredicate]
entityChecks) table ColumnMigration -> TableMigration be (table' ColumnMigration)
alterColumns =
 let initialTbl :: table ColumnMigration
initialTbl = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$
                  forall (table :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
(Beamable table, Applicative m) =>
(forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> table f -> table g -> m (table h)
zipBeamFieldsM
                      (\(Columnar' Columnar (TableField table) a
fd :: Columnar' (TableField table) x)
                        (Columnar' (Const [FieldCheck]
checks) :: Columnar' (Const [FieldCheck]) x) ->
                         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall a. Text -> [FieldCheck] -> ColumnMigration a
ColumnMigration (Columnar (TableField table) a
fd forall s a. s -> Getting a s a -> a
^. forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) [FieldCheck]
checks)
                               :: Columnar' ColumnMigration x))
                      (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity table)
dt) table (Const [FieldCheck])
tblFieldChecks

     TableMigration WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  (table' ColumnMigration)
alterColumns' = table ColumnMigration -> TableMigration be (table' ColumnMigration)
alterColumns table ColumnMigration
initialTbl
     ((table' ColumnMigration
newTbl, [BeamSqlBackendAlterTableSyntax be]
cmds), (TableName Maybe Text
tblSchema' Text
tblNm', [TableCheck]
tblChecks')) =
       forall s a. State s a -> s -> (a, s)
runState (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  [BeamSqlBackendAlterTableSyntax be]
  (State (TableName, [TableCheck]))
  (table' ColumnMigration)
alterColumns')
                ( Maybe Text -> Text -> TableName
TableName (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Maybe Text
dbTableSchema DatabaseEntityDescriptor be (TableEntity table)
dt) (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableCurrentName DatabaseEntityDescriptor be (TableEntity table)
dt)
                , [TableCheck]
tblChecks )

     fieldChecks' :: table' (Const [FieldCheck])
fieldChecks' = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (ColumnMigration Text
_ [FieldCheck]
checks) :: Columnar' ColumnMigration a) ->
                                     forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall {k} a (b :: k). a -> Const a b
Const [FieldCheck]
checks) :: Columnar' (Const [FieldCheck]) a)
                                  table' ColumnMigration
newTbl

     tbl' :: TableSettings table'
     tbl' :: TableSettings table'
tbl' = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (ColumnMigration Text
nm [FieldCheck]
_) :: Columnar' ColumnMigration a) ->
                              forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField (forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
nm) Text
nm) :: Columnar' (TableField table') a)
                          table' ColumnMigration
newTbl
 in forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BeamSqlBackendAlterTableSyntax be]
cmds (\BeamSqlBackendAlterTableSyntax be
cmd -> forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (forall syntax.
IsSql92DdlCommandSyntax syntax =>
Sql92DdlCommandAlterTableSyntax syntax -> syntax
alterTableCmd BeamSqlBackendAlterTableSyntax be
cmd) forall a. Maybe a
Nothing) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity (forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable
                                  (forall (tbl :: (* -> *) -> *) be.
Table tbl =>
Maybe Text
-> Text
-> Text
-> TableSettings tbl
-> DatabaseEntityDescriptor be (TableEntity tbl)
DatabaseTable Maybe Text
tblSchema' (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableOrigName DatabaseEntityDescriptor be (TableEntity table)
dt)
                                     Text
tblNm' TableSettings table'
tbl')
                                   [TableCheck]
tblChecks' table' (Const [FieldCheck])
fieldChecks') [SomeDatabasePredicate]
entityChecks)

-- * Fields

-- | Build a schema for a field. This function takes the name and type of the
-- field and a variable number of modifiers, such as constraints and default
-- values. GHC will complain at you if the modifiers do not make sense. For
-- example, you cannot apply the 'notNull' constraint to a column with a 'Maybe'
-- type.
--
-- Example of creating a table named "Employee" with three columns: "FirstName",
-- "LastName", and "HireDate"
--
-- @
-- data Employee f =
--   Employee { _firstName :: C f Text
--            , _lastName  :: C f Text
--            , _hireDate  :: C f (Maybe LocalTime)
--            } deriving Generic
-- instance Beamable Employee
--
-- instance Table Employee where
--    data PrimaryKey Employee f = EmployeeKey (C f Text) (C f Text) deriving Generic
--    primaryKey = EmployeeKey \<$\> _firstName \<*\> _lastName
--
-- instance Beamable PrimaryKey Employee f
--
-- data EmployeeDb entity
--     = EmployeeDb { _employees :: entity (TableEntity Employee) }
--     deriving Generic
-- instance Database EmployeeDb
--
-- migration :: IsSql92DdlCommandSyntax syntax => Migration syntax () EmployeeDb
-- migration = do
--   employees <- createTable "EmployeesTable"
--                  (Employee (field "FirstNameField" (varchar (Just 15)) notNull)
--                            (field "last_name" (varchar Nothing) notNull (defaultTo_ (val_ "Smith")))
--                            (field "hiredDate" (maybeType timestamp)))
--   return (EmployeeDb employees)
-- @
field :: ( BeamMigrateSqlBackend be
         , FieldReturnType 'False 'False be resTy a )
      => Text -> DataType be resTy -> a
field :: forall be resTy a.
(BeamMigrateSqlBackend be,
 FieldReturnType 'False 'False be resTy a) =>
Text -> DataType be resTy -> a
field Text
name (DataType Sql92ExpressionCastTargetSyntax
  (Sql92ExpressionSyntax (BeamSqlBackendSyntax be))
ty) = forall (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a.
(FieldReturnType defaultGiven collationGiven be resTy a,
 BeamMigrateSqlBackend be) =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> a
field' (forall {k} (t :: k). Proxy t
Proxy @'False) (forall {k} (t :: k). Proxy t
Proxy @'False) Text
name Sql92ExpressionCastTargetSyntax
  (Sql92ExpressionSyntax (BeamSqlBackendSyntax be))
ty forall a. Maybe a
Nothing forall a. Maybe a
Nothing []

-- ** Default values

-- | Represents the default value of a field with a given column schema syntax and type
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_ :: BeamMigrateSqlBackend be
           => (forall s. QExpr be s a)
           -> DefaultValue be a
defaultTo_ :: forall be a.
BeamMigrateSqlBackend be =>
(forall s. QExpr be s a) -> DefaultValue be a
defaultTo_ (QExpr Text -> BeamSqlBackendExpressionSyntax be
e) =
  forall be a. BeamSqlBackendExpressionSyntax be -> DefaultValue be a
DefaultValue (Text -> BeamSqlBackendExpressionSyntax be
e Text
"t")

-- ** Constraints

-- | Represents a constraint in the given column schema syntax
newtype Constraint be
  = Constraint (BeamSqlBackendConstraintSyntax be)

newtype NotNullConstraint be
  = NotNullConstraint (Constraint be)

-- | The SQL92 @NOT NULL@ constraint
notNull :: BeamMigrateSqlBackend be => NotNullConstraint be
notNull :: forall be. BeamMigrateSqlBackend be => NotNullConstraint be
notNull = forall be. Constraint be -> NotNullConstraint be
NotNullConstraint (forall be. BeamSqlBackendConstraintSyntax be -> Constraint be
Constraint forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
notNullConstraintSyntax)

-- | SQL @UNIQUE@ constraint
unique :: BeamMigrateSqlBackend be => Constraint be
unique :: forall be. BeamMigrateSqlBackend be => Constraint be
unique = forall be. BeamSqlBackendConstraintSyntax be -> Constraint be
Constraint forall constraint.
IsSql92ColumnConstraintSyntax constraint =>
constraint
uniqueColumnConstraintSyntax

-- ** 'field' variable arity classes

class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a | a -> be resTy where
  field' :: BeamMigrateSqlBackend be
         => Proxy defaultGiven -> Proxy collationGiven
         -> Text
         -> BeamMigrateSqlBackendDataTypeSyntax be
         -> Maybe (BeamSqlBackendExpressionSyntax be)
         -> Maybe Text -> [ BeamSqlBackendColumnConstraintDefinitionSyntax be ]
         -> a

instance FieldReturnType 'True collationGiven be resTy a =>
  FieldReturnType 'False collationGiven be resTy (DefaultValue be resTy -> a) where
  field' :: BeamMigrateSqlBackend be =>
Proxy 'False
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> DefaultValue be resTy
-> a
field' Proxy 'False
_ Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
_ Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints (DefaultValue BeamSqlBackendExpressionSyntax be
e) =
    forall (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a.
(FieldReturnType defaultGiven collationGiven be resTy a,
 BeamMigrateSqlBackend be) =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> a
field' (forall {k} (t :: k). Proxy t
Proxy @'True) Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty (forall a. a -> Maybe a
Just BeamSqlBackendExpressionSyntax be
e) Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints

instance FieldReturnType defaultGiven collationGiven be resTy a =>
  FieldReturnType defaultGiven collationGiven be resTy (Constraint be -> a) where
  field' :: BeamMigrateSqlBackend be =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> Constraint be
-> a
field' Proxy defaultGiven
defaultGiven Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints (Constraint BeamSqlBackendConstraintSyntax be
e) =
    forall (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a.
(FieldReturnType defaultGiven collationGiven be resTy a,
 BeamMigrateSqlBackend be) =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> a
field' Proxy defaultGiven
defaultGiven Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' Maybe Text
collation ([BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints forall a. [a] -> [a] -> [a]
++ [ forall constraint.
IsSql92ColumnConstraintDefinitionSyntax constraint =>
Maybe Text
-> Sql92ColumnConstraintDefinitionConstraintSyntax constraint
-> Maybe
     (Sql92ColumnConstraintDefinitionAttributesSyntax constraint)
-> constraint
constraintDefinitionSyntax forall a. Maybe a
Nothing BeamSqlBackendConstraintSyntax be
e forall a. Maybe a
Nothing ])

instance ( FieldReturnType defaultGiven collationGiven be resTy (Constraint be -> a)
         , IsNotNull resTy ) =>
  FieldReturnType defaultGiven collationGiven be resTy (NotNullConstraint be -> a) where
  field' :: BeamMigrateSqlBackend be =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> NotNullConstraint be
-> a
field' Proxy defaultGiven
defaultGiven Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints (NotNullConstraint Constraint be
c) =
    forall (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a.
(FieldReturnType defaultGiven collationGiven be resTy a,
 BeamMigrateSqlBackend be) =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> a
field' Proxy defaultGiven
defaultGiven Proxy collationGiven
collationGiven Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints Constraint be
c

instance ( FieldReturnType 'True collationGiven be resTy a
         , TypeError ('Text "Only one DEFAULT clause can be given per 'field' invocation") ) =>
  FieldReturnType 'True collationGiven be resTy (DefaultValue be resTy -> a) where

  field' :: BeamMigrateSqlBackend be =>
Proxy 'True
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> DefaultValue be resTy
-> a
field' = forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable because of GHC Custom Type Errors"

instance ( FieldReturnType defaultGiven collationGiven be resTy a
         , TypeError ('Text "Only one type declaration allowed per 'field' invocation")) =>
  FieldReturnType defaultGiven collationGiven be resTy (DataType be' x -> a) where
  field' :: BeamMigrateSqlBackend be =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> DataType be' x
-> a
field' = forall a. HasCallStack => [Char] -> a
error [Char]
"Unreachable because of GHC Custom Type Errors"

instance ( BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) ) =>
  FieldReturnType defaultGiven collationGiven be resTy (TableFieldSchema be resTy) where
  field' :: BeamMigrateSqlBackend be =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> TableFieldSchema be resTy
field' Proxy defaultGiven
_ Proxy collationGiven
_ Text
nm BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints =
    forall be a.
Text -> FieldSchema be a -> [FieldCheck] -> TableFieldSchema be a
TableFieldSchema Text
nm (forall be a.
BeamSqlBackendColumnSchemaSyntax be -> FieldSchema be a
FieldSchema (forall columnSchema.
IsSql92ColumnSchemaSyntax columnSchema =>
Sql92ColumnSchemaColumnTypeSyntax columnSchema
-> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema)
-> [Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema]
-> Maybe Text
-> columnSchema
columnSchemaSyntax BeamMigrateSqlBackendDataTypeSyntax be
ty Maybe (BeamSqlBackendExpressionSyntax be)
default_' [BeamSqlBackendColumnConstraintDefinitionSyntax be]
constraints Maybe Text
collation)) [FieldCheck]
checks
    where checks :: [FieldCheck]
checks = [ (QualifiedName -> Text -> SomeDatabasePredicate) -> FieldCheck
FieldCheck (\QualifiedName
tbl Text
field'' -> forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (forall be.
HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) =>
QualifiedName
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> TableHasColumn be
TableHasColumn QualifiedName
tbl Text
field'' BeamMigrateSqlBackendDataTypeSyntax be
ty :: TableHasColumn be)) ] forall a. [a] -> [a] -> [a]
++
                   forall a b. (a -> b) -> [a] -> [b]
map (\BeamSqlBackendColumnConstraintDefinitionSyntax be
cns -> (QualifiedName -> Text -> SomeDatabasePredicate) -> FieldCheck
FieldCheck (\QualifiedName
tbl Text
field'' -> forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (forall be.
QualifiedName
-> Text
-> BeamSqlBackendColumnConstraintDefinitionSyntax be
-> TableColumnHasConstraint be
TableColumnHasConstraint QualifiedName
tbl Text
field'' BeamSqlBackendColumnConstraintDefinitionSyntax be
cns :: TableColumnHasConstraint be))) [BeamSqlBackendColumnConstraintDefinitionSyntax 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" ':$$:
                                   'ShowType (Maybe x) ':$$:
                                   'Text "Either remove 'notNull' from your migration or 'Maybe' from your table")
  IsNotNull x = ()