beam-core-0.7.2.2: Database/Beam/Schema/Tables.hs
{-# 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, fieldNamed
, defaultDbSettings
, RenamableWithRule(..), RenamableField(..)
, FieldRenamer(..)
, Lenses, LensFor(..)
-- * Columnar and Column Tags
, Columnar, C, Columnar'(..)
, ComposeColumnar(..)
, Nullable, TableField(..)
, Exposed
, fieldName
, TableSettings, HaskellTable
, TableSkeleton, Ignored(..)
, GFieldsFulfillConstraint(..), FieldsFulfillConstraint
, FieldsFulfillConstraintNullable
, WithConstraint(..)
, TagReducesTo(..), ReplaceBaseTag
, withConstrainedFields, withConstraints
, withNullableConstrainedFields, withNullableConstraints
-- * Tables
, Table(..), Beamable(..)
, Retaggable(..), (:*:)(..) -- Reexported for use with 'alongsideTable'
, defTblFieldSettings
, tableValuesNeeded
, pk
, allBeamValues, changeBeamRep
, alongsideTable )
where
import Database.Beam.Backend.Types
import Control.Arrow (first)
import Control.Monad.Identity
import Control.Monad.Writer
import Data.Char (isUpper, toLower)
import Data.Monoid ((<>))
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 '(* -> *) -> *'. 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](http://tathougies.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 monad 'm'), then we can
-- transform the two databases over 'f' and 'g' to a database in 'h',
-- within the monad 'm'.
--
-- If that doesn't make sense, don't worry. This is mostly beam internal
zipTables :: Monad 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)
, Monad 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 be combine (f :: db f) (g :: db g) =
refl $ \h ->
to <$> gZipDatabase (Proxy @f, Proxy @g, h, be) combine (from f) (from g)
where
-- For GHC 8.0.1 renamer bug
refl :: (Proxy h -> m (db h)) -> m (db h)
refl fn = fn 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://tathougies.github.io/beam/user-guide/models)
defaultDbSettings :: ( Generic (DatabaseSettings be db)
, GAutoDbSettings (Rep (DatabaseSettings be db) ()) ) =>
DatabaseSettings be db
defaultDbSettings = to' 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 (f e -> f e)
-- | A newtype wrapper around 'Columnar f a -> Columnar f ' (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 = runIdentity $
zipTables (Proxy @be) (\_ _ -> pure (EntityModification id)) (undefined :: DatabaseModification f be db) (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 = runIdentity $
zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
pure (Columnar' (FieldModification id :: FieldModification f x))) (undefined :: TableSkeleton tbl) (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 db mods =
runIdentity $ zipTables (Proxy @be) (\tbl (EntityModification entityFn) -> pure (entityFn tbl)) 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 mods tbl =
runIdentity $ zipBeamFieldsM (\(Columnar' field :: Columnar' f a) (Columnar' (FieldModification fieldFn :: FieldModification f a)) ->
pure (Columnar' (fieldFn field))) tbl 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 :: (Text -> Text)
-> tbl (FieldModification (TableField tbl))
-> EntityModification (DatabaseEntity be db) be (TableEntity tbl)
modifyTable modTblNm modFields =
EntityModification (\(DatabaseEntity (DatabaseTable nm fields)) ->
(DatabaseEntity (DatabaseTable (modTblNm nm) (withTableModification modFields fields))))
-- | 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 newName = FieldModification (\_ -> TableField newName)
newtype FieldRenamer entity = FieldRenamer { withFieldRenamer :: entity -> entity }
class RenamableField f where
renameField :: Proxy f -> Proxy a -> (Text -> Text) -> Columnar f a -> Columnar f a
instance RenamableField (TableField tbl) where
renameField _ _ f (TableField nm) = TableField (f nm)
class RenamableWithRule mod where
renamingFields :: (Text -> Text) -> mod
instance Database be db => RenamableWithRule (db (EntityModification (DatabaseEntity be db) be)) where
renamingFields renamer =
runIdentity $
zipTables (Proxy @be) (\_ _ -> pure (renamingFields renamer))
(undefined :: DatabaseModification f be db)
(undefined :: DatabaseModification f be db)
instance IsDatabaseEntity be entity => RenamableWithRule (EntityModification (DatabaseEntity be db) be entity) where
renamingFields renamer =
EntityModification (\(DatabaseEntity tbl) -> DatabaseEntity (withFieldRenamer (renamingFields renamer) tbl))
instance (Beamable tbl, RenamableField f) => RenamableWithRule (tbl (FieldModification f)) where
renamingFields renamer =
runIdentity $
zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
pure (Columnar' (FieldModification (renameField (Proxy @f) (Proxy @x) renamer) :: FieldModification f x) ::
Columnar' (FieldModification f) x))
(undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl)
instance IsString (FieldModification (TableField tbl) a) where
fromString = fieldNamed . fromString
-- * Database entity types
-- | An entity tag for tables. See the documentation for 'Table' or consult the
-- [manual](https://tathougies.github.io/beam/user-guide/models) for more.
data TableEntity (tbl :: (* -> *) -> *)
data ViewEntity (view :: (* -> *) -> *)
--data UniqueConstraint (tbl :: (* -> *) -> *) (c :: (* -> *) -> *)
data DomainTypeEntity (ty :: *)
--data CharacterSetEntity
--data CollationEntity
--data TranslationEntity
--data AssertionEntity
class RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be entityType)) =>
IsDatabaseEntity be entityType where
data DatabaseEntityDescriptor be entityType :: *
type DatabaseEntityDefaultRequirements be entityType :: Constraint
type DatabaseEntityRegularRequirements be entityType :: Constraint
dbEntityName :: Lens' (DatabaseEntityDescriptor be entityType) Text
dbEntityAuto :: DatabaseEntityDefaultRequirements be entityType =>
Text -> DatabaseEntityDescriptor be entityType
instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (TableEntity tbl))) where
renamingFields renamer =
FieldRenamer $ \(DatabaseTable tblName fields) ->
DatabaseTable tblName $
changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) ->
Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $
fields
instance Beamable tbl => IsDatabaseEntity be (TableEntity tbl) where
data DatabaseEntityDescriptor be (TableEntity tbl) where
DatabaseTable :: Table tbl => Text -> 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 f (DatabaseTable t s) = fmap (\t' -> DatabaseTable t' s) (f t)
dbEntityAuto nm =
DatabaseTable (unCamelCaseSel nm) defTblFieldSettings
instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (ViewEntity tbl))) where
renamingFields renamer =
FieldRenamer $ \(DatabaseView tblName fields) ->
DatabaseView tblName $
changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) ->
Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $
fields
instance Beamable tbl => IsDatabaseEntity be (ViewEntity tbl) where
data DatabaseEntityDescriptor be (ViewEntity tbl) where
DatabaseView :: Text -> 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 f (DatabaseView t s) = fmap (\t' -> DatabaseView t' s) (f t)
dbEntityAuto nm =
DatabaseView (unCamelCaseSel nm) defTblFieldSettings
instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (DomainTypeEntity ty))) where
renamingFields _ = FieldRenamer id
instance IsDatabaseEntity be (DomainTypeEntity ty) where
data DatabaseEntityDescriptor be (DomainTypeEntity ty)
= DatabaseDomainType !Text
type DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) = ()
type DatabaseEntityRegularRequirements be (DomainTypeEntity ty) = ()
dbEntityName f (DatabaseDomainType t) = DatabaseDomainType <$> f t
dbEntityAuto = DatabaseDomainType
-- | 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 :: (* -> *) -> *) entityType where
DatabaseEntity ::
IsDatabaseEntity be entityType =>
DatabaseEntityDescriptor be entityType -> DatabaseEntity be db entityType
dbEntityDescriptor :: SimpleGetter (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
dbEntityDescriptor = Lens.to (\(DatabaseEntity e) -> 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' = M1 autoDbSettings'
instance GAutoDbSettings (x p) => GAutoDbSettings (C1 f x p) where
autoDbSettings' = M1 autoDbSettings'
instance (GAutoDbSettings (x p), GAutoDbSettings (y p)) => GAutoDbSettings ((x :*: y) p) where
autoDbSettings' = autoDbSettings' :*: autoDbSettings'
instance ( Selector f, IsDatabaseEntity be x, DatabaseEntityDefaultRequirements be x ) =>
GAutoDbSettings (S1 f (K1 Generic.R (DatabaseEntity be db x)) p) where
autoDbSettings' = M1 (K1 (DatabaseEntity (dbEntityAuto name)))
where name = T.pack (selName (undefined :: S1 f (K1 Generic.R (DatabaseEntity be db x)) p))
class GZipDatabase be f g h x y z where
gZipDatabase :: Monad 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 p combine ~(M1 f) ~(M1 g) = M1 <$> gZipDatabase p combine f 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 p combine ~(ax :*: bx) ~(ay :*: by) =
do a <- gZipDatabase p combine ax ay
b <- gZipDatabase p combine bx by
pure (a :*: b)
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 _ combine ~(K1 x) ~(K1 y) =
K1 <$> combine x y
data Lenses (t :: (* -> *) -> *) (f :: * -> *) 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 'justRef' and 'nothingRef' 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 :: * -> *) 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 can be renamed using the 'IsString'
-- instance for 'TableField', or the 'fieldNamed' function.
data TableField (table :: (* -> *) -> *) ty
= TableField
{ _fieldName :: Text -- ^ The field name
} deriving (Show, Eq)
-- | Van Laarhoven lens to retrieve or set the field name from a 'TableField'.
fieldName :: Lens' (TableField table ty) Text
fieldName f (TableField name) = TableField <$> f 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' = from
to' :: Generic x => Rep x () -> x
to' = 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 '(* -> *) -> *'. 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 :: (* -> *) -> *) 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 :: * -> *) :: *
-- | 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://tathougies.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 combine (f :: table f) g =
to' <$> gZipTables (Proxy :: Proxy (Rep (table Exposed))) combine (from' f) (from' g)
tblSkeleton :: TableSkeleton table
default tblSkeleton :: ( Generic (TableSkeleton table)
, GTableSkeleton (Rep (TableSkeleton table))
) => TableSkeleton table
tblSkeleton = withProxy $ \proxy -> to' (gTblSkeleton proxy)
where withProxy :: (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table) -> TableSkeleton table
withProxy f = f Proxy
tableValuesNeeded :: Beamable table => Proxy table -> Int
tableValuesNeeded (Proxy :: Proxy table) = length (allBeamValues (const ()) (tblSkeleton :: TableSkeleton table))
allBeamValues :: Beamable table => (forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (f :: forall a. Columnar' f a -> b) (tbl :: table f) =
execWriter (zipBeamFieldsM combine tbl tbl)
where combine :: Columnar' f a -> Columnar' f a -> Writer [b] (Columnar' f a)
combine x _ = do tell [f x]
return x
changeBeamRep :: Beamable table => (forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep f tbl = runIdentity (zipBeamFieldsM (\x _ -> return (f x)) tbl tbl)
alongsideTable :: Beamable tbl => tbl f -> tbl g -> tbl (Columnar' f :*: Columnar' g)
alongsideTable a b =
runIdentity $
zipBeamFieldsM (\x y -> pure (Columnar' (x :*: y))) a b
class Retaggable f x | x -> f where
type Retag (tag :: (* -> *) -> * -> *) x :: *
retag :: (forall a. Columnar' f a -> Columnar' (tag f) a) -> x
-> Retag tag x
instance Beamable tbl => Retaggable f (tbl (f :: * -> *)) where
type Retag tag (tbl f) = tbl (tag f)
retag = 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 transform (a, b) = (retag transform a, retag transform 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 transform (a, b, c) = (retag transform a, retag transform b, retag transform 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 transform (a, b, c, d) =
(retag transform a, retag transform b, retag transform c, retag transform 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 transform (a, b, c, d, e) =
( retag transform a, retag transform b, retag transform c, retag transform d
, retag transform 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 transform (a, b, c, d, e, f) =
( retag transform a, retag transform b, retag transform c, retag transform d
, retag transform e, retag transform 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 transform (a, b, c, d, e, f, g) =
( retag transform a, retag transform b, retag transform c, retag transform d
, retag transform e, retag transform f, retag transform 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 transform (a, b, c, d, e, f, g, h) =
( retag transform a, retag transform b, retag transform c, retag transform d
, retag transform e, retag transform f, retag transform g, retag transform h )
-- Carry a constraint instance
data WithConstraint (c :: * -> Constraint) x where
WithConstraint :: c x => x -> WithConstraint c x
class GFieldsFulfillConstraint (c :: * -> Constraint) (exposed :: * -> *) values withconstraint where
gWithConstrainedFields :: Proxy c -> Proxy exposed -> values () -> withconstraint ()
instance GFieldsFulfillConstraint c exposed values withconstraint =>
GFieldsFulfillConstraint c (M1 s m exposed) (M1 s m values) (M1 s m withconstraint) where
gWithConstrainedFields c _ (M1 x) = M1 (gWithConstrainedFields c (Proxy @exposed) x)
instance GFieldsFulfillConstraint c U1 U1 U1 where
gWithConstrainedFields _ _ _ = U1
instance (GFieldsFulfillConstraint c aExp a aC, GFieldsFulfillConstraint c bExp b bC) =>
GFieldsFulfillConstraint c (aExp :*: bExp) (a :*: b) (aC :*: bC) where
gWithConstrainedFields be _ (a :*: b) = gWithConstrainedFields be (Proxy @aExp) a :*: gWithConstrainedFields be (Proxy @bExp) b
instance (c x) => GFieldsFulfillConstraint c (K1 Generic.R (Exposed x)) (K1 Generic.R x) (K1 Generic.R (WithConstraint c x)) where
gWithConstrainedFields _ _ (K1 x) = K1 (WithConstraint x)
instance FieldsFulfillConstraint c t =>
GFieldsFulfillConstraint c (K1 Generic.R (t Exposed)) (K1 Generic.R (t Identity)) (K1 Generic.R (t (WithConstraint c))) where
gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t Exposed))) (from x)))
instance FieldsFulfillConstraintNullable c t =>
GFieldsFulfillConstraint c (K1 Generic.R (t (Nullable Exposed))) (K1 Generic.R (t (Nullable Identity))) (K1 Generic.R (t (Nullable (WithConstraint c)))) where
gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t (Nullable Exposed)))) (from x)))
withConstrainedFields :: forall c tbl
. FieldsFulfillConstraint c tbl => tbl Identity -> tbl (WithConstraint c)
withConstrainedFields =
to . gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl Exposed))) . from
withConstraints :: forall c tbl. (Beamable tbl, FieldsFulfillConstraint c tbl) => tbl (WithConstraint c)
withConstraints =
withConstrainedFields (changeBeamRep (\_ -> Columnar' undefined) tblSkeleton)
withNullableConstrainedFields :: forall c tbl
. FieldsFulfillConstraintNullable c tbl => tbl (Nullable Identity) -> tbl (Nullable (WithConstraint c))
withNullableConstrainedFields =
to . gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl (Nullable Exposed)))) . from
withNullableConstraints :: forall c tbl. (Beamable tbl, FieldsFulfillConstraintNullable c tbl) => tbl (Nullable (WithConstraint c))
withNullableConstraints =
withNullableConstrainedFields (changeBeamRep (\_ -> Columnar' undefined) tblSkeleton)
type FieldsFulfillConstraint (c :: * -> Constraint) t =
( Generic (t (WithConstraint c)), Generic (t Identity), Generic (t Exposed)
, GFieldsFulfillConstraint c (Rep (t Exposed)) (Rep (t Identity)) (Rep (t (WithConstraint c))))
type FieldsFulfillConstraintNullable (c :: * -> Constraint) t =
( Generic (t (Nullable (WithConstraint c))), Generic (t (Nullable Identity)), Generic (t (Nullable Exposed))
, GFieldsFulfillConstraint c (Rep (t (Nullable Exposed))) (Rep (t (Nullable Identity))) (Rep (t (Nullable (WithConstraint c)))))
-- | Synonym for 'primaryKey'
pk :: Table t => t f -> PrimaryKey t f
pk = primaryKey
-- | Return a 'TableSettings' for the appropriate 'table' type where each column
-- has been given its default name. See the
-- [manual](https://tathougies.github.io/beam/user-guide/models) for
-- information on the default naming convention.
defTblFieldSettings :: ( Generic (TableSettings table)
, GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>
TableSettings table
defTblFieldSettings = withProxy $ \proxy -> to' (gDefTblFieldSettings proxy)
where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table
withProxy f = f Proxy
class GZipTables f g h (exposedRep :: * -> *) 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 _ combine ~(f1 :*: f2) ~(g1 :*: g2) =
(:*:) <$> gZipTables (Proxy :: Proxy exp1) combine f1 g1
<*> gZipTables (Proxy :: Proxy exp2) combine f2 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 _ combine ~(M1 f) ~(M1 g) = M1 <$> gZipTables (Proxy :: Proxy exp) combine f 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 _ combine ~(K1 f) ~(K1 g) = (\(Columnar' h) -> K1 h) <$> combine (Columnar' f :: Columnar' f a) (Columnar' 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 _ combine ~(K1 f) ~(K1 g) = K1 <$> zipBeamFieldsM combine f g
instance GZipTables f g h U1 U1 U1 U1 where
gZipTables _ _ _ _ = pure 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 _ combine ~(K1 f) ~(K1 g) = K1 <$> zipBeamFieldsM (adapt combine) f 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 func x y = toNullable <$> func ( fromNullable x ) ( fromNullable y )
fromNullable :: Columnar' (Nullable w) a -> Columnar' w (Maybe a)
fromNullable ~(Columnar' x) = Columnar' x
toNullable :: Columnar' w (Maybe a) -> Columnar' (Nullable w) a
toNullable ~(Columnar' x) = Columnar' 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)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x))
instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (C1 f p x) where
gDefTblFieldSettings (_ :: Proxy (C1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x))
instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where
gDefTblFieldSettings (_ :: Proxy ((a :*: b) p)) = gDefTblFieldSettings (Proxy :: Proxy (a p)) :*: gDefTblFieldSettings (Proxy :: Proxy (b p))
instance Selector f =>
GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where
gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s)
where s = TableField name
name = unCamelCaseSel (T.pack (selName (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 _ = error "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 :: (* -> *) -> *) (sub :: (* -> *) -> *) :: SubTableStrategy where
ChooseSubTableStrategy tbl (PrimaryKey tbl) = 'RecursiveKeyStrategy
ChooseSubTableStrategy tbl (PrimaryKey rel) = 'PrimaryKeyStrategy
ChooseSubTableStrategy tbl sub = 'BeamableStrategy
-- TODO is this necessary
type family CheckNullable (f :: * -> *) :: Constraint where
CheckNullable (Nullable f) = ()
CheckNullable f = TypeError ('Text "Recursive reference without Nullable constraint forms 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 :: * -> *) 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 _ = primaryKey tbl
where tbl = changeBeamRep (\(Columnar' (TableField nm) :: Columnar' (TableField rel) a) ->
let c = Columnar' (TableField nm) :: Columnar' (TableField tbl) a
in runIdentity (reduceTag (\_ -> pure c) undefined)) $
to' $ gDefTblFieldSettings (Proxy @(Rep (rel (TableField rel)) ()))
instance ( Generic (sub f)
, GDefaultTableFieldSettings (Rep (sub f) ()) ) =>
SubTableStrategyImpl 'BeamableStrategy f sub where
namedSubTable _ = to' $ gDefTblFieldSettings (Proxy @(Rep (sub f) ()))
instance ( CheckNullable f, SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) ) =>
SubTableStrategyImpl 'RecursiveKeyStrategy f (PrimaryKey rel) where
namedSubTable _ = namedSubTable (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 _ = M1 . K1 $ settings'
where tbl :: sub f
tbl = namedSubTable (Proxy @strategy)
relName = unCamelCaseSel (T.pack (selName (undefined :: S1 f' (K1 Generic.R (sub f)) p)))
settings' :: sub f
settings' = changeBeamRep (reduceTag %~ \(Columnar' (TableField nm)) -> Columnar' (TableField (relName <> "__" <> nm))) 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 f ~(Columnar' (TableField nm)) =
(\(Columnar' (TableField nm')) -> Columnar' (TableField nm')) <$>
f (Columnar' (TableField nm))
instance TagReducesTo f f' => TagReducesTo (Nullable f) f' where
reduceTag fn ~(Columnar' x :: Columnar' (Nullable f) a) =
(\(Columnar' x' :: Columnar' f (Maybe a')) -> Columnar' x') <$>
reduceTag fn (Columnar' 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 (gTblSkeleton (Proxy :: Proxy p))
instance GTableSkeleton U1 where
gTblSkeleton _ = U1
instance (GTableSkeleton a, GTableSkeleton b) =>
GTableSkeleton (a :*: b) where
gTblSkeleton _ = gTblSkeleton (Proxy :: Proxy a) :*: gTblSkeleton (Proxy :: Proxy b)
instance GTableSkeleton (K1 Generic.R (Ignored field)) where
gTblSkeleton _ = K1 Ignored
instance ( Beamable tbl
) => GTableSkeleton (K1 Generic.R (tbl Ignored))
where
gTblSkeleton _ = K1 (tblSkeleton :: TableSkeleton tbl)
instance ( Beamable tbl
) => GTableSkeleton (K1 Generic.R (tbl (Nullable Ignored)))
where
gTblSkeleton _ = K1 . runIdentity
$ zipBeamFieldsM transform
(tblSkeleton :: TableSkeleton tbl)
(tblSkeleton :: TableSkeleton tbl)
where
transform :: Columnar' Ignored a
-> Columnar' Ignored a
-> Identity (Columnar' (Nullable Ignored) a)
transform _ _ = Identity (Columnar' Ignored)
-- * Internal functions
unCamelCase :: T.Text -> [T.Text]
unCamelCase "" = []
unCamelCase s
| (comp, next) <- T.break isUpper s, not (T.null comp) =
let next' = maybe mempty (uncurry T.cons . first toLower) (T.uncons next)
in T.toLower comp:unCamelCase next'
| otherwise =
let (comp, next) = T.span isUpper s
next' = maybe mempty (uncurry T.cons . first toLower) (T.uncons next)
in T.toLower comp:unCamelCase 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 original =
let symbolLeft = T.dropWhile (=='_') original
in if T.null symbolLeft
then original
else if T.any (=='_') symbolLeft
then symbolLeft
else case unCamelCase symbolLeft of
[] -> symbolLeft
[xs] -> xs
_:xs -> T.intercalate "_" xs