{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}

-- | Defines a generic schema type that can be used to define schemas for Beam tables
module Database.Beam.Schema.Tables
    (
    -- * Database Types
      Database
    , zipTables

    , DatabaseSettings
    , IsDatabaseEntity(..)
    , DatabaseEntityDescriptor(..)
    , DatabaseEntity(..), TableEntity, ViewEntity, DomainTypeEntity
    , dbEntityDescriptor
    , DatabaseModification, EntityModification(..)
    , FieldModification(..)
    , dbModification, tableModification, withDbModification
    , withTableModification, modifyTable, modifyEntityName
    , setEntityName, modifyTableFields, fieldNamed
    , modifyEntitySchema, setEntitySchema
    , defaultDbSettings

    , RenamableWithRule(..), RenamableField(..)
    , FieldRenamer(..)

    , Lenses, LensFor(..)

    -- * Columnar and Column Tags
    , Columnar, C, Columnar'(..)
    , ComposeColumnar(..)
    , Nullable, TableField(..)
    , Exposed
    , fieldName, fieldPath

    , TableSettings, HaskellTable
    , TableSkeleton, Ignored(..)
    , GFieldsFulfillConstraint(..), FieldsFulfillConstraint
    , FieldsFulfillConstraintNullable
    , WithConstraint(..)
    , HasConstraint(..)
    , TagReducesTo(..), ReplaceBaseTag
    , withConstrainedFields, withConstraints
    , withNullableConstrainedFields, withNullableConstraints

    -- * Tables
    , Table(..), Beamable(..)
    , Retaggable(..), (:*:)(..) -- Reexported for use with 'alongsideTable'
    , defTblFieldSettings
    , tableValuesNeeded
    , pk
    , allBeamValues, changeBeamRep
    , alongsideTable
    , defaultFieldName )
    where

import           Database.Beam.Backend.Types

import           Control.Applicative (liftA2)
import           Control.Arrow (first)
import           Control.Monad.Identity
import           Control.Monad.Writer hiding ((<>))

import           Data.Char (isUpper, toLower)
import           Data.Foldable (fold)
import qualified Data.List.NonEmpty as NE
import           Data.Proxy
import           Data.String (IsString(..))
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Typeable

import qualified GHC.Generics as Generic
import           GHC.Generics hiding (R, C)
import           GHC.TypeLits
import           GHC.Types

import           Lens.Micro hiding (to)
import qualified Lens.Micro as Lens

-- | Allows introspection into database types.
--
--   All database types must be of kind '(Type -> Type) -> Type'. If
--   the type parameter is named 'f', each field must be of the type
--   of 'f' applied to some type for which an 'IsDatabaseEntity'
--   instance exists.
--
--   The 'be' type parameter is necessary so that the compiler can
--   ensure that backend-specific entities only work on the proper
--   backend.
--
--   Entities are documented under [the corresponding
--   section](Database.Beam.Schema#entities) and in the
--   [manual](https://haskell-beam.github.io/beam/user-guide/databases/)
class Database be db where

    -- | Default derived function. Do not implement this yourself.
    --
    --   The idea is that, for any two databases over particular entity tags 'f'
    --   and 'g', if we can take any entity in 'f' and 'g' to the corresponding
    --   entity in 'h' (in the possibly effectful applicative functor 'm'), then we can
    --   transform the two databases over 'f' and 'g' to a database in 'h',
    --   within 'm'.
    --
    --   If that doesn't make sense, don't worry. This is mostly beam internal
    zipTables :: 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)
    default zipTables :: ( Generic (db f), Generic (db g), Generic (db h)
                         , Applicative m
                         , GZipDatabase be f g h
                                        (Rep (db f)) (Rep (db g)) (Rep (db h)) ) =>
                         Proxy be ->
                         (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements 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
be forall tbl.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine (db f
f :: db f) (db g
g :: db g) =
      forall (h :: * -> *) (m :: * -> *).
(Proxy h -> m (db h)) -> m (db h)
refl forall a b. (a -> b) -> a -> b
$ \Proxy h
h ->
        forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Applicative m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements be tbl) =>
    f tbl -> g tbl -> m (h tbl))
-> x ()
-> y ()
-> m (z ())
gZipDatabase (forall {k} (t :: k). Proxy t
Proxy @f, forall {k} (t :: k). Proxy t
Proxy @g, Proxy h
h, Proxy be
be) forall tbl.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine (forall a x. Generic a => a -> Rep a x
from db f
f) (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 :: forall (h :: * -> *) (m :: * -> *).
(Proxy h -> m (db h)) -> m (db h)
refl Proxy h -> m (db h)
fn = Proxy h -> m (db h)
fn forall {k} (t :: k). Proxy t
Proxy

-- | Automatically provide names for tables, and descriptions for tables (using
--   'defTblFieldSettings'). Your database must implement 'Generic', and must be
--   auto-derivable. For more information on name generation, see the
--   [manual](https://haskell-beam.github.io/beam/user-guide/models)
defaultDbSettings :: ( Generic (DatabaseSettings be db)
                     , GAutoDbSettings (Rep (DatabaseSettings be db) ()) ) =>
                     DatabaseSettings be db
defaultDbSettings :: forall be (db :: (* -> *) -> *).
(Generic (DatabaseSettings be db),
 GAutoDbSettings (Rep (DatabaseSettings be db) ())) =>
DatabaseSettings be db
defaultDbSettings = forall x. Generic x => Rep x () -> x
to' forall x. GAutoDbSettings x => x
autoDbSettings'

-- | A helper data type that lets you modify a database schema. Converts all
-- entities in the database into functions from that entity to itself.
type DatabaseModification f be db = db (EntityModification f be)
-- | A newtype wrapper around 'f e -> f e' (i.e., an endomorphism between entity
--   types in 'f'). You usually want to use 'modifyTable' or another function to
--   contstruct these for you.
newtype EntityModification f be e = EntityModification (Endo (f e))
  deriving (EntityModification f be e
[EntityModification f be e] -> EntityModification f be e
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {f :: * -> *} {be} {e}.
Semigroup (EntityModification f be e)
forall (f :: * -> *) be e. EntityModification f be e
forall (f :: * -> *) be e.
[EntityModification f be e] -> EntityModification f be e
forall (f :: * -> *) be e.
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
mconcat :: [EntityModification f be e] -> EntityModification f be e
$cmconcat :: forall (f :: * -> *) be e.
[EntityModification f be e] -> EntityModification f be e
mappend :: EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
$cmappend :: forall (f :: * -> *) be e.
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
mempty :: EntityModification f be e
$cmempty :: forall (f :: * -> *) be e. EntityModification f be e
Monoid, NonEmpty (EntityModification f be e) -> EntityModification f be e
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
forall b.
Integral b =>
b -> EntityModification f be e -> EntityModification f be e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (f :: * -> *) be e.
NonEmpty (EntityModification f be e) -> EntityModification f be e
forall (f :: * -> *) be e.
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
forall (f :: * -> *) be e b.
Integral b =>
b -> EntityModification f be e -> EntityModification f be e
stimes :: forall b.
Integral b =>
b -> EntityModification f be e -> EntityModification f be e
$cstimes :: forall (f :: * -> *) be e b.
Integral b =>
b -> EntityModification f be e -> EntityModification f be e
sconcat :: NonEmpty (EntityModification f be e) -> EntityModification f be e
$csconcat :: forall (f :: * -> *) be e.
NonEmpty (EntityModification f be e) -> EntityModification f be e
<> :: EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
$c<> :: forall (f :: * -> *) be e.
EntityModification f be e
-> EntityModification f be e -> EntityModification f be e
Semigroup)
-- | A newtype wrapper around 'Columnar f a -> Columnar f a' (i.e., an
--   endomorphism between 'Columnar's over 'f'). You usually want to use
--   'fieldNamed' or the 'IsString' instance to rename the field, when 'f ~
--   TableField'
newtype FieldModification f a
  = FieldModification (Columnar f a -> Columnar f a)

-- | Return a 'DatabaseModification' that does nothing. This is useful if you
--   only want to rename one table. You can do
--
-- > dbModification { tbl1 = modifyTable (\oldNm -> "NewTableName") tableModification }
dbModification :: forall f be db. Database be db => DatabaseModification f be db
dbModification :: forall (f :: * -> *) be (db :: (* -> *) -> *).
Database be db =>
DatabaseModification f be db
dbModification = 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) (\EntityModification f be tbl
_ EntityModification f be tbl
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) (forall a. HasCallStack => a
undefined :: DatabaseModification f be db) (forall a. HasCallStack => a
undefined :: DatabaseModification f be db)

-- | Return a table modification (for use with 'modifyTable') that does nothing.
--   Useful if you only want to change the table name, or if you only want to
--   modify a few fields.
--
--   For example,
--
-- > tableModification { field1 = "Column1" }
--
--   is a table modification (where 'f ~ TableField tbl') that changes the
--   column name of 'field1' to "Column1".
tableModification :: forall f tbl. Beamable tbl => tbl (FieldModification f)
tableModification :: forall (f :: * -> *) (tbl :: (* -> *) -> *).
Beamable tbl =>
tbl (FieldModification f)
tableModification = 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 (f :: * -> *) a.
(Columnar f a -> Columnar f a) -> FieldModification f a
FieldModification forall a. a -> a
id :: FieldModification f x))) (forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (forall a. HasCallStack => a
undefined :: TableSkeleton tbl)

-- | Modify a database according to a given modification. Most useful for
--   'DatabaseSettings' to change the name mappings of tables and fields. For
--   example, you can use this to modify the default names of a table
--
-- > db :: DatabaseSettings MyDb
-- > db = defaultDbSettings `withDbModification`
-- >      dbModification {
-- >        -- Change default name "table1" to "Table_1". Change the name of "table1Field1" to "first_name"
-- >        table1 = modifyTable (\_ -> "Table_1") (tableModification { table1Field1 = "first_name" }
-- >      }
withDbModification :: forall db be entity
                    . Database be db
                   => db (entity be db)
                   -> DatabaseModification (entity be db) be db
                   -> db (entity be db)
withDbModification :: forall (db :: (* -> *) -> *) be
       (entity :: * -> ((* -> *) -> *) -> * -> *).
Database be db =>
db (entity be db)
-> DatabaseModification (entity be db) be db -> db (entity be db)
withDbModification db (entity be db)
db DatabaseModification (entity be db) be db
mods =
  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) (\entity be db tbl
tbl (EntityModification Endo (entity be db tbl)
entityFn) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Endo a -> a -> a
appEndo Endo (entity be db tbl)
entityFn entity be db tbl
tbl)) db (entity be db)
db DatabaseModification (entity be db) be db
mods

-- | Modify a table according to the given field modifications. Invoked by
--   'modifyTable' to apply the modification in the database. Not used as often in
--   user code, but provided for completeness.
withTableModification :: Beamable tbl => tbl (FieldModification f) -> tbl f -> tbl f
withTableModification :: forall (tbl :: (* -> *) -> *) (f :: * -> *).
Beamable tbl =>
tbl (FieldModification f) -> tbl f -> tbl f
withTableModification tbl (FieldModification f)
mods tbl f
tbl =
  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 f a
field :: Columnar' f a) (Columnar' (FieldModification Columnar f a -> Columnar f a
fieldFn :: FieldModification f a)) ->
                                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (Columnar f a -> Columnar f a
fieldFn Columnar f a
field))) tbl f
tbl tbl (FieldModification f)
mods


-- | Provide an 'EntityModification' for 'TableEntity's. Allows you to modify
--   the name of the table and provide a modification for each field in the
--   table. See the examples for 'withDbModification' for more.
modifyTable :: (Beamable tbl, Table tbl)
            => (Text -> Text)
            -> tbl (FieldModification (TableField tbl))
            -> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTable :: forall (tbl :: (* -> *) -> *) be (db :: (* -> *) -> *).
(Beamable tbl, Table tbl) =>
(Text -> Text)
-> tbl (FieldModification (TableField tbl))
-> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTable Text -> Text
modTblNm tbl (FieldModification (TableField tbl))
modFields = forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
(Text -> Text)
-> EntityModification (DatabaseEntity be db) be entity
modifyEntityName Text -> Text
modTblNm forall a. Semigroup a => a -> a -> a
<> forall (tbl :: (* -> *) -> *) be (db :: (* -> *) -> *).
tbl (FieldModification (TableField tbl))
-> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTableFields tbl (FieldModification (TableField tbl))
modFields
{-# DEPRECATED modifyTable "Instead of 'modifyTable fTblNm fFields', use 'modifyEntityName _ <> modifyTableFields _'" #-}

-- | Construct an 'EntityModification' to rename any database entity
modifyEntityName :: IsDatabaseEntity be entity => (Text -> Text) -> EntityModification (DatabaseEntity be db) be entity
modifyEntityName :: forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
(Text -> Text)
-> EntityModification (DatabaseEntity be db) be entity
modifyEntityName Text -> Text
modTblNm = forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (forall a. (a -> a) -> Endo a
Endo (\(DatabaseEntity DatabaseEntityDescriptor be entity
tbl) -> forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (DatabaseEntityDescriptor be entity
tbl forall a b. a -> (a -> b) -> b
& 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
modTblNm)))

-- | Construct an 'EntityModification' to set the schema of a database entity
modifyEntitySchema :: IsDatabaseEntity be entity => (Maybe Text -> Maybe Text) -> EntityModification (DatabaseEntity be db) be entity
modifyEntitySchema :: forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
(Maybe Text -> Maybe Text)
-> EntityModification (DatabaseEntity be db) be entity
modifyEntitySchema Maybe Text -> Maybe Text
modSchema = forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (forall a. (a -> a) -> Endo a
Endo (\(DatabaseEntity DatabaseEntityDescriptor be entity
tbl) -> forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (DatabaseEntityDescriptor be entity
tbl forall a b. a -> (a -> b) -> b
& forall be entityType.
IsDatabaseEntity be entityType =>
Traversal' (DatabaseEntityDescriptor be entityType) (Maybe Text)
dbEntitySchema forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe Text -> Maybe Text
modSchema)))

-- | Change the entity name without consulting the beam-assigned one
setEntityName :: IsDatabaseEntity be entity => Text -> EntityModification (DatabaseEntity be db) be entity
setEntityName :: forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
Text -> EntityModification (DatabaseEntity be db) be entity
setEntityName Text
nm = forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
(Text -> Text)
-> EntityModification (DatabaseEntity be db) be entity
modifyEntityName (\Text
_ -> Text
nm)

setEntitySchema :: IsDatabaseEntity be entity => Maybe Text -> EntityModification (DatabaseEntity be db) be entity
setEntitySchema :: forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
Maybe Text -> EntityModification (DatabaseEntity be db) be entity
setEntitySchema Maybe Text
nm = forall be entity (db :: (* -> *) -> *).
IsDatabaseEntity be entity =>
(Maybe Text -> Maybe Text)
-> EntityModification (DatabaseEntity be db) be entity
modifyEntitySchema (\Maybe Text
_ -> Maybe Text
nm)

-- | Construct an 'EntityModification' to rename the fields of a 'TableEntity'
modifyTableFields :: tbl (FieldModification (TableField tbl)) -> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTableFields :: forall (tbl :: (* -> *) -> *) be (db :: (* -> *) -> *).
tbl (FieldModification (TableField tbl))
-> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTableFields tbl (FieldModification (TableField tbl))
modFields = forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (forall a. (a -> a) -> Endo a
Endo (\(DatabaseEntity tbl :: DatabaseEntityDescriptor be (TableEntity tbl)
tbl@(DatabaseTable {})) -> forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity DatabaseEntityDescriptor be (TableEntity tbl)
tbl { dbTableSettings :: TableSettings tbl
dbTableSettings = forall (tbl :: (* -> *) -> *) (f :: * -> *).
Beamable tbl =>
tbl (FieldModification f) -> tbl f -> tbl f
withTableModification tbl (FieldModification (TableField tbl))
modFields (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
tbl) }))

-- | A field modification to rename the field. Also offered under the 'IsString'
--   instance for 'FieldModification (TableField tbl) a' for convenience.
fieldNamed :: Text -> FieldModification (TableField tbl) a
fieldNamed :: forall (tbl :: (* -> *) -> *) a.
Text -> FieldModification (TableField tbl) a
fieldNamed Text
newName = forall (f :: * -> *) a.
(Columnar f a -> Columnar f a) -> FieldModification f a
FieldModification (forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
newName)

newtype FieldRenamer entity = FieldRenamer { forall entity. FieldRenamer entity -> entity -> entity
withFieldRenamer :: entity -> entity }

class RenamableField f where
  renameField :: Proxy f -> Proxy a -> (NE.NonEmpty Text -> Text) -> Columnar f a -> Columnar f a
instance RenamableField (TableField tbl) where
  renameField :: forall a.
Proxy (TableField tbl)
-> Proxy a
-> (NonEmpty Text -> Text)
-> Columnar (TableField tbl) a
-> Columnar (TableField tbl) a
renameField Proxy (TableField tbl)
_ Proxy a
_ NonEmpty Text -> Text
f (TableField NonEmpty Text
path Text
_) = forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField NonEmpty Text
path (NonEmpty Text -> Text
f NonEmpty Text
path)

class RenamableWithRule mod where
  renamingFields :: (NE.NonEmpty Text -> Text) -> mod
instance Database be db => RenamableWithRule (db (EntityModification (DatabaseEntity be db) be)) where
  renamingFields :: (NonEmpty Text -> Text)
-> db (EntityModification (DatabaseEntity be db) be)
renamingFields NonEmpty Text -> Text
renamer =
    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) (\EntityModification Any be tbl
_ EntityModification Any be tbl
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mod. RenamableWithRule mod => (NonEmpty Text -> Text) -> mod
renamingFields NonEmpty Text -> Text
renamer))
              (forall a. HasCallStack => a
undefined :: DatabaseModification f be db)
              (forall a. HasCallStack => a
undefined :: DatabaseModification f be db)
instance IsDatabaseEntity be entity => RenamableWithRule (EntityModification (DatabaseEntity be db) be entity) where
  renamingFields :: (NonEmpty Text -> Text)
-> EntityModification (DatabaseEntity be db) be entity
renamingFields NonEmpty Text -> Text
renamer =
    forall (f :: * -> *) be e. Endo (f e) -> EntityModification f be e
EntityModification (forall a. (a -> a) -> Endo a
Endo (\(DatabaseEntity DatabaseEntityDescriptor be entity
tbl) -> forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (forall entity. FieldRenamer entity -> entity -> entity
withFieldRenamer (forall mod. RenamableWithRule mod => (NonEmpty Text -> Text) -> mod
renamingFields NonEmpty Text -> Text
renamer) DatabaseEntityDescriptor be entity
tbl)))
instance (Beamable tbl, RenamableField f) => RenamableWithRule (tbl (FieldModification f)) where
  renamingFields :: (NonEmpty Text -> Text) -> tbl (FieldModification f)
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 (f :: * -> *) a.
(Columnar f a -> Columnar f a) -> FieldModification f a
FieldModification (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 @f) (forall {k} (t :: k). Proxy t
Proxy @x) NonEmpty Text -> Text
renamer) :: FieldModification f x) ::
                               Columnar' (FieldModification f) x))
                   (forall a. HasCallStack => a
undefined :: TableSkeleton tbl) (forall a. HasCallStack => a
undefined :: TableSkeleton tbl)

instance IsString (FieldModification (TableField tbl) a) where
  fromString :: String -> FieldModification (TableField tbl) a
fromString = forall (tbl :: (* -> *) -> *) a.
Text -> FieldModification (TableField tbl) a
fieldNamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- * Database entity types

-- | An entity tag for tables. See the documentation for 'Table' or consult the
--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for more.
data TableEntity (tbl :: (Type -> Type) -> Type)
data ViewEntity (view :: (Type -> Type) -> Type)
--data UniqueConstraint (tbl :: (* -> *) -> *) (c :: (* -> *) -> *)
data DomainTypeEntity (ty :: Type)
--data CharacterSetEntity
--data CollationEntity
--data TranslationEntity
--data AssertionEntity

class RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be entityType)) =>
    IsDatabaseEntity be entityType where
  data DatabaseEntityDescriptor be entityType :: Type
  type DatabaseEntityDefaultRequirements be entityType :: Constraint
  type DatabaseEntityRegularRequirements be entityType :: Constraint

  dbEntityName :: Lens' (DatabaseEntityDescriptor be entityType) Text
  dbEntitySchema :: Traversal' (DatabaseEntityDescriptor be entityType) (Maybe Text)

  dbEntityAuto :: DatabaseEntityDefaultRequirements be entityType =>
                  Text -> DatabaseEntityDescriptor be entityType

instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (TableEntity tbl))) where
  renamingFields :: (NonEmpty Text -> Text)
-> FieldRenamer (DatabaseEntityDescriptor be (TableEntity tbl))
renamingFields NonEmpty Text -> Text
renamer =
    forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer forall a b. (a -> b) -> a -> b
$ \DatabaseEntityDescriptor be (TableEntity tbl)
tbl ->
      DatabaseEntityDescriptor be (TableEntity tbl)
tbl { dbTableSettings :: TableSettings tbl
dbTableSettings =
              forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' Columnar (TableField tbl) a
tblField :: Columnar' (TableField tbl) a) ->
                               forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (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 @a)
                                                      NonEmpty Text -> Text
renamer Columnar (TableField tbl) a
tblField)
                                 :: Columnar' (TableField tbl) a) forall a b. (a -> b) -> a -> b
$
              forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor be (TableEntity tbl)
tbl }

instance Beamable tbl => IsDatabaseEntity be (TableEntity tbl) where
  data DatabaseEntityDescriptor be (TableEntity tbl) where
    DatabaseTable
      :: Table tbl =>
       { forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Maybe Text
dbTableSchema      :: Maybe Text
       , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableOrigName    :: Text
       , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableCurrentName :: Text
       , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings    :: TableSettings tbl }
      -> DatabaseEntityDescriptor be (TableEntity tbl)
  type DatabaseEntityDefaultRequirements be (TableEntity tbl) =
    ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ())
    , Generic (TableSettings tbl), Table tbl, Beamable tbl )
  type DatabaseEntityRegularRequirements be (TableEntity tbl) =
    ( Table tbl, Beamable tbl )

  dbEntityName :: Lens' (DatabaseEntityDescriptor be (TableEntity tbl)) Text
dbEntityName Text -> f Text
f DatabaseEntityDescriptor be (TableEntity tbl)
tbl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
t' -> DatabaseEntityDescriptor be (TableEntity tbl)
tbl { dbTableCurrentName :: Text
dbTableCurrentName = Text
t' }) (Text -> f Text
f (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableCurrentName DatabaseEntityDescriptor be (TableEntity tbl)
tbl))
  dbEntitySchema :: Traversal'
  (DatabaseEntityDescriptor be (TableEntity tbl)) (Maybe Text)
dbEntitySchema Maybe Text -> f (Maybe Text)
f DatabaseEntityDescriptor be (TableEntity tbl)
tbl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Text
s' -> DatabaseEntityDescriptor be (TableEntity tbl)
tbl { dbTableSchema :: Maybe Text
dbTableSchema = Maybe Text
s'}) (Maybe Text -> f (Maybe Text)
f (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Maybe Text
dbTableSchema DatabaseEntityDescriptor be (TableEntity tbl)
tbl))
  dbEntityAuto :: DatabaseEntityDefaultRequirements be (TableEntity tbl) =>
Text -> DatabaseEntityDescriptor be (TableEntity tbl)
dbEntityAuto Text
nm =
    forall (tbl :: (* -> *) -> *) be.
Table tbl =>
Maybe Text
-> Text
-> Text
-> TableSettings tbl
-> DatabaseEntityDescriptor be (TableEntity tbl)
DatabaseTable forall a. Maybe a
Nothing Text
nm (Text -> Text
unCamelCaseSel Text
nm) forall (table :: (* -> *) -> *).
(Generic (TableSettings table),
 GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
TableSettings table
defTblFieldSettings

instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (ViewEntity tbl))) where
  renamingFields :: (NonEmpty Text -> Text)
-> FieldRenamer (DatabaseEntityDescriptor be (ViewEntity tbl))
renamingFields NonEmpty Text -> Text
renamer =
    forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer forall a b. (a -> b) -> a -> b
$ \DatabaseEntityDescriptor be (ViewEntity tbl)
vw ->
      DatabaseEntityDescriptor be (ViewEntity tbl)
vw { dbViewSettings :: TableSettings tbl
dbViewSettings =
             forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' Columnar (TableField tbl) a
tblField :: Columnar' (TableField tbl) a) ->
                              forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (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 @a)
                                                     NonEmpty Text -> Text
renamer Columnar (TableField tbl) a
tblField)
                                :: Columnar' (TableField tbl) a) forall a b. (a -> b) -> a -> b
$
             forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> TableSettings tbl
dbViewSettings DatabaseEntityDescriptor be (ViewEntity tbl)
vw }

instance Beamable tbl => IsDatabaseEntity be (ViewEntity tbl) where
  data DatabaseEntityDescriptor be (ViewEntity tbl) where
    DatabaseView
      :: { forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> Maybe Text
dbViewSchema :: Maybe Text
         , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> Text
dbViewOrigName :: Text
         , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> Text
dbViewCurrentName :: Text
         , forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> TableSettings tbl
dbViewSettings :: TableSettings tbl }
      -> DatabaseEntityDescriptor be (ViewEntity tbl)
  type DatabaseEntityDefaultRequirements be (ViewEntity tbl) =
    ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ())
    , Generic (TableSettings tbl), Beamable tbl )
  type DatabaseEntityRegularRequirements be (ViewEntity tbl) =
    (  Beamable tbl )

  dbEntityName :: Lens' (DatabaseEntityDescriptor be (ViewEntity tbl)) Text
dbEntityName Text -> f Text
f DatabaseEntityDescriptor be (ViewEntity tbl)
vw = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
t' -> DatabaseEntityDescriptor be (ViewEntity tbl)
vw { dbViewCurrentName :: Text
dbViewCurrentName = Text
t' }) (Text -> f Text
f (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> Text
dbViewCurrentName DatabaseEntityDescriptor be (ViewEntity tbl)
vw))
  dbEntitySchema :: Traversal'
  (DatabaseEntityDescriptor be (ViewEntity tbl)) (Maybe Text)
dbEntitySchema Maybe Text -> f (Maybe Text)
f DatabaseEntityDescriptor be (ViewEntity tbl)
vw = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Text
s' -> DatabaseEntityDescriptor be (ViewEntity tbl)
vw { dbViewSchema :: Maybe Text
dbViewSchema = Maybe Text
s' }) (Maybe Text -> f (Maybe Text)
f (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (ViewEntity tbl) -> Maybe Text
dbViewSchema DatabaseEntityDescriptor be (ViewEntity tbl)
vw))
  dbEntityAuto :: DatabaseEntityDefaultRequirements be (ViewEntity tbl) =>
Text -> DatabaseEntityDescriptor be (ViewEntity tbl)
dbEntityAuto Text
nm =
    forall (tbl :: (* -> *) -> *) be.
Maybe Text
-> Text
-> Text
-> TableSettings tbl
-> DatabaseEntityDescriptor be (ViewEntity tbl)
DatabaseView forall a. Maybe a
Nothing Text
nm (Text -> Text
unCamelCaseSel Text
nm) forall (table :: (* -> *) -> *).
(Generic (TableSettings table),
 GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
TableSettings table
defTblFieldSettings

instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (DomainTypeEntity ty))) where
  renamingFields :: (NonEmpty Text -> Text)
-> FieldRenamer (DatabaseEntityDescriptor be (DomainTypeEntity ty))
renamingFields NonEmpty Text -> Text
_ = forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer forall a. a -> a
id

instance IsDatabaseEntity be (DomainTypeEntity ty) where
  data DatabaseEntityDescriptor be (DomainTypeEntity ty)
    = DatabaseDomainType !(Maybe Text) !Text
  type DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) = ()
  type DatabaseEntityRegularRequirements be (DomainTypeEntity ty) = ()

  dbEntityName :: Lens' (DatabaseEntityDescriptor be (DomainTypeEntity ty)) Text
dbEntityName Text -> f Text
f (DatabaseDomainType Maybe Text
s Text
t) = forall be ty.
Maybe Text
-> Text -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
DatabaseDomainType Maybe Text
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f Text
t
  dbEntitySchema :: Traversal'
  (DatabaseEntityDescriptor be (DomainTypeEntity ty)) (Maybe Text)
dbEntitySchema Maybe Text -> f (Maybe Text)
f (DatabaseDomainType Maybe Text
s Text
t) = forall be ty.
Maybe Text
-> Text -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
DatabaseDomainType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> f (Maybe Text)
f Maybe Text
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
  dbEntityAuto :: DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) =>
Text -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
dbEntityAuto = forall be ty.
Maybe Text
-> Text -> DatabaseEntityDescriptor be (DomainTypeEntity ty)
DatabaseDomainType forall a. Maybe a
Nothing

-- | Represents a meta-description of a particular entityType. Mostly, a wrapper
--   around 'DatabaseEntityDescriptor be entityType', but carries around the
--   'IsDatabaseEntity' dictionary.
data DatabaseEntity be (db :: (Type -> Type) -> Type) entityType  where
    DatabaseEntity ::
      IsDatabaseEntity be entityType =>
      DatabaseEntityDescriptor be entityType ->  DatabaseEntity be db entityType

dbEntityDescriptor :: SimpleGetter (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor :: forall be (db :: (* -> *) -> *) entityType.
SimpleGetter
  (DatabaseEntity be db entityType)
  (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor = forall s a. (s -> a) -> SimpleGetter s a
Lens.to (\(DatabaseEntity DatabaseEntityDescriptor be entityType
e) -> DatabaseEntityDescriptor be entityType
e)

-- | When parameterized by this entity tag, a database type will hold
--   meta-information on the Haskell mappings of database entities. Under the
--   hood, each entity type is transformed into its 'DatabaseEntityDescriptor'
--   type. For tables this includes the table name as well as the corresponding
--   'TableSettings', which provides names for each column.
type DatabaseSettings be db = db (DatabaseEntity be db)

class GAutoDbSettings x where
    autoDbSettings' :: x
instance GAutoDbSettings (x p) => GAutoDbSettings (D1 f x p) where
    autoDbSettings' :: D1 f x p
autoDbSettings' = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall x. GAutoDbSettings x => x
autoDbSettings'
instance GAutoDbSettings (x p) => GAutoDbSettings (C1 f x p) where
    autoDbSettings' :: C1 f x p
autoDbSettings' = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall x. GAutoDbSettings x => x
autoDbSettings'
instance (GAutoDbSettings (x p), GAutoDbSettings (y p)) => GAutoDbSettings ((x :*: y) p) where
    autoDbSettings' :: (:*:) x y p
autoDbSettings' = forall x. GAutoDbSettings x => x
autoDbSettings' forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall x. GAutoDbSettings x => x
autoDbSettings'
instance ( Selector f, IsDatabaseEntity be x, DatabaseEntityDefaultRequirements be x ) =>
  GAutoDbSettings (S1 f (K1 Generic.R (DatabaseEntity be db x)) p) where
  autoDbSettings' :: S1 f (K1 R (DatabaseEntity be db x)) p
autoDbSettings' = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall k i c (p :: k). c -> K1 i c p
K1 (forall be entityType (db :: (* -> *) -> *).
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType
-> DatabaseEntity be db entityType
DatabaseEntity (forall be entityType.
(IsDatabaseEntity be entityType,
 DatabaseEntityDefaultRequirements be entityType) =>
Text -> DatabaseEntityDescriptor be entityType
dbEntityAuto Text
name)))
    where name :: Text
name = String -> Text
T.pack (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. HasCallStack => a
undefined :: S1 f (K1 Generic.R (DatabaseEntity be db x)) p))

class GZipDatabase be f g h x y z where
  gZipDatabase :: Applicative m =>
                  (Proxy f, Proxy g, Proxy h, Proxy be)
               -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements 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 :: forall (m :: * -> *).
Applicative m =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(M1 x ()
f) ~(M1 y ()
g) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Applicative m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements 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 :: forall (m :: * -> *).
Applicative m =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(ax ()
ax :*: bx ()
bx) ~(ay ()
ay :*: by ()
by) =
    forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Applicative m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ax ()
ax ay ()
ay) (forall be (f :: * -> *) (g :: * -> *) (h :: * -> *) (x :: * -> *)
       (y :: * -> *) (z :: * -> *) (m :: * -> *).
(GZipDatabase be f g h x y z, Applicative m) =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine bx ()
bx by ()
by)
instance (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) =>
  GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl)) where

  gZipDatabase :: forall (m :: * -> *).
Applicative m =>
(Proxy f, Proxy g, Proxy h, Proxy be)
-> (forall tbl.
    (IsDatabaseEntity be tbl,
     DatabaseEntityRegularRequirements 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.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine ~(K1 f tbl
x) ~(K1 g tbl
y) =
    forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall tbl.
(IsDatabaseEntity be tbl,
 DatabaseEntityRegularRequirements be tbl) =>
f tbl -> g tbl -> m (h tbl)
combine f tbl
x g tbl
y

data Lenses (t :: (Type -> Type) -> Type) (f :: Type -> Type) x
data LensFor t x where
    LensFor :: Generic t => Lens' t x -> LensFor t x

-- | A type family that we use to "tag" columns in our table datatypes.
--
--   This is what allows us to use the same table type to hold table data, describe table settings,
--   derive lenses, and provide expressions.
--
--   The basic rules are
--
-- > Columnar Identity x = x
--
--   Thus, any Beam table applied to 'Identity' will yield a simplified version of the data type, that contains
--   just what you'd expect.
--
--   The 'Nullable' type is used when referencing 'PrimaryKey's that we want to include optionally.
--   For example, if we have a table with a 'PrimaryKey', like the following
--
-- > data BeamTableT f = BeamTableT
-- >                   { _refToAnotherTable :: PrimaryKey AnotherTableT f
-- >                   , ... }
--
--   we would typically be required to provide values for the 'PrimaryKey' embedded into 'BeamTableT'. We can use
--   'Nullable' to lift this constraint.
--
-- > data BeamTableT f = BeamTableT
-- >                   { _refToAnotherTable :: PrimaryKey AnotherTableT (Nullable f)
-- >                   , ... }
--
--   Now we can use 'just_' and 'nothing_' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable'
--   automatically has its fields converted into 'Maybe' using 'Nullable'.
--
--   The last 'Columnar' rule is
--
-- > Columnar f x = f x
--
--   Use this rule if you'd like to parameterize your table type over any other functor. For example, this is used
--   in the query modules to write expressions such as 'TableT QExpr', which returns a table whose fields have been
--   turned into query expressions.
--
--   The other rules are used within Beam to provide lenses and to expose the inner structure of the data type.
type family Columnar (f :: Type -> Type) x where
    Columnar Exposed x = Exposed x

    Columnar Identity x = x

    Columnar (Lenses t f) x = LensFor (t f) (Columnar f x)
--    Columnar (Lenses t f) x = LensFor (t f) (f x)

    Columnar (Nullable c) x = Columnar c (Maybe x)

    Columnar f x = f x

-- | A short type-alias for 'Columnar'. May shorten your schema definitions
type C f a = Columnar f a

-- | If you declare a function 'Columnar f a -> b' and try to constrain your
--   function by a type class for 'f', GHC will complain, because 'f' is
--   ambiguous in 'Columnar f a'. For example, 'Columnar Identity (Maybe a) ~
--   Maybe a' and 'Columnar (Nullable Identity) a ~ Maybe a', so given a type
--   'Columnar f a', we cannot know the type of 'f'.
--
--   Thus, if you need to know 'f', you can instead use 'Columnar''. Since its a
--   newtype, it carries around the 'f' paramater unambiguously. Internally, it
--   simply wraps 'Columnar f a'
newtype Columnar' f a = Columnar' (Columnar f a)

-- | Like 'Data.Functor.Compose', but with an intermediate 'Columnar'
newtype ComposeColumnar f g a = ComposeColumnar (f (Columnar g a))

-- | Metadata for a field of type 'ty' in 'table'.
--
--   Essentially a wrapper over the field name, but with a phantom type
--   parameter, so that it forms an appropriate column tag.
--
--   Usually you use the 'defaultDbSettings' function to generate an appropriate
--   naming convention for you, and then modify it with 'withDbModification' if
--   necessary. Under this scheme, the field n be renamed using the 'IsString'
--   instance for 'TableField', or the 'fieldNamed' function.
data TableField (table :: (Type -> Type) -> Type) ty
  = TableField
  { forall (table :: (* -> *) -> *) ty.
TableField table ty -> NonEmpty Text
_fieldPath :: NE.NonEmpty T.Text
    -- ^ The path that led to this field. Each element is the haskell
    -- name of the record field in which this table is stored.
  , forall (table :: (* -> *) -> *) ty. TableField table ty -> Text
_fieldName :: Text  -- ^ The field name
  } deriving (Int -> TableField table ty -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (table :: (* -> *) -> *) ty.
Int -> TableField table ty -> ShowS
forall (table :: (* -> *) -> *) ty. [TableField table ty] -> ShowS
forall (table :: (* -> *) -> *) ty. TableField table ty -> String
showList :: [TableField table ty] -> ShowS
$cshowList :: forall (table :: (* -> *) -> *) ty. [TableField table ty] -> ShowS
show :: TableField table ty -> String
$cshow :: forall (table :: (* -> *) -> *) ty. TableField table ty -> String
showsPrec :: Int -> TableField table ty -> ShowS
$cshowsPrec :: forall (table :: (* -> *) -> *) ty.
Int -> TableField table ty -> ShowS
Show, TableField table ty -> TableField table ty -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (table :: (* -> *) -> *) ty.
TableField table ty -> TableField table ty -> Bool
/= :: TableField table ty -> TableField table ty -> Bool
$c/= :: forall (table :: (* -> *) -> *) ty.
TableField table ty -> TableField table ty -> Bool
== :: TableField table ty -> TableField table ty -> Bool
$c== :: forall (table :: (* -> *) -> *) ty.
TableField table ty -> TableField table ty -> Bool
Eq)

-- | Van Laarhoven lens to retrieve or set the field name from a 'TableField'.
fieldName :: Lens' (TableField table ty) Text
fieldName :: forall (table :: (* -> *) -> *) ty.
Lens' (TableField table ty) Text
fieldName Text -> f Text
f (TableField NonEmpty Text
path Text
name) = forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField NonEmpty Text
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f Text
name

fieldPath :: Traversal' (TableField table ty) Text
fieldPath :: forall (table :: (* -> *) -> *) ty.
Traversal' (TableField table ty) Text
fieldPath Text -> f Text
f (TableField NonEmpty Text
orig Text
name) = forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> f Text
f NonEmpty Text
orig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name

-- | Represents a table that contains metadata on its fields. In particular,
--   each field of type 'Columnar f a' is transformed into 'TableField table a'.
--   You can get or update the name of each field by using the 'fieldName' lens.
type TableSettings table = table (TableField table)

-- | The regular Haskell version of the table. Equivalent to 'tbl Identity'
type HaskellTable table = table Identity

-- | Column tag that ignores the type.
data Ignored x = Ignored
-- | A form of 'table' all fields 'Ignored'. Useful as a parameter to
--   'zipTables' when you only care about one table.
type TableSkeleton table = table Ignored

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

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

type HasBeamFields table f g h = ( GZipTables f g h (Rep (table Exposed))
                                                    (Rep (table f))
                                                    (Rep (table g))
                                                    (Rep (table h))

                                 , Generic (table f)
                                 , Generic (table g)
                                 , Generic (table h)
                                 )

-- | The big Kahuna! All beam tables implement this class.
--
--   The kind of all table types is '(Type -> Type) -> Type'. This is
--   because all table types are actually /table type constructors/.
--   Every table type takes in another type constructor, called the
--   /column tag/, and uses that constructor to instantiate the column
--   types.  See the documentation for 'Columnar'.
--
--   This class is mostly Generic-derivable. You need only specify a
--   type for the table's primary key and a method to extract the
--   primary key given the table.
--
--   An example table:
--
-- > data BlogPostT f = BlogPost
-- >                  { _blogPostSlug    :: Columnar f Text
-- >                  , _blogPostBody    :: Columnar f Text
-- >                  , _blogPostDate    :: Columnar f UTCTime
-- >                  , _blogPostAuthor  :: PrimaryKey AuthorT f
-- >                  , _blogPostTagline :: Columnar f (Maybe Text)
-- >                  , _blogPostImageGallery :: PrimaryKey ImageGalleryT (Nullable f) }
-- >                    deriving Generic
-- > instance Beamable BlogPostT
-- > instance Table BlogPostT where
-- >    data PrimaryKey BlogPostT f = BlogPostId (Columnar f Text) deriving Generic
-- >    primaryKey = BlogPostId . _blogPostSlug
-- > instance Beamable (PrimaryKey BlogPostT)
--
--   We can interpret this as follows:
--
--     * The `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, and `_blogPostTagline` fields are of types 'Text', 'Text', 'UTCTime', and 'Maybe Text' respectfully.
--     * Since `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, `_blogPostAuthor` must be provided (i.e, they cannot contain 'Nothing'), they will be given SQL NOT NULL constraints.
--       `_blogPostTagline` is declared 'Maybe' so 'Nothing' will be stored as NULL in the database. `_blogPostImageGallery` will be allowed to be empty because it uses the 'Nullable' tag modifier.
--     * `blogPostAuthor` references the `AuthorT` table (not given here) and is required.
--     * `blogPostImageGallery` references the `ImageGalleryT` table (not given here), but this relation is not required (i.e., it may be 'Nothing'. See 'Nullable').
class (Typeable table, Beamable table, Beamable (PrimaryKey table)) => Table (table :: (Type -> Type) -> Type) where

    -- | A data type representing the types of primary keys for this table.
    --   In order to play nicely with the default deriving mechanism, this type must be an instance of 'Generic'.
    data PrimaryKey table (column :: Type -> Type) :: Type

    -- | Given a table, this should return the PrimaryKey from the table. By keeping this polymorphic over column,
    --   we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants)
    primaryKey :: table column -> PrimaryKey table column

-- | Provides a number of introspection routines for the beam library. Allows us
--   to "zip" tables with different column tags together. Always instantiate an
--   empty 'Beamable' instance for tables, primary keys, and any type that you
--   would like to embed within either. See the
--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for more
--   information on embedding.
class Beamable table where
    zipBeamFieldsM :: Applicative m =>
                      (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h)

    default zipBeamFieldsM :: ( HasBeamFields table f g h
                              , Applicative m

                              ) => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
                                -> table f
                                -> table g
                                -> m (table h)

    zipBeamFieldsM forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine (table f
f :: table f) table g
g =
        forall x. Generic x => Rep x () -> x
to' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (g :: * -> *) (h :: * -> *)
       (exposedRep :: * -> *) (fRep :: * -> *) (gRep :: * -> *)
       (hRep :: * -> *) (m :: * -> *).
(GZipTables f g h exposedRep fRep gRep hRep, Applicative m) =>
Proxy exposedRep
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> fRep ()
-> gRep ()
-> m (hRep ())
gZipTables (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep (table Exposed))) forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine (forall x. Generic x => x -> Rep x ()
from' table f
f) (forall x. Generic x => x -> Rep x ()
from' table g
g)

    tblSkeleton :: TableSkeleton table

    default tblSkeleton :: ( Generic (TableSkeleton table)
                           , GTableSkeleton (Rep (TableSkeleton table))
                           ) => TableSkeleton table

    tblSkeleton = (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table)
-> TableSkeleton table
withProxy forall a b. (a -> b) -> a -> b
$ \Proxy (Rep (TableSkeleton table))
proxy -> forall x. Generic x => Rep x () -> x
to' (forall (x :: * -> *). GTableSkeleton x => Proxy x -> x ()
gTblSkeleton Proxy (Rep (TableSkeleton table))
proxy)
        where withProxy :: (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table) -> TableSkeleton table
              withProxy :: (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table)
-> TableSkeleton table
withProxy Proxy (Rep (TableSkeleton table)) -> TableSkeleton table
f = Proxy (Rep (TableSkeleton table)) -> TableSkeleton table
f forall {k} (t :: k). Proxy t
Proxy

tableValuesNeeded :: Beamable table => Proxy table -> Int
tableValuesNeeded :: forall (table :: (* -> *) -> *).
Beamable table =>
Proxy table -> Int
tableValuesNeeded (Proxy table
Proxy :: Proxy table) = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (forall a b. a -> b -> a
const ()) (forall (table :: (* -> *) -> *).
Beamable table =>
TableSkeleton table
tblSkeleton :: TableSkeleton table))

allBeamValues :: Beamable table => (forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues :: forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (forall a. Columnar' f a -> b
f :: forall a. Columnar' f a -> b) (table f
tbl :: table f) =
    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 forall a.
Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
combine table f
tbl table f
tbl)
    where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
          combine :: forall a.
Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
combine Columnar' f a
x Columnar' f a
_ = do forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [forall a. Columnar' f a -> b
f Columnar' f a
x]
                           forall (m :: * -> *) a. Monad m => a -> m a
return Columnar' f a
x

changeBeamRep :: Beamable table => (forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep :: forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep forall a. Columnar' f a -> Columnar' g a
f table f
tbl = forall a. Identity a -> a
runIdentity (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' f a
x Columnar' f a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Columnar' f a -> Columnar' g a
f Columnar' f a
x)) table f
tbl table f
tbl)

alongsideTable :: Beamable tbl => tbl f -> tbl g -> tbl (Columnar' f :*: Columnar' g)
alongsideTable :: forall (tbl :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable tbl =>
tbl f -> tbl g -> tbl (Columnar' f :*: Columnar' g)
alongsideTable tbl f
a tbl g
b =
  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' f a
x Columnar' g a
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (Columnar' f a
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Columnar' g a
y))) tbl f
a tbl g
b

class Retaggable f x | x -> f where
  type Retag (tag :: (Type -> Type) -> Type -> Type) x :: Type

  retag :: (forall a. Columnar' f a -> Columnar' (tag f) a) -> x
        -> Retag tag x

instance Beamable tbl => Retaggable f (tbl (f :: Type -> Type)) where
  type Retag tag (tbl f) = tbl (tag f)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> tbl f -> Retag tag (tbl f)
retag = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep

instance (Retaggable f a, Retaggable f b) => Retaggable f (a, b) where
  type Retag tag (a, b) = (Retag tag a, Retag tag b)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> (a, b) -> Retag tag (a, b)
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform (a
a, b
b) = (forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform b
b)

instance (Retaggable f a, Retaggable f b, Retaggable f c) =>
  Retaggable f (a, b, c) where
  type Retag tag (a, b, c) = (Retag tag a, Retag tag b, Retag tag c)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> (a, b, c) -> Retag tag (a, b, c)
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform (a
a, b
b, c
c) = (forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform c
c)

instance (Retaggable f a, Retaggable f b, Retaggable f c, Retaggable f d) =>
  Retaggable f (a, b, c, d) where
  type Retag tag (a, b, c, d) =
    (Retag tag a, Retag tag b, Retag tag c, Retag tag d)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> (a, b, c, d) -> Retag tag (a, b, c, d)
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform (a
a, b
b, c
c, d
d) =
    (forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform c
c, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform d
d)

instance ( Retaggable f a, Retaggable f b, Retaggable f c, Retaggable f d
         , Retaggable f e ) =>
  Retaggable f (a, b, c, d, e) where
  type Retag tag (a, b, c, d, e) =
    (Retag tag a, Retag tag b, Retag tag c, Retag tag d, Retag tag e)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> (a, b, c, d, e) -> Retag tag (a, b, c, d, e)
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform (a
a, b
b, c
c, d
d, e
e) =
    ( forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform c
c, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform d
d
    , forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f a -> Columnar' (tag f) a
transform e
e)

instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d
         , Retaggable f' e, Retaggable f' f ) =>
  Retaggable f' (a, b, c, d, e, f) where
  type Retag tag (a, b, c, d, e, f) =
    ( Retag tag a, Retag tag b, Retag tag c, Retag tag d
    , Retag tag e, Retag tag f)

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f' a -> Columnar' (tag f') a)
-> (a, b, c, d, e, f) -> Retag tag (a, b, c, d, e, f)
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform (a
a, b
b, c
c, d
d, e
e, f
f) =
    ( forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform c
c, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform d
d
    , forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform e
e, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform f
f )

instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d
         , Retaggable f' e, Retaggable f' f, Retaggable f' g ) =>
  Retaggable f' (a, b, c, d, e, f, g) where
  type Retag tag (a, b, c, d, e, f, g) =
    ( Retag tag a, Retag tag b, Retag tag c, Retag tag d
    , Retag tag e, Retag tag f, Retag tag g )

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f' a -> Columnar' (tag f') a)
-> (a, b, c, d, e, f, g) -> Retag tag (a, b, c, d, e, f, g)
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform (a
a, b
b, c
c, d
d, e
e, f
f, g
g) =
    ( forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform c
c, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform d
d
    , forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform e
e, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform f
f, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform g
g )

instance ( Retaggable f' a, Retaggable f' b, Retaggable f' c, Retaggable f' d
         , Retaggable f' e, Retaggable f' f, Retaggable f' g, Retaggable f' h ) =>
  Retaggable f' (a, b, c, d, e, f, g, h) where
  type Retag tag (a, b, c, d, e, f, g, h) =
    ( Retag tag a, Retag tag b, Retag tag c, Retag tag d
    , Retag tag e, Retag tag f, Retag tag g, Retag tag h )

  retag :: forall (tag :: (* -> *) -> * -> *).
(forall a. Columnar' f' a -> Columnar' (tag f') a)
-> (a, b, c, d, e, f, g, h) -> Retag tag (a, b, c, d, e, f, g, h)
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform (a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h) =
    ( forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform a
a, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform b
b, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform c
c, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform d
d
    , forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform e
e, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform f
f, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform g
g, forall (f :: * -> *) x (tag :: (* -> *) -> * -> *).
Retaggable f x =>
(forall a. Columnar' f a -> Columnar' (tag f) a)
-> x -> Retag tag x
retag forall a. Columnar' f' a -> Columnar' (tag f') a
transform h
h )

-- | Carry a constraint instance and the value it applies to.
data WithConstraint (c :: Type -> Constraint) x where
  WithConstraint :: c x => x -> WithConstraint c x

-- | Carry a constraint instance.
data HasConstraint (c :: Type -> Constraint) x where
  HasConstraint :: c x => HasConstraint c x

class GFieldsFulfillConstraint (c :: Type -> Constraint) (exposed :: Type -> Type) withconstraint where
  gWithConstrainedFields :: Proxy c -> Proxy exposed -> withconstraint ()
instance GFieldsFulfillConstraint c exposed withconstraint =>
    GFieldsFulfillConstraint c (M1 s m exposed) (M1 s m withconstraint) where
  gWithConstrainedFields :: Proxy c -> Proxy (M1 s m exposed) -> M1 s m withconstraint ()
gWithConstrainedFields Proxy c
c Proxy (M1 s m exposed)
_ = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields Proxy c
c (forall {k} (t :: k). Proxy t
Proxy @exposed))
instance GFieldsFulfillConstraint c U1 U1 where
  gWithConstrainedFields :: Proxy c -> Proxy U1 -> U1 ()
gWithConstrainedFields Proxy c
_ Proxy U1
_ = forall k (p :: k). U1 p
U1
instance (GFieldsFulfillConstraint c aExp aC, GFieldsFulfillConstraint c bExp bC) =>
  GFieldsFulfillConstraint c (aExp :*: bExp) (aC :*: bC) where
  gWithConstrainedFields :: Proxy c -> Proxy (aExp :*: bExp) -> (:*:) aC bC ()
gWithConstrainedFields Proxy c
be Proxy (aExp :*: bExp)
_ = forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields Proxy c
be (forall {k} (t :: k). Proxy t
Proxy @aExp) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields Proxy c
be (forall {k} (t :: k). Proxy t
Proxy @bExp)
instance (c x) => GFieldsFulfillConstraint c (K1 Generic.R (Exposed x)) (K1 Generic.R (HasConstraint c x)) where
  gWithConstrainedFields :: Proxy c -> Proxy (K1 R (Exposed x)) -> K1 R (HasConstraint c x) ()
gWithConstrainedFields Proxy c
_ Proxy (K1 R (Exposed x))
_ = forall k i c (p :: k). c -> K1 i c p
K1 forall (c :: * -> Constraint) x. c x => HasConstraint c x
HasConstraint
instance FieldsFulfillConstraint c t =>
    GFieldsFulfillConstraint c (K1 Generic.R (t Exposed)) (K1 Generic.R (t (HasConstraint c))) where
  gWithConstrainedFields :: Proxy c
-> Proxy (K1 R (t Exposed)) -> K1 R (t (HasConstraint c)) ()
gWithConstrainedFields Proxy c
_ Proxy (K1 R (t Exposed))
_ = forall k i c (p :: k). c -> K1 i c p
K1 (forall a x. Generic a => Rep a x -> a
to (forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (t :: k). Proxy t
Proxy @(Rep (t Exposed)))))
instance FieldsFulfillConstraintNullable c t =>
    GFieldsFulfillConstraint c (K1 Generic.R (t (Nullable Exposed))) (K1 Generic.R (t (Nullable (HasConstraint c)))) where
  gWithConstrainedFields :: Proxy c
-> Proxy (K1 R (t (Nullable Exposed)))
-> K1 R (t (Nullable (HasConstraint c))) ()
gWithConstrainedFields Proxy c
_ Proxy (K1 R (t (Nullable Exposed)))
_ = forall k i c (p :: k). c -> K1 i c p
K1 (forall a x. Generic a => Rep a x -> a
to (forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (t :: k). Proxy t
Proxy @(Rep (t (Nullable Exposed))))))

withConstrainedFields :: forall c tbl
                       . (FieldsFulfillConstraint c tbl, Beamable tbl) => tbl Identity -> tbl (WithConstraint c)
withConstrainedFields :: forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(FieldsFulfillConstraint c tbl, Beamable tbl) =>
tbl Identity -> tbl (WithConstraint c)
withConstrainedFields = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a.
Columnar' (HasConstraint c) a
-> Columnar' Identity a
-> Identity (Columnar' (WithConstraint c) a)
f (forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(Beamable tbl, FieldsFulfillConstraint c tbl) =>
tbl (HasConstraint c)
withConstraints @c @tbl)
  where f :: forall a. Columnar' (HasConstraint c) a -> Columnar' Identity a -> Identity (Columnar' (WithConstraint c) a)
        f :: forall a.
Columnar' (HasConstraint c) a
-> Columnar' Identity a
-> Identity (Columnar' (WithConstraint c) a)
f (Columnar' HasConstraint c a
Columnar (HasConstraint c) a
HasConstraint) (Columnar' Columnar Identity a
a) = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) x. c x => x -> WithConstraint c x
WithConstraint Columnar Identity a
a

withConstraints :: forall c tbl. (Beamable tbl, FieldsFulfillConstraint c tbl) => tbl (HasConstraint c)
withConstraints :: forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(Beamable tbl, FieldsFulfillConstraint c tbl) =>
tbl (HasConstraint c)
withConstraints = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (t :: k). Proxy t
Proxy @(Rep (tbl Exposed)))

withNullableConstrainedFields :: forall c tbl
                               . (FieldsFulfillConstraintNullable c tbl, Beamable tbl) => tbl (Nullable Identity) -> tbl (Nullable (WithConstraint c))
withNullableConstrainedFields :: forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(FieldsFulfillConstraintNullable c tbl, Beamable tbl) =>
tbl (Nullable Identity) -> tbl (Nullable (WithConstraint c))
withNullableConstrainedFields = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a.
Columnar' (Nullable (HasConstraint c)) a
-> Columnar' (Nullable Identity) a
-> Identity (Columnar' (Nullable (WithConstraint c)) a)
f (forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(Beamable tbl, FieldsFulfillConstraintNullable c tbl) =>
tbl (Nullable (HasConstraint c))
withNullableConstraints @c @tbl)
  where f :: forall a. Columnar' (Nullable (HasConstraint c)) a -> Columnar' (Nullable Identity) a -> Identity (Columnar' (Nullable (WithConstraint c)) a)
        f :: forall a.
Columnar' (Nullable (HasConstraint c)) a
-> Columnar' (Nullable Identity) a
-> Identity (Columnar' (Nullable (WithConstraint c)) a)
f (Columnar' HasConstraint c (Maybe a)
Columnar (Nullable (HasConstraint c)) a
HasConstraint) (Columnar' Columnar (Nullable Identity) a
a) = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) x. c x => x -> WithConstraint c x
WithConstraint Columnar (Nullable Identity) a
a

withNullableConstraints ::  forall c tbl. (Beamable tbl, FieldsFulfillConstraintNullable c tbl) => tbl (Nullable (HasConstraint c))
withNullableConstraints :: forall (c :: * -> Constraint) (tbl :: (* -> *) -> *).
(Beamable tbl, FieldsFulfillConstraintNullable c tbl) =>
tbl (Nullable (HasConstraint c))
withNullableConstraints = forall a x. Generic a => Rep a x -> a
to forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) (exposed :: * -> *)
       (withconstraint :: * -> *).
GFieldsFulfillConstraint c exposed withconstraint =>
Proxy c -> Proxy exposed -> withconstraint ()
gWithConstrainedFields (forall {k} (t :: k). Proxy t
Proxy @c) (forall {k} (t :: k). Proxy t
Proxy @(Rep (tbl (Nullable Exposed))))

type FieldsFulfillConstraint (c :: Type -> Constraint) t =
  ( Generic (t (HasConstraint c)), Generic (t Identity), Generic (t Exposed)
  , GFieldsFulfillConstraint c (Rep (t Exposed)) (Rep (t (HasConstraint c))))

type FieldsFulfillConstraintNullable (c :: Type -> Constraint) t =
  ( Generic (t (Nullable (HasConstraint c))), Generic (t (Nullable Identity)), Generic (t (Nullable Exposed))
  , GFieldsFulfillConstraint c (Rep (t (Nullable Exposed))) (Rep (t (Nullable (HasConstraint c)))))

-- | Synonym for 'primaryKey'
pk :: Table t => t f -> PrimaryKey t f
pk :: forall (t :: (* -> *) -> *) (f :: * -> *).
Table t =>
t f -> PrimaryKey t f
pk = forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey

-- | Return a 'TableSettings' for the appropriate 'table' type where each column
--   has been given its default name. See the
--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for
--   information on the default naming convention.
defTblFieldSettings :: ( Generic (TableSettings table)
                       , GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
                       TableSettings table
defTblFieldSettings :: forall (table :: (* -> *) -> *).
(Generic (TableSettings table),
 GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
TableSettings table
defTblFieldSettings = forall (table :: (* -> *) -> *).
(Proxy (Rep (TableSettings table) ()) -> TableSettings table)
-> TableSettings table
withProxy forall a b. (a -> b) -> a -> b
$ \Proxy (Rep (TableSettings table) ())
proxy -> forall x. Generic x => Rep x () -> x
to' (forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings Proxy (Rep (TableSettings table) ())
proxy)
    where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table
          withProxy :: forall (table :: (* -> *) -> *).
(Proxy (Rep (TableSettings table) ()) -> TableSettings table)
-> TableSettings table
withProxy Proxy (Rep (TableSettings table) ()) -> TableSettings table
f = Proxy (Rep (TableSettings table) ()) -> TableSettings table
f forall {k} (t :: k). Proxy t
Proxy

class GZipTables f g h (exposedRep :: Type -> Type) fRep gRep hRep where
    gZipTables :: Applicative m => Proxy exposedRep
                                -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
                                -> fRep ()
                                -> gRep ()
                                -> m (hRep ())

instance ( GZipTables f g h exp1 f1 g1 h1
         , GZipTables f g h exp2 f2 g2 h2
         ) => GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2)
   where

        gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy (exp1 :*: exp2)
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> (:*:) f1 f2 ()
-> (:*:) g1 g2 ()
-> m ((:*:) h1 h2 ())
gZipTables Proxy (exp1 :*: exp2)
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine ~(f1 ()
f1 :*: f2 ()
f2) ~(g1 ()
g1 :*: g2 ()
g2) =
            forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (g :: * -> *) (h :: * -> *)
       (exposedRep :: * -> *) (fRep :: * -> *) (gRep :: * -> *)
       (hRep :: * -> *) (m :: * -> *).
(GZipTables f g h exposedRep fRep gRep hRep, Applicative m) =>
Proxy exposedRep
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> fRep ()
-> gRep ()
-> m (hRep ())
gZipTables (forall {k} (t :: k). Proxy t
Proxy :: Proxy exp1) forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine f1 ()
f1 g1 ()
g1
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) (g :: * -> *) (h :: * -> *)
       (exposedRep :: * -> *) (fRep :: * -> *) (gRep :: * -> *)
       (hRep :: * -> *) (m :: * -> *).
(GZipTables f g h exposedRep fRep gRep hRep, Applicative m) =>
Proxy exposedRep
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> fRep ()
-> gRep ()
-> m (hRep ())
gZipTables (forall {k} (t :: k). Proxy t
Proxy :: Proxy exp2) forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine f2 ()
f2 g2 ()
g2

instance GZipTables f g h exp fRep gRep hRep =>
    GZipTables f g h (M1 x y exp) (M1 x y fRep) (M1 x y gRep) (M1 x y hRep) where
        gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy (M1 x y exp)
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> M1 x y fRep ()
-> M1 x y gRep ()
-> m (M1 x y hRep ())
gZipTables Proxy (M1 x y exp)
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine ~(M1 fRep ()
f) ~(M1 gRep ()
g) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (g :: * -> *) (h :: * -> *)
       (exposedRep :: * -> *) (fRep :: * -> *) (gRep :: * -> *)
       (hRep :: * -> *) (m :: * -> *).
(GZipTables f g h exposedRep fRep gRep hRep, Applicative m) =>
Proxy exposedRep
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> fRep ()
-> gRep ()
-> m (hRep ())
gZipTables (forall {k} (t :: k). Proxy t
Proxy :: Proxy exp) forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine fRep ()
f gRep ()
g

instance ( fa ~ Columnar f a
         , ga ~ Columnar g a
         , ha ~ Columnar h a
         , ha ~ Columnar h a) =>
    GZipTables f g h (K1 Generic.R (Exposed a)) (K1 Generic.R fa) (K1 Generic.R ga) (K1 Generic.R ha) where
        gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy (K1 R (Exposed a))
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> K1 R fa ()
-> K1 R ga ()
-> m (K1 R ha ())
gZipTables Proxy (K1 R (Exposed a))
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine ~(K1 fa
f) ~(K1 ga
g) = (\(Columnar' Columnar h a
h) -> forall k i c (p :: k). c -> K1 i c p
K1 Columnar h a
h) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' fa
f :: Columnar' f a) (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' ga
g :: Columnar' g a)

instance ( Beamable tbl
         ) => GZipTables f g h (K1 Generic.R (tbl Exposed)) (K1 Generic.R (tbl f))
                                                            (K1 Generic.R (tbl g))
                                                            (K1 Generic.R (tbl h))
   where
    gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy (K1 R (tbl Exposed))
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> K1 R (tbl f) ()
-> K1 R (tbl g) ()
-> m (K1 R (tbl h) ())
gZipTables Proxy (K1 R (tbl Exposed))
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine ~(K1 tbl f
f) ~(K1 tbl g
g) = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine tbl f
f tbl g
g


instance GZipTables f g h U1 U1 U1 U1 where
  gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy U1
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> U1 ()
-> U1 ()
-> m (U1 ())
gZipTables Proxy U1
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
_ U1 ()
_ U1 ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance  ( Beamable tbl
          ) => GZipTables f g h (K1 Generic.R (tbl (Nullable Exposed)))
                                (K1 Generic.R (tbl (Nullable f)))
                                (K1 Generic.R (tbl (Nullable g)))
                                (K1 Generic.R (tbl (Nullable h)))
   where

    gZipTables :: forall (m :: * -> *).
Applicative m =>
Proxy (K1 R (tbl (Nullable Exposed)))
-> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> K1 R (tbl (Nullable f)) ()
-> K1 R (tbl (Nullable g)) ()
-> m (K1 R (tbl (Nullable h)) ())
gZipTables Proxy (K1 R (tbl (Nullable Exposed)))
_ forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine ~(K1 tbl (Nullable f)
f) ~(K1 tbl (Nullable g)
g) =  forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 (forall (m :: * -> *).
Applicative m =>
(forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> forall a.
   Columnar' (Nullable f) a
   -> Columnar' (Nullable g) a -> m (Columnar' (Nullable h) a)
adapt forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine) tbl (Nullable f)
f tbl (Nullable g)
g
      where
        adapt :: Applicative m => (forall a . Columnar' f a            -> Columnar' g a            -> m (Columnar' h a)           )
                               -> (forall a . Columnar' (Nullable f) a -> Columnar' (Nullable g) a -> m (Columnar' (Nullable h) a))
        adapt :: forall (m :: * -> *).
Applicative m =>
(forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> forall a.
   Columnar' (Nullable f) a
   -> Columnar' (Nullable g) a -> m (Columnar' (Nullable h) a)
adapt forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
func Columnar' (Nullable f) a
x Columnar' (Nullable g) a
y = forall (w :: * -> *) a.
Columnar' w (Maybe a) -> Columnar' (Nullable w) a
toNullable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
func ( forall (w :: * -> *) a.
Columnar' (Nullable w) a -> Columnar' w (Maybe a)
fromNullable Columnar' (Nullable f) a
x ) ( forall (w :: * -> *) a.
Columnar' (Nullable w) a -> Columnar' w (Maybe a)
fromNullable Columnar' (Nullable g) a
y )

        fromNullable :: Columnar' (Nullable w) a -> Columnar' w (Maybe a)
        fromNullable :: forall (w :: * -> *) a.
Columnar' (Nullable w) a -> Columnar' w (Maybe a)
fromNullable ~(Columnar' Columnar (Nullable w) a
x) = forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' Columnar (Nullable w) a
x

        toNullable   :: Columnar' w (Maybe a) -> Columnar' (Nullable w) a
        toNullable :: forall (w :: * -> *) a.
Columnar' w (Maybe a) -> Columnar' (Nullable w) a
toNullable ~(Columnar' Columnar w (Maybe a)
x) = forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' Columnar w (Maybe a)
x

class GDefaultTableFieldSettings x where
    gDefTblFieldSettings :: Proxy x -> x
instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (D1 f p x) where
    gDefTblFieldSettings :: Proxy (D1 f p x) -> D1 f p x
gDefTblFieldSettings (Proxy (D1 f p x)
_ :: Proxy (D1 f p x)) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy :: Proxy (p x))
instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (C1 f p x) where
    gDefTblFieldSettings :: Proxy (C1 f p x) -> C1 f p x
gDefTblFieldSettings (Proxy (C1 f p x)
_ :: Proxy (C1 f p x)) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy :: Proxy (p x))
instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where
    gDefTblFieldSettings :: Proxy ((:*:) a b p) -> (:*:) a b p
gDefTblFieldSettings (Proxy ((:*:) a b p)
_ :: Proxy ((a :*: b) p)) = forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy :: Proxy (b p))

instance Selector f  =>
    GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where
    gDefTblFieldSettings :: Proxy (S1 f (K1 R (TableField table field)) p)
-> S1 f (K1 R (TableField table field)) p
gDefTblFieldSettings (Proxy (S1 f (K1 R (TableField table field)) p)
_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall k i c (p :: k). c -> K1 i c p
K1 TableField table field
s)
        where s :: TableField table field
s = forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField (forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
rawSelName) Text
name
              name :: Text
name = Text -> Text
unCamelCaseSel Text
rawSelName
              rawSelName :: Text
rawSelName = String -> Text
T.pack (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. HasCallStack => a
undefined :: S1 f (K1 Generic.R (TableField table field)) ()))

instance ( TypeError ('Text "All Beamable types must be record types, so appropriate names can be given to columns")) => GDefaultTableFieldSettings (K1 r f p) where
  gDefTblFieldSettings :: Proxy (K1 r f p) -> K1 r f p
gDefTblFieldSettings Proxy (K1 r f p)
_ = forall a. HasCallStack => String -> a
error String
"impossible"

-- | Type-level representation of the naming strategy to use for defaulting
--   Needed because primary keys should be named after the default naming of
--   their corresponding table, not the names of the record selectors in the
--   primary key (if any).
data SubTableStrategy
  = PrimaryKeyStrategy
  | BeamableStrategy
  | RecursiveKeyStrategy

type family ChooseSubTableStrategy (tbl :: (Type -> Type) -> Type) (sub :: (Type -> Type) -> Type) :: SubTableStrategy where
  ChooseSubTableStrategy tbl (PrimaryKey tbl) = 'RecursiveKeyStrategy
  ChooseSubTableStrategy tbl (PrimaryKey rel) = 'PrimaryKeyStrategy
  ChooseSubTableStrategy tbl sub = 'BeamableStrategy

-- TODO is this necessary
type family CheckNullable (f :: Type -> Type) :: Constraint where
  CheckNullable (Nullable f) = ()
  CheckNullable f = TypeError ('Text "Recursive references without Nullable constraint form an infinite loop." ':$$:
                               'Text "Hint: Only embed nullable 'PrimaryKey tbl' within the definition of 'tbl'." ':$$:
                               'Text "      For example, replace 'PrimaryKey tbl f' with 'PrimaryKey tbl (Nullable f)'")


class SubTableStrategyImpl (strategy :: SubTableStrategy) (f :: Type -> Type) sub where
  namedSubTable :: Proxy strategy -> sub f

-- The defaulting with @TableField rel@ is necessary to avoid infinite loops
instance ( Table rel, Generic (rel (TableField rel))
         , TagReducesTo f (TableField tbl)
         , GDefaultTableFieldSettings (Rep (rel (TableField rel)) ()) ) =>
  SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) where
  namedSubTable :: Proxy 'PrimaryKeyStrategy -> PrimaryKey rel f
namedSubTable Proxy 'PrimaryKeyStrategy
_ = forall (table :: (* -> *) -> *) (column :: * -> *).
Table table =>
table column -> PrimaryKey table column
primaryKey rel f
tbl
    where tbl :: rel f
tbl = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (TableField NonEmpty Text
path Text
nm) :: Columnar' (TableField rel) a) ->
                                  let c :: Columnar' (TableField tbl) a
c = forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField NonEmpty Text
path Text
nm) :: Columnar' (TableField tbl) a
                                  in forall a. Identity a -> a
runIdentity (forall (f :: * -> *) (f' :: * -> *) (m :: * -> *) a' a.
(TagReducesTo f f', Functor m) =>
(Columnar' f' a' -> m (Columnar' f' a'))
-> Columnar' f a -> m (Columnar' f a)
reduceTag (\Columnar' (TableField tbl) a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Columnar' (TableField tbl) a
c) forall a. HasCallStack => a
undefined)) forall a b. (a -> b) -> a -> b
$
                forall x. Generic x => Rep x () -> x
to' forall a b. (a -> b) -> a -> b
$ forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy @(Rep (rel (TableField rel)) ()))
instance ( Generic (sub f)
         , GDefaultTableFieldSettings (Rep (sub f) ()) ) =>
         SubTableStrategyImpl 'BeamableStrategy f sub where
  namedSubTable :: Proxy 'BeamableStrategy -> sub f
namedSubTable Proxy 'BeamableStrategy
_ = forall x. Generic x => Rep x () -> x
to' forall a b. (a -> b) -> a -> b
$ forall x. GDefaultTableFieldSettings x => Proxy x -> x
gDefTblFieldSettings (forall {k} (t :: k). Proxy t
Proxy @(Rep (sub f) ()))
instance ( CheckNullable f, SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) ) =>
         SubTableStrategyImpl 'RecursiveKeyStrategy f (PrimaryKey rel) where
  namedSubTable :: Proxy 'RecursiveKeyStrategy -> PrimaryKey rel f
namedSubTable Proxy 'RecursiveKeyStrategy
_ = forall (strategy :: SubTableStrategy) (f :: * -> *)
       (sub :: (* -> *) -> *).
SubTableStrategyImpl strategy f sub =>
Proxy strategy -> sub f
namedSubTable (forall {k} (t :: k). Proxy t
Proxy @'PrimaryKeyStrategy)

instance {-# OVERLAPPING #-}
         ( Selector f'
         , ChooseSubTableStrategy tbl sub ~ strategy
         , SubTableStrategyImpl strategy f sub
         , TagReducesTo f (TableField tbl)
         , Beamable sub ) =>
         GDefaultTableFieldSettings (S1 f' (K1 Generic.R (sub f)) p) where
  gDefTblFieldSettings :: Proxy (S1 f' (K1 R (sub f)) p) -> S1 f' (K1 R (sub f)) p
gDefTblFieldSettings Proxy (S1 f' (K1 R (sub f)) p)
_ = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ sub f
settings'
    where tbl :: sub f
          tbl :: sub f
tbl = forall (strategy :: SubTableStrategy) (f :: * -> *)
       (sub :: (* -> *) -> *).
SubTableStrategyImpl strategy f sub =>
Proxy strategy -> sub f
namedSubTable (forall {k} (t :: k). Proxy t
Proxy @strategy)

          origSelName :: Text
origSelName = String -> Text
T.pack (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. HasCallStack => a
undefined :: S1 f' (K1 Generic.R (sub f)) p))
          relName :: Text
relName = Text -> Text
unCamelCaseSel Text
origSelName

          settings' :: sub f
          settings' :: sub f
settings' = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (forall (f :: * -> *) (f' :: * -> *) (m :: * -> *) a' a.
(TagReducesTo f f', Functor m) =>
(Columnar' f' a' -> m (Columnar' f' a'))
-> Columnar' f a -> m (Columnar' f a)
reduceTag forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \(Columnar' (TableField NonEmpty Text
path Text
nm)) -> forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField (forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
origSelName forall a. Semigroup a => a -> a -> a
<> NonEmpty Text
path) (Text
relName forall a. Semigroup a => a -> a -> a
<> Text
"__" forall a. Semigroup a => a -> a -> a
<> Text
nm))) sub f
tbl

type family ReplaceBaseTag tag f where
  ReplaceBaseTag tag (Nullable f) = Nullable (ReplaceBaseTag tag f)
  ReplaceBaseTag tag x = tag

-- | Class to automatically unwrap nested Nullables
class TagReducesTo f f' | f -> f' where
  reduceTag :: Functor m =>
               (Columnar' f' a' -> m (Columnar' f' a'))
            -> Columnar' f a -> m (Columnar' f a)
instance TagReducesTo (TableField tbl) (TableField tbl) where
  reduceTag :: forall (m :: * -> *) a' a.
Functor m =>
(Columnar' (TableField tbl) a'
 -> m (Columnar' (TableField tbl) a'))
-> Columnar' (TableField tbl) a -> m (Columnar' (TableField tbl) a)
reduceTag Columnar' (TableField tbl) a' -> m (Columnar' (TableField tbl) a')
f ~(Columnar' (TableField NonEmpty Text
path Text
nm)) =
    (\(Columnar' (TableField NonEmpty Text
path' Text
nm')) -> forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField NonEmpty Text
path' Text
nm')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Columnar' (TableField tbl) a' -> m (Columnar' (TableField tbl) a')
f (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall (table :: (* -> *) -> *) ty.
NonEmpty Text -> Text -> TableField table ty
TableField NonEmpty Text
path Text
nm))
instance TagReducesTo f f' => TagReducesTo (Nullable f) f' where
  reduceTag :: forall (m :: * -> *) a' a.
Functor m =>
(Columnar' f' a' -> m (Columnar' f' a'))
-> Columnar' (Nullable f) a -> m (Columnar' (Nullable f) a)
reduceTag Columnar' f' a' -> m (Columnar' f' a')
fn ~(Columnar' Columnar (Nullable f) a
x :: Columnar' (Nullable f) a) =
    (\(Columnar' Columnar f (Maybe a)
x' :: Columnar' f (Maybe a')) -> forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' Columnar f (Maybe a)
x') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          forall (f :: * -> *) (f' :: * -> *) (m :: * -> *) a' a.
(TagReducesTo f f', Functor m) =>
(Columnar' f' a' -> m (Columnar' f' a'))
-> Columnar' f a -> m (Columnar' f a)
reduceTag Columnar' f' a' -> m (Columnar' f' a')
fn (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' Columnar (Nullable f) a
x :: Columnar' f (Maybe a))

class GTableSkeleton x where
    gTblSkeleton :: Proxy x -> x ()

instance GTableSkeleton p => GTableSkeleton (M1 t f p) where
    gTblSkeleton :: Proxy (M1 t f p) -> M1 t f p ()
gTblSkeleton (Proxy (M1 t f p)
_ :: Proxy (M1 t f p)) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (x :: * -> *). GTableSkeleton x => Proxy x -> x ()
gTblSkeleton (forall {k} (t :: k). Proxy t
Proxy :: Proxy p))

instance GTableSkeleton U1 where
    gTblSkeleton :: Proxy U1 -> U1 ()
gTblSkeleton Proxy U1
_ = forall k (p :: k). U1 p
U1

instance (GTableSkeleton a, GTableSkeleton b) =>
    GTableSkeleton (a :*: b) where
        gTblSkeleton :: Proxy (a :*: b) -> (:*:) a b ()
gTblSkeleton Proxy (a :*: b)
_ = forall (x :: * -> *). GTableSkeleton x => Proxy x -> x ()
gTblSkeleton (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (x :: * -> *). GTableSkeleton x => Proxy x -> x ()
gTblSkeleton (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)

instance GTableSkeleton (K1 Generic.R (Ignored field)) where
    gTblSkeleton :: Proxy (K1 R (Ignored field)) -> K1 R (Ignored field) ()
gTblSkeleton Proxy (K1 R (Ignored field))
_ = forall k i c (p :: k). c -> K1 i c p
K1 forall x. Ignored x
Ignored

instance ( Beamable tbl
         ) => GTableSkeleton (K1 Generic.R (tbl Ignored))
   where
    gTblSkeleton :: Proxy (K1 R (tbl Ignored)) -> K1 R (tbl Ignored) ()
gTblSkeleton Proxy (K1 R (tbl Ignored))
_ = forall k i c (p :: k). c -> K1 i c p
K1 (forall (table :: (* -> *) -> *).
Beamable table =>
TableSkeleton table
tblSkeleton :: TableSkeleton tbl)

instance ( Beamable tbl
         ) => GTableSkeleton (K1 Generic.R (tbl (Nullable Ignored)))
   where
    gTblSkeleton :: Proxy (K1 R (tbl (Nullable Ignored)))
-> K1 R (tbl (Nullable Ignored)) ()
gTblSkeleton Proxy (K1 R (tbl (Nullable Ignored)))
_ = forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a.
Columnar' Ignored a
-> Columnar' Ignored a -> Identity (Columnar' (Nullable Ignored) a)
transform
                                    (forall (table :: (* -> *) -> *).
Beamable table =>
TableSkeleton table
tblSkeleton :: TableSkeleton tbl)
                                    (forall (table :: (* -> *) -> *).
Beamable table =>
TableSkeleton table
tblSkeleton :: TableSkeleton tbl)
        where
          transform :: Columnar' Ignored a
                    -> Columnar' Ignored a
                    -> Identity (Columnar' (Nullable Ignored) a)
          transform :: forall a.
Columnar' Ignored a
-> Columnar' Ignored a -> Identity (Columnar' (Nullable Ignored) a)
transform Columnar' Ignored a
_ Columnar' Ignored a
_ = forall a. a -> Identity a
Identity (forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall x. Ignored x
Ignored)


-- * Internal functions

unCamelCase :: T.Text -> [T.Text]
unCamelCase :: Text -> [Text]
unCamelCase Text
"" = []
unCamelCase Text
s
    | (Text
comp, Text
next) <- (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isUpper Text
s, Bool -> Bool
not (Text -> Bool
T.null Text
comp) =
          let next' :: Text
next' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Text -> Text
T.cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Char -> Char
toLower) (Text -> Maybe (Char, Text)
T.uncons Text
next)
          in Text -> Text
T.toLower Text
compforall a. a -> [a] -> [a]
:Text -> [Text]
unCamelCase Text
next'
    | Bool
otherwise =
          let (Text
comp, Text
next) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isUpper Text
s
              next' :: Text
next' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Text -> Text
T.cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Char -> Char
toLower) (Text -> Maybe (Char, Text)
T.uncons Text
next)
          in Text -> Text
T.toLower Text
compforall a. a -> [a] -> [a]
:Text -> [Text]
unCamelCase Text
next'

-- | Camel casing magic for standard beam record field names.
--
--   All leading underscores are ignored. If what remains is camel-cased beam
--   will convert it to use underscores instead. If there are any underscores in
--   what remains, then the entire name (minus the leading underscares). If the
--   field name is solely underscores, beam will assume you know what you're
--   doing and include the full original name as the field name
unCamelCaseSel :: Text -> Text
unCamelCaseSel :: Text -> Text
unCamelCaseSel Text
original =
  let symbolLeft :: Text
symbolLeft = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'_') Text
original
  in if Text -> Bool
T.null Text
symbolLeft
     then Text
original
     else if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
==Char
'_') Text
symbolLeft
          then Text
symbolLeft
          else case Text -> [Text]
unCamelCase Text
symbolLeft of
                 [] -> Text
symbolLeft
                 [Text
xs] -> Text
xs
                 Text
_:[Text]
xs -> Text -> [Text] -> Text
T.intercalate Text
"_" [Text]
xs

-- | Produce the beam default field name for the given path
defaultFieldName :: NE.NonEmpty Text -> Text
defaultFieldName :: NonEmpty Text -> Text
defaultFieldName NonEmpty Text
comps = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse (String -> Text
T.pack String
"__") (Text -> Text
unCamelCaseSel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Text
comps))