{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- | This module provides functions to generate the auxiliary structures for the user data type
module Database.Groundhog.TH
  ( -- * Settings format
    -- $settingsDoc
    mkPersist,
    groundhog,
    groundhogFile,

    -- * Settings for code generation
    CodegenConfig (..),
    defaultCodegenConfig,
    defaultMkEntityDecs,
    defaultMkEmbeddedDecs,
    defaultMkPrimitiveDecs,
    -- $namingStylesDoc
    NamingStyle (..),
    suffixNamingStyle,
    persistentNamingStyle,
    conciseNamingStyle,
    lowerCaseSuffixNamingStyle,
    toUnderscore,
    firstChar,

    -- * Utility functions
    mkTHEntityDef,
    mkTHEmbeddedDef,
    mkTHPrimitiveDef,
    applyEntitySettings,
    applyEmbeddedSettings,
    applyPrimitiveSettings,

    -- * Helpers
    showReadConverter,
    enumConverter,
  )
where

import Control.Applicative
import Control.Monad (forM, forM_, liftM2, unless, when)
import Data.Char (isDigit, isLower, isSpace, isUpper, toLower, toUpper)
import Data.List (intercalate, nub, (\\))
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.String
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml as Y (ParseException (..), decodeHelper)
import Database.Groundhog.Core (UniqueType (..), delim)
import Database.Groundhog.Generic
import Database.Groundhog.TH.CodeGen
import Database.Groundhog.TH.Settings
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (Lift (..), StrictType, VarStrictType)
import qualified Text.Libyaml as Y

data CodegenConfig = CodegenConfig
  { -- | Naming style that is applied for all definitions
    CodegenConfig -> NamingStyle
namingStyle :: NamingStyle,
    -- | Codegenerator will create a function with this name that will run 'migrate' for each non-polymorphic entity in definition
    CodegenConfig -> Maybe String
migrationFunction :: Maybe String,
    -- | Functions that produce Haskell code for the entities. In most cases when overriding, the default functions that produce mappings are not replaced but kept along with custom code. Example: @['defaultMkEntityDecs', mkMyDecs]@.
    CodegenConfig -> [[THEntityDef] -> Q [Dec]]
mkEntityDecs :: [[THEntityDef] -> Q [Dec]],
    CodegenConfig -> [[THEmbeddedDef] -> Q [Dec]]
mkEmbeddedDecs :: [[THEmbeddedDef] -> Q [Dec]],
    CodegenConfig -> [[THPrimitiveDef] -> Q [Dec]]
mkPrimitiveDecs :: [[THPrimitiveDef] -> Q [Dec]]
  }

defaultCodegenConfig :: CodegenConfig
defaultCodegenConfig :: CodegenConfig
defaultCodegenConfig = NamingStyle
-> Maybe String
-> [[THEntityDef] -> Q [Dec]]
-> [[THEmbeddedDef] -> Q [Dec]]
-> [[THPrimitiveDef] -> Q [Dec]]
-> CodegenConfig
CodegenConfig NamingStyle
suffixNamingStyle Maybe String
forall a. Maybe a
Nothing [[THEntityDef] -> Q [Dec]
defaultMkEntityDecs] [[THEmbeddedDef] -> Q [Dec]
defaultMkEmbeddedDecs] [[THPrimitiveDef] -> Q [Dec]
defaultMkPrimitiveDecs]

-- $namingStylesDoc
-- When describing a datatype you can omit the most of the declarations.
-- In this case the omitted parts of description will be automatically generated using the default names created by naming style.
-- Any default name can be overridden by setting its value explicitly.

-- | Defines how the names are created. The mk* functions correspond to the set* functions.
-- Functions mkNormal* define names of non-record constructor Field
data NamingStyle = NamingStyle
  { -- | Create name of the table for the datatype. Parameters: data name.
    NamingStyle -> String -> String
mkDbEntityName :: String -> String,
    -- | Create name of the backend-specific key constructor for the datatype. Parameters: data name.
    NamingStyle -> String -> String
mkEntityKeyName :: String -> String,
    -- | Create name for phantom constructor used to parametrise 'Field'. Parameters: data name, constructor name, constructor position.
    NamingStyle -> String -> String -> Int -> String
mkPhantomName :: String -> String -> Int -> String,
    -- | Create name for phantom unique key used to parametrise 'Key'. Parameters: data name, constructor name, unique constraint name.
    NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String,
    -- | Create name of constructor for the unique key. Parameters: data name, constructor name, unique constraint name.
    NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String,
    -- | Create name used by 'persistName' for the unique key. Parameters: data name, constructor name, unique constraint name.
    NamingStyle -> String -> String -> String -> String
mkUniqueKeyDbName :: String -> String -> String -> String,
    -- | Create name of the constructor specific table. Parameters: data name, constructor name, constructor position.
    NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String,
    -- | Create name of the db field for autokey. Parameters: data name, constructor name, constructor position.
    NamingStyle -> String -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String,
    -- | Create name of the field column in a database. Parameters: data name, constructor name, constructor position, field record name, field position.
    NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String,
    -- | Create name of field constructor used in expressions. Parameters: data name, constructor name, constructor position, field record name, field position.
    NamingStyle -> String -> String -> Int -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String,
    -- | Create name of selector (see 'Embedded') constructor used in expressions. Parameters: data name, constructor name, field record name, field position.
    NamingStyle -> String -> String -> String -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String,
    -- | Create field name used to refer to the it in settings for non-record constructors. Parameters: data name, constructor name, constructor position, field position.
    NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String,
    -- | Create name of the field column in a database. Parameters: data name, constructor name, constructor position, field position.
    NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String,
    -- | Create name of field constructor used in expressions. Parameters: data name, constructor name, constructor position, field position.
    NamingStyle -> String -> String -> Int -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String,
    -- | Create name of selector (see 'Embedded') constructor used in expressions. Parameters: data name, constructor name, field position.
    NamingStyle -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
  }

-- | Default style. Adds \"Field\" to each record field name.
--
-- Example:
--
-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}
-- > -- Generated code
-- > data NormalConstructor
-- > data RecordConstructor
-- > instance PersistEntity where
-- >   data Field (SomeData a) where
-- >     Normal0Field :: Field NormalConstructor Int
-- >     BarField :: Field RecordConstructor (Maybe String)
-- >     AscField :: Field RecordConstructor a
-- > ...
suffixNamingStyle :: NamingStyle
suffixNamingStyle :: NamingStyle
suffixNamingStyle =
  NamingStyle :: (String -> String)
-> (String -> String)
-> (String -> String -> Int -> String)
-> (String -> String -> String -> String)
-> (String -> String -> String -> String)
-> (String -> String -> String -> String)
-> (String -> String -> Int -> String)
-> (String -> String -> Int -> String)
-> (String -> String -> Int -> String -> Int -> String)
-> (String -> String -> Int -> String -> Int -> String)
-> (String -> String -> String -> Int -> String)
-> (String -> String -> Int -> Int -> String)
-> (String -> String -> Int -> Int -> String)
-> (String -> String -> Int -> Int -> String)
-> (String -> String -> Int -> String)
-> NamingStyle
NamingStyle
    { mkDbEntityName :: String -> String
mkDbEntityName = \String
dName -> String
dName,
      mkEntityKeyName :: String -> String
mkEntityKeyName = \String
dName -> String
dName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Key",
      mkPhantomName :: String -> String -> Int -> String
mkPhantomName = \String
_ String
cName Int
_ -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Constructor",
      mkUniqueKeyPhantomName :: String -> String -> String -> String
mkUniqueKeyPhantomName = \String
_ String
_ String
uName -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
uName,
      mkUniqueKeyConstrName :: String -> String -> String -> String
mkUniqueKeyConstrName = \String
_ String
_ String
uName -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
uName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Key",
      mkUniqueKeyDbName :: String -> String -> String -> String
mkUniqueKeyDbName = \String
_ String
_ String
uName -> String
"Key" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
delim] String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
uName,
      mkDbConstrName :: String -> String -> Int -> String
mkDbConstrName = \String
_ String
cName Int
_ -> String
cName,
      mkDbConstrAutoKeyName :: String -> String -> Int -> String
mkDbConstrAutoKeyName = \String
_ String
_ Int
_ -> String
"id",
      mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName = \String
_ String
_ Int
_ String
fName Int
_ -> String
fName,
      mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkExprFieldName = \String
_ String
_ Int
_ String
fName Int
_ -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field",
      mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprSelectorName = \String
_ String
_ String
fName Int
_ -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Selector",
      mkNormalFieldName :: String -> String -> Int -> Int -> String
mkNormalFieldName = \String
_ String
cName Int
_ Int
fNum -> (Char -> Char) -> String -> String
firstChar Char -> Char
toLower String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum,
      mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName = \String
_ String
cName Int
_ Int
fNum -> (Char -> Char) -> String -> String
firstChar Char -> Char
toLower String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum,
      mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalExprFieldName = \String
_ String
cName Int
_ Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Field",
      mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprSelectorName = \String
_ String
cName Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Selector"
    }

-- | Creates field names in Persistent fashion prepending constructor names to the fields.
--
-- Example:
--
-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}
-- > -- Generated code
-- > data NormalConstructor
-- > data RecordConstructor
-- > instance PersistEntity where
-- >   data Field (SomeData a) where
-- >     Normal0 :: Field NormalConstructor Int
-- >     RecordBar :: Field RecordConstructor (Maybe String)
-- >     RecordAsc :: Field RecordConstructor a
-- > ...
persistentNamingStyle :: NamingStyle
persistentNamingStyle :: NamingStyle
persistentNamingStyle =
  NamingStyle
suffixNamingStyle
    { mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkExprFieldName = \String
_ String
cName Int
_ String
fName Int
_ -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName,
      mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprSelectorName = \String
_ String
cName String
fName Int
_ -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName,
      mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalExprFieldName = \String
_ String
cName Int
_ Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum,
      mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprSelectorName = \String
_ String
cName Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum
    }

-- | Creates the shortest field names. It is more likely to lead in name conflicts than other naming styles.
--
-- Example:
--
-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}
-- > -- Generated code
-- > data NormalConstructor
-- > data RecordConstructor
-- > instance PersistEntity where
-- >   data Field (SomeData a) where
-- >     Normal0 :: Field NormalConstructor Int
-- >     Bar :: Field RecordConstructor (Maybe String)
-- >     Asc :: Field RecordConstructor a
-- > ...
conciseNamingStyle :: NamingStyle
conciseNamingStyle :: NamingStyle
conciseNamingStyle =
  NamingStyle
suffixNamingStyle
    { mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkExprFieldName = \String
_ String
_ Int
_ String
fName Int
_ -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName,
      mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprSelectorName = \String
_ String
_ String
fName Int
_ -> (Char -> Char) -> String -> String
firstChar Char -> Char
toUpper String
fName,
      mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalExprFieldName = \String
_ String
cName Int
_ Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum,
      mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprSelectorName = \String
_ String
cName Int
fNum -> String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum
    }

-- | The generated Haskell names of phantom types (constructors, fields, etc.) are the same as with suffixNamingStyle. But the table names and columns are converted from camelCase to underscore_lower_case with `toUnderscore`.
lowerCaseSuffixNamingStyle :: NamingStyle
lowerCaseSuffixNamingStyle :: NamingStyle
lowerCaseSuffixNamingStyle =
  NamingStyle
suffixNamingStyle
    { mkDbEntityName :: String -> String
mkDbEntityName = \String
dName -> String -> String
toUnderscore String
dName,
      mkDbConstrName :: String -> String -> Int -> String
mkDbConstrName = \String
_ String
cName Int
_ -> String -> String
toUnderscore String
cName,
      mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName = \String
_ String
_ Int
_ String
fName Int
_ -> String -> String
toUnderscore String
fName,
      mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName = \String
_ String
cName Int
_ Int
fNum -> String -> String
toUnderscore (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fNum
    }

-- | Creates the auxiliary structures.
-- Particularly, it creates GADT 'Field' data instance for referring to the fields in expressions and phantom types for data constructors.
-- The default names of auxiliary datatypes and names used in database are generated using the naming style and can be changed via configuration.
-- The datatypes and their generation options are defined via YAML configuration parsed by quasiquoter 'groundhog'.
mkPersist :: CodegenConfig -> PersistDefinitions -> Q [Dec]
mkPersist :: CodegenConfig -> PersistDefinitions -> Q [Dec]
mkPersist CodegenConfig {[[THPrimitiveDef] -> Q [Dec]]
[[THEmbeddedDef] -> Q [Dec]]
[[THEntityDef] -> Q [Dec]]
Maybe String
NamingStyle
mkPrimitiveDecs :: [[THPrimitiveDef] -> Q [Dec]]
mkEmbeddedDecs :: [[THEmbeddedDef] -> Q [Dec]]
mkEntityDecs :: [[THEntityDef] -> Q [Dec]]
migrationFunction :: Maybe String
namingStyle :: NamingStyle
mkPrimitiveDecs :: CodegenConfig -> [[THPrimitiveDef] -> Q [Dec]]
mkEmbeddedDecs :: CodegenConfig -> [[THEmbeddedDef] -> Q [Dec]]
mkEntityDecs :: CodegenConfig -> [[THEntityDef] -> Q [Dec]]
migrationFunction :: CodegenConfig -> Maybe String
namingStyle :: CodegenConfig -> NamingStyle
..} PersistDefinitions {[PSPrimitiveDef]
[PSEmbeddedDef]
[PSEntityDef]
psPrimitives :: PersistDefinitions -> [PSPrimitiveDef]
psEmbeddeds :: PersistDefinitions -> [PSEmbeddedDef]
psEntities :: PersistDefinitions -> [PSEntityDef]
psPrimitives :: [PSPrimitiveDef]
psEmbeddeds :: [PSEmbeddedDef]
psEntities :: [PSEntityDef]
..} = do
  Q ()
checkEnabledLanguageExtensions
  let duplicates :: [String]
duplicates =
        (String -> String) -> [String] -> [String]
forall b a. Eq b => (a -> b) -> [a] -> [b]
notUniqueBy String -> String
forall a. a -> a
id ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
          (PSEntityDef -> String) -> [PSEntityDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PSEntityDef -> String
psDataName [PSEntityDef]
psEntities [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PSEmbeddedDef -> String) -> [PSEmbeddedDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PSEmbeddedDef -> String
psEmbeddedName [PSEmbeddedDef]
psEmbeddeds [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PSPrimitiveDef -> String) -> [PSPrimitiveDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PSPrimitiveDef -> String
psPrimitiveName [PSPrimitiveDef]
psPrimitives
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
duplicates) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"All definitions must be unique. Found duplicates: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
duplicates
  let getDecl :: String -> Q Dec
getDecl String
name = do
        Info
info <- Name -> Q Info
reify (Name -> Q Info) -> Name -> Q Info
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
name
        Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ case Info
info of
          TyConI Dec
d -> Dec
d
          Info
_ -> String -> Dec
forall a. HasCallStack => String -> a
error (String -> Dec) -> String -> Dec
forall a b. (a -> b) -> a -> b
$ String
"Only datatypes can be processed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name

  [THEntityDef]
entities <- [PSEntityDef] -> (PSEntityDef -> Q THEntityDef) -> Q [THEntityDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PSEntityDef]
psEntities ((PSEntityDef -> Q THEntityDef) -> Q [THEntityDef])
-> (PSEntityDef -> Q THEntityDef) -> Q [THEntityDef]
forall a b. (a -> b) -> a -> b
$ \PSEntityDef
e ->
    (String -> THEntityDef)
-> (THEntityDef -> THEntityDef)
-> Either String THEntityDef
-> THEntityDef
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> THEntityDef
forall a. HasCallStack => String -> a
error THEntityDef -> THEntityDef
forall a. a -> a
id (Either String THEntityDef -> THEntityDef)
-> (Dec -> Either String THEntityDef) -> Dec -> THEntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THEntityDef -> Either String THEntityDef
validateEntity (THEntityDef -> Either String THEntityDef)
-> (Dec -> THEntityDef) -> Dec -> Either String THEntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef
applyEntitySettings NamingStyle
namingStyle PSEntityDef
e (THEntityDef -> THEntityDef)
-> (Dec -> THEntityDef) -> Dec -> THEntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamingStyle -> Dec -> THEntityDef
mkTHEntityDef NamingStyle
namingStyle (Dec -> THEntityDef) -> Q Dec -> Q THEntityDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Dec
getDecl (PSEntityDef -> String
psDataName PSEntityDef
e)
  [THEmbeddedDef]
embeddeds <- [PSEmbeddedDef]
-> (PSEmbeddedDef -> Q THEmbeddedDef) -> Q [THEmbeddedDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PSEmbeddedDef]
psEmbeddeds ((PSEmbeddedDef -> Q THEmbeddedDef) -> Q [THEmbeddedDef])
-> (PSEmbeddedDef -> Q THEmbeddedDef) -> Q [THEmbeddedDef]
forall a b. (a -> b) -> a -> b
$ \PSEmbeddedDef
e ->
    (String -> THEmbeddedDef)
-> (THEmbeddedDef -> THEmbeddedDef)
-> Either String THEmbeddedDef
-> THEmbeddedDef
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> THEmbeddedDef
forall a. HasCallStack => String -> a
error THEmbeddedDef -> THEmbeddedDef
forall a. a -> a
id (Either String THEmbeddedDef -> THEmbeddedDef)
-> (Dec -> Either String THEmbeddedDef) -> Dec -> THEmbeddedDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded (THEmbeddedDef -> Either String THEmbeddedDef)
-> (Dec -> THEmbeddedDef) -> Dec -> Either String THEmbeddedDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings PSEmbeddedDef
e (THEmbeddedDef -> THEmbeddedDef)
-> (Dec -> THEmbeddedDef) -> Dec -> THEmbeddedDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamingStyle -> Dec -> THEmbeddedDef
mkTHEmbeddedDef NamingStyle
namingStyle (Dec -> THEmbeddedDef) -> Q Dec -> Q THEmbeddedDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Dec
getDecl (PSEmbeddedDef -> String
psEmbeddedName PSEmbeddedDef
e)
  [THPrimitiveDef]
primitives <- [PSPrimitiveDef]
-> (PSPrimitiveDef -> Q THPrimitiveDef) -> Q [THPrimitiveDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PSPrimitiveDef]
psPrimitives ((PSPrimitiveDef -> Q THPrimitiveDef) -> Q [THPrimitiveDef])
-> (PSPrimitiveDef -> Q THPrimitiveDef) -> Q [THPrimitiveDef]
forall a b. (a -> b) -> a -> b
$ \PSPrimitiveDef
e ->
    PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef
applyPrimitiveSettings PSPrimitiveDef
e (THPrimitiveDef -> THPrimitiveDef)
-> (Dec -> THPrimitiveDef) -> Dec -> THPrimitiveDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamingStyle -> Dec -> THPrimitiveDef
mkTHPrimitiveDef NamingStyle
namingStyle (Dec -> THPrimitiveDef) -> Q Dec -> Q THPrimitiveDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Dec
getDecl (PSPrimitiveDef -> String
psPrimitiveName PSPrimitiveDef
e)
  let mkEntityDecs' :: [[THEntityDef] -> Q [Dec]]
mkEntityDecs' = ([[THEntityDef] -> Q [Dec]] -> [[THEntityDef] -> Q [Dec]])
-> (String
    -> [[THEntityDef] -> Q [Dec]] -> [[THEntityDef] -> Q [Dec]])
-> Maybe String
-> [[THEntityDef] -> Q [Dec]]
-> [[THEntityDef] -> Q [Dec]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[THEntityDef] -> Q [Dec]] -> [[THEntityDef] -> Q [Dec]]
forall a. a -> a
id (\String
name -> (String -> [THEntityDef] -> Q [Dec]
mkMigrateFunction String
name ([THEntityDef] -> Q [Dec])
-> [[THEntityDef] -> Q [Dec]] -> [[THEntityDef] -> Q [Dec]]
forall a. a -> [a] -> [a]
:)) Maybe String
migrationFunction [[THEntityDef] -> Q [Dec]]
mkEntityDecs
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (([THEntityDef] -> Q [Dec]) -> Q [Dec])
-> [[THEntityDef] -> Q [Dec]] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (([THEntityDef] -> Q [Dec]) -> [THEntityDef] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [THEntityDef]
entities) [[THEntityDef] -> Q [Dec]]
mkEntityDecs' [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. [a] -> [a] -> [a]
++ (([THEmbeddedDef] -> Q [Dec]) -> Q [Dec])
-> [[THEmbeddedDef] -> Q [Dec]] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (([THEmbeddedDef] -> Q [Dec]) -> [THEmbeddedDef] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [THEmbeddedDef]
embeddeds) [[THEmbeddedDef] -> Q [Dec]]
mkEmbeddedDecs [Q [Dec]] -> [Q [Dec]] -> [Q [Dec]]
forall a. [a] -> [a] -> [a]
++ (([THPrimitiveDef] -> Q [Dec]) -> Q [Dec])
-> [[THPrimitiveDef] -> Q [Dec]] -> [Q [Dec]]
forall a b. (a -> b) -> [a] -> [b]
map (([THPrimitiveDef] -> Q [Dec]) -> [THPrimitiveDef] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [THPrimitiveDef]
primitives) [[THPrimitiveDef] -> Q [Dec]]
mkPrimitiveDecs

applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef
applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef
applyEntitySettings NamingStyle
style PSEntityDef {String
Maybe String
Maybe [PSUniqueKeyDef]
Maybe [PSConstructorDef]
Maybe (Maybe PSAutoKeyDef)
psConstructors :: PSEntityDef -> Maybe [PSConstructorDef]
psUniqueKeys :: PSEntityDef -> Maybe [PSUniqueKeyDef]
psAutoKey :: PSEntityDef -> Maybe (Maybe PSAutoKeyDef)
psEntitySchema :: PSEntityDef -> Maybe String
psDbEntityName :: PSEntityDef -> Maybe String
psConstructors :: Maybe [PSConstructorDef]
psUniqueKeys :: Maybe [PSUniqueKeyDef]
psAutoKey :: Maybe (Maybe PSAutoKeyDef)
psEntitySchema :: Maybe String
psDbEntityName :: Maybe String
psDataName :: String
psDataName :: PSEntityDef -> String
..} def :: THEntityDef
def@THEntityDef {String
[TyVarBndr]
[THUniqueKeyDef]
[THConstructorDef]
Maybe String
Maybe THAutoKeyDef
Name
thConstructors :: THEntityDef -> [THConstructorDef]
thTypeParams :: THEntityDef -> [TyVarBndr]
thUniqueKeys :: THEntityDef -> [THUniqueKeyDef]
thAutoKey :: THEntityDef -> Maybe THAutoKeyDef
thEntitySchema :: THEntityDef -> Maybe String
thDbEntityName :: THEntityDef -> String
thDataName :: THEntityDef -> Name
thConstructors :: [THConstructorDef]
thTypeParams :: [TyVarBndr]
thUniqueKeys :: [THUniqueKeyDef]
thAutoKey :: Maybe THAutoKeyDef
thEntitySchema :: Maybe String
thDbEntityName :: String
thDataName :: Name
..} =
  THEntityDef
def
    { thDbEntityName :: String
thDbEntityName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thDbEntityName Maybe String
psDbEntityName,
      thEntitySchema :: Maybe String
thEntitySchema = Maybe String
psEntitySchema,
      thAutoKey :: Maybe THAutoKeyDef
thAutoKey = Maybe THAutoKeyDef
thAutoKey',
      thUniqueKeys :: [THUniqueKeyDef]
thUniqueKeys = [THUniqueKeyDef]
-> ([PSUniqueKeyDef] -> [THUniqueKeyDef])
-> Maybe [PSUniqueKeyDef]
-> [THUniqueKeyDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THUniqueKeyDef]
thUniqueKeys ((PSUniqueKeyDef -> THUniqueKeyDef)
-> [PSUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> [a] -> [b]
map PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey') Maybe [PSUniqueKeyDef]
psUniqueKeys,
      thConstructors :: [THConstructorDef]
thConstructors = [THConstructorDef]
thConstructors'
    }
  where
    thAutoKey' :: Maybe THAutoKeyDef
thAutoKey' = Maybe THAutoKeyDef
-> (Maybe PSAutoKeyDef -> Maybe THAutoKeyDef)
-> Maybe (Maybe PSAutoKeyDef)
-> Maybe THAutoKeyDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe THAutoKeyDef
thAutoKey ((THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef)
-> Maybe THAutoKeyDef -> Maybe PSAutoKeyDef -> Maybe THAutoKeyDef
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings Maybe THAutoKeyDef
thAutoKey) Maybe (Maybe PSAutoKeyDef)
psAutoKey
    thConstructors' :: [THConstructorDef]
thConstructors' = [THConstructorDef]
-> ([PSConstructorDef] -> [THConstructorDef])
-> Maybe [PSConstructorDef]
-> [THConstructorDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THConstructorDef]
thConstructors'' ([THConstructorDef] -> [PSConstructorDef] -> [THConstructorDef]
f [THConstructorDef]
thConstructors'') Maybe [PSConstructorDef]
psConstructors
      where
        thConstructors'' :: [THConstructorDef]
thConstructors'' = (THConstructorDef -> THConstructorDef)
-> [THConstructorDef] -> [THConstructorDef]
forall a b. (a -> b) -> [a] -> [b]
map THConstructorDef -> THConstructorDef
checkAutoKey [THConstructorDef]
thConstructors
        checkAutoKey :: THConstructorDef -> THConstructorDef
checkAutoKey cDef :: THConstructorDef
cDef@THConstructorDef {String
[THUniqueDef]
[THFieldDef]
Maybe String
Name
thConstrUniques :: THConstructorDef -> [THUniqueDef]
thConstrFields :: THConstructorDef -> [THFieldDef]
thDbAutoKeyName :: THConstructorDef -> Maybe String
thDbConstrName :: THConstructorDef -> String
thPhantomConstrName :: THConstructorDef -> String
thConstrName :: THConstructorDef -> Name
thConstrUniques :: [THUniqueDef]
thConstrFields :: [THFieldDef]
thDbAutoKeyName :: Maybe String
thDbConstrName :: String
thPhantomConstrName :: String
thConstrName :: Name
..} = THConstructorDef
cDef {thDbAutoKeyName :: Maybe String
thDbAutoKeyName = Maybe THAutoKeyDef
thAutoKey' Maybe THAutoKeyDef -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String
thDbAutoKeyName}

    mkUniqueKey' :: PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey' = NamingStyle
-> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey NamingStyle
style (Name -> String
nameBase Name
thDataName) ([THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head [THConstructorDef]
thConstructors')
    f :: [THConstructorDef] -> [PSConstructorDef] -> [THConstructorDef]
f = (PSConstructorDef -> [THConstructorDef] -> [THConstructorDef])
-> [THConstructorDef] -> [PSConstructorDef] -> [THConstructorDef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PSConstructorDef -> [THConstructorDef] -> [THConstructorDef])
 -> [THConstructorDef] -> [PSConstructorDef] -> [THConstructorDef])
-> (PSConstructorDef -> [THConstructorDef] -> [THConstructorDef])
-> [THConstructorDef]
-> [PSConstructorDef]
-> [THConstructorDef]
forall a b. (a -> b) -> a -> b
$ String
-> (PSConstructorDef -> String)
-> (THConstructorDef -> String)
-> (PSConstructorDef -> THConstructorDef -> THConstructorDef)
-> PSConstructorDef
-> [THConstructorDef]
-> [THConstructorDef]
forall x a b.
(Eq x, Show x) =>
String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne String
"constructor" PSConstructorDef -> String
psConstrName (Name -> String
nameBase (Name -> String)
-> (THConstructorDef -> Name) -> THConstructorDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THConstructorDef -> Name
thConstrName) PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings

mkUniqueKey :: NamingStyle -> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey :: NamingStyle
-> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey style :: NamingStyle
style@NamingStyle {String -> String
String -> String -> Int -> String
String -> String -> Int -> Int -> String
String -> String -> Int -> String -> Int -> String
String -> String -> String -> String
String -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String
mkUniqueKeyDbName :: String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String
mkPhantomName :: String -> String -> Int -> String
mkEntityKeyName :: String -> String
mkDbEntityName :: String -> String
mkNormalExprSelectorName :: NamingStyle -> String -> String -> Int -> String
mkNormalExprFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkExprSelectorName :: NamingStyle -> String -> String -> String -> Int -> String
mkExprFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: NamingStyle -> String -> String -> Int -> String
mkUniqueKeyDbName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: NamingStyle -> String -> String -> String -> String
mkPhantomName :: NamingStyle -> String -> String -> Int -> String
mkEntityKeyName :: NamingStyle -> String -> String
mkDbEntityName :: NamingStyle -> String -> String
..} String
dName cDef :: THConstructorDef
cDef@THConstructorDef {String
[THUniqueDef]
[THFieldDef]
Maybe String
Name
thConstrUniques :: [THUniqueDef]
thConstrFields :: [THFieldDef]
thDbAutoKeyName :: Maybe String
thDbConstrName :: String
thPhantomConstrName :: String
thConstrName :: Name
thConstrUniques :: THConstructorDef -> [THUniqueDef]
thConstrFields :: THConstructorDef -> [THFieldDef]
thDbAutoKeyName :: THConstructorDef -> Maybe String
thDbConstrName :: THConstructorDef -> String
thPhantomConstrName :: THConstructorDef -> String
thConstrName :: THConstructorDef -> Name
..} PSUniqueKeyDef {String
Maybe Bool
Maybe String
Maybe [PSFieldDef String]
psUniqueKeyIsDef :: PSUniqueKeyDef -> Maybe Bool
psUniqueKeyMakeEmbedded :: PSUniqueKeyDef -> Maybe Bool
psUniqueKeyFields :: PSUniqueKeyDef -> Maybe [PSFieldDef String]
psUniqueKeyDbName :: PSUniqueKeyDef -> Maybe String
psUniqueKeyConstrName :: PSUniqueKeyDef -> Maybe String
psUniqueKeyPhantomName :: PSUniqueKeyDef -> Maybe String
psUniqueKeyName :: PSUniqueKeyDef -> String
psUniqueKeyIsDef :: Maybe Bool
psUniqueKeyMakeEmbedded :: Maybe Bool
psUniqueKeyFields :: Maybe [PSFieldDef String]
psUniqueKeyDbName :: Maybe String
psUniqueKeyConstrName :: Maybe String
psUniqueKeyPhantomName :: Maybe String
psUniqueKeyName :: String
..} = THUniqueKeyDef
key
  where
    key :: THUniqueKeyDef
key =
      THUniqueKeyDef :: String
-> String
-> String
-> String
-> [THFieldDef]
-> Bool
-> Bool
-> THUniqueKeyDef
THUniqueKeyDef
        { thUniqueKeyName :: String
thUniqueKeyName = String
psUniqueKeyName,
          thUniqueKeyPhantomName :: String
thUniqueKeyPhantomName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> String
mkUniqueKeyPhantomName String
dName (Name -> String
nameBase Name
thConstrName) String
psUniqueKeyName) Maybe String
psUniqueKeyPhantomName,
          thUniqueKeyConstrName :: String
thUniqueKeyConstrName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> String
mkUniqueKeyConstrName String
dName (Name -> String
nameBase Name
thConstrName) String
psUniqueKeyName) Maybe String
psUniqueKeyConstrName,
          thUniqueKeyDbName :: String
thUniqueKeyDbName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> String
mkUniqueKeyDbName String
dName (Name -> String
nameBase Name
thConstrName) String
psUniqueKeyName) Maybe String
psUniqueKeyDbName,
          thUniqueKeyFields :: [THFieldDef]
thUniqueKeyFields = [THFieldDef]
-> ([PSFieldDef String] -> [THFieldDef])
-> Maybe [PSFieldDef String]
-> [THFieldDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THFieldDef]
uniqueFields ([THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f [THFieldDef]
uniqueFields) Maybe [PSFieldDef String]
psUniqueKeyFields,
          thUniqueKeyMakeEmbedded :: Bool
thUniqueKeyMakeEmbedded = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
psUniqueKeyMakeEmbedded,
          thUniqueKeyIsDef :: Bool
thUniqueKeyIsDef = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
psUniqueKeyIsDef
        }
    f :: [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f = (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PSFieldDef String -> [THFieldDef] -> [THFieldDef])
 -> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef])
-> (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef]
-> [PSFieldDef String]
-> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ String
-> (PSFieldDef String -> String)
-> (THFieldDef -> String)
-> (PSFieldDef String -> THFieldDef -> THFieldDef)
-> PSFieldDef String
-> [THFieldDef]
-> [THFieldDef]
forall x a b.
(Eq x, Show x) =>
String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne String
"unique field" PSFieldDef String -> String
forall str. PSFieldDef str -> str
psFieldName THFieldDef -> String
thFieldName PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings
    uniqueFields :: [THFieldDef]
uniqueFields = NamingStyle
-> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey NamingStyle
style String
dName THUniqueKeyDef
key THConstructorDef
cDef

applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings def :: THAutoKeyDef
def@THAutoKeyDef {Bool
String
thAutoKeyIsDef :: THAutoKeyDef -> Bool
thAutoKeyConstrName :: THAutoKeyDef -> String
thAutoKeyIsDef :: Bool
thAutoKeyConstrName :: String
..} PSAutoKeyDef {Maybe Bool
Maybe String
psAutoKeyIsDef :: PSAutoKeyDef -> Maybe Bool
psAutoKeyConstrName :: PSAutoKeyDef -> Maybe String
psAutoKeyIsDef :: Maybe Bool
psAutoKeyConstrName :: Maybe String
..} =
  THAutoKeyDef
def
    { thAutoKeyConstrName :: String
thAutoKeyConstrName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thAutoKeyConstrName Maybe String
psAutoKeyConstrName,
      thAutoKeyIsDef :: Bool
thAutoKeyIsDef = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
thAutoKeyIsDef Maybe Bool
psAutoKeyIsDef
    }

applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings PSConstructorDef {String
Maybe String
Maybe [PSFieldDef String]
Maybe [PSUniqueDef]
psConstrUniques :: PSConstructorDef -> Maybe [PSUniqueDef]
psConstrFields :: PSConstructorDef -> Maybe [PSFieldDef String]
psDbAutoKeyName :: PSConstructorDef -> Maybe String
psDbConstrName :: PSConstructorDef -> Maybe String
psPhantomConstrName :: PSConstructorDef -> Maybe String
psConstrUniques :: Maybe [PSUniqueDef]
psConstrFields :: Maybe [PSFieldDef String]
psDbAutoKeyName :: Maybe String
psDbConstrName :: Maybe String
psPhantomConstrName :: Maybe String
psConstrName :: String
psConstrName :: PSConstructorDef -> String
..} def :: THConstructorDef
def@THConstructorDef {String
[THUniqueDef]
[THFieldDef]
Maybe String
Name
thConstrUniques :: [THUniqueDef]
thConstrFields :: [THFieldDef]
thDbAutoKeyName :: Maybe String
thDbConstrName :: String
thPhantomConstrName :: String
thConstrName :: Name
thConstrUniques :: THConstructorDef -> [THUniqueDef]
thConstrFields :: THConstructorDef -> [THFieldDef]
thDbAutoKeyName :: THConstructorDef -> Maybe String
thDbConstrName :: THConstructorDef -> String
thPhantomConstrName :: THConstructorDef -> String
thConstrName :: THConstructorDef -> Name
..} =
  THConstructorDef
def
    { thPhantomConstrName :: String
thPhantomConstrName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thPhantomConstrName Maybe String
psPhantomConstrName,
      thDbConstrName :: String
thDbConstrName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thDbConstrName Maybe String
psDbConstrName,
      thDbAutoKeyName :: Maybe String
thDbAutoKeyName = Maybe String
psDbAutoKeyName Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
thDbAutoKeyName,
      thConstrFields :: [THFieldDef]
thConstrFields = [THFieldDef]
-> ([PSFieldDef String] -> [THFieldDef])
-> Maybe [PSFieldDef String]
-> [THFieldDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THFieldDef]
thConstrFields ([THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f [THFieldDef]
thConstrFields) Maybe [PSFieldDef String]
psConstrFields,
      thConstrUniques :: [THUniqueDef]
thConstrUniques = [THUniqueDef]
-> ([PSUniqueDef] -> [THUniqueDef])
-> Maybe [PSUniqueDef]
-> [THUniqueDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THUniqueDef]
thConstrUniques ((PSUniqueDef -> THUniqueDef) -> [PSUniqueDef] -> [THUniqueDef]
forall a b. (a -> b) -> [a] -> [b]
map PSUniqueDef -> THUniqueDef
convertUnique) Maybe [PSUniqueDef]
psConstrUniques
    }
  where
    f :: [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f = (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PSFieldDef String -> [THFieldDef] -> [THFieldDef])
 -> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef])
-> (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef]
-> [PSFieldDef String]
-> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ String
-> (PSFieldDef String -> String)
-> (THFieldDef -> String)
-> (PSFieldDef String -> THFieldDef -> THFieldDef)
-> PSFieldDef String
-> [THFieldDef]
-> [THFieldDef]
forall x a b.
(Eq x, Show x) =>
String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne String
"field" PSFieldDef String -> String
forall str. PSFieldDef str -> str
psFieldName THFieldDef -> String
thFieldName PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings
    convertUnique :: PSUniqueDef -> THUniqueDef
convertUnique (PSUniqueDef String
uName Maybe UniqueType
uType [Either String String]
uFields) = String -> UniqueType -> [Either String String] -> THUniqueDef
THUniqueDef String
uName (UniqueType -> Maybe UniqueType -> UniqueType
forall a. a -> Maybe a -> a
fromMaybe UniqueType
UniqueConstraint Maybe UniqueType
uType) [Either String String]
uFields

applyFieldSettings :: PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings :: PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings PSFieldDef {String
Maybe String
Maybe [PSFieldDef String]
Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psDbFieldName :: forall str. PSFieldDef str -> Maybe str
psDbTypeName :: forall str. PSFieldDef str -> Maybe str
psExprName :: forall str. PSFieldDef str -> Maybe str
psEmbeddedDef :: forall str. PSFieldDef str -> Maybe [PSFieldDef str]
psDefaultValue :: forall str. PSFieldDef str -> Maybe str
psReferenceParent :: forall str.
PSFieldDef str
-> Maybe
     (Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType,
      Maybe ReferenceActionType)
psFieldConverter :: forall str. PSFieldDef str -> Maybe str
psFieldConverter :: Maybe String
psReferenceParent :: Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psDefaultValue :: Maybe String
psEmbeddedDef :: Maybe [PSFieldDef String]
psExprName :: Maybe String
psDbTypeName :: Maybe String
psDbFieldName :: Maybe String
psFieldName :: String
psFieldName :: forall str. PSFieldDef str -> str
..} def :: THFieldDef
def@THFieldDef {String
Maybe String
Maybe [PSFieldDef String]
Maybe Name
Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
Type
thFieldConverter :: THFieldDef -> Maybe Name
thReferenceParent :: THFieldDef
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
thDefaultValue :: THFieldDef -> Maybe String
thEmbeddedDef :: THFieldDef -> Maybe [PSFieldDef String]
thFieldType :: THFieldDef -> Type
thExprName :: THFieldDef -> String
thDbTypeName :: THFieldDef -> Maybe String
thDbFieldName :: THFieldDef -> String
thFieldConverter :: Maybe Name
thReferenceParent :: Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
thDefaultValue :: Maybe String
thEmbeddedDef :: Maybe [PSFieldDef String]
thFieldType :: Type
thExprName :: String
thDbTypeName :: Maybe String
thDbFieldName :: String
thFieldName :: String
thFieldName :: THFieldDef -> String
..} =
  THFieldDef
def
    { thDbFieldName :: String
thDbFieldName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thDbFieldName Maybe String
psDbFieldName,
      thExprName :: String
thExprName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thExprName Maybe String
psExprName,
      thDbTypeName :: Maybe String
thDbTypeName = Maybe String
psDbTypeName,
      thEmbeddedDef :: Maybe [PSFieldDef String]
thEmbeddedDef = Maybe [PSFieldDef String]
psEmbeddedDef,
      thDefaultValue :: Maybe String
thDefaultValue = Maybe String
psDefaultValue,
      thReferenceParent :: Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
thReferenceParent = Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
psReferenceParent,
      thFieldConverter :: Maybe Name
thFieldConverter = (String -> Name) -> Maybe String -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName Maybe String
psFieldConverter
    }

applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings PSEmbeddedDef {String
Maybe String
Maybe [PSFieldDef String]
psEmbeddedFields :: PSEmbeddedDef -> Maybe [PSFieldDef String]
psDbEmbeddedName :: PSEmbeddedDef -> Maybe String
psEmbeddedFields :: Maybe [PSFieldDef String]
psDbEmbeddedName :: Maybe String
psEmbeddedName :: String
psEmbeddedName :: PSEmbeddedDef -> String
..} def :: THEmbeddedDef
def@THEmbeddedDef {String
[TyVarBndr]
[THFieldDef]
Name
thEmbeddedFields :: THEmbeddedDef -> [THFieldDef]
thEmbeddedTypeParams :: THEmbeddedDef -> [TyVarBndr]
thDbEmbeddedName :: THEmbeddedDef -> String
thEmbeddedConstructorName :: THEmbeddedDef -> Name
thEmbeddedName :: THEmbeddedDef -> Name
thEmbeddedFields :: [THFieldDef]
thEmbeddedTypeParams :: [TyVarBndr]
thDbEmbeddedName :: String
thEmbeddedConstructorName :: Name
thEmbeddedName :: Name
..} =
  THEmbeddedDef
def
    { thDbEmbeddedName :: String
thDbEmbeddedName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thDbEmbeddedName Maybe String
psDbEmbeddedName,
      thEmbeddedFields :: [THFieldDef]
thEmbeddedFields = [THFieldDef]
-> ([PSFieldDef String] -> [THFieldDef])
-> Maybe [PSFieldDef String]
-> [THFieldDef]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [THFieldDef]
thEmbeddedFields ([THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f [THFieldDef]
thEmbeddedFields) Maybe [PSFieldDef String]
psEmbeddedFields
    }
  where
    f :: [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
f = (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PSFieldDef String -> [THFieldDef] -> [THFieldDef])
 -> [THFieldDef] -> [PSFieldDef String] -> [THFieldDef])
-> (PSFieldDef String -> [THFieldDef] -> [THFieldDef])
-> [THFieldDef]
-> [PSFieldDef String]
-> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ String
-> (PSFieldDef String -> String)
-> (THFieldDef -> String)
-> (PSFieldDef String -> THFieldDef -> THFieldDef)
-> PSFieldDef String
-> [THFieldDef]
-> [THFieldDef]
forall x a b.
(Eq x, Show x) =>
String -> (a -> x) -> (b -> x) -> (a -> b -> b) -> a -> [b] -> [b]
replaceOne String
"field" PSFieldDef String -> String
forall str. PSFieldDef str -> str
psFieldName THFieldDef -> String
thFieldName PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings

applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef
applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef
applyPrimitiveSettings PSPrimitiveDef {String
Maybe String
psPrimitiveConverter :: PSPrimitiveDef -> String
psPrimitiveDbName :: PSPrimitiveDef -> Maybe String
psPrimitiveConverter :: String
psPrimitiveDbName :: Maybe String
psPrimitiveName :: String
psPrimitiveName :: PSPrimitiveDef -> String
..} def :: THPrimitiveDef
def@THPrimitiveDef {String
Name
thPrimitiveConverter :: THPrimitiveDef -> Name
thPrimitiveDbName :: THPrimitiveDef -> String
thPrimitiveName :: THPrimitiveDef -> Name
thPrimitiveConverter :: Name
thPrimitiveDbName :: String
thPrimitiveName :: Name
..} =
  THPrimitiveDef
def
    { thPrimitiveDbName :: String
thPrimitiveDbName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
thPrimitiveDbName Maybe String
psPrimitiveDbName,
      thPrimitiveConverter :: Name
thPrimitiveConverter = String -> Name
mkName String
psPrimitiveConverter
    }

mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey :: NamingStyle
-> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey NamingStyle
style String
dName THUniqueKeyDef
uniqueKey THConstructorDef
cDef = (Either String String -> Int -> THFieldDef)
-> [Either String String] -> [Int] -> [THFieldDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (THFieldDef -> Int -> THFieldDef
setSelector (THFieldDef -> Int -> THFieldDef)
-> (Either String String -> THFieldDef)
-> Either String String
-> Int
-> THFieldDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String String -> THFieldDef
findField) (THUniqueDef -> [Either String String]
thUniqueFields THUniqueDef
uniqueDef) [Int
0 ..]
  where
    findField :: Either String String -> THFieldDef
findField (Left String
name) = String
-> (THFieldDef -> String) -> String -> [THFieldDef] -> THFieldDef
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"field" THFieldDef -> String
thFieldName String
name ([THFieldDef] -> THFieldDef) -> [THFieldDef] -> THFieldDef
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cDef
    findField (Right String
expr) = String -> THFieldDef
forall a. HasCallStack => String -> a
error (String -> THFieldDef) -> String -> THFieldDef
forall a b. (a -> b) -> a -> b
$ String
"A unique key may not contain expressions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr
    uniqueDef :: THUniqueDef
uniqueDef = String
-> (THUniqueDef -> String)
-> String
-> [THUniqueDef]
-> THUniqueDef
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"unique" THUniqueDef -> String
thUniqueName (THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
uniqueKey) ([THUniqueDef] -> THUniqueDef) -> [THUniqueDef] -> THUniqueDef
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cDef
    setSelector :: THFieldDef -> Int -> THFieldDef
setSelector THFieldDef
f Int
i = THFieldDef
f {thExprName :: String
thExprName = NamingStyle -> String -> String -> String -> Int -> String
mkExprSelectorName NamingStyle
style String
dName (THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
uniqueKey) (THFieldDef -> String
thFieldName THFieldDef
f) Int
i}

notUniqueBy :: Eq b => (a -> b) -> [a] -> [b]
notUniqueBy :: (a -> b) -> [a] -> [b]
notUniqueBy a -> b
f [a]
xs = let xs' :: [b]
xs' = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs in [b] -> [b]
forall a. Eq a => [a] -> [a]
nub ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ [b]
xs' [b] -> [b] -> [b]
forall a. Eq a => [a] -> [a] -> [a]
\\ [b] -> [b]
forall a. Eq a => [a] -> [a]
nub [b]
xs'

assertUnique :: (Eq b, Show b) => (a -> b) -> [a] -> String -> Either String ()
assertUnique :: (a -> b) -> [a] -> String -> Either String ()
assertUnique a -> b
f [a]
xs String
what = case (a -> b) -> [a] -> [b]
forall b a. Eq b => (a -> b) -> [a] -> [b]
notUniqueBy a -> b
f [a]
xs of
  [] -> () -> Either String ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [b]
ys -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"All " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be unique: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [b] -> String
forall a. Show a => a -> String
show [b]
ys

-- we need to validate datatype names because TH just creates unusable fields with spaces
assertSpaceFree :: String -> String -> Either String ()
assertSpaceFree :: String -> String -> Either String ()
assertSpaceFree String
s String
what = Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
s) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Spaces in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" are not allowed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s

validateEntity :: THEntityDef -> Either String THEntityDef
validateEntity :: THEntityDef -> Either String THEntityDef
validateEntity THEntityDef
def = do
  let constrs :: [THConstructorDef]
constrs = THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
  (THConstructorDef -> String)
-> [THConstructorDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THConstructorDef -> String
thPhantomConstrName [THConstructorDef]
constrs String
"constructor phantom name"
  (THConstructorDef -> String)
-> [THConstructorDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THConstructorDef -> String
thDbConstrName [THConstructorDef]
constrs String
"constructor db name"
  [THConstructorDef]
-> (THConstructorDef -> Either String ()) -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [THConstructorDef]
constrs ((THConstructorDef -> Either String ()) -> Either String ())
-> (THConstructorDef -> Either String ()) -> Either String ()
forall a b. (a -> b) -> a -> b
$ \THConstructorDef
cdef -> do
    let fields :: [THFieldDef]
fields = THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
    String -> String -> Either String ()
assertSpaceFree (THConstructorDef -> String
thPhantomConstrName THConstructorDef
cdef) String
"constructor phantom name"
    (THFieldDef -> String)
-> [THFieldDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THFieldDef -> String
thExprName [THFieldDef]
fields String
"expr field name in a constructor"
    (THFieldDef -> String)
-> [THFieldDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THFieldDef -> String
thDbFieldName [THFieldDef]
fields String
"db field name in a constructor"
    (THFieldDef -> Either String ())
-> [THFieldDef] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ THFieldDef -> Either String ()
validateField [THFieldDef]
fields
    case (THUniqueDef -> Bool) -> [THUniqueDef] -> [THUniqueDef]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(THUniqueDef String
_ UniqueType
_ [Either String String]
uFields) -> [Either String String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Either String String]
uFields) ([THUniqueDef] -> [THUniqueDef]) -> [THUniqueDef] -> [THUniqueDef]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cdef of
      [] -> () -> Either String ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      [THUniqueDef]
ys -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Constraints must have at least one field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [THUniqueDef] -> String
forall a. Show a => a -> String
show [THUniqueDef]
ys
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (THConstructorDef -> Maybe String
thDbAutoKeyName THConstructorDef
cdef) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe THAutoKeyDef -> Bool
forall a. Maybe a -> Bool
isNothing (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def)) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
      String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Presence of autokey definitions should be the same in entity and constructors definitions " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show (THConstructorDef -> Maybe String
thDbAutoKeyName THConstructorDef
cdef) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe THAutoKeyDef -> String
forall a. Show a => a -> String
show (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def)

  -- check that unique keys = [] for multiple constructor datatype
  if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [THConstructorDef]
constrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([THUniqueKeyDef] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([THUniqueKeyDef] -> Bool) -> [THUniqueKeyDef] -> Bool
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def)
    then String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Unique keys may exist only for datatypes with single constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def)
    else -- check that all unique keys reference existing uniques

      let uniqueNames :: [String]
uniqueNames = (THUniqueDef -> String) -> [THUniqueDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map THUniqueDef -> String
thUniqueName ([THUniqueDef] -> [String]) -> [THUniqueDef] -> [String]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques (THConstructorDef -> [THUniqueDef])
-> THConstructorDef -> [THUniqueDef]
forall a b. (a -> b) -> a -> b
$ [THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head [THConstructorDef]
constrs
       in [THUniqueKeyDef]
-> (THUniqueKeyDef -> Either String ()) -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Either String ()) -> Either String ())
-> (THUniqueKeyDef -> Either String ()) -> Either String ()
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
cKey ->
            Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
cKey String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
uniqueNames) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
              String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Unique key mentions unknown unique: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
cKey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def)
  let isPrimary :: UniqueType -> Bool
isPrimary UniqueType
x = case UniqueType
x of
        UniquePrimary Bool
_ -> Bool
True
        UniqueType
_ -> Bool
False
      primaryConstraints :: Int
primaryConstraints = [THUniqueDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([THUniqueDef] -> Int) -> [THUniqueDef] -> Int
forall a b. (a -> b) -> a -> b
$ (THUniqueDef -> Bool) -> [THUniqueDef] -> [THUniqueDef]
forall a. (a -> Bool) -> [a] -> [a]
filter (UniqueType -> Bool
isPrimary (UniqueType -> Bool)
-> (THUniqueDef -> UniqueType) -> THUniqueDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THUniqueDef -> UniqueType
thUniqueType) ([THUniqueDef] -> [THUniqueDef]) -> [THUniqueDef] -> [THUniqueDef]
forall a b. (a -> b) -> a -> b
$ (THConstructorDef -> [THUniqueDef])
-> [THConstructorDef] -> [THUniqueDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap THConstructorDef -> [THUniqueDef]
thConstrUniques [THConstructorDef]
constrs
  if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [THConstructorDef]
constrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    then
      Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
primaryConstraints Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Custom primary keys may exist only for datatypes with single constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def)
    else
      Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
primaryConstraints Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (THAutoKeyDef -> Int) -> Maybe THAutoKeyDef -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> THAutoKeyDef -> Int
forall a b. a -> b -> a
const Int
1) (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"A datatype cannot have more than one primary key constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def)
  -- check that only one of the keys is default
  let keyDefaults :: [Bool]
keyDefaults = ([Bool] -> [Bool])
-> (THAutoKeyDef -> [Bool] -> [Bool])
-> Maybe THAutoKeyDef
-> [Bool]
-> [Bool]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Bool] -> [Bool]
forall a. a -> a
id ((:) (Bool -> [Bool] -> [Bool])
-> (THAutoKeyDef -> Bool) -> THAutoKeyDef -> [Bool] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THAutoKeyDef -> Bool
thAutoKeyIsDef) (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def) ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map THUniqueKeyDef -> Bool
thUniqueKeyIsDef (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def)
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
keyDefaults) Bool -> Bool -> Bool
&& [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
forall a. a -> a
id [Bool]
keyDefaults) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"A datatype with keys must have one default key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (THEntityDef -> Name
thDataName THEntityDef
def)
  THEntityDef -> Either String THEntityDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure THEntityDef
def

validateField :: THFieldDef -> Either String ()
validateField :: THFieldDef -> Either String ()
validateField THFieldDef
fDef = do
  String -> String -> Either String ()
assertSpaceFree (THFieldDef -> String
thExprName THFieldDef
fDef) String
"field expr name"
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (THFieldDef -> Maybe String
thDbTypeName THFieldDef
fDef) Bool -> Bool -> Bool
&& Maybe [PSFieldDef String] -> Bool
forall a. Maybe a -> Bool
isJust (THFieldDef -> Maybe [PSFieldDef String]
thEmbeddedDef THFieldDef
fDef)) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"A field may not have both type and embeddedType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (THFieldDef -> String
thFieldName THFieldDef
fDef)

validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded THEmbeddedDef
def = do
  let fields :: [THFieldDef]
fields = THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def
  (THFieldDef -> String)
-> [THFieldDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THFieldDef -> String
thExprName [THFieldDef]
fields String
"expr field name in an embedded datatype"
  (THFieldDef -> String)
-> [THFieldDef] -> String -> Either String ()
forall b a.
(Eq b, Show b) =>
(a -> b) -> [a] -> String -> Either String ()
assertUnique THFieldDef -> String
thDbFieldName [THFieldDef]
fields String
"db field name in an embedded datatype"
  (THFieldDef -> Either String ())
-> [THFieldDef] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ THFieldDef -> Either String ()
validateField [THFieldDef]
fields
  THEmbeddedDef -> Either String THEmbeddedDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure THEmbeddedDef
def

mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDef NamingStyle {String -> String
String -> String -> Int -> String
String -> String -> Int -> Int -> String
String -> String -> Int -> String -> Int -> String
String -> String -> String -> String
String -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String
mkUniqueKeyDbName :: String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String
mkPhantomName :: String -> String -> Int -> String
mkEntityKeyName :: String -> String
mkDbEntityName :: String -> String
mkNormalExprSelectorName :: NamingStyle -> String -> String -> Int -> String
mkNormalExprFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkExprSelectorName :: NamingStyle -> String -> String -> String -> Int -> String
mkExprFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: NamingStyle -> String -> String -> Int -> String
mkUniqueKeyDbName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: NamingStyle -> String -> String -> String -> String
mkPhantomName :: NamingStyle -> String -> String -> Int -> String
mkEntityKeyName :: NamingStyle -> String -> String
mkDbEntityName :: NamingStyle -> String -> String
..} Dec
dec = Name
-> String
-> Maybe String
-> Maybe THAutoKeyDef
-> [THUniqueKeyDef]
-> [TyVarBndr]
-> [THConstructorDef]
-> THEntityDef
THEntityDef Name
dName (String -> String
mkDbEntityName String
dName') Maybe String
forall a. Maybe a
Nothing Maybe THAutoKeyDef
autokey [] [TyVarBndr]
typeVars [THConstructorDef]
constrs
  where
    (Name
dName, [TyVarBndr]
typeVars, [Con]
cons) = Dec -> (Name, [TyVarBndr], [Con])
fromDataD Dec
dec
    constrs :: [THConstructorDef]
constrs = (Int -> Con -> THConstructorDef)
-> [Int] -> [Con] -> [THConstructorDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Con -> THConstructorDef
mkConstr [Int
0 ..] [Con]
cons
    dName' :: String
dName' = Name -> String
nameBase Name
dName
    autokey :: Maybe THAutoKeyDef
autokey = THAutoKeyDef -> Maybe THAutoKeyDef
forall a. a -> Maybe a
Just (THAutoKeyDef -> Maybe THAutoKeyDef)
-> THAutoKeyDef -> Maybe THAutoKeyDef
forall a b. (a -> b) -> a -> b
$ String -> Bool -> THAutoKeyDef
THAutoKeyDef (String -> String
mkEntityKeyName String
dName') Bool
True

    mkConstr :: Int -> Con -> THConstructorDef
mkConstr Int
cNum Con
c = case Con
c of
      NormalC Name
name [BangType]
params -> Name -> [THFieldDef] -> THConstructorDef
mkConstr' Name
name ([THFieldDef] -> THConstructorDef)
-> [THFieldDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ (BangType -> Int -> THFieldDef)
-> [BangType] -> [Int] -> [THFieldDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String -> BangType -> Int -> THFieldDef
mkField (Name -> String
nameBase Name
name)) [BangType]
params [Int
0 ..]
      RecC Name
name [VarBangType]
params -> Name -> [THFieldDef] -> THConstructorDef
mkConstr' Name
name ([THFieldDef] -> THConstructorDef)
-> [THFieldDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Int -> THFieldDef)
-> [VarBangType] -> [Int] -> [THFieldDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String -> VarBangType -> Int -> THFieldDef
mkVarField (Name -> String
nameBase Name
name)) [VarBangType]
params [Int
0 ..]
      Con
_ -> String -> THConstructorDef
forall a. HasCallStack => String -> a
error (String -> THConstructorDef) -> String -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ String
"Only regular types and records are supported" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
dName
      where
        mkConstr' :: Name -> [THFieldDef] -> THConstructorDef
mkConstr' Name
name [THFieldDef]
params = Name
-> String
-> String
-> Maybe String
-> [THFieldDef]
-> [THUniqueDef]
-> THConstructorDef
THConstructorDef Name
name ((String -> String -> Int -> String) -> String
forall t. (String -> String -> Int -> t) -> t
apply String -> String -> Int -> String
mkPhantomName) ((String -> String -> Int -> String) -> String
forall t. (String -> String -> Int -> t) -> t
apply String -> String -> Int -> String
mkDbConstrName) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String -> String -> Int -> String) -> String
forall t. (String -> String -> Int -> t) -> t
apply String -> String -> Int -> String
mkDbConstrAutoKeyName) [THFieldDef]
params []
          where
            apply :: (String -> String -> Int -> t) -> t
apply String -> String -> Int -> t
f = String -> String -> Int -> t
f String
dName' (Name -> String
nameBase Name
name) Int
cNum

        mkField :: String -> StrictType -> Int -> THFieldDef
        mkField :: String -> BangType -> Int -> THFieldDef
mkField String
cName (Bang
_, Type
t) Int
fNum = String
-> String
-> Maybe String
-> String
-> Type
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe Name
-> THFieldDef
THFieldDef ((String -> String -> Int -> Int -> String) -> String
forall t. (String -> String -> Int -> Int -> t) -> t
apply String -> String -> Int -> Int -> String
mkNormalFieldName) ((String -> String -> Int -> Int -> String) -> String
forall t. (String -> String -> Int -> Int -> t) -> t
apply String -> String -> Int -> Int -> String
mkNormalDbFieldName) Maybe String
forall a. Maybe a
Nothing ((String -> String -> Int -> Int -> String) -> String
forall t. (String -> String -> Int -> Int -> t) -> t
apply String -> String -> Int -> Int -> String
mkNormalExprFieldName) Type
t Maybe [PSFieldDef String]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
forall a. Maybe a
Nothing Maybe Name
forall a. Maybe a
Nothing
          where
            apply :: (String -> String -> Int -> Int -> t) -> t
apply String -> String -> Int -> Int -> t
f = String -> String -> Int -> Int -> t
f String
dName' String
cName Int
cNum Int
fNum
        mkVarField :: String -> VarStrictType -> Int -> THFieldDef
        mkVarField :: String -> VarBangType -> Int -> THFieldDef
mkVarField String
cName (Name
fName, Bang
_, Type
t) Int
fNum = String
-> String
-> Maybe String
-> String
-> Type
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe Name
-> THFieldDef
THFieldDef String
fName' ((String -> String -> Int -> String -> Int -> String) -> String
forall t. (String -> String -> Int -> String -> Int -> t) -> t
apply String -> String -> Int -> String -> Int -> String
mkDbFieldName) Maybe String
forall a. Maybe a
Nothing ((String -> String -> Int -> String -> Int -> String) -> String
forall t. (String -> String -> Int -> String -> Int -> t) -> t
apply String -> String -> Int -> String -> Int -> String
mkExprFieldName) Type
t Maybe [PSFieldDef String]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
forall a. Maybe a
Nothing Maybe Name
forall a. Maybe a
Nothing
          where
            apply :: (String -> String -> Int -> String -> Int -> t) -> t
apply String -> String -> Int -> String -> Int -> t
f = String -> String -> Int -> String -> Int -> t
f String
dName' String
cName Int
cNum String
fName' Int
fNum
            fName' :: String
fName' = Name -> String
nameBase Name
fName

mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef
mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef
mkTHEmbeddedDef NamingStyle {String -> String
String -> String -> Int -> String
String -> String -> Int -> Int -> String
String -> String -> Int -> String -> Int -> String
String -> String -> String -> String
String -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String
mkUniqueKeyDbName :: String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String
mkPhantomName :: String -> String -> Int -> String
mkEntityKeyName :: String -> String
mkDbEntityName :: String -> String
mkNormalExprSelectorName :: NamingStyle -> String -> String -> Int -> String
mkNormalExprFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkExprSelectorName :: NamingStyle -> String -> String -> String -> Int -> String
mkExprFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: NamingStyle -> String -> String -> Int -> String
mkUniqueKeyDbName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: NamingStyle -> String -> String -> String -> String
mkPhantomName :: NamingStyle -> String -> String -> Int -> String
mkEntityKeyName :: NamingStyle -> String -> String
mkDbEntityName :: NamingStyle -> String -> String
..} Dec
dec = Name
-> Name -> String -> [TyVarBndr] -> [THFieldDef] -> THEmbeddedDef
THEmbeddedDef Name
dName Name
cName (String -> String
mkDbEntityName String
dName') [TyVarBndr]
typeVars [THFieldDef]
fields
  where
    (Name
dName, [TyVarBndr]
typeVars, [Con]
cons) = Dec -> (Name, [TyVarBndr], [Con])
fromDataD Dec
dec
    dName' :: String
dName' = Name -> String
nameBase Name
dName

    (Name
cName, [THFieldDef]
fields) = case [Con]
cons of
      [Con
cons'] -> case Con
cons' of
        NormalC Name
name [BangType]
params -> (Name
name, (BangType -> Int -> THFieldDef)
-> [BangType] -> [Int] -> [THFieldDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String -> BangType -> Int -> THFieldDef
mkField (Name -> String
nameBase Name
name)) [BangType]
params [Int
0 ..])
        RecC Name
name [VarBangType]
params -> (Name
name, (VarBangType -> Int -> THFieldDef)
-> [VarBangType] -> [Int] -> [THFieldDef]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String -> VarBangType -> Int -> THFieldDef
mkVarField (Name -> String
nameBase Name
name)) [VarBangType]
params [Int
0 ..])
        Con
_ -> String -> (Name, [THFieldDef])
forall a. HasCallStack => String -> a
error (String -> (Name, [THFieldDef])) -> String -> (Name, [THFieldDef])
forall a b. (a -> b) -> a -> b
$ String
"Only regular types and records are supported" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
dName
      [Con]
_ -> String -> (Name, [THFieldDef])
forall a. HasCallStack => String -> a
error (String -> (Name, [THFieldDef])) -> String -> (Name, [THFieldDef])
forall a b. (a -> b) -> a -> b
$ String
"An embedded datatype must have exactly one constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
dName

    mkField :: String -> StrictType -> Int -> THFieldDef
    mkField :: String -> BangType -> Int -> THFieldDef
mkField String
cName' (Bang
_, Type
t) Int
fNum = String
-> String
-> Maybe String
-> String
-> Type
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe Name
-> THFieldDef
THFieldDef ((String -> String -> Int -> Int -> String) -> String
forall t t. Num t => (String -> String -> t -> Int -> t) -> t
apply String -> String -> Int -> Int -> String
mkNormalFieldName) ((String -> String -> Int -> Int -> String) -> String
forall t t. Num t => (String -> String -> t -> Int -> t) -> t
apply String -> String -> Int -> Int -> String
mkNormalDbFieldName) Maybe String
forall a. Maybe a
Nothing (String -> String -> Int -> String
mkNormalExprSelectorName String
dName' String
cName' Int
fNum) Type
t Maybe [PSFieldDef String]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
forall a. Maybe a
Nothing Maybe Name
forall a. Maybe a
Nothing
      where
        apply :: (String -> String -> t -> Int -> t) -> t
apply String -> String -> t -> Int -> t
f = String -> String -> t -> Int -> t
f String
dName' String
cName' t
0 Int
fNum
    mkVarField :: String -> VarStrictType -> Int -> THFieldDef
    mkVarField :: String -> VarBangType -> Int -> THFieldDef
mkVarField String
cName' (Name
fName, Bang
_, Type
t) Int
fNum = String
-> String
-> Maybe String
-> String
-> Type
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
     (Maybe ((Maybe String, String), [String]),
      Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe Name
-> THFieldDef
THFieldDef String
fName' ((String -> String -> Int -> String -> Int -> String) -> String
forall t t.
Num t =>
(String -> String -> t -> String -> Int -> t) -> t
apply String -> String -> Int -> String -> Int -> String
mkDbFieldName) Maybe String
forall a. Maybe a
Nothing (String -> String -> String -> Int -> String
mkExprSelectorName String
dName' String
cName' String
fName' Int
fNum) Type
t Maybe [PSFieldDef String]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe
  (Maybe ((Maybe String, String), [String]),
   Maybe ReferenceActionType, Maybe ReferenceActionType)
forall a. Maybe a
Nothing Maybe Name
forall a. Maybe a
Nothing
      where
        apply :: (String -> String -> t -> String -> Int -> t) -> t
apply String -> String -> t -> String -> Int -> t
f = String -> String -> t -> String -> Int -> t
f String
dName' String
cName' t
0 String
fName' Int
fNum
        fName' :: String
fName' = Name -> String
nameBase Name
fName

mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef
mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef
mkTHPrimitiveDef NamingStyle {String -> String
String -> String -> Int -> String
String -> String -> Int -> Int -> String
String -> String -> Int -> String -> Int -> String
String -> String -> String -> String
String -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String
mkUniqueKeyDbName :: String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String
mkPhantomName :: String -> String -> Int -> String
mkEntityKeyName :: String -> String
mkDbEntityName :: String -> String
mkNormalExprSelectorName :: NamingStyle -> String -> String -> Int -> String
mkNormalExprFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: NamingStyle -> String -> String -> Int -> Int -> String
mkExprSelectorName :: NamingStyle -> String -> String -> String -> Int -> String
mkExprFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbConstrAutoKeyName :: NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: NamingStyle -> String -> String -> Int -> String
mkUniqueKeyDbName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: NamingStyle -> String -> String -> String -> String
mkPhantomName :: NamingStyle -> String -> String -> Int -> String
mkEntityKeyName :: NamingStyle -> String -> String
mkDbEntityName :: NamingStyle -> String -> String
..} Dec
dec = Name -> String -> Name -> THPrimitiveDef
THPrimitiveDef Name
dName (String -> String
mkDbEntityName String
dName') 'showReadConverter
  where
    dName :: Name
dName = case Dec
dec of
#if MIN_VERSION_template_haskell(2, 11, 0)
      DataD Cxt
_ Name
name [TyVarBndr]
_ Maybe Type
_ [Con]
_ [DerivClause]
_ -> Name
name
      NewtypeD Cxt
_ Name
name [TyVarBndr]
_ Maybe Type
_ Con
_ [DerivClause]
_ -> Name
name
#else
      DataD _ name _ _ _ -> name
      NewtypeD _ name _ _ _ -> name
#endif
      Dec
_ -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Only datatypes and newtypes can be declared as primitive: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
dec
    dName' :: String
dName' = Name -> String
nameBase Name
dName

showReadConverter :: (Show a, Read a) => (a -> String, String -> a)
showReadConverter :: (a -> String, String -> a)
showReadConverter = (a -> String
forall a. Show a => a -> String
show, String -> a
forall a. Read a => String -> a
read)

enumConverter :: Enum a => (a -> Int, Int -> a)
enumConverter :: (a -> Int, Int -> a)
enumConverter = (a -> Int
forall a. Enum a => a -> Int
fromEnum, Int -> a
forall a. Enum a => Int -> a
toEnum)

firstChar :: (Char -> Char) -> String -> String
firstChar :: (Char -> Char) -> String -> String
firstChar Char -> Char
f String
s = Char -> Char
f (String -> Char
forall a. [a] -> a
head String
s) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
tail String
s

-- | Transforms string from camelCase to lower_case_underscore naming convention.
-- ColumnName -> column_name, parseURL -> parse_url, FieldIEEE754Floating -> field_ieee754_floating
toUnderscore :: String -> String
toUnderscore :: String -> String
toUnderscore = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go
  where
    go :: String -> String
go (Char
x : Char
y : Char
z : String
xs) | Char -> Bool
isUpper Char
x Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
y Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
z = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go (Char
z Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
    go (Char
x : Char
y : String
xs) | (Char -> Bool
isLower Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x) Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
y = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
    go (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
    go String
"" = String
""

-- $settingsDoc
-- Groundhog needs to analyze the datatypes and create the auxiliary definitions before it can work with them.
-- We use YAML-based settings to list the datatypes and adjust the result of their introspection.
--
-- A datatype can be treated as entity or embedded. An entity is stored in its own table, can be referenced in fields of other data, etc. It is a first-class value.
-- An embedded type can only be a field of an entity or another embedded type. For example, the tuples are embedded.
-- You can create your own embedded types and adjust the fields names of an existing embedded type individually for any place where it is used.
--
-- Unless the property is marked as mandatory, it can be omitted. In this case value created by the NamingStyle will be used.
--
-- @
-- data Settable = First {foo :: String, bar :: Int, next :: Maybe (Key Settable BackendSpecific)} deriving (Eq, Show)
--
--    \-- The declaration with defaulted names
--
-- mkPersist defaultCodegenConfig [groundhog|
-- entity: Settable                       # If we did not have a constraint, this line would be enough
-- keys:
--  - name: someconstraint
-- constructors:
--  - name: First
--    uniques:
--      - name: someconstraint
--        fields: [foo, bar]
-- |]
-- @
--
-- Which is equivalent to the example below that has all properties set explicitly.
--
-- @
-- mkPersist defaultCodegenConfig [groundhog|
-- definitions:                           # First level key whose value is a list of definitions. It can be considered an optional header.
--                                       # The list elements start with hyphen+space. Keys are separated from values by a colon+space. See full definition at http://yaml.org/spec/1.2/spec.html.
--  - entity: Settable                   # Mandatory. Entity datatype name
--    dbName: Settable                   # Name of the main table
--    \# schema: public                   # Name of the schema to which the table belongs
--    autoKey:                           # Description of the autoincremented key for data family Key instance
--      constrName: SettableKey          # Name of constructor
--      default: true                    # The default key is used when entity is referenced without key wrapper. E.g., \"field :: SomeData\" instead of \"field :: Key SomeData keytype\"
--    keys:                              # List of the unique keys. An entity may have unique keys only if it has one constructor
--      - name: someconstraint           # This name references names from uniques field of constructor
--        keyPhantom: Someconstraint     # Name of phantom datatype that corresponds for each unique key
--        constrName: SomeconstraintKey  # Name of data family Key instance constructor for this unique key
--        dbName: Key\#Someconstraint     # It is used for function \"persistName\" of \"PersistField (Key Settable (Unique Someconstraint))\"
--        fields: []                     # Set fields that comprise this unique constraint. It works like setting fields in constructors
--        mkEmbedded: false              # Defines if instance of \"Embedded (Key Settable (Unique Someconstraint))\" will be created. The \"Selector\" constructor names are defined by properties of key fields.
--        default: false                 # Defines if this unique key is used as default
--    constructors:                      # List of constructors. The constructors you don't change can be omitted
--      - name: First                    # Mandatory. Constructor name
--        phantomName: FooBarConstructor # Constructor phantom type name used to guarantee type safety
--        dbName: First                  # Name of constructor table which is created only for datatypes with multiple constructors
--        keyDbName: id                  # Name for the primary key column
--        fields:                        # List of constructor fields. If you don't change a field, you can omit it
--          - name: foo                  # The name as in constructor record. If constructor is not a record, the name is created by 'mkNormalFieldName'. For example, the fields in constructor SomeConstr would have names someConstr0 and someConstr1 by default.
--            dbName: foo                # Column name
--            exprName: FooField         # Name of a field used in expressions
--          \# type: varchar              # This would result in having field type DbOther \"varchar\" instead of DbString. Value of this attribute will be used by DB backend for migration
--          \# default: foo_value         # The default value for column in the clause
--          \# reference:                 # This is explicit reference to a parent table not mapped by Groundhog
--          \#   schema: myschema         # Optional schema
--          \#   table: mytable           # Name of the parent table
--          \#   columns: [mytable_id]    # Parent columns. If the current field is embedded, e.g., a tuple, it will be a composite key
--          \#   onDelete: cascade        # Defines ON DELETE clause of references. It can have values: no action, restrict, cascade, set null, set default
--          \#   onUpdate: restrict       # Defines ON UPDATE
--          \# onDelete: cascade          # Clauses onDelete and onUpdate can be set outside of reference too. This is deprecated and kept for compatibility
--          \# If onDelete or onUpdate are omitted, the database will choose the action automatically. Note that it may differ across databases.
--          \# For example, MySQL has \"restrict\" by default, but in PostgreSQL it is \"no action\".
--          - name: bar
--            dbName: bar
--            exprName: BarField
--                                       # For some databases \"type: integer\" would be appropriate
--          - name: next
--            dbName: next
--            exprName: NextField
--        uniques:
--          - name: someconstraint
--            type: constraint           # The type can be be \"constraint\", \"index\", or \"primary\"
--            fields: [foo, bar]         # List of constructor parameter names. Not column names.
--   # This is example for databases which support expression indexes.
--   # Note that for checking index during migration expression should be written in exactly the same form as database returns.
--   #  - name: myuniqueindex
--   #    type: index
--   #    fields: [foo, {expr: "(bar + 1)" }]
-- |]
-- @
--
-- This is an example of embedded datatype usage.
--
-- @
-- data Company = Company {name :: String, headquarter :: Address, dataCentre :: Address, salesOffice :: Address} deriving (Eq, Show)
-- data Address = Address {city :: String, zipCode :: String, street :: String} deriving (Eq, Show)
--
-- mkPersist defaultCodegenConfig [groundhog|
-- definitions:
--  - entity: Company
--    constructors:
--      - name: Company
--        fields:
--                                        # Property embeddedType of headquarter field is not mentioned, so the corresponding table columns will have names prefixed with headquarter (headquarter$city, headquarter$zip_code, headquarter$street)
--          - name: dataCentre
--            embeddedType:               # If a field has an embedded type you can access its subfields. If you do it, the database columns will match with the embedded dbNames (no prefixing).
--              - name: city              # Just a regular list of fields. However, note that you should use default dbNames of embedded
--                dbName: dc_city
--              - name: zip_code          # Here we use embedded dbName (zip_code) which differs from the name used in Address definition (zipCode) for accessing the field.
--                dbName: dc_zipcode
--              - name: street
--                dbName: dc_street
--          - name: salesOffice
--            embeddedType:               # Similar declaration, but using another syntax for YAML objects
--              - {name: city, dbName: sales_city}
--              - {name: zip_code, dbName: sales_zipcode}
--              - {name: street, dbName: sales_street}
--  - embedded: Address
--    fields:                             # The syntax is the same as for constructor fields. Nested embedded types are allowed.
--      - name: city                      # This line does nothing and can be omitted. Default settings for city are not changed.
--      - name: zipCode
--        dbName: zip_code                # Change column name.
--                                        # Street is not mentioned so it will have default settings.
-- |]
-- @
--
-- We can also make our types instances of `PrimitivePersistField` to store them in one column.
--
-- @
-- data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
--  deriving (Eq, Show, Enum)
-- data Point = Point Int Int
--  deriving (Eq, Show, Read)
--
-- mkPersist defaultCodegenConfig [groundhog|
-- definitions:
--  - primitive: WeekDay
--    converter: enumConverter            # Its column will have integer type. The conversion will use Enum instance.
--  - primitive: Point
--    converter: showReadConverter        # Its column will have string type. The conversion will use Show/Read instances. If representation is omitted, showread will be used by default.
-- |]
-- @

-- | Converts quasiquoted settings into the datatype used by mkPersist.
groundhog :: QuasiQuoter
groundhog :: QuasiQuoter
groundhog =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
parseDefinitions,
      quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"groundhog: pattern quasiquoter",
      quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"groundhog: type quasiquoter",
      quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"groundhog: declaration quasiquoter"
    }

-- | Parses configuration stored in the file
--
-- > mkPersist defaultCodegenConfig [groundhogFile|../groundhog.yaml|]
groundhogFile :: QuasiQuoter
groundhogFile :: QuasiQuoter
groundhogFile = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
groundhog

parseDefinitions :: String -> Q Exp
parseDefinitions :: String -> Q Exp
parseDefinitions String
s = do
  Either ParseException ([Warning], Either String PersistDefinitions)
result <- IO
  (Either
     ParseException ([Warning], Either String PersistDefinitions))
-> Q (Either
        ParseException ([Warning], Either String PersistDefinitions))
forall a. IO a -> Q a
runIO (IO
   (Either
      ParseException ([Warning], Either String PersistDefinitions))
 -> Q (Either
         ParseException ([Warning], Either String PersistDefinitions)))
-> IO
     (Either
        ParseException ([Warning], Either String PersistDefinitions))
-> Q (Either
        ParseException ([Warning], Either String PersistDefinitions))
forall a b. (a -> b) -> a -> b
$ ConduitM () Event Parse ()
-> IO
     (Either
        ParseException ([Warning], Either String PersistDefinitions))
forall a.
FromJSON a =>
ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], Either String a))
decodeHelper (ByteString -> ConduitM () Event Parse ()
forall (m :: * -> *) i.
MonadResource m =>
ByteString -> ConduitM i Event m ()
Y.decode (ByteString -> ConduitM () Event Parse ())
-> ByteString -> ConduitM () Event Parse ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
s)
  case Either ParseException ([Warning], Either String PersistDefinitions)
result of
    Left ParseException
err -> case ParseException
err of
      InvalidYaml (Just (Y.YamlParseException String
problem String
context YamlMark
mark)) ->
        String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ String
"YAML parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
problem,
              String
"Context: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
context,
              String
"At line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (YamlMark -> Int
Y.yamlLine YamlMark
mark),
              String -> [String]
lines String
s [String] -> Int -> String
forall a. [a] -> Int -> a
!! YamlMark -> Int
Y.yamlLine YamlMark
mark,
              Int -> Char -> String
forall a. Int -> a -> [a]
replicate (YamlMark -> Int
Y.yamlColumn YamlMark
mark) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"^"
            ]
      ParseException
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseException -> String
forall a. Show a => a -> String
show ParseException
err
    Right ([Warning]
_, Left String
err) -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right ([Warning]
_, Right PersistDefinitions
result') -> PersistDefinitions -> Q Exp
forall t. Lift t => t -> Q Exp
lift (PersistDefinitions
result' :: PersistDefinitions)

checkEnabledLanguageExtensions :: Q ()
checkEnabledLanguageExtensions :: Q ()
checkEnabledLanguageExtensions = do
  [Extension]
exts <- Q [Extension]
extsEnabled
  let missingExtensions :: [String]
missingExtensions = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show ([Extension]
requiredLanguageExtensions [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Extension]
exts)
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missingExtensions) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
      String
"Groundhog requires that you enable additionally the following language extensions: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
missingExtensions

requiredLanguageExtensions :: [Extension]
requiredLanguageExtensions :: [Extension]
requiredLanguageExtensions =
  [ Extension
GADTs,
    Extension
TypeFamilies,
    Extension
TemplateHaskell,
    Extension
QuasiQuotes,
    Extension
FlexibleInstances
  ]

defaultMkEntityDecs :: [THEntityDef] -> Q [Dec]
defaultMkEntityDecs :: [THEntityDef] -> Q [Dec]
defaultMkEntityDecs =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (Q [[Dec]] -> Q [Dec])
-> ([THEntityDef] -> Q [[Dec]]) -> [THEntityDef] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (THEntityDef -> Q [Dec]) -> [THEntityDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( \THEntityDef
def ->
          [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((THEntityDef -> Q [Dec]) -> Q [Dec])
-> [THEntityDef -> Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
              ((THEntityDef -> Q [Dec]) -> THEntityDef -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ THEntityDef
def)
              [ THEntityDef -> Q [Dec]
mkEntityPhantomConstructors,
                THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances,
                THEntityDef -> Q [Dec]
mkAutoKeyPersistFieldInstance,
                THEntityDef -> Q [Dec]
mkAutoKeyPrimitivePersistFieldInstance,
                THEntityDef -> Q [Dec]
mkEntityUniqueKeysPhantoms,
                THEntityDef -> Q [Dec]
mkUniqueKeysIsUniqueInstances,
                THEntityDef -> Q [Dec]
mkUniqueKeysEmbeddedInstances,
                THEntityDef -> Q [Dec]
mkUniqueKeysPersistFieldInstances,
                THEntityDef -> Q [Dec]
mkUniqueKeysPrimitiveOrPurePersistFieldInstances,
                THEntityDef -> Q [Dec]
mkKeyEqShowInstances,
                THEntityDef -> Q [Dec]
mkEntityPersistFieldInstance,
                THEntityDef -> Q [Dec]
mkEntitySinglePersistFieldInstance,
                THEntityDef -> Q [Dec]
mkPersistEntityInstance,
                THEntityDef -> Q [Dec]
mkEntityNeverNullInstance
              ]
      )

defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec]
defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec]
defaultMkEmbeddedDecs =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (Q [[Dec]] -> Q [Dec])
-> ([THEmbeddedDef] -> Q [[Dec]]) -> [THEmbeddedDef] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (THEmbeddedDef -> Q [Dec]) -> [THEmbeddedDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( \THEmbeddedDef
def ->
          [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((THEmbeddedDef -> Q [Dec]) -> Q [Dec])
-> [THEmbeddedDef -> Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
              ((THEmbeddedDef -> Q [Dec]) -> THEmbeddedDef -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef
def)
              [ THEmbeddedDef -> Q [Dec]
mkEmbeddedPersistFieldInstance,
                THEmbeddedDef -> Q [Dec]
mkEmbeddedPurePersistFieldInstance,
                THEmbeddedDef -> Q [Dec]
mkEmbeddedInstance
              ]
      )

defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec]
defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec]
defaultMkPrimitiveDecs =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (Q [[Dec]] -> Q [Dec])
-> ([THPrimitiveDef] -> Q [[Dec]]) -> [THPrimitiveDef] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (THPrimitiveDef -> Q [Dec]) -> [THPrimitiveDef] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( \THPrimitiveDef
def ->
          [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((THPrimitiveDef -> Q [Dec]) -> Q [Dec])
-> [THPrimitiveDef -> Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
              ((THPrimitiveDef -> Q [Dec]) -> THPrimitiveDef -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ THPrimitiveDef
def)
              [ THPrimitiveDef -> Q [Dec]
mkPrimitivePersistFieldInstance,
                THPrimitiveDef -> Q [Dec]
mkPrimitivePrimitivePersistFieldInstance
              ]
      )

#if MIN_VERSION_template_haskell(2, 17, 0)
fromDataD :: InstanceDec -> (Name, [TyVarBndr ()], [Con])
#else
fromDataD :: InstanceDec -> (Name, [TyVarBndr], [Con])
#endif
fromDataD :: Dec -> (Name, [TyVarBndr], [Con])
fromDataD Dec
dec = case Dec
dec of
#if MIN_VERSION_template_haskell(2, 11, 0)
  (DataD Cxt
_ Name
dName [TyVarBndr]
typeVars Maybe Type
_ [Con]
constrs [DerivClause]
_) -> (Name
dName, [TyVarBndr]
typeVars, [Con]
constrs)
#else
  (DataD _ dName typeVars constrs _) -> (dName, typeVars, constrs)
#endif
  Dec
_ -> String -> (Name, [TyVarBndr], [Con])
forall a. HasCallStack => String -> a
error (String -> (Name, [TyVarBndr], [Con]))
-> String -> (Name, [TyVarBndr], [Con])
forall a b. (a -> b) -> a -> b
$ String
"Only datatypes can be processed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
dec