{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides an 'AnnotatedDatabaseSettings' type to be used as a drop-in replacement for the
-- standard 'DatabaseSettings'. Is it possible to \"downcast\" an 'AnnotatedDatabaseSettings' to a standard
-- 'DatabaseSettings' simply by calling 'deAnnotateDatabase'.
module Database.Beam.AutoMigrate.Annotated
  ( -- * User annotations
    Annotation (..),

    -- * Annotating a 'DatabaseSettings'
    AnnotatedDatabaseSettings,
    AnnotatedDatabaseEntity (..),
    IsAnnotatedDatabaseEntity (..),
    TableSchema,
    TableFieldSchema (..),
    FieldSchema (..),
    dbAnnotatedSchema,
    dbAnnotatedConstraints,
    annotatedDescriptor,
    defaultTableSchema,
    GDefaultTableSchema(..),

    -- * Downcasting annotated types
    lowerEntityDescriptor,
    deannotate,

    -- * Specifying constraints
    -- $specifyingConstraints
    annotateTableFields,

    -- * Specifying Column constraints
    -- $specifyingColumnConstraints
    defaultsTo,

    -- * Specifying Table constraints
    -- $specifyingTableConstraints
    UniqueConstraint (..),

    -- ** Unique constraint
    uniqueConstraintOn,

    -- ** Foreign key constraint
    ForeignKeyConstraint (..),
    foreignKeyOnPk,
    foreignKeyOn,

    -- * Other types and functions
    TableKind,
    DatabaseKind,

    -- * Ports from Beam
    zipTables,
    GZipDatabase,

    -- * Internals
    pgDefaultConstraint,
  )
where

import Data.Kind
import Data.Monoid (Endo (..))
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Database.Beam as Beam
import Database.Beam.AutoMigrate.Compat
import Database.Beam.AutoMigrate.Types
import Database.Beam.AutoMigrate.Util
import Database.Beam.Backend.SQL (HasSqlValueSyntax (..), displaySyntax)
import Database.Beam.Postgres (Postgres)
import qualified Database.Beam.Postgres.Syntax as Pg
import Database.Beam.Query (QExpr)
import Database.Beam.Schema.Tables
  ( DatabaseEntity,
    DatabaseEntityDefaultRequirements,
    DatabaseEntityDescriptor,
    DatabaseEntityRegularRequirements,
    EntityModification (..),
    FieldModification (..),
    IsDatabaseEntity,
    PrimaryKey,
    TableEntity,
    dbEntityDescriptor,
    dbEntityName,
    dbTableSettings,
  )
import GHC.Generics as Generic
import Lens.Micro (SimpleGetter, (^.))
import qualified Lens.Micro as Lens

--
-- Annotating a 'DatabaseSettings' with meta information.
--

-- | To make kind signatures more readable.
type DatabaseKind = (Type -> Type) -> Type

-- | To make kind signatures more readable.
type TableKind = (Type -> Type) -> Type

-- | A user-defined annotation. Currently the only possible annotation is the ability to specify for which
-- tables the FK-discovery algorithm is \"turned\" off.
data Annotation where
  -- | Specifies that the given 'TableKind' (i.e. a table) has user-specified FK constraints. This is
  -- useful in case of ambiguity, i.e. when the automatic FK-discovery algorithm is not capable to
  -- infer the correct 'ForeignKey' constraints for a 'Table'. This can happen when the 'PrimaryKey' type
  -- family is not injective, which means there are multiple tables of table @FooT@ in the DB. Consider a
  -- situation where we have a table @BarT@ having a field of type @barField :: PrimaryKey FooT f@ but
  -- (crucially) there are two tables with type @f (TableEntity FooT)@ in the final database. In this
  -- circumstance the FK-discovery algorithm will bail out with a (static) error, and this is where this
  -- annotation comes into play: it allows us to selectively \"disable\" the discovery for the given
  -- table(s), and manually override the FKs.
  --
  -- /Caveat emptor/: Due to what we said earlier (namely that we cannot enforce that tables are not
  -- repeated multiple times within a DB) there might be situations where also the specified 'TableKind'
  -- is not unique. In this case the annotation would affect all the tables of the same type, but that is
  -- usually unavoidable, as the ambiguity was already present the minute we introduced in the DB two tables
  -- of the same type, and so it makes sense for the user to fully resolve the ambiguity manually.
  UserDefinedFk :: TableKind -> Annotation

-- | Zip tables together. Unfortunately we cannot reuse the stock 'zipTables' from 'beam-core', because it
-- works by supplying a rank-2 function with 'IsDatabaseEntity' and 'DatabaseEntityRegularRequirements' as
-- witnesses, we we need the annotated counterparts instead.
--
-- This function can be written without the need of a typeclass, but alas it requires the /unexported/
-- 'GZipDatabase' from 'beam-core', so we had to re-implement this ourselves for now.
zipTables ::
  ( Generic (db f),
    Generic (db g),
    Generic (db h),
    Monad m,
    GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))
  ) =>
  Proxy be ->
  (forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) ->
  db f ->
  db g ->
  m (db h)
-- We need the pattern type signature on 'combine' to get around a type checking bug in GHC 8.0.1.
-- In future releases, we will switch to the standard forall.
zipTables :: Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
zipTables Proxy be
be forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine (db f
f :: db f) (db g
g :: db g) =
  (Proxy h -> m (db h)) -> m (db h)
forall (h :: * -> *) (m :: * -> *).
(Proxy h -> m (db h)) -> m (db h)
refl ((Proxy h -> m (db h)) -> m (db h))
-> (Proxy h -> m (db h)) -> m (db h)
forall a b. (a -> b) -> a -> b
$ \Proxy h
h ->
    Rep (db h) () -> db h
forall a x. Generic a => Rep a x -> a
to (Rep (db h) () -> db h) -> m (Rep (db h) ()) -> m (db h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> Rep (db f) ()
-> Rep (db g) ()
-> m (Rep (db h) ())
forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Monad m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
gZipDatabase (Proxy f
forall k (t :: k). Proxy t
Proxy @f, Proxy g
forall k (t :: k). Proxy t
Proxy @g, Proxy h
h, Proxy be
be) forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine (db f -> Rep (db f) ()
forall a x. Generic a => a -> Rep a x
from db f
f) (db g -> Rep (db g) ()
forall a x. Generic a => a -> Rep a x
from db g
g)
  where
    -- For GHC 8.0.1 renamer bug
    refl :: (Proxy h -> m (db h)) -> m (db h)
    refl :: (Proxy h -> m (db h)) -> m (db h)
refl Proxy h -> m (db h)
fn = Proxy h -> m (db h)
fn Proxy h
forall k (t :: k). Proxy t
Proxy

-- | See above on why this class has been re-implemented.
class GZipDatabase be f g h x y z where
  gZipDatabase ::
    Monad m =>
    (Proxy f, Proxy g, Proxy h, Proxy be) ->
    (forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) ->
    x () ->
    y () ->
    m (z ())

instance GZipDatabase be f g h x y z => GZipDatabase be f g h (M1 a b x) (M1 a b y) (M1 a b z) where
  gZipDatabase :: (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> M1 a b x ()
-> M1 a b y ()
-> m (M1 a b z ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
p forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(M1 x ()
f) ~(M1 y ()
g) = z () -> M1 a b z ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (z () -> M1 a b z ()) -> m (z ()) -> m (M1 a b z ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Monad m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
p forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine x ()
f y ()
g

instance
  ( GZipDatabase be f g h ax ay az,
    GZipDatabase be f g h bx by bz
  ) =>
  GZipDatabase be f g h (ax :*: bx) (ay :*: by) (az :*: bz)
  where
  gZipDatabase :: (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> (:*:) ax bx ()
-> (:*:) ay by ()
-> m ((:*:) az bz ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
p forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(ax ()
ax :*: bx ()
bx) ~(ay ()
ay :*: by ()
by) = do
    az ()
a <- (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> ax ()
-> ay ()
-> m (az ())
forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Monad m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
p forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ax ()
ax ay ()
ay
    bz ()
b <- (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> bx ()
-> by ()
-> m (bz ())
forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Monad m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
p forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine bx ()
bx by ()
by
    (:*:) az bz () -> m ((:*:) az bz ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (az ()
a az () -> bz () -> (:*:) az bz ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bz ()
b)

instance
  ( IsAnnotatedDatabaseEntity be tbl,
    AnnotatedDatabaseEntityRegularRequirements be tbl
  ) =>
  GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl))
  where
  gZipDatabase :: (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> K1 R (f tbl) ()
-> K1 R (g tbl) ()
-> m (K1 R (h tbl) ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
_ forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(K1 f tbl
x) ~(K1 g tbl
y) =
    h tbl -> K1 R (h tbl) ()
forall k i c (p :: k). c -> K1 i c p
K1 (h tbl -> K1 R (h tbl) ()) -> m (h tbl) -> m (K1 R (h tbl) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f tbl -> g tbl -> m (h tbl)
forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine f tbl
x g tbl
y

instance
  ( Beam.Database be db,
    Generic (db f),
    Generic (db g),
    Generic (db h),
    GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))
  ) =>
  GZipDatabase be f g h (K1 Generic.R (db f)) (K1 Generic.R (db g)) (K1 Generic.R (db h))
  where
  gZipDatabase :: (Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> K1 R (db f) ()
-> K1 R (db g) ()
-> m (K1 R (db h) ())
gZipDatabase (Proxy f, Proxy g, Proxy h, Proxy be)
_ forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(K1 db f
x) ~(K1 db g
y) =
    db h -> K1 R (db h) ()
forall k i c (p :: k). c -> K1 i c p
K1 (db h -> K1 R (db h) ()) -> m (db h) -> m (K1 R (db h) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> db f
-> db g
-> m (db h)
forall (db :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *) (m :: * -> *) be.
(Generic (db f), Generic (db g), Generic (db h), Monad m,
 GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h))) =>
Proxy be
-> (forall tbl.
    (IsAnnotatedDatabaseEntity be tbl,
     AnnotatedDatabaseEntityRegularRequirements 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 :: Proxy be) forall tbl.
(IsAnnotatedDatabaseEntity be tbl,
 AnnotatedDatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine db f
x db g
y

--
-- An annotated Database settings.
--

-- | An 'AnnotatedDatabaseSettings' is similar in spirit to a @beam-core@ 'DatabaseSettings', but it
-- embellish the latter with extra metadata this library can use to derive more information about the input
-- DB, like table and column constraints.
type AnnotatedDatabaseSettings be db = db (AnnotatedDatabaseEntity be db)

-- | An 'AnnotatedDatabaseEntity' wraps the underlying 'DatabaseEntity' together with an annotated
-- description called 'AnnotatedDatabaseEntityDescriptor', which is once again similar to the standard
-- 'DatabaseEntityDescriptor' from Beam.
--
-- An 'AnnotatedDatabaseEntityDescriptor' is not a concrete type, but rather a data family provided by the
-- 'IsAnnotatedDatabaseEntity'.
data AnnotatedDatabaseEntity be (db :: (* -> *) -> *) entityType where
  AnnotatedDatabaseEntity ::
    (IsAnnotatedDatabaseEntity be entityType, IsDatabaseEntity be entityType) =>
    AnnotatedDatabaseEntityDescriptor be entityType ->
    DatabaseEntity be db entityType ->
    AnnotatedDatabaseEntity be db entityType

class IsDatabaseEntity be entityType => IsAnnotatedDatabaseEntity be entityType where
  data AnnotatedDatabaseEntityDescriptor be entityType :: *
  type AnnotatedDatabaseEntityDefaultRequirements be entityType :: Constraint
  type AnnotatedDatabaseEntityRegularRequirements be entityType :: Constraint

  dbAnnotatedEntityAuto ::
    AnnotatedDatabaseEntityRegularRequirements be entityType =>
    DatabaseEntityDescriptor be entityType ->
    AnnotatedDatabaseEntityDescriptor be entityType

instance
  IsDatabaseEntity be (TableEntity tbl) =>
  IsAnnotatedDatabaseEntity be (TableEntity tbl)
  where
  data AnnotatedDatabaseEntityDescriptor be (TableEntity tbl) where
    AnnotatedDatabaseTable ::
      Beam.Table tbl =>
      { AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> TableSchema tbl
dbAnnotatedSchema :: TableSchema tbl,
        AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
dbAnnotatedConstraints :: Set TableConstraint
      } ->
      AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
  type
    AnnotatedDatabaseEntityDefaultRequirements be (TableEntity tbl) =
      (DatabaseEntityDefaultRequirements be (TableEntity tbl))
  type
    AnnotatedDatabaseEntityRegularRequirements be (TableEntity tbl) =
      ( DatabaseEntityRegularRequirements be (TableEntity tbl),
        GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()),
        Generic (TableSchema tbl),
        Generic (Beam.TableSettings tbl)
      )

  dbAnnotatedEntityAuto :: DatabaseEntityDescriptor be (TableEntity tbl)
-> AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
dbAnnotatedEntityAuto DatabaseEntityDescriptor be (TableEntity tbl)
edesc = TableSchema tbl
-> Set TableConstraint
-> AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
forall (tbl :: (* -> *) -> *) be.
Table tbl =>
TableSchema tbl
-> Set TableConstraint
-> AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
AnnotatedDatabaseTable (TableSettings tbl -> TableSchema tbl
forall (tbl :: (* -> *) -> *).
(GDefaultTableSchema
   (Rep (TableSchema tbl) ()) (Rep (TableSettings tbl) ()),
 Generic (TableSchema tbl), Generic (TableSettings tbl)) =>
TableSettings tbl -> TableSchema tbl
defaultTableSchema (TableSettings tbl -> TableSchema tbl)
-> (DatabaseEntityDescriptor be (TableEntity tbl)
    -> TableSettings tbl)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> TableSchema tbl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
forall be (tbl :: (* -> *) -> *).
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings (DatabaseEntityDescriptor be (TableEntity tbl) -> TableSchema tbl)
-> DatabaseEntityDescriptor be (TableEntity tbl) -> TableSchema tbl
forall a b. (a -> b) -> a -> b
$ DatabaseEntityDescriptor be (TableEntity tbl)
edesc) Set TableConstraint
forall a. Monoid a => a
mempty

-- | A 'SimpleGetter' to get a plain 'DatabaseEntityDescriptor' from an 'AnnotatedDatabaseEntity'.
lowerEntityDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
lowerEntityDescriptor :: Getting
  r
  (AnnotatedDatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
lowerEntityDescriptor = (AnnotatedDatabaseEntity be db entityType
 -> DatabaseEntityDescriptor be entityType)
-> SimpleGetter
     (AnnotatedDatabaseEntity be db entityType)
     (DatabaseEntityDescriptor be entityType)
forall s a. (s -> a) -> SimpleGetter s a
Lens.to (\(AnnotatedDatabaseEntity AnnotatedDatabaseEntityDescriptor be entityType
_ DatabaseEntity be db entityType
e) -> DatabaseEntity be db entityType
e DatabaseEntity be db entityType
-> Getting
     (DatabaseEntityDescriptor be entityType)
     (DatabaseEntity be db entityType)
     (DatabaseEntityDescriptor be entityType)
-> DatabaseEntityDescriptor be entityType
forall s a. s -> Getting a s a -> a
^. Getting
  (DatabaseEntityDescriptor be entityType)
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor)

annotatedDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (AnnotatedDatabaseEntityDescriptor be entityType)
annotatedDescriptor :: Getting
  r
  (AnnotatedDatabaseEntity be db entityType)
  (AnnotatedDatabaseEntityDescriptor be entityType)
annotatedDescriptor = (AnnotatedDatabaseEntity be db entityType
 -> AnnotatedDatabaseEntityDescriptor be entityType)
-> SimpleGetter
     (AnnotatedDatabaseEntity be db entityType)
     (AnnotatedDatabaseEntityDescriptor be entityType)
forall s a. (s -> a) -> SimpleGetter s a
Lens.to (\(AnnotatedDatabaseEntity AnnotatedDatabaseEntityDescriptor be entityType
e DatabaseEntity be db entityType
_) -> AnnotatedDatabaseEntityDescriptor be entityType
e)

deannotate :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntity be db entityType)
deannotate :: Getting
  r
  (AnnotatedDatabaseEntity be db entityType)
  (DatabaseEntity be db entityType)
deannotate = (AnnotatedDatabaseEntity be db entityType
 -> DatabaseEntity be db entityType)
-> SimpleGetter
     (AnnotatedDatabaseEntity be db entityType)
     (DatabaseEntity be db entityType)
forall s a. (s -> a) -> SimpleGetter s a
Lens.to (\(AnnotatedDatabaseEntity AnnotatedDatabaseEntityDescriptor be entityType
_ DatabaseEntity be db entityType
e) -> DatabaseEntity be db entityType
e)

-- | A table schema.
type TableSchema tbl =
  tbl (TableFieldSchema tbl)

-- | A schema for a field within a given table
data TableFieldSchema (tbl :: (* -> *) -> *) ty where
  TableFieldSchema ::
    { TableFieldSchema tbl ty -> ColumnName
tableFieldName :: ColumnName,
      TableFieldSchema tbl ty -> FieldSchema ty
tableFieldSchema :: FieldSchema ty
    } ->
    TableFieldSchema tbl ty

data FieldSchema ty where
  FieldSchema ::
    ColumnType ->
    Set ColumnConstraint ->
    FieldSchema ty

deriving instance Show (FieldSchema ty)

--
-- Deriving a 'TableSchema'.
--

class GDefaultTableSchema x y where
  gDefTblSchema :: Proxy x -> y -> x

instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (D1 f x p) (D1 f y p) where
  gDefTblSchema :: Proxy (D1 f x p) -> D1 f y p -> D1 f x p
gDefTblSchema (Proxy (D1 f x p)
Proxy :: Proxy (D1 f x p)) (M1 y p
y) =
    x p -> D1 f x p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (x p -> D1 f x p) -> x p -> D1 f x p
forall a b. (a -> b) -> a -> b
$ Proxy (x p) -> y p -> x p
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema (Proxy (x p)
forall k (t :: k). Proxy t
Proxy :: Proxy (x p)) y p
y

instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (C1 f x p) (C1 f y p) where
  gDefTblSchema :: Proxy (C1 f x p) -> C1 f y p -> C1 f x p
gDefTblSchema (Proxy (C1 f x p)
Proxy :: Proxy (C1 f x p)) (M1 y p
y) =
    x p -> C1 f x p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (x p -> C1 f x p) -> x p -> C1 f x p
forall a b. (a -> b) -> a -> b
$ Proxy (x p) -> y p -> x p
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema (Proxy (x p)
forall k (t :: k). Proxy t
Proxy :: Proxy (x p)) y p
y

instance
  (GDefaultTableSchema (a p) (c p), GDefaultTableSchema (b p) (d p)) =>
  GDefaultTableSchema ((a :*: b) p) ((c :*: d) p)
  where
  gDefTblSchema :: Proxy ((:*:) a b p) -> (:*:) c d p -> (:*:) a b p
gDefTblSchema (Proxy ((:*:) a b p)
Proxy :: Proxy ((a :*: b) p)) (c p
c :*: d p
d) =
    Proxy (a p) -> c p -> a p
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema (Proxy (a p)
forall k (t :: k). Proxy t
Proxy :: Proxy (a p)) c p
c
      a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Proxy (b p) -> d p -> b p
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema (Proxy (b p)
forall k (t :: k). Proxy t
Proxy :: Proxy (b p)) d p
d

instance
  ( SchemaConstraint (Beam.TableField tbl ty) ~ ColumnConstraint,
    HasSchemaConstraints (Beam.TableField tbl ty),
    HasColumnType ty
  ) =>
  GDefaultTableSchema
    (S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p)
    (S1 f (K1 Generic.R (Beam.TableField tbl ty)) p)
  where
  gDefTblSchema :: Proxy (S1 f (K1 R (TableFieldSchema tbl ty)) p)
-> S1 f (K1 R (TableField tbl ty)) p
-> S1 f (K1 R (TableFieldSchema tbl ty)) p
gDefTblSchema (Proxy (S1 f (K1 R (TableFieldSchema tbl ty)) p)
_ :: Proxy (S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p)) (M1 (K1 TableField tbl ty
fName)) = K1 R (TableFieldSchema tbl ty) p
-> S1 f (K1 R (TableFieldSchema tbl ty)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (TableFieldSchema tbl ty -> K1 R (TableFieldSchema tbl ty) p
forall k i c (p :: k). c -> K1 i c p
K1 TableFieldSchema tbl ty
s)
    where
      s :: TableFieldSchema tbl ty
s = ColumnName -> FieldSchema ty -> TableFieldSchema tbl ty
forall ty (tbl :: (* -> *) -> *).
ColumnName -> FieldSchema ty -> TableFieldSchema tbl ty
TableFieldSchema (Text -> ColumnName
ColumnName (Text -> ColumnName) -> Text -> ColumnName
forall a b. (a -> b) -> a -> b
$ TableField tbl ty
fName TableField tbl ty -> Getting Text (TableField tbl ty) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl ty) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
Beam.fieldName) FieldSchema ty
defaultFieldSchema
      defaultFieldSchema :: FieldSchema ty
defaultFieldSchema =
        ColumnType -> Set ColumnConstraint -> FieldSchema ty
forall ty. ColumnType -> Set ColumnConstraint -> FieldSchema ty
FieldSchema
          (Proxy ty -> ColumnType
forall ty. HasColumnType ty => Proxy ty -> ColumnType
defaultColumnType (Proxy ty
forall k (t :: k). Proxy t
Proxy @ty))
          (Proxy (TableField tbl ty)
-> Set (SchemaConstraint (TableField tbl ty))
forall ty.
HasSchemaConstraints ty =>
Proxy ty -> Set (SchemaConstraint ty)
schemaConstraints (Proxy (TableField tbl ty)
forall k (t :: k). Proxy t
Proxy @(Beam.TableField tbl ty)))

-- | Instance where /g/ is things like a 'PrimaryKey' or a /mixin/.
instance
  ( Generic (g (Beam.TableField tbl2)),
    Generic (g (TableFieldSchema tbl2)),
    GDefaultTableSchema
      (Rep (g (TableFieldSchema tbl2)) ())
      (Rep (g (Beam.TableField tbl2)) ())
  ) =>
  GDefaultTableSchema
    (S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ())
    (S1 f (K1 Generic.R (g (Beam.TableField tbl2))) ())
  where
  gDefTblSchema :: Proxy (S1 f (K1 R (g (TableFieldSchema tbl2))) ())
-> S1 f (K1 R (g (TableField tbl2))) ()
-> S1 f (K1 R (g (TableFieldSchema tbl2))) ()
gDefTblSchema (Proxy (S1 f (K1 R (g (TableFieldSchema tbl2))) ())
_ :: Proxy (S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ())) (M1 (K1 g (TableField tbl2)
fName)) =
    K1 R (g (TableFieldSchema tbl2)) ()
-> S1 f (K1 R (g (TableFieldSchema tbl2))) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (g (TableFieldSchema tbl2) -> K1 R (g (TableFieldSchema tbl2)) ()
forall k i c (p :: k). c -> K1 i c p
K1 (g (TableFieldSchema tbl2) -> K1 R (g (TableFieldSchema tbl2)) ())
-> g (TableFieldSchema tbl2) -> K1 R (g (TableFieldSchema tbl2)) ()
forall a b. (a -> b) -> a -> b
$ Rep (g (TableFieldSchema tbl2)) () -> g (TableFieldSchema tbl2)
forall a. Generic a => Rep a () -> a
to' (Rep (g (TableFieldSchema tbl2)) () -> g (TableFieldSchema tbl2))
-> Rep (g (TableFieldSchema tbl2)) () -> g (TableFieldSchema tbl2)
forall a b. (a -> b) -> a -> b
$ Proxy (Rep (g (TableFieldSchema tbl2)) ())
-> Rep (g (TableField tbl2)) ()
-> Rep (g (TableFieldSchema tbl2)) ()
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema Proxy (Rep (g (TableFieldSchema tbl2)) ())
forall k (t :: k). Proxy t
Proxy (g (TableField tbl2) -> Rep (g (TableField tbl2)) ()
forall a. Generic a => a -> Rep a ()
from' g (TableField tbl2)
fName))

-- | Instance for things like 'Nullable (TableFieldSchema tbl)'.
instance
  ( Generic (PrimaryKey tbl1 (g (Beam.TableField tbl2))),
    Generic (PrimaryKey tbl1 (g (TableFieldSchema tbl2))),
    GDefaultTableSchema
      (Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ())
      (Rep (PrimaryKey tbl1 (g (Beam.TableField tbl2))) ())
  ) =>
  GDefaultTableSchema
    (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)
    (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (Beam.TableField tbl2)))) p)
  where
  gDefTblSchema :: Proxy (S1 f (K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)
-> S1 f (K1 R (PrimaryKey tbl1 (g (TableField tbl2)))) p
-> S1 f (K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p
gDefTblSchema (Proxy (S1 f (K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)
_ :: Proxy (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)) (M1 (K1 PrimaryKey tbl1 (g (TableField tbl2))
fName)) =
    K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) p
-> S1 f (K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (PrimaryKey tbl1 (g (TableFieldSchema tbl2))
-> K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) p
forall k i c (p :: k). c -> K1 i c p
K1 (PrimaryKey tbl1 (g (TableFieldSchema tbl2))
 -> K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) p)
-> PrimaryKey tbl1 (g (TableFieldSchema tbl2))
-> K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) p
forall a b. (a -> b) -> a -> b
$ Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ()
-> PrimaryKey tbl1 (g (TableFieldSchema tbl2))
forall a. Generic a => Rep a () -> a
to' (Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ()
 -> PrimaryKey tbl1 (g (TableFieldSchema tbl2)))
-> Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ()
-> PrimaryKey tbl1 (g (TableFieldSchema tbl2))
forall a b. (a -> b) -> a -> b
$ Proxy (Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ())
-> Rep (PrimaryKey tbl1 (g (TableField tbl2))) ()
-> Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ()
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema Proxy (Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ())
forall k (t :: k). Proxy t
Proxy (PrimaryKey tbl1 (g (TableField tbl2))
-> Rep (PrimaryKey tbl1 (g (TableField tbl2))) ()
forall a. Generic a => a -> Rep a ()
from' PrimaryKey tbl1 (g (TableField tbl2))
fName))

defaultTableSchema ::
  forall tbl.
  ( GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()),
    Generic (TableSchema tbl),
    Generic (Beam.TableSettings tbl)
  ) =>
  Beam.TableSettings tbl ->
  TableSchema tbl
defaultTableSchema :: TableSettings tbl -> TableSchema tbl
defaultTableSchema TableSettings tbl
tSettings =
  Rep (TableSchema tbl) () -> TableSchema tbl
forall a x. Generic a => Rep a x -> a
to (Rep (TableSchema tbl) () -> TableSchema tbl)
-> Rep (TableSchema tbl) () -> TableSchema tbl
forall a b. (a -> b) -> a -> b
$ Proxy (Rep (TableSchema tbl) ())
-> Rep (TableSettings tbl) () -> Rep (TableSchema tbl) ()
forall x y. GDefaultTableSchema x y => Proxy x -> y -> x
gDefTblSchema (Proxy (Rep (TableSchema tbl) ())
forall k (t :: k). Proxy t
Proxy :: Proxy (Rep (TableSchema tbl) ())) (TableSettings tbl -> Rep (TableSettings tbl) ()
forall a. Generic a => a -> Rep a ()
from' TableSettings tbl
tSettings)

from' :: Generic a => a -> Rep a ()
from' :: a -> Rep a ()
from' = a -> Rep a ()
forall a x. Generic a => a -> Rep a x
from

to' :: Generic a => Rep a () -> a
to' :: Rep a () -> a
to' = Rep a () -> a
forall a x. Generic a => Rep a x -> a
to

--
-- Annotating 'Table's and 'Field's after the default 'AnnotatedDatabaseSettings' has been instantiated.
--

-- $specifyingConstraints
-- Once an 'AnnotatedDatabaseSettings' has been acquired, the user is able to customise the default
-- medatata associated with it. In order to do so, one can reuse the existing machinery from Beam, in
-- particular the `withDbModification`. For example:
--
-- > annotatedDB :: AnnotatedDatabaseSettings Postgres FlowerDB
-- > annotatedDB = defaultAnnotatedDbSettings flowerDB `withDbModification` dbModification
-- >   { dbFlowers   = annotateTableFields tableModification { flowerDiscounted = defaultsTo (val_ $ Just True)
-- >                                                         , flowerPrice = defaultsTo (val_ $ Just 10.0)
-- >                                                         }
-- >                <> uniqueFields [U (addressPostalCode . addressRegion . flowerAddress)]
-- >   , dbLineItems = annotateTableFields tableModification { lineItemDiscount = defaultsTo (val_ $ Just False) }
-- >                <> uniqueFields [U lineItemFlowerID, U lineItemOrderID, U lineItemQuantity]
-- >   , dbOrders = annotateTableFields tableModification { orderTime = defaultsTo (cast_ currentTimestamp_ utctime) }
-- >              <> foreignKeyOnPk (dbFlowers flowerDB) orderFlowerIdRef Cascade Restrict
-- >              <> uniqueFields [U (addressPostalCode . addressRegion . orderAddress)]
-- >   }
--
-- Refer to the rest of the documentation for this module for more information about 'annotateTableFields',
-- 'uniqueFields' and 'foreignKeyOnPk'.

-- | Annotate the table fields for a given 'AnnotatedDatabaseEntity'. Refer to the $specifyingConstraints
-- section for an example.
annotateTableFields ::
  tbl (FieldModification (TableFieldSchema tbl)) ->
  EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
annotateTableFields :: tbl (FieldModification (TableFieldSchema tbl))
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
annotateTableFields tbl (FieldModification (TableFieldSchema tbl))
modFields =
  Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification
    ( (AnnotatedDatabaseEntity be db (TableEntity tbl)
 -> AnnotatedDatabaseEntity be db (TableEntity tbl))
-> Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
forall a. (a -> a) -> Endo a
Endo
        ( \(AnnotatedDatabaseEntity tbl :: AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl@(AnnotatedDatabaseTable {}) DatabaseEntity be db (TableEntity tbl)
e) ->
            AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> DatabaseEntity be db (TableEntity tbl)
-> AnnotatedDatabaseEntity be db (TableEntity tbl)
forall be entityType (db :: (* -> *) -> *).
(IsAnnotatedDatabaseEntity be entityType,
 IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
-> AnnotatedDatabaseEntity be db entityType
AnnotatedDatabaseEntity
              ( AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
R:AnnotatedDatabaseEntityDescriptorbeTableEntity be tbl
tbl
                  { dbAnnotatedSchema :: TableSchema tbl
dbAnnotatedSchema = tbl (FieldModification (TableFieldSchema tbl))
-> TableSchema tbl -> TableSchema tbl
forall (tbl :: (* -> *) -> *) (f :: * -> *).
Beamable tbl =>
tbl (FieldModification f) -> tbl f -> tbl f
Beam.withTableModification tbl (FieldModification (TableFieldSchema tbl))
modFields (AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> TableSchema tbl
forall be (tbl :: (* -> *) -> *).
AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> TableSchema tbl
dbAnnotatedSchema AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl)
                  }
              )
              DatabaseEntity be db (TableEntity tbl)
e
        )
    )

--
-- Specifying default values (Postgres-specific)
--

-- $specifyingColumnConstraints
-- Due to the fact most column constraints can span /multiple/ columns (think about @UNIQUE@ or
-- @FOREIGN KEY@) the only constraint associated to a 'TableFieldSchema' we allow to customise at the
-- \"single-column-granularity\" is @DEFAULT@.

-- | Specify a default value for an entity. The relevant migration will generate an associated SQL
-- @DEFAULT@. This function accepts any Beam's expression that also the standard 'field' machinery would
-- accept, for example:
--
-- > defaultsTo (val_ $ Just 10)
defaultsTo ::
  (HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) =>
  (forall ctx s. Beam.QGenExpr ctx Postgres s ty) ->
  FieldModification (TableFieldSchema tbl) ty
defaultsTo :: (forall ctx s. QGenExpr ctx Postgres s ty)
-> FieldModification (TableFieldSchema tbl) ty
defaultsTo forall ctx s. QGenExpr ctx Postgres s ty
tyVal = (Columnar (TableFieldSchema tbl) ty
 -> Columnar (TableFieldSchema tbl) ty)
-> FieldModification (TableFieldSchema tbl) ty
forall (f :: * -> *) a.
(Columnar f a -> Columnar f a) -> FieldModification f a
FieldModification ((Columnar (TableFieldSchema tbl) ty
  -> Columnar (TableFieldSchema tbl) ty)
 -> FieldModification (TableFieldSchema tbl) ty)
-> (Columnar (TableFieldSchema tbl) ty
    -> Columnar (TableFieldSchema tbl) ty)
-> FieldModification (TableFieldSchema tbl) ty
forall a b. (a -> b) -> a -> b
$ \Columnar (TableFieldSchema tbl) ty
old ->
  case TableFieldSchema tbl ty -> FieldSchema ty
forall (tbl :: (* -> *) -> *) ty.
TableFieldSchema tbl ty -> FieldSchema ty
tableFieldSchema Columnar (TableFieldSchema tbl) ty
TableFieldSchema tbl ty
old of
    FieldSchema ColumnType
ty Set ColumnConstraint
c ->
      Columnar (TableFieldSchema tbl) ty
TableFieldSchema tbl ty
old
        { tableFieldSchema :: FieldSchema ty
tableFieldSchema =
            ColumnType -> Set ColumnConstraint -> FieldSchema ty
forall ty. ColumnType -> Set ColumnConstraint -> FieldSchema ty
FieldSchema ColumnType
ty (Set ColumnConstraint -> FieldSchema ty)
-> Set ColumnConstraint -> FieldSchema ty
forall a b. (a -> b) -> a -> b
$ ColumnConstraint -> Set ColumnConstraint
forall a. a -> Set a
S.singleton ((forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
forall ty.
(HasColumnType ty, HasSqlValueSyntax PgValueSyntax ty) =>
(forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
pgDefaultConstraint forall ctx s. QGenExpr ctx Postgres s ty
tyVal) Set ColumnConstraint
-> Set ColumnConstraint -> Set ColumnConstraint
forall a. Semigroup a => a -> a -> a
<> Set ColumnConstraint
c
        }

-- | Postgres-specific function to convert any 'QGenExpr' into a meaningful 'PgExpressionSyntax', so
-- that it can be rendered inside a 'Default' column constraint.
pgDefaultConstraint ::
  forall ty.
  (HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) =>
  (forall ctx s. Beam.QGenExpr ctx Postgres s ty) ->
  ColumnConstraint
pgDefaultConstraint :: (forall ctx s. QGenExpr ctx Postgres s ty) -> ColumnConstraint
pgDefaultConstraint forall ctx s. QGenExpr ctx Postgres s ty
tyVal =
  let syntaxFragment :: Text
syntaxFragment = String -> Text
T.pack (String -> Text)
-> (PgExpressionSyntax -> String) -> PgExpressionSyntax -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgSyntax -> String
forall syntax. Sql92DisplaySyntax syntax => syntax -> String
displaySyntax (PgSyntax -> String)
-> (PgExpressionSyntax -> PgSyntax) -> PgExpressionSyntax -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgExpressionSyntax -> PgSyntax
Pg.fromPgExpression (PgExpressionSyntax -> Text) -> PgExpressionSyntax -> Text
forall a b. (a -> b) -> a -> b
$ (forall s. QExpr Postgres s ty) -> PgExpressionSyntax
forall a. (forall s. QExpr Postgres s a) -> PgExpressionSyntax
defaultTo_ forall s. QExpr Postgres s ty
forall ctx s. QGenExpr ctx Postgres s ty
tyVal
      dVal :: Text
dVal = case Proxy ty -> Maybe Text
forall ty. HasColumnType ty => Proxy ty -> Maybe Text
defaultTypeCast (Proxy ty
forall k (t :: k). Proxy t
Proxy @ty) of
        Maybe Text
Nothing -> Text
syntaxFragment
        Just Text
tc | Text -> Char
T.head Text
syntaxFragment Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' -> Text
syntaxFragment Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tc
        -- NOTE(and) Special-case handling for CURRENT_TIMESTAMP. See issue #31.
        Just Text
tc | Text
syntaxFragment Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"CURRENT_TIMESTAMP" -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
syntaxFragment Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tc
        Just Text
tc -> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
syntaxFragment Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tc
   in Text -> ColumnConstraint
Default Text
dVal
  where
    -- NOTE(adn) We are unfortunately once again forced to copy and paste some code from beam-migrate.
    -- In particular, `beam-migrate` wraps the returning 'QExpr' into a 'DefaultValue' newtype wrapper,
    -- which only purpose is to define an instance for 'FieldReturnType' (cfr.
    -- /Database.Beam.AutoMigrate.SQL.Tables/) and the underlying 'BeamSqlBackendExpressionSyntax' is used to
    -- call 'columnSchemaSyntax', which is then used in /their own/ definition of `FieldSchema`, which we
    -- don't follow.
    -- NOTE(adn) It's unclear what \"t\" stands for here, probably \"TablePrefix\". Not documented in
    -- `beam-migrate` itself.
    defaultTo_ :: (forall s. QExpr Postgres s a) -> Pg.PgExpressionSyntax
    defaultTo_ :: (forall s. QExpr Postgres s a) -> PgExpressionSyntax
defaultTo_ (Beam.QExpr e) = Text -> BeamSqlBackendExpressionSyntax Postgres
e Text
"t"

--
-- Specifying uniqueness constraints
--

-- $specifyingTableConstraints
-- Is it possible to annotate an 'AnnotatedDatabaseEntity' with @UNIQUE@ and @FOREIGN KEY@ constraints.

data UniqueConstraint (tbl :: ((* -> *) -> *)) where
  -- | Use this to \"tag\" a standard Beam 'TableField' selector or 'PrimaryKey'.
  U :: HasColumnNames entity tbl => (tbl (Beam.TableField tbl) -> entity) -> UniqueConstraint tbl

-- | Given a list of 'TableField' selectors wrapped in a 'UniqueConstraint' type constructor, it adds
-- to the relevant 'AnnotatedDatabaseEntity' a new @UNIQUE@ 'TableConstraint' composed by /all/ the
-- fields specified. To put it differently, every call to 'uniqueConstraintOn' generates a /separate/
-- @UNIQUE@ constraint composed by the listed fields.
-- If a 'PrimaryKey' is passed as input, it will desugar under the hood into as many columns as
-- the primary key refers to.
uniqueConstraintOn ::
  [UniqueConstraint tbl] ->
  EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
uniqueConstraintOn :: [UniqueConstraint tbl]
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
uniqueConstraintOn [UniqueConstraint tbl]
us =
  Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification
    ( (AnnotatedDatabaseEntity be db (TableEntity tbl)
 -> AnnotatedDatabaseEntity be db (TableEntity tbl))
-> Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
forall a. (a -> a) -> Endo a
Endo
        ( \(AnnotatedDatabaseEntity tbl :: AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl@(AnnotatedDatabaseTable {}) DatabaseEntity be db (TableEntity tbl)
e) ->
            AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> DatabaseEntity be db (TableEntity tbl)
-> AnnotatedDatabaseEntity be db (TableEntity tbl)
forall be entityType (db :: (* -> *) -> *).
(IsAnnotatedDatabaseEntity be entityType,
 IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
-> AnnotatedDatabaseEntity be db entityType
AnnotatedDatabaseEntity
              ( AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
R:AnnotatedDatabaseEntityDescriptorbeTableEntity be tbl
tbl
                  { dbAnnotatedConstraints :: Set TableConstraint
dbAnnotatedConstraints =
                      let cols :: [ColumnName]
cols = (UniqueConstraint tbl -> [ColumnName])
-> [UniqueConstraint tbl] -> [ColumnName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\case (U tbl (TableField tbl) -> entity
f) -> tbl (TableField tbl)
-> (tbl (TableField tbl) -> entity) -> [ColumnName]
forall entity (tbl :: (* -> *) -> *).
HasColumnNames entity tbl =>
tbl (TableField tbl)
-> (tbl (TableField tbl) -> entity) -> [ColumnName]
colNames (DatabaseEntity be db (TableEntity tbl) -> tbl (TableField tbl)
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl)
e) tbl (TableField tbl) -> entity
f) [UniqueConstraint tbl]
us
                          tName :: Text
tName = DatabaseEntity be db (TableEntity tbl)
e DatabaseEntity be db (TableEntity tbl)
-> Getting Text (DatabaseEntity be db (TableEntity tbl)) Text
-> Text
forall s a. s -> Getting a s a -> a
^. Getting
  Text
  (DatabaseEntity be db (TableEntity tbl))
  (DatabaseEntityDescriptor be (TableEntity tbl))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor Getting
  Text
  (DatabaseEntity be db (TableEntity tbl))
  (DatabaseEntityDescriptor be (TableEntity tbl))
-> ((Text -> Const Text Text)
    -> DatabaseEntityDescriptor be (TableEntity tbl)
    -> Const Text (DatabaseEntityDescriptor be (TableEntity tbl)))
-> Getting Text (DatabaseEntity be db (TableEntity tbl)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> DatabaseEntityDescriptor be (TableEntity tbl)
-> Const Text (DatabaseEntityDescriptor be (TableEntity tbl))
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName
                          conname :: Text
conname = Text -> [Text] -> Text
T.intercalate Text
"_" (Text
tName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ColumnName -> Text) -> [ColumnName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ColumnName -> Text
columnName [ColumnName]
cols) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_ukey"
                       in TableConstraint -> Set TableConstraint -> Set TableConstraint
forall a. Ord a => a -> Set a -> Set a
S.insert (Text -> Set ColumnName -> TableConstraint
Unique Text
conname ([ColumnName] -> Set ColumnName
forall a. Ord a => [a] -> Set a
S.fromList [ColumnName]
cols)) (AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
forall be (tbl :: (* -> *) -> *).
AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
dbAnnotatedConstraints AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl)
                  }
              )
              DatabaseEntity be db (TableEntity tbl)
e
        )
    )

--
-- Specifying FK constrainst
--

data ForeignKeyConstraint (tbl :: ((* -> *) -> *)) (tbl' :: ((* -> *) -> *)) where
  References ::
    Beam.Beamable (PrimaryKey tbl') =>
    (tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) ->
    (tbl' (Beam.TableField tbl') -> Beam.Columnar Beam.Identity (Beam.TableField tbl' ty)) ->
    ForeignKeyConstraint tbl tbl'

-- | Special-case combinator to use when defining FK constraints referencing the /primary key/ of the
-- target table.
foreignKeyOnPk ::
  ( Beam.Beamable (PrimaryKey tbl'),
    Beam.Beamable tbl',
    Beam.Table tbl',
    PrimaryKey tbl' f ~ PrimaryKey tbl' g
  ) =>
  -- | The 'DatabaseEntity' of the /referenced/ table.
  DatabaseEntity be db (TableEntity tbl') ->
  -- | A function yielding a 'PrimaryKey'. This is usually a record field of the table
  -- you want to define the FK /for/, and it must have /PrimaryKey externalTable f/ as
  -- its column-tag.
  (tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) ->
  -- | What do to \"on delete\"
  ReferenceAction ->
  -- | What do to \"on update\"
  ReferenceAction ->
  EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOnPk :: DatabaseEntity be db (TableEntity tbl')
-> (tbl (TableField tbl) -> PrimaryKey tbl' (TableField tbl))
-> ReferenceAction
-> ReferenceAction
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOnPk DatabaseEntity be db (TableEntity tbl')
externalEntity tbl (TableField tbl) -> PrimaryKey tbl' (TableField tbl)
ourColumn ReferenceAction
onDelete ReferenceAction
onUpdate =
  Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification
    ( (AnnotatedDatabaseEntity be db (TableEntity tbl)
 -> AnnotatedDatabaseEntity be db (TableEntity tbl))
-> Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
forall a. (a -> a) -> Endo a
Endo
        ( \(AnnotatedDatabaseEntity tbl :: AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl@(AnnotatedDatabaseTable {}) DatabaseEntity be db (TableEntity tbl)
e) ->
            AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> DatabaseEntity be db (TableEntity tbl)
-> AnnotatedDatabaseEntity be db (TableEntity tbl)
forall be entityType (db :: (* -> *) -> *).
(IsAnnotatedDatabaseEntity be entityType,
 IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
-> AnnotatedDatabaseEntity be db entityType
AnnotatedDatabaseEntity
              ( AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
R:AnnotatedDatabaseEntityDescriptorbeTableEntity be tbl
tbl
                  { dbAnnotatedConstraints :: Set TableConstraint
dbAnnotatedConstraints =
                      let colPairs :: [(ColumnName, ColumnName)]
colPairs =
                            (ColumnName -> ColumnName -> (ColumnName, ColumnName))
-> [ColumnName] -> [ColumnName] -> [(ColumnName, ColumnName)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                              (,)
                              (PrimaryKey tbl' (TableField tbl) -> [ColumnName]
forall (tbl :: (* -> *) -> *) (c :: (* -> *) -> *).
Beamable tbl =>
tbl (TableField c) -> [ColumnName]
fieldAsColumnNames (tbl (TableField tbl) -> PrimaryKey tbl' (TableField tbl)
ourColumn (DatabaseEntity be db (TableEntity tbl) -> tbl (TableField tbl)
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl)
e)))
                              (PrimaryKey tbl' (TableField tbl') -> [ColumnName]
forall (tbl :: (* -> *) -> *) (c :: (* -> *) -> *).
Beamable tbl =>
tbl (TableField c) -> [ColumnName]
fieldAsColumnNames (tbl' (TableField tbl') -> PrimaryKey tbl' (TableField tbl')
forall (t :: (* -> *) -> *) (f :: * -> *).
Table t =>
t f -> PrimaryKey t f
Beam.pk (DatabaseEntity be db (TableEntity tbl') -> tbl' (TableField tbl')
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl')
externalEntity)))
                          tName :: Text
tName = DatabaseEntity be db (TableEntity tbl')
externalEntity DatabaseEntity be db (TableEntity tbl')
-> Getting Text (DatabaseEntity be db (TableEntity tbl')) Text
-> Text
forall s a. s -> Getting a s a -> a
^. Getting
  Text
  (DatabaseEntity be db (TableEntity tbl'))
  (DatabaseEntityDescriptor be (TableEntity tbl'))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor Getting
  Text
  (DatabaseEntity be db (TableEntity tbl'))
  (DatabaseEntityDescriptor be (TableEntity tbl'))
-> ((Text -> Const Text Text)
    -> DatabaseEntityDescriptor be (TableEntity tbl')
    -> Const Text (DatabaseEntityDescriptor be (TableEntity tbl')))
-> Getting Text (DatabaseEntity be db (TableEntity tbl')) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> DatabaseEntityDescriptor be (TableEntity tbl')
-> Const Text (DatabaseEntityDescriptor be (TableEntity tbl'))
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName
                          conname :: Text
conname = Text -> [Text] -> Text
T.intercalate Text
"_" (Text
tName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((ColumnName, ColumnName) -> Text)
-> [(ColumnName, ColumnName)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnName -> Text
columnName (ColumnName -> Text)
-> ((ColumnName, ColumnName) -> ColumnName)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColumnName, ColumnName) -> ColumnName
forall a b. (a, b) -> b
snd) [(ColumnName, ColumnName)]
colPairs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_fkey"
                       in TableConstraint -> Set TableConstraint -> Set TableConstraint
forall a. Ord a => a -> Set a -> Set a
S.insert
                            (Text
-> TableName
-> Set (ColumnName, ColumnName)
-> ReferenceAction
-> ReferenceAction
-> TableConstraint
ForeignKey Text
conname (Text -> TableName
TableName Text
tName) ([(ColumnName, ColumnName)] -> Set (ColumnName, ColumnName)
forall a. Ord a => [a] -> Set a
S.fromList [(ColumnName, ColumnName)]
colPairs) ReferenceAction
onDelete ReferenceAction
onUpdate)
                            (AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
forall be (tbl :: (* -> *) -> *).
AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
dbAnnotatedConstraints AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl)
                  }
              )
              DatabaseEntity be db (TableEntity tbl)
e
        )
    )

foreignKeyOn ::
  Beam.Beamable tbl' =>
  DatabaseEntity be db (TableEntity tbl') ->
  [ForeignKeyConstraint tbl tbl'] ->
  -- | On Delete
  ReferenceAction ->
  -- | On Update
  ReferenceAction ->
  EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOn :: DatabaseEntity be db (TableEntity tbl')
-> [ForeignKeyConstraint tbl tbl']
-> ReferenceAction
-> ReferenceAction
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
foreignKeyOn DatabaseEntity be db (TableEntity tbl')
externalEntity [ForeignKeyConstraint tbl tbl']
us ReferenceAction
onDelete ReferenceAction
onUpdate =
  Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
-> EntityModification
     (AnnotatedDatabaseEntity be db) be (TableEntity tbl)
forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification
    ( (AnnotatedDatabaseEntity be db (TableEntity tbl)
 -> AnnotatedDatabaseEntity be db (TableEntity tbl))
-> Endo (AnnotatedDatabaseEntity be db (TableEntity tbl))
forall a. (a -> a) -> Endo a
Endo
        ( \(AnnotatedDatabaseEntity tbl :: AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl@(AnnotatedDatabaseTable {}) DatabaseEntity be db (TableEntity tbl)
e) ->
            AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> DatabaseEntity be db (TableEntity tbl)
-> AnnotatedDatabaseEntity be db (TableEntity tbl)
forall be entityType (db :: (* -> *) -> *).
(IsAnnotatedDatabaseEntity be entityType,
 IsDatabaseEntity be entityType) =>
AnnotatedDatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
-> AnnotatedDatabaseEntity be db entityType
AnnotatedDatabaseEntity
              ( AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
R:AnnotatedDatabaseEntityDescriptorbeTableEntity be tbl
tbl
                  { dbAnnotatedConstraints :: Set TableConstraint
dbAnnotatedConstraints =
                      let colPairs :: [(ColumnName, ColumnName)]
colPairs =
                            (ForeignKeyConstraint tbl tbl' -> [(ColumnName, ColumnName)])
-> [ForeignKeyConstraint tbl tbl'] -> [(ColumnName, ColumnName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                              ( \case
                                  (References tbl (TableField tbl) -> PrimaryKey tbl' (TableField tbl)
ours tbl' (TableField tbl') -> Columnar Identity (TableField tbl' ty)
theirs) ->
                                    (ColumnName -> ColumnName -> (ColumnName, ColumnName))
-> [ColumnName] -> [ColumnName] -> [(ColumnName, ColumnName)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                                      (,)
                                      (PrimaryKey tbl' (TableField tbl) -> [ColumnName]
forall (tbl :: (* -> *) -> *) (c :: (* -> *) -> *).
Beamable tbl =>
tbl (TableField c) -> [ColumnName]
fieldAsColumnNames (tbl (TableField tbl) -> PrimaryKey tbl' (TableField tbl)
ours (DatabaseEntity be db (TableEntity tbl) -> tbl (TableField tbl)
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl)
e)))
                                      [Text -> ColumnName
ColumnName (tbl' (TableField tbl') -> Columnar Identity (TableField tbl' ty)
theirs (DatabaseEntity be db (TableEntity tbl') -> tbl' (TableField tbl')
forall be (db :: (* -> *) -> *) (tbl :: (* -> *) -> *).
DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl
tableSettings DatabaseEntity be db (TableEntity tbl')
externalEntity) TableField tbl' ty
-> Getting Text (TableField tbl' ty) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TableField tbl' ty) Text
forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
Beam.fieldName)]
                              )
                              [ForeignKeyConstraint tbl tbl']
us
                          tName :: Text
tName = DatabaseEntity be db (TableEntity tbl')
externalEntity DatabaseEntity be db (TableEntity tbl')
-> Getting Text (DatabaseEntity be db (TableEntity tbl')) Text
-> Text
forall s a. s -> Getting a s a -> a
^. Getting
  Text
  (DatabaseEntity be db (TableEntity tbl'))
  (DatabaseEntityDescriptor be (TableEntity tbl'))
forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor Getting
  Text
  (DatabaseEntity be db (TableEntity tbl'))
  (DatabaseEntityDescriptor be (TableEntity tbl'))
-> ((Text -> Const Text Text)
    -> DatabaseEntityDescriptor be (TableEntity tbl')
    -> Const Text (DatabaseEntityDescriptor be (TableEntity tbl')))
-> Getting Text (DatabaseEntity be db (TableEntity tbl')) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> DatabaseEntityDescriptor be (TableEntity tbl')
-> Const Text (DatabaseEntityDescriptor be (TableEntity tbl'))
forall be entityType.
IsDatabaseEntity be entityType =>
Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityName
                          conname :: Text
conname = Text -> [Text] -> Text
T.intercalate Text
"_" (Text
tName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((ColumnName, ColumnName) -> Text)
-> [(ColumnName, ColumnName)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnName -> Text
columnName (ColumnName -> Text)
-> ((ColumnName, ColumnName) -> ColumnName)
-> (ColumnName, ColumnName)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColumnName, ColumnName) -> ColumnName
forall a b. (a, b) -> b
snd) [(ColumnName, ColumnName)]
colPairs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_fkey"
                       in TableConstraint -> Set TableConstraint -> Set TableConstraint
forall a. Ord a => a -> Set a -> Set a
S.insert
                            (Text
-> TableName
-> Set (ColumnName, ColumnName)
-> ReferenceAction
-> ReferenceAction
-> TableConstraint
ForeignKey Text
conname (Text -> TableName
TableName Text
tName) ([(ColumnName, ColumnName)] -> Set (ColumnName, ColumnName)
forall a. Ord a => [a] -> Set a
S.fromList [(ColumnName, ColumnName)]
colPairs) ReferenceAction
onDelete ReferenceAction
onUpdate)
                            (AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
forall be (tbl :: (* -> *) -> *).
AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
-> Set TableConstraint
dbAnnotatedConstraints AnnotatedDatabaseEntityDescriptor be (TableEntity tbl)
tbl)
                  }
              )
              DatabaseEntity be db (TableEntity tbl)
e
        )
    )