{-# LANGUAGE UndecidableInstances #-}

-- | Checked database types
module Database.Beam.Migrate.Types.CheckedEntities where

import Database.Beam
import Database.Beam.Backend.SQL
import Database.Beam.Schema.Tables

import Database.Beam.Migrate.Checks
import Database.Beam.Migrate.Generics.Tables
import Database.Beam.Migrate.Types.Predicates

import Control.Applicative
import Control.Monad.Writer
import Control.Monad.Identity

import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import Data.String

import GHC.Types
import GHC.Generics

import Lens.Micro (Lens', (&), (^.), (.~), (%~))

-- * Checked Database Entities

-- | Like 'IsDatabaseEntity' in @beam-core@, but for entities against which we
-- can generate 'DatabasePredicate's. Conceptually, this is the same as
-- 'IsDatabaseEntity', but with one extra function to generate
-- 'DatabasePredicate's from the description.
class IsDatabaseEntity be entity => IsCheckedDatabaseEntity be entity where
  -- | The type of the descriptor for this checked entity. Usually this wraps
  -- the corresponding 'DatabaseEntityDescriptor' from 'IsDatabaseEntity', along
  -- with some mechanism for generating 'DatabasePredicate's.
  data CheckedDatabaseEntityDescriptor be entity :: *

  -- | Like 'DatabaseEntityDefaultRequirements' but for checked entities
  type CheckedDatabaseEntityDefaultRequirements be entity :: Constraint

  -- | Produce the corresponding 'DatabaseEntityDescriptor'
  unCheck :: CheckedDatabaseEntityDescriptor be entity -> DatabaseEntityDescriptor be entity
  unCheck CheckedDatabaseEntityDescriptor be entity
d = CheckedDatabaseEntityDescriptor be entity
d CheckedDatabaseEntityDescriptor be entity
-> Getting
     (DatabaseEntityDescriptor be entity)
     (CheckedDatabaseEntityDescriptor be entity)
     (DatabaseEntityDescriptor be entity)
-> DatabaseEntityDescriptor be entity
forall s a. s -> Getting a s a -> a
^. Getting
  (DatabaseEntityDescriptor be entity)
  (CheckedDatabaseEntityDescriptor be entity)
  (DatabaseEntityDescriptor be entity)
forall be entity.
IsCheckedDatabaseEntity be entity =>
Lens'
  (CheckedDatabaseEntityDescriptor be entity)
  (DatabaseEntityDescriptor be entity)
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
                      => Text -> CheckedDatabaseEntityDescriptor be entity

-- | Like 'DatabaseEntity' but for checked databases
data CheckedDatabaseEntity be (db :: (* -> *) -> *) entityType where
  CheckedDatabaseEntity :: IsCheckedDatabaseEntity be entityType
                        => CheckedDatabaseEntityDescriptor be entityType
                        -> [ SomeDatabasePredicate ]
                        -> CheckedDatabaseEntity be db entityType

-- | The type of a checked database descriptor. Conceptually, this is just a
-- 'DatabaseSettings' with a set of predicates. Use 'unCheckDatabase' to get the
-- regular 'DatabaseSettings' object and 'collectChecks' to access the
-- predicates.
type CheckedDatabaseSettings be db = db (CheckedDatabaseEntity be db)

renameCheckedEntity :: (Text -> Text) -> EntityModification (CheckedDatabaseEntity be db) be ent
renameCheckedEntity :: (Text -> Text)
-> EntityModification (CheckedDatabaseEntity be db) be ent
renameCheckedEntity Text -> Text
renamer =
  Endo (CheckedDatabaseEntity be db ent)
-> EntityModification (CheckedDatabaseEntity be db) be ent
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification ((CheckedDatabaseEntity be db ent
 -> CheckedDatabaseEntity be db ent)
-> Endo (CheckedDatabaseEntity be db ent)
forall a. (a -> a) -> Endo a
Endo (\(CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be ent
desc [SomeDatabasePredicate]
checks) -> (CheckedDatabaseEntityDescriptor be ent
-> [SomeDatabasePredicate] -> CheckedDatabaseEntity be db ent
forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity (CheckedDatabaseEntityDescriptor be ent
desc CheckedDatabaseEntityDescriptor be ent
-> (CheckedDatabaseEntityDescriptor be ent
    -> CheckedDatabaseEntityDescriptor be ent)
-> CheckedDatabaseEntityDescriptor be ent
forall a b. a -> (a -> b) -> b
& (DatabaseEntityDescriptor be ent
 -> Identity (DatabaseEntityDescriptor be ent))
-> CheckedDatabaseEntityDescriptor be ent
-> Identity (CheckedDatabaseEntityDescriptor be ent)
forall be entity.
IsCheckedDatabaseEntity be entity =>
Lens'
  (CheckedDatabaseEntityDescriptor be entity)
  (DatabaseEntityDescriptor be entity)
unChecked ((DatabaseEntityDescriptor be ent
  -> Identity (DatabaseEntityDescriptor be ent))
 -> CheckedDatabaseEntityDescriptor be ent
 -> Identity (CheckedDatabaseEntityDescriptor be ent))
-> ((Text -> Identity Text)
    -> DatabaseEntityDescriptor be ent
    -> Identity (DatabaseEntityDescriptor be ent))
-> (Text -> Identity Text)
-> CheckedDatabaseEntityDescriptor be ent
-> Identity (CheckedDatabaseEntityDescriptor be ent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Identity Text)
-> DatabaseEntityDescriptor be ent
-> Identity (DatabaseEntityDescriptor be ent)
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName ((Text -> Identity Text)
 -> CheckedDatabaseEntityDescriptor be ent
 -> Identity (CheckedDatabaseEntityDescriptor be ent))
-> (Text -> Text)
-> CheckedDatabaseEntityDescriptor be ent
-> CheckedDatabaseEntityDescriptor be ent
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Text
renamer) [SomeDatabasePredicate]
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
unCheckDatabase :: CheckedDatabaseSettings be db -> DatabaseSettings be db
unCheckDatabase CheckedDatabaseSettings be db
db = Identity (DatabaseSettings be db) -> DatabaseSettings be db
forall a. Identity a -> a
runIdentity (Identity (DatabaseSettings be db) -> DatabaseSettings be db)
-> Identity (DatabaseSettings be db) -> DatabaseSettings be db
forall a b. (a -> b) -> a -> b
$ Proxy be
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements be tbl) =>
    CheckedDatabaseEntity be db tbl
    -> CheckedDatabaseEntity be db tbl
    -> Identity (DatabaseEntity be db tbl))
-> CheckedDatabaseSettings be db
-> CheckedDatabaseSettings be db
-> Identity (DatabaseSettings be db)
forall be (db :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
(Database be db, Applicative m) =>
Proxy be
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
zipTables (Proxy be
forall k (t :: k). Proxy t
Proxy @be) (\(CheckedDatabaseEntity x _) CheckedDatabaseEntity be db tbl
_ -> DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl))
-> DatabaseEntity be db tbl -> Identity (DatabaseEntity be db tbl)
forall a b. (a -> b) -> a -> b
$ DatabaseEntityDescriptor be tbl -> DatabaseEntity be db tbl
forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (CheckedDatabaseEntityDescriptor be tbl
-> DatabaseEntityDescriptor be tbl
forall be entity.
IsCheckedDatabaseEntity be entity =>
CheckedDatabaseEntityDescriptor be entity
-> DatabaseEntityDescriptor be entity
unCheck CheckedDatabaseEntityDescriptor be tbl
x)) CheckedDatabaseSettings be db
db CheckedDatabaseSettings be db
db

-- | A @beam-migrate@ database schema is defined completely by the set of
-- predicates that apply to it. This function allows you to access this
-- definition for a 'CheckedDatabaseSettings' object.
collectChecks :: forall be db. Database be  db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ]
collectChecks :: CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db = let (CheckedDatabaseSettings be db
_ :: CheckedDatabaseSettings be db, [SomeDatabasePredicate]
a) =
                         Writer [SomeDatabasePredicate] (CheckedDatabaseSettings be db)
-> (CheckedDatabaseSettings be db, [SomeDatabasePredicate])
forall w a. Writer w a -> (a, w)
runWriter (Writer [SomeDatabasePredicate] (CheckedDatabaseSettings be db)
 -> (CheckedDatabaseSettings be db, [SomeDatabasePredicate]))
-> Writer [SomeDatabasePredicate] (CheckedDatabaseSettings be db)
-> (CheckedDatabaseSettings be db, [SomeDatabasePredicate])
forall a b. (a -> b) -> a -> b
$ Proxy be
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements be tbl) =>
    CheckedDatabaseEntity be db tbl
    -> CheckedDatabaseEntity be db tbl
    -> WriterT
         [SomeDatabasePredicate] Identity (CheckedDatabaseEntity be db tbl))
-> CheckedDatabaseSettings be db
-> CheckedDatabaseSettings be db
-> Writer [SomeDatabasePredicate] (CheckedDatabaseSettings be db)
forall be (db :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
(Database be db, Applicative m) =>
Proxy be
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
zipTables (Proxy be
forall k (t :: k). Proxy t
Proxy @be)
                           (\(CheckedDatabaseEntity entity cs :: CheckedDatabaseEntity be db entityType) CheckedDatabaseEntity be db tbl
b ->
                              do [SomeDatabasePredicate]
-> WriterT [SomeDatabasePredicate] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (CheckedDatabaseEntityDescriptor be tbl -> [SomeDatabasePredicate]
forall be entity.
IsCheckedDatabaseEntity be entity =>
CheckedDatabaseEntityDescriptor be entity
-> [SomeDatabasePredicate]
collectEntityChecks CheckedDatabaseEntityDescriptor be tbl
entity)
                                 [SomeDatabasePredicate]
-> WriterT [SomeDatabasePredicate] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [SomeDatabasePredicate]
cs
                                 CheckedDatabaseEntity be db tbl
-> WriterT
     [SomeDatabasePredicate] Identity (CheckedDatabaseEntity be db tbl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckedDatabaseEntity be db tbl
b) CheckedDatabaseSettings be db
db CheckedDatabaseSettings be db
db
                   in [SomeDatabasePredicate]
a

instance IsCheckedDatabaseEntity be (DomainTypeEntity ty) where
  data CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty) =
    CheckedDatabaseDomainType (DatabaseEntityDescriptor be (DomainTypeEntity ty))
                              [ DomainCheck ]
  type CheckedDatabaseEntityDefaultRequirements be (DomainTypeEntity ty) =
    DatabaseEntityDefaultRequirements be (DomainTypeEntity ty)

  unChecked :: (DatabaseEntityDescriptor be (DomainTypeEntity ty)
 -> f (DatabaseEntityDescriptor be (DomainTypeEntity ty)))
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
-> f (CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty))
unChecked DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> f (DatabaseEntityDescriptor be (DomainTypeEntity ty))
f (CheckedDatabaseDomainType x cks) = (DatabaseEntityDescriptor be (DomainTypeEntity ty)
 -> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty))
-> f (DatabaseEntityDescriptor be (DomainTypeEntity ty))
-> f (CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DatabaseEntityDescriptor be (DomainTypeEntity ty)
x' -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [DomainCheck]
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
forall be ty.
DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [DomainCheck]
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
CheckedDatabaseDomainType DatabaseEntityDescriptor be (DomainTypeEntity ty)
x' [DomainCheck]
cks) (DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> f (DatabaseEntityDescriptor be (DomainTypeEntity ty))
f DatabaseEntityDescriptor be (DomainTypeEntity ty)
x)
  collectEntityChecks :: CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [SomeDatabasePredicate]
collectEntityChecks (CheckedDatabaseDomainType dt domainChecks) =
    (DomainCheck -> SomeDatabasePredicate)
-> [DomainCheck] -> [SomeDatabasePredicate]
forall a b. (a -> b) -> [a] -> [b]
map (\(DomainCheck QualifiedName -> SomeDatabasePredicate
mkCheck) -> QualifiedName -> SomeDatabasePredicate
mkCheck (DatabaseEntityDescriptor be (DomainTypeEntity ty) -> QualifiedName
forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (DomainTypeEntity ty)
dt)) [DomainCheck]
domainChecks
  checkedDbEntityAuto :: Text -> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
checkedDbEntityAuto Text
domTypeName =
    DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [DomainCheck]
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
forall be ty.
DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [DomainCheck]
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
CheckedDatabaseDomainType (Text -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
forall be entityType.
(IsDatabaseEntity be entityType,
 DatabaseEntityDefaultRequirements be entityType) =>
Text -> DatabaseEntityDescriptor be entityType
dbEntityAuto Text
domTypeName) []

instance Beamable tbl => IsCheckedDatabaseEntity be (TableEntity tbl) where
  data CheckedDatabaseEntityDescriptor be (TableEntity tbl) where
    CheckedDatabaseTable :: Table tbl
                         => DatabaseEntityDescriptor be (TableEntity tbl)
                         -> [ TableCheck ]
                         -> tbl (Const [FieldCheck])
                         -> CheckedDatabaseEntityDescriptor be (TableEntity tbl)

  type CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl)  =
    ( DatabaseEntityDefaultRequirements be (TableEntity tbl)
    , Generic (tbl (Const [FieldCheck]))
    , GMigratableTableSettings be (Rep (tbl Identity)) (Rep (tbl (Const [FieldCheck])))
    , BeamSqlBackend be )

  unChecked :: (DatabaseEntityDescriptor be (TableEntity tbl)
 -> f (DatabaseEntityDescriptor be (TableEntity tbl)))
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
-> f (CheckedDatabaseEntityDescriptor be (TableEntity tbl))
unChecked DatabaseEntityDescriptor be (TableEntity tbl)
-> f (DatabaseEntityDescriptor be (TableEntity tbl))
f (CheckedDatabaseTable x cks fcks) = (DatabaseEntityDescriptor be (TableEntity tbl)
 -> CheckedDatabaseEntityDescriptor be (TableEntity tbl))
-> f (DatabaseEntityDescriptor be (TableEntity tbl))
-> f (CheckedDatabaseEntityDescriptor be (TableEntity tbl))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DatabaseEntityDescriptor be (TableEntity tbl)
x' -> DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable DatabaseEntityDescriptor be (TableEntity tbl)
x' [TableCheck]
cks tbl (Const [FieldCheck])
fcks) (DatabaseEntityDescriptor be (TableEntity tbl)
-> f (DatabaseEntityDescriptor be (TableEntity tbl))
f DatabaseEntityDescriptor be (TableEntity tbl)
x)
  collectEntityChecks :: CheckedDatabaseEntityDescriptor be (TableEntity tbl)
-> [SomeDatabasePredicate]
collectEntityChecks (CheckedDatabaseTable dt tblChecks tblFieldChecks) =
    [Maybe SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. [Maybe a] -> [a]
catMaybes ((TableCheck -> Maybe SomeDatabasePredicate)
-> [TableCheck] -> [Maybe SomeDatabasePredicate]
forall a b. (a -> b) -> [a] -> [b]
map (\(TableCheck forall (tbl :: (* -> *) -> *).
Table tbl =>
QualifiedName
-> tbl (TableField tbl) -> Maybe SomeDatabasePredicate
mkCheck) -> QualifiedName
-> tbl (TableField tbl) -> Maybe SomeDatabasePredicate
forall (tbl :: (* -> *) -> *).
Table tbl =>
QualifiedName
-> tbl (TableField tbl) -> Maybe SomeDatabasePredicate
mkCheck (DatabaseEntityDescriptor be (TableEntity tbl) -> QualifiedName
forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (TableEntity tbl)
dt) (DatabaseEntityDescriptor be (TableEntity tbl)
-> tbl (TableField tbl)
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt)) [TableCheck]
tblChecks) [SomeDatabasePredicate]
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate]
forall a. Semigroup a => a -> a -> a
<>
    Writer [SomeDatabasePredicate] (tbl (Const [FieldCheck]))
-> [SomeDatabasePredicate]
forall w a. Writer w a -> w
execWriter ((forall a.
 Columnar' (TableField tbl) a
 -> Columnar' (Const [FieldCheck]) a
 -> WriterT
      [SomeDatabasePredicate]
      Identity
      (Columnar' (Const [FieldCheck]) a))
-> tbl (TableField tbl)
-> tbl (Const [FieldCheck])
-> Writer [SomeDatabasePredicate] (tbl (Const [FieldCheck]))
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 tbl) a
fd) c :: Columnar' (Const [FieldCheck]) a
c@(Columnar' (Const fieldChecks)) ->
                                    [SomeDatabasePredicate]
-> WriterT [SomeDatabasePredicate] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ((FieldCheck -> SomeDatabasePredicate)
-> [FieldCheck] -> [SomeDatabasePredicate]
forall a b. (a -> b) -> [a] -> [b]
map (\(FieldCheck QualifiedName -> Text -> SomeDatabasePredicate
mkCheck) -> QualifiedName -> Text -> SomeDatabasePredicate
mkCheck (DatabaseEntityDescriptor be (TableEntity tbl) -> QualifiedName
forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (TableEntity tbl)
dt) (Columnar (TableField tbl) a
TableField tbl a
fd TableField tbl a -> Getting Text (TableField tbl a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName)) [FieldCheck]
fieldChecks) WriterT [SomeDatabasePredicate] Identity ()
-> WriterT
     [SomeDatabasePredicate] Identity (Columnar' (Const [FieldCheck]) a)
-> WriterT
     [SomeDatabasePredicate] Identity (Columnar' (Const [FieldCheck]) a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                    Columnar' (Const [FieldCheck]) a
-> WriterT
     [SomeDatabasePredicate] Identity (Columnar' (Const [FieldCheck]) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Columnar' (Const [FieldCheck]) a
c)
                               (DatabaseEntityDescriptor be (TableEntity tbl)
-> tbl (TableField tbl)
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt) tbl (Const [FieldCheck])
tblFieldChecks)

  checkedDbEntityAuto :: Text -> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
checkedDbEntityAuto Text
tblTypeName =
    let tblChecks :: [TableCheck]
tblChecks =
          [ (forall (tbl :: (* -> *) -> *).
 Table tbl =>
 QualifiedName
 -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
TableCheck ((forall (tbl :: (* -> *) -> *).
  Table tbl =>
  QualifiedName
  -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
 -> TableCheck)
-> (forall (tbl :: (* -> *) -> *).
    Table tbl =>
    QualifiedName
    -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
forall a b. (a -> b) -> a -> b
$ \QualifiedName
tblName tbl (TableField tbl)
_ ->
              SomeDatabasePredicate -> Maybe SomeDatabasePredicate
forall a. a -> Maybe a
Just (TableExistsPredicate -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (QualifiedName -> TableExistsPredicate
TableExistsPredicate QualifiedName
tblName))
          , (forall (tbl :: (* -> *) -> *).
 Table tbl =>
 QualifiedName
 -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
TableCheck ((forall (tbl :: (* -> *) -> *).
  Table tbl =>
  QualifiedName
  -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
 -> TableCheck)
-> (forall (tbl :: (* -> *) -> *).
    Table tbl =>
    QualifiedName
    -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)
-> TableCheck
forall a b. (a -> b) -> a -> b
$ \QualifiedName
tblName tbl (TableField tbl)
tblFields ->
              case (forall a. Columnar' (TableField tbl) a -> Text)
-> PrimaryKey tbl (TableField tbl) -> [Text]
forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField tbl) a
fd) -> Columnar (TableField tbl) a
TableField tbl a
fd TableField tbl a -> Getting Text (TableField tbl a) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl a) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) (tbl (TableField tbl) -> PrimaryKey tbl (TableField tbl)
forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey tbl (TableField tbl)
tblFields) of
                [] -> Maybe SomeDatabasePredicate
forall a. Maybe a
Nothing
                [Text]
pkFields -> SomeDatabasePredicate -> Maybe SomeDatabasePredicate
forall a. a -> Maybe a
Just (TableHasPrimaryKey -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (QualifiedName -> [Text] -> TableHasPrimaryKey
TableHasPrimaryKey QualifiedName
tblName [Text]
pkFields))
          ]

        fieldChecks :: tbl (Const [FieldCheck])
fieldChecks = Rep (tbl (Const [FieldCheck])) () -> tbl (Const [FieldCheck])
forall a x. Generic a => Rep a x -> a
to (Proxy be
-> Proxy (Rep (tbl Identity))
-> Bool
-> Rep (tbl (Const [FieldCheck])) ()
forall be (i :: * -> *) (fieldCheck :: * -> *).
GMigratableTableSettings be i fieldCheck =>
Proxy be -> Proxy i -> Bool -> fieldCheck ()
gDefaultTblSettingsChecks (Proxy be
forall k (t :: k). Proxy t
Proxy @be) (Proxy (Rep (tbl Identity))
forall k (t :: k). Proxy t
Proxy @(Rep (tbl Identity))) Bool
False)
    in DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable (Text -> DatabaseEntityDescriptor be (TableEntity tbl)
forall be entityType.
(IsDatabaseEntity be entityType,
 DatabaseEntityDefaultRequirements be entityType) =>
Text -> DatabaseEntityDescriptor be entityType
dbEntityAuto Text
tblTypeName) [TableCheck]
tblChecks tbl (Const [FieldCheck])
fieldChecks

-- | Purposefully opaque type describing how to modify a table field. Used to
-- parameterize the second argument to 'modifyCheckedTable'. For now, the only
-- way to construct a value is the 'IsString' instance, which allows you to
-- rename the field.
data CheckedFieldModification tbl a
  = CheckedFieldModification
      (TableField tbl a -> TableField tbl a)
      ([FieldCheck] -> [FieldCheck])

checkedFieldNamed :: Text -> CheckedFieldModification tbl a
checkedFieldNamed :: Text -> CheckedFieldModification tbl a
checkedFieldNamed Text
t = (TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification ((Text -> Identity Text)
-> TableField tbl a -> Identity (TableField tbl a)
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName ((Text -> Identity Text)
 -> TableField tbl a -> Identity (TableField tbl a))
-> Text -> TableField tbl a -> TableField tbl a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
t) [FieldCheck] -> [FieldCheck]
forall a. a -> a
id

instance IsString (CheckedFieldModification tbl a) where
  fromString :: String -> CheckedFieldModification tbl a
fromString = Text -> CheckedFieldModification tbl a
forall (tbl :: (* -> *) -> *) a.
Text -> CheckedFieldModification tbl a
checkedFieldNamed (Text -> CheckedFieldModification tbl a)
-> (String -> Text) -> String -> CheckedFieldModification tbl a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

instance Beamable tbl => RenamableWithRule (tbl (CheckedFieldModification tbl)) where
  renamingFields :: (NonEmpty Text -> Text) -> tbl (CheckedFieldModification tbl)
renamingFields NonEmpty Text -> Text
renamer =
    Identity (tbl (CheckedFieldModification tbl))
-> tbl (CheckedFieldModification tbl)
forall a. Identity a -> a
runIdentity (Identity (tbl (CheckedFieldModification tbl))
 -> tbl (CheckedFieldModification tbl))
-> Identity (tbl (CheckedFieldModification tbl))
-> tbl (CheckedFieldModification tbl)
forall a b. (a -> b) -> a -> b
$
    (forall a.
 Columnar' Ignored a
 -> Columnar' Ignored a
 -> Identity (Columnar' (CheckedFieldModification tbl) a))
-> tbl Ignored
-> tbl Ignored
-> Identity (tbl (CheckedFieldModification tbl))
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' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
                       Columnar' (CheckedFieldModification tbl) a
-> Identity (Columnar' (CheckedFieldModification tbl) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Columnar (CheckedFieldModification tbl) a
-> Columnar' (CheckedFieldModification tbl) a
forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' ((TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification (Proxy (TableField tbl)
-> Proxy a
-> (NonEmpty Text -> Text)
-> Columnar (TableField tbl) a
-> Columnar (TableField tbl) a
forall (f :: * -> *) a.
RenamableField f =>
Proxy f
-> Proxy a
-> (NonEmpty Text -> Text)
-> Columnar f a
-> Columnar f a
renameField (Proxy (TableField tbl)
forall k (t :: k). Proxy t
Proxy @(TableField tbl)) (Proxy a
forall k (t :: k). Proxy t
Proxy @x) NonEmpty Text -> Text
renamer) [FieldCheck] -> [FieldCheck]
forall a. a -> a
id :: CheckedFieldModification tbl x) ::
                               Columnar' (CheckedFieldModification tbl) x))
                   (tbl Ignored
forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (tbl Ignored
forall a. HasCallStack => a
undefined :: TableSkeleton tbl)

-- | Modify a checked table.
--
--   The first argument is a function that takes the original table name as
--   input and produces a new table name.
--
--   The second argument gives instructions on how to rename each field in the
--   table. Use 'checkedTableModification' to create a value of this type which
--   does no renaming. Each field in the table supplied here has the type
--   'CheckedFieldModification'. Most commonly, the programmer will use the
--   @OverloadedStrings@ instance to provide a new name.
--
-- == Examples
--
--    Rename a table, without renaming any of its fields:
--
-- @
-- modifyCheckedTable (\_ -> "NewTblNm") checkedTableModification
-- @
--
--    Modify a table, renaming the field called @_field1@ in Haskell to
--    "FirstName". Note that below, @"FirstName"@ represents a
--    'CheckedFieldModification' object.
--
-- @
-- modifyCheckedTable id (checkedTableModification { _field1 = "FirstName" })
-- @

modifyCheckedTable
  :: ( Text -> Text )
  -> tbl (CheckedFieldModification tbl)
  -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl)
modifyCheckedTable :: (Text -> Text)
-> tbl (CheckedFieldModification tbl)
-> EntityModification
     (CheckedDatabaseEntity be db) be (TableEntity tbl)
modifyCheckedTable Text -> Text
renamer tbl (CheckedFieldModification tbl)
modFields =
  Endo (CheckedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (CheckedDatabaseEntity be db) be (TableEntity tbl)
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (Endo (CheckedDatabaseEntity be db (TableEntity tbl))
 -> EntityModification
      (CheckedDatabaseEntity be db) be (TableEntity tbl))
-> Endo (CheckedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (CheckedDatabaseEntity be db) be (TableEntity tbl)
forall a b. (a -> b) -> a -> b
$ (CheckedDatabaseEntity be db (TableEntity tbl)
 -> CheckedDatabaseEntity be db (TableEntity tbl))
-> Endo (CheckedDatabaseEntity be db (TableEntity tbl))
forall a. (a -> a) -> Endo a
Endo ((CheckedDatabaseEntity be db (TableEntity tbl)
  -> CheckedDatabaseEntity be db (TableEntity tbl))
 -> Endo (CheckedDatabaseEntity be db (TableEntity tbl)))
-> (CheckedDatabaseEntity be db (TableEntity tbl)
    -> CheckedDatabaseEntity be db (TableEntity tbl))
-> Endo (CheckedDatabaseEntity be db (TableEntity tbl))
forall a b. (a -> b) -> a -> b
$
  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) [SomeDatabasePredicate]
extraChecks) ->
    let fields' :: tbl (TableField tbl)
fields' =
          Identity (tbl (TableField tbl)) -> tbl (TableField tbl)
forall a. Identity a -> a
runIdentity (Identity (tbl (TableField tbl)) -> tbl (TableField tbl))
-> Identity (tbl (TableField tbl)) -> tbl (TableField tbl)
forall a b. (a -> b) -> a -> b
$
          (forall a.
 Columnar' (CheckedFieldModification tbl) a
 -> Columnar' (TableField tbl) a
 -> Identity (Columnar' (TableField tbl) a))
-> tbl (CheckedFieldModification tbl)
-> tbl (TableField tbl)
-> Identity (tbl (TableField tbl))
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' (CheckedFieldModification fieldMod _)) (Columnar' Columnar (TableField tbl) a
field) ->
                             Columnar' (TableField tbl) a
-> Identity (Columnar' (TableField tbl) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Columnar' (TableField tbl) a
 -> Identity (Columnar' (TableField tbl) a))
-> Columnar' (TableField tbl) a
-> Identity (Columnar' (TableField tbl) a)
forall a b. (a -> b) -> a -> b
$ Columnar (TableField tbl) a -> Columnar' (TableField tbl) a
forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (TableField tbl a -> TableField tbl a
fieldMod Columnar (TableField tbl) a
TableField tbl a
field))
                         tbl (CheckedFieldModification tbl)
modFields (DatabaseEntityDescriptor be (TableEntity tbl)
-> tbl (TableField tbl)
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt)
        fieldChecks' :: tbl (Const [FieldCheck])
fieldChecks' =
          Identity (tbl (Const [FieldCheck])) -> tbl (Const [FieldCheck])
forall a. Identity a -> a
runIdentity (Identity (tbl (Const [FieldCheck])) -> tbl (Const [FieldCheck]))
-> Identity (tbl (Const [FieldCheck])) -> tbl (Const [FieldCheck])
forall a b. (a -> b) -> a -> b
$
          (forall a.
 Columnar' (CheckedFieldModification tbl) a
 -> Columnar' (Const [FieldCheck]) a
 -> Identity (Columnar' (Const [FieldCheck]) a))
-> tbl (CheckedFieldModification tbl)
-> tbl (Const [FieldCheck])
-> Identity (tbl (Const [FieldCheck]))
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' (CheckedFieldModification _ csMod)) (Columnar' (Const cs)) ->
                             Columnar' (Const [FieldCheck]) a
-> Identity (Columnar' (Const [FieldCheck]) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Columnar' (Const [FieldCheck]) a
 -> Identity (Columnar' (Const [FieldCheck]) a))
-> Columnar' (Const [FieldCheck]) a
-> Identity (Columnar' (Const [FieldCheck]) a)
forall a b. (a -> b) -> a -> b
$ Columnar (Const [FieldCheck]) a -> Columnar' (Const [FieldCheck]) a
forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' ([FieldCheck] -> Const [FieldCheck] a
forall k a (b :: k). a -> Const a b
Const ([FieldCheck] -> [FieldCheck]
csMod [FieldCheck]
cs)))
                         tbl (CheckedFieldModification tbl)
modFields tbl (Const [FieldCheck])
fieldChecks
    in CheckedDatabaseEntityDescriptor be (TableEntity tbl)
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db (TableEntity tbl)
forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity (DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable
                                (DatabaseEntityDescriptor be (TableEntity tbl)
R:DatabaseEntityDescriptorbeTableEntity be tbl
dt { dbTableCurrentName :: Text
dbTableCurrentName = Text -> Text
renamer (DatabaseEntityDescriptor be (TableEntity tbl) -> Text
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableCurrentName DatabaseEntityDescriptor be (TableEntity tbl)
dt)
                                    , dbTableSettings :: tbl (TableField tbl)
dbTableSettings = tbl (TableField tbl)
fields'})
                                [TableCheck]
tblChecks tbl (Const [FieldCheck])
fieldChecks') [SomeDatabasePredicate]
extraChecks

-- | Produce a table field modification that does nothing
--
--   Most commonly supplied as the second argument to 'modifyCheckedTable' when
--   you just want to rename the table, not the fields.
checkedTableModification :: forall tbl. Beamable tbl => tbl (CheckedFieldModification tbl)
checkedTableModification :: tbl (CheckedFieldModification tbl)
checkedTableModification =
  Identity (tbl (CheckedFieldModification tbl))
-> tbl (CheckedFieldModification tbl)
forall a. Identity a -> a
runIdentity (Identity (tbl (CheckedFieldModification tbl))
 -> tbl (CheckedFieldModification tbl))
-> Identity (tbl (CheckedFieldModification tbl))
-> tbl (CheckedFieldModification tbl)
forall a b. (a -> b) -> a -> b
$
  (forall a.
 Columnar' Ignored a
 -> Columnar' Ignored a
 -> Identity (Columnar' (CheckedFieldModification tbl) a))
-> tbl Ignored
-> tbl Ignored
-> Identity (tbl (CheckedFieldModification tbl))
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' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
                    Columnar' (CheckedFieldModification tbl) a
-> Identity (Columnar' (CheckedFieldModification tbl) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Columnar (CheckedFieldModification tbl) a
-> Columnar' (CheckedFieldModification tbl) a
forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' ((TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification TableField tbl a -> TableField tbl a
forall a. a -> a
id [FieldCheck] -> [FieldCheck]
forall a. a -> a
id :: CheckedFieldModification tbl x)))
                 (tbl Ignored
forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (tbl Ignored
forall a. HasCallStack => a
undefined :: TableSkeleton tbl)