{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.Groundhog.TH
(
mkPersist,
groundhog,
groundhogFile,
CodegenConfig (..),
defaultCodegenConfig,
defaultMkEntityDecs,
defaultMkEmbeddedDecs,
defaultMkPrimitiveDecs,
NamingStyle (..),
suffixNamingStyle,
persistentNamingStyle,
conciseNamingStyle,
lowerCaseSuffixNamingStyle,
toUnderscore,
firstChar,
mkTHEntityDef,
mkTHEmbeddedDef,
mkTHPrimitiveDef,
applyEntitySettings,
applyEmbeddedSettings,
applyPrimitiveSettings,
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
{
CodegenConfig -> NamingStyle
namingStyle :: NamingStyle,
CodegenConfig -> Maybe String
migrationFunction :: Maybe String,
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]
data NamingStyle = NamingStyle
{
NamingStyle -> String -> String
mkDbEntityName :: String -> String,
NamingStyle -> String -> String
mkEntityKeyName :: String -> String,
NamingStyle -> String -> String -> Int -> String
mkPhantomName :: String -> String -> Int -> String,
NamingStyle -> String -> String -> String -> String
mkUniqueKeyPhantomName :: String -> String -> String -> String,
NamingStyle -> String -> String -> String -> String
mkUniqueKeyConstrName :: String -> String -> String -> String,
NamingStyle -> String -> String -> String -> String
mkUniqueKeyDbName :: String -> String -> String -> String,
NamingStyle -> String -> String -> Int -> String
mkDbConstrName :: String -> String -> Int -> String,
NamingStyle -> String -> String -> Int -> String
mkDbConstrAutoKeyName :: String -> String -> Int -> String,
NamingStyle -> String -> String -> Int -> String -> Int -> String
mkDbFieldName :: String -> String -> Int -> String -> Int -> String,
NamingStyle -> String -> String -> Int -> String -> Int -> String
mkExprFieldName :: String -> String -> Int -> String -> Int -> String,
NamingStyle -> String -> String -> String -> Int -> String
mkExprSelectorName :: String -> String -> String -> Int -> String,
NamingStyle -> String -> String -> Int -> Int -> String
mkNormalFieldName :: String -> String -> Int -> Int -> String,
NamingStyle -> String -> String -> Int -> Int -> String
mkNormalDbFieldName :: String -> String -> Int -> Int -> String,
NamingStyle -> String -> String -> Int -> Int -> String
mkNormalExprFieldName :: String -> String -> Int -> Int -> String,
NamingStyle -> String -> String -> Int -> String
mkNormalExprSelectorName :: String -> String -> Int -> String
}
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"
}
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
}
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
}
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
}
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
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)
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
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)
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
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
""
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"
}
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