{-# 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.Monoid
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 forall s a. s -> Getting a s a -> a
^. 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 :: forall be (db :: (* -> *) -> *) ent.
(Text -> Text)
-> EntityModification (CheckedDatabaseEntity be db) be ent
renameCheckedEntity Text -> Text
renamer =
  forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (forall a. (a -> a) -> Endo a
Endo (\(CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be ent
desc [SomeDatabasePredicate]
checks) -> (forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity (CheckedDatabaseEntityDescriptor be ent
desc forall a b. a -> (a -> b) -> b
& forall be entity.
IsCheckedDatabaseEntity be entity =>
Lens'
  (CheckedDatabaseEntityDescriptor be entity)
  (DatabaseEntityDescriptor be entity)
unChecked forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName 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 :: forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> DatabaseSettings be db
unCheckDatabase CheckedDatabaseSettings be db
db = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ 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 (forall {k} (t :: k). Proxy t
Proxy @be) (\(CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be tbl
x [SomeDatabasePredicate]
_) CheckedDatabaseEntity be db tbl
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (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 :: forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db = let (CheckedDatabaseSettings be db
_ :: CheckedDatabaseSettings be db, [SomeDatabasePredicate]
a) =
                         forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ 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 (forall {k} (t :: k). Proxy t
Proxy @be)
                           (\(CheckedDatabaseEntity CheckedDatabaseEntityDescriptor be tbl
entity [SomeDatabasePredicate]
cs :: CheckedDatabaseEntity be db entityType) CheckedDatabaseEntity be db tbl
b ->
                              do forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall be entity.
IsCheckedDatabaseEntity be entity =>
CheckedDatabaseEntityDescriptor be entity
-> [SomeDatabasePredicate]
collectEntityChecks CheckedDatabaseEntityDescriptor be tbl
entity)
                                 forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [SomeDatabasePredicate]
cs
                                 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 :: Lens'
  (CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty))
  (DatabaseEntityDescriptor be (DomainTypeEntity ty))
unChecked DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> f (DatabaseEntityDescriptor be (DomainTypeEntity ty))
f (CheckedDatabaseDomainType DatabaseEntityDescriptor be (DomainTypeEntity ty)
x [DomainCheck]
cks) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DatabaseEntityDescriptor be (DomainTypeEntity ty)
x' -> 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 DatabaseEntityDescriptor be (DomainTypeEntity ty)
dt [DomainCheck]
domainChecks) =
    forall a b. (a -> b) -> [a] -> [b]
map (\(DomainCheck QualifiedName -> SomeDatabasePredicate
mkCheck) -> QualifiedName -> SomeDatabasePredicate
mkCheck (forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (DomainTypeEntity ty)
dt)) [DomainCheck]
domainChecks
  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements
  be (DomainTypeEntity ty) =>
Text -> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
checkedDbEntityAuto Text
domTypeName =
    forall be ty.
DatabaseEntityDescriptor be (DomainTypeEntity ty)
-> [DomainCheck]
-> CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty)
CheckedDatabaseDomainType (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 :: Lens'
  (CheckedDatabaseEntityDescriptor be (TableEntity tbl))
  (DatabaseEntityDescriptor be (TableEntity tbl))
unChecked DatabaseEntityDescriptor be (TableEntity tbl)
-> f (DatabaseEntityDescriptor be (TableEntity tbl))
f (CheckedDatabaseTable DatabaseEntityDescriptor be (TableEntity tbl)
x [TableCheck]
cks tbl (Const [FieldCheck])
fcks) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DatabaseEntityDescriptor be (TableEntity tbl)
x' -> 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 DatabaseEntityDescriptor be (TableEntity tbl)
dt [TableCheck]
tblChecks tbl (Const [FieldCheck])
tblFieldChecks) =
    forall a. [Maybe a] -> [a]
catMaybes (forall a b. (a -> b) -> [a] -> [b]
map (\(TableCheck forall (tbl :: (* -> *) -> *).
Table tbl =>
QualifiedName
-> tbl (TableField tbl) -> Maybe SomeDatabasePredicate
mkCheck) -> forall (tbl :: (* -> *) -> *).
Table tbl =>
QualifiedName
-> tbl (TableField tbl) -> Maybe SomeDatabasePredicate
mkCheck (forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (TableEntity tbl)
dt) (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt)) [TableCheck]
tblChecks) forall a. Semigroup a => a -> a -> a
<>
    forall w a. Writer w a -> w
execWriter (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 [FieldCheck]
fieldChecks)) ->
                                    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall a b. (a -> b) -> [a] -> [b]
map (\(FieldCheck QualifiedName -> Text -> SomeDatabasePredicate
mkCheck) -> QualifiedName -> Text -> SomeDatabasePredicate
mkCheck (forall be entity.
IsDatabaseEntity be entity =>
DatabaseEntityDescriptor be entity -> QualifiedName
qname DatabaseEntityDescriptor be (TableEntity tbl)
dt) (Columnar (TableField tbl) a
fd forall s a. s -> Getting a s a -> a
^. forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName)) [FieldCheck]
fieldChecks) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Columnar' (Const [FieldCheck]) a
c)
                               (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt) tbl (Const [FieldCheck])
tblFieldChecks)

  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl) =>
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 a b. (a -> b) -> a -> b
$ \QualifiedName
tblName tbl (TableField tbl)
_ ->
              forall a. a -> Maybe a
Just (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 a b. (a -> b) -> a -> b
$ \QualifiedName
tblName tbl (TableField tbl)
tblFields ->
              case 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
fd forall s a. s -> Getting a s a -> a
^. forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName) (forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey tbl (TableField tbl)
tblFields) of
                [] -> forall a. Maybe a
Nothing
                [Text]
pkFields -> forall a. a -> Maybe a
Just (forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (QualifiedName -> [Text] -> TableHasPrimaryKey
TableHasPrimaryKey QualifiedName
tblName [Text]
pkFields))
          ]

        fieldChecks :: tbl (Const [FieldCheck])
fieldChecks = forall a x. Generic a => Rep a x -> a
to (forall be (i :: * -> *) (fieldCheck :: * -> *).
GMigratableTableSettings be i fieldCheck =>
Proxy be -> Proxy i -> Bool -> fieldCheck ()
gDefaultTblSettingsChecks (forall {k} (t :: k). Proxy t
Proxy @be) (forall {k} (t :: k). Proxy t
Proxy @(Rep (tbl Identity))) Bool
False)
    in forall (tbl :: (* -> *) -> *) be.
Table tbl =>
DatabaseEntityDescriptor be (TableEntity tbl)
-> [TableCheck]
-> tbl (Const [FieldCheck])
-> CheckedDatabaseEntityDescriptor be (TableEntity tbl)
CheckedDatabaseTable (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 :: forall (tbl :: (* -> *) -> *) a.
Text -> CheckedFieldModification tbl a
checkedFieldNamed Text
t = forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification (forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
t) forall a. a -> a
id

instance IsString (CheckedFieldModification tbl a) where
  fromString :: String -> CheckedFieldModification tbl a
fromString = forall (tbl :: (* -> *) -> *) a.
Text -> CheckedFieldModification tbl a
checkedFieldNamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    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 Ignored a
_ :: Columnar' Ignored x) (Columnar' Columnar Ignored a
_ :: Columnar' Ignored x) ->
                       forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification (forall (f :: * -> *) a.
RenamableField f =>
Proxy f
-> Proxy a
-> (NonEmpty Text -> Text)
-> Columnar f a
-> Columnar f a
renameField (forall {k} (t :: k). Proxy t
Proxy @(TableField tbl)) (forall {k} (t :: k). Proxy t
Proxy @x) NonEmpty Text -> Text
renamer) forall a. a -> a
id :: CheckedFieldModification tbl x) ::
                               Columnar' (CheckedFieldModification tbl) x))
                   (forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (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 :: forall (tbl :: (* -> *) -> *) be (db :: (* -> *) -> *).
(Text -> Text)
-> tbl (CheckedFieldModification tbl)
-> EntityModification
     (CheckedDatabaseEntity be db) be (TableEntity tbl)
modifyCheckedTable Text -> Text
renamer tbl (CheckedFieldModification tbl)
modFields =
  forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$
  \(CheckedDatabaseEntity (CheckedDatabaseTable DatabaseEntityDescriptor be (TableEntity tbl)
dt [TableCheck]
tblChecks tbl (Const [FieldCheck])
fieldChecks) [SomeDatabasePredicate]
extraChecks) ->
    let fields' :: tbl (TableField tbl)
fields' =
          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' (CheckedFieldModification TableField tbl a -> TableField tbl a
fieldMod [FieldCheck] -> [FieldCheck]
_)) (Columnar' Columnar (TableField tbl) a
field) ->
                             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (TableField tbl a -> TableField tbl a
fieldMod Columnar (TableField tbl) a
field))
                         tbl (CheckedFieldModification tbl)
modFields (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
dt)
        fieldChecks' :: tbl (Const [FieldCheck])
fieldChecks' =
          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' (CheckedFieldModification TableField tbl a -> TableField tbl a
_ [FieldCheck] -> [FieldCheck]
csMod)) (Columnar' (Const [FieldCheck]
cs)) ->
                             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall {k} a (b :: k). a -> Const a b
Const ([FieldCheck] -> [FieldCheck]
csMod [FieldCheck]
cs)))
                         tbl (CheckedFieldModification tbl)
modFields tbl (Const [FieldCheck])
fieldChecks
    in 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
                                (DatabaseEntityDescriptor be (TableEntity tbl)
dt { dbTableCurrentName :: Text
dbTableCurrentName = Text -> Text
renamer (forall (tbl :: (* -> *) -> *) be.
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 :: forall (tbl :: (* -> *) -> *).
Beamable tbl =>
tbl (CheckedFieldModification tbl)
checkedTableModification =
  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 Ignored a
_ :: Columnar' Ignored x) (Columnar' Columnar Ignored a
_ :: Columnar' Ignored x) ->
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (tbl :: (* -> *) -> *) a.
(TableField tbl a -> TableField tbl a)
-> ([FieldCheck] -> [FieldCheck]) -> CheckedFieldModification tbl a
CheckedFieldModification forall a. a -> a
id forall a. a -> a
id :: CheckedFieldModification tbl x)))
                 (forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (forall a. HasCallStack => a
undefined :: TableSkeleton tbl)