{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.Groundhog.TH.CodeGen
( mkEmbeddedPersistFieldInstance,
mkEmbeddedPurePersistFieldInstance,
mkEmbeddedInstance,
mkEntityPhantomConstructors,
mkEntityPhantomConstructorInstances,
mkEntityUniqueKeysPhantoms,
mkAutoKeyPersistFieldInstance,
mkAutoKeyPrimitivePersistFieldInstance,
mkUniqueKeysIsUniqueInstances,
mkUniqueKeysEmbeddedInstances,
mkUniqueKeysPersistFieldInstances,
mkUniqueKeysPrimitiveOrPurePersistFieldInstances,
mkKeyEqShowInstances,
mkEntityPersistFieldInstance,
mkEntitySinglePersistFieldInstance,
mkPersistEntityInstance,
mkEntityNeverNullInstance,
mkPrimitivePersistFieldInstance,
mkPrimitivePrimitivePersistFieldInstance,
mkMigrateFunction,
)
where
import Control.Arrow (first)
import Control.Monad (filterM, forM, forM_, liftM2, replicateM, zipWithM)
import Data.Either (lefts, rights)
import Data.List (findIndex, nub, partition)
import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe)
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.TH.Settings
import qualified GHC.Read as R
import Language.Haskell.TH hiding (TyVarBndr)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (Lift (..))
import qualified Text.ParserCombinators.ReadPrec as R
import qualified Text.Read.Lex as R
mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPersistFieldInstance THEmbeddedDef
def = do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
let embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types
Dec
persistName' <- do
Name
v <- String -> Q Name
newName String
"v"
let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure embedded) -> $(pure t)|]
let paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
let fullEmbeddedName :: ExpQ
fullEmbeddedName =
if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types
then [|$(stringE $ thDbEmbeddedName def)|]
else [|$(stringE $ thDbEmbeddedName def) ++ [delim] ++ $(paramNames)|]
let body :: BodyQ
body = ExpQ -> BodyQ
normalB ExpQ
fullEmbeddedName
let pat :: PatQ
pat = if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types then PatQ
wildP else Name -> PatQ
varP Name
v
Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []]
Dec
toPersistValues' <- do
(PatQ
pat, ExpQ
body) <- Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) ExpQ -> ExpQ
forall a. a -> a
id
Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
fromPersistValues' <- do
Name
xs <- String -> Q Name
newName String
"xs"
Name
failureName <- String -> Q Name
newName String
"failure"
(Bool
isFailureUsed, Exp
body) <- Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
xs (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|(\a -> fail (failMessage a $(varE xs)) >> pure (a, [])) undefined|]
failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
locals :: [Q Dec]
locals = if Bool
isFailureUsed then [Q Dec
failureFunc] else []
Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body) [Q Dec]
locals]
Dec
dbType' <- do
Name
v <- String -> Q Name
newName String
"v"
Name
proxy <- String -> Q Name
newName String
"p"
let mkField :: Int -> THFieldDef -> ExpQ
mkField Int
fNum THFieldDef
f = do
Name
a <- String -> Q Name
newName String
"a"
let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
nvar :: ExpQ
nvar =
if Type -> Bool
hasFreeVars (THFieldDef -> Type
thFieldType THFieldDef
f)
then
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
fNum PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [Name -> PatQ
varP Name
a] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate ([THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PatQ
wildP
in ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
v) [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
a) []]
else [|undefined :: $(pure $ thFieldType f)|]
typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
[|(fname, $typ)|]
let pat :: PatQ
pat = if [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def then PatQ
wildP else Name -> PatQ
varP Name
v
Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, PatQ
pat] (ExpQ -> BodyQ
normalB [|DbEmbedded (EmbeddedDef False $(listE $ zipWith mkField [0 ..] $ thEmbeddedFields def)) Nothing|]) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
embedded) [Dec]
decs]
mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues Name
constrName [THFieldDef]
fieldDefs ExpQ -> ExpQ
processResult = do
[Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
let processField :: Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ)
processField Name
fName THFieldDef
fDef = do
Bool
isP <- Type -> Q Bool
isPrim (THFieldDef -> Type
thFieldType THFieldDef
fDef)
let field :: ExpQ
field = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) (THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef) (Name -> ExpQ
varE Name
fName)
if Bool
isP
then (Maybe StmtQ, ExpQ) -> Q (Maybe StmtQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StmtQ
forall a. Maybe a
Nothing, [|(toPrimitivePersistValue $field :)|])
else String -> Q Name
newName String
"x" Q Name -> (Name -> Q (Maybe StmtQ, ExpQ)) -> Q (Maybe StmtQ, ExpQ)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (Maybe StmtQ, ExpQ) -> Q (Maybe StmtQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StmtQ -> Maybe StmtQ
forall a. a -> Maybe a
Just (StmtQ -> Maybe StmtQ) -> StmtQ -> Maybe StmtQ
forall a b. (a -> b) -> a -> b
$ PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
x) [|toPersistValues $field|], Name -> ExpQ
varE Name
x)
([StmtQ]
binds, [ExpQ]
funcs) <- ([Maybe StmtQ] -> [StmtQ])
-> ([Maybe StmtQ], [ExpQ]) -> ([StmtQ], [ExpQ])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Maybe StmtQ] -> [StmtQ]
forall a. [Maybe a] -> [a]
catMaybes (([Maybe StmtQ], [ExpQ]) -> ([StmtQ], [ExpQ]))
-> ([(Maybe StmtQ, ExpQ)] -> ([Maybe StmtQ], [ExpQ]))
-> [(Maybe StmtQ, ExpQ)]
-> ([StmtQ], [ExpQ])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Maybe StmtQ, ExpQ)] -> ([Maybe StmtQ], [ExpQ])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe StmtQ, ExpQ)] -> ([StmtQ], [ExpQ]))
-> Q [(Maybe StmtQ, ExpQ)] -> Q ([StmtQ], [ExpQ])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ))
-> [Name] -> [THFieldDef] -> Q [(Maybe StmtQ, ExpQ)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> THFieldDef -> Q (Maybe StmtQ, ExpQ)
processField [Name]
patVars [THFieldDef]
fieldDefs
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
constrName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
patVars
result :: ExpQ
result = [|pure $(processResult $ if null funcs then [|id|] else foldr1 (\a b -> [|$a . $b|]) funcs)|]
body :: ExpQ
body = if [StmtQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StmtQ]
binds then ExpQ
result else [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [StmtQ]
binds [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ExpQ -> StmtQ
noBindS ExpQ
result]
(PatQ, ExpQ) -> Q (PatQ, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatQ
pat, ExpQ
body)
mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
values Name
constrName [THFieldDef]
fieldDefs = do
[Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
mkArg :: (Name, THFieldDef) -> ExpQ
mkArg (Name
fName, THFieldDef
fDef) = do
Bool
isP <- Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
fDef
let x :: ExpQ
x =
if Bool
isP
then [|fromPrimitivePersistValue $(varE fName)|]
else Name -> ExpQ
varE Name
fName
ExpQ -> (Name -> ExpQ) -> Maybe Name -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ
x (\Name
convName -> [|snd $(varE convName) $ $x|]) (Maybe Name -> ExpQ) -> Maybe Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef
result :: ExpQ
result = (ExpQ -> (Name, THFieldDef) -> ExpQ)
-> ExpQ -> [(Name, THFieldDef)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
func (Name, THFieldDef)
f -> ExpQ -> ExpQ -> ExpQ
appE ExpQ
func (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name, THFieldDef) -> ExpQ
mkArg (Name, THFieldDef)
f) (Name -> ExpQ
conE Name
constrName) ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
goField :: Name -> [(Name, THFieldDef)] -> ExpQ
goField Name
xs [(Name, THFieldDef)]
vars = do
([(Name, THFieldDef)]
fields, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool)
-> ((Name, THFieldDef) -> Q Bool) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
[Name]
xss <- (Name
xs Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> Q [Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, THFieldDef) -> Q Name) -> [(Name, THFieldDef)] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> (Name, THFieldDef) -> Q Name
forall a b. a -> b -> a
const (Q Name -> (Name, THFieldDef) -> Q Name)
-> Q Name -> (Name, THFieldDef) -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"xs") [(Name, THFieldDef)]
fields
let f :: Name -> Name -> (Name, b) -> StmtQ
f Name
oldXs Name
newXs (Name
fname, b
_) = PatQ -> ExpQ -> StmtQ
bindS (Name -> [PatQ] -> PatQ
conP '(,) [Name -> PatQ
varP Name
fname, Name -> PatQ
varP Name
newXs]) [|fromPersistValues $(varE oldXs)|]
stmts :: [StmtQ]
stmts = (Name -> Name -> (Name, THFieldDef) -> StmtQ)
-> [Name] -> [Name] -> [(Name, THFieldDef)] -> [StmtQ]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> (Name, THFieldDef) -> StmtQ
forall b. Name -> Name -> (Name, b) -> StmtQ
f [Name]
xss ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
xss) [(Name, THFieldDef)]
fields
expr :: ExpQ
expr = Name -> [(Name, THFieldDef)] -> ExpQ
goPrim ([Name] -> Name
forall a. [a] -> a
last [Name]
xss) [(Name, THFieldDef)]
rest
[StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [StmtQ]
stmts [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [ExpQ -> StmtQ
noBindS ExpQ
expr]
goPrim :: Name -> [(Name, THFieldDef)] -> ExpQ
goPrim Name
xs [(Name, THFieldDef)]
vars = do
Name
xs' <- String -> Q Name
newName String
"xs"
([(Name, THFieldDef)]
prims, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM (Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
let body' :: ExpQ
body' = case [(Name, THFieldDef)]
rest of
[] -> [|pure ($result, $(varE xs'))|]
[(Name, THFieldDef)]
_ -> Name -> [(Name, THFieldDef)] -> ExpQ
goField Name
xs' [(Name, THFieldDef)]
rest
m :: MatchQ
m = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (((Name, THFieldDef) -> PatQ -> PatQ)
-> PatQ -> [(Name, THFieldDef)] -> PatQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Name
fName, THFieldDef
_) PatQ
p -> PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
fName) '(:) PatQ
p) (Name -> PatQ
varP Name
xs') [(Name, THFieldDef)]
prims) (ExpQ -> BodyQ
normalB ExpQ
body') []
if [(Name, THFieldDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, THFieldDef)]
prims
then ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m]
else ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m, MatchQ
failure]
Exp
body <- Name -> [(Name, THFieldDef)] -> ExpQ
goPrim Name
values ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
Bool
anyPrim <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (THFieldDef -> Q Bool) -> [THFieldDef] -> Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Q Bool
isPrim (Type -> Q Bool) -> (THFieldDef -> Type) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType) [THFieldDef]
fieldDefs
(Bool, Exp) -> Q (Bool, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
anyPrim, Exp
body)
mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec]
mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
dataType Name
cName [THFieldDef]
fieldDefs [Type]
context = do
Dec
toPurePersistValues' <- do
[Name]
vars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP Name
cName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vars
body :: ExpQ
body = [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars [THFieldDef]
fieldDefs
Name -> [ClauseQ] -> Q Dec
funD 'toPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
fromPurePersistValues' <-
let goField :: Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goField Name
xs [(Name, THFieldDef)]
vars ExpQ
result MatchQ
failure = do
([(Name, THFieldDef)]
fields, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool)
-> ((Name, THFieldDef) -> Q Bool) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
[Name]
xss <- (Name
xs Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> Q [Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, THFieldDef) -> Q Name) -> [(Name, THFieldDef)] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> (Name, THFieldDef) -> Q Name
forall a b. a -> b -> a
const (Q Name -> (Name, THFieldDef) -> Q Name)
-> Q Name -> (Name, THFieldDef) -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"xs") [(Name, THFieldDef)]
fields
let f :: Name -> Name -> (Name, b) -> Q Dec
f Name
oldXs Name
newXs (Name
fName, b
_) = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> [PatQ] -> PatQ
conP '(,) [Name -> PatQ
varP Name
fName, Name -> PatQ
varP Name
newXs]) (ExpQ -> BodyQ
normalB [|fromPurePersistValues $(varE oldXs)|]) []
let stmts :: [Q Dec]
stmts = (Name -> Name -> (Name, THFieldDef) -> Q Dec)
-> [Name] -> [Name] -> [(Name, THFieldDef)] -> [Q Dec]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> (Name, THFieldDef) -> Q Dec
forall b. Name -> Name -> (Name, b) -> Q Dec
f [Name]
xss ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
xss) [(Name, THFieldDef)]
fields
(Bool
isFailureUsed, ExpQ
expr) <- Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim ([Name] -> Name
forall a. [a] -> a
last [Name]
xss) [(Name, THFieldDef)]
rest ExpQ
result MatchQ
failure
(Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
isFailureUsed, [Q Dec] -> ExpQ -> ExpQ
letE [Q Dec]
stmts ExpQ
expr)
goPrim :: Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim Name
xs [(Name, THFieldDef)]
vars ExpQ
result MatchQ
failure = do
Name
xs' <- String -> Q Name
newName String
"xs"
([(Name, THFieldDef)]
prims, [(Name, THFieldDef)]
rest) <- ((Name, THFieldDef) -> Q Bool)
-> [(Name, THFieldDef)]
-> Q ([(Name, THFieldDef)], [(Name, THFieldDef)])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
spanM (Type -> Q Bool
isPrim (Type -> Q Bool)
-> ((Name, THFieldDef) -> Type) -> (Name, THFieldDef) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType (THFieldDef -> Type)
-> ((Name, THFieldDef) -> THFieldDef) -> (Name, THFieldDef) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) [(Name, THFieldDef)]
vars
(Bool
isFailureUsed, ExpQ
body') <- case [(Name, THFieldDef)]
rest of
[] -> (Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [|($result, $(varE xs'))|])
[(Name, THFieldDef)]
_ -> Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goField Name
xs' [(Name, THFieldDef)]
rest ExpQ
result MatchQ
failure
let m :: MatchQ
m = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (((Name, THFieldDef) -> PatQ -> PatQ)
-> PatQ -> [(Name, THFieldDef)] -> PatQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Name
fName, THFieldDef
_) PatQ
p -> PatQ -> Name -> PatQ -> PatQ
infixP (Name -> PatQ
varP Name
fName) '(:) PatQ
p) (Name -> PatQ
varP Name
xs') [(Name, THFieldDef)]
prims) (ExpQ -> BodyQ
normalB ExpQ
body') []
(Bool, ExpQ) -> Q (Bool, ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, ExpQ) -> Q (Bool, ExpQ)) -> (Bool, ExpQ) -> Q (Bool, ExpQ)
forall a b. (a -> b) -> a -> b
$
if [(Name, THFieldDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, THFieldDef)]
prims
then (Bool
isFailureUsed, ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m])
else (Bool
True, ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) [MatchQ
m, MatchQ
failure])
mkArg :: (Name, THFieldDef) -> ExpQ
mkArg (Name
fName, THFieldDef
fDef) = do
Bool
isP <- Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
fDef
let x :: ExpQ
x =
if Bool
isP
then [|fromPrimitivePersistValue $(varE fName)|]
else Name -> ExpQ
varE Name
fName
ExpQ -> (Name -> ExpQ) -> Maybe Name -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ
x (\Name
convName -> [|snd $(varE convName) $ $x|]) (Maybe Name -> ExpQ) -> Maybe Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef
in do
Name
xs <- String -> Q Name
newName String
"xs"
let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|(\a -> error (failMessage a $(varE xs)) `asTypeOf` (a, [])) undefined|]
Name
failureName <- String -> Q Name
newName String
"failure"
[Name]
patVars <- (THFieldDef -> Q Name) -> [THFieldDef] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> THFieldDef -> Q Name
forall a b. a -> b -> a
const (Q Name -> THFieldDef -> Q Name) -> Q Name -> THFieldDef -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [THFieldDef]
fieldDefs
let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
result :: ExpQ
result = (ExpQ -> (Name, THFieldDef) -> ExpQ)
-> ExpQ -> [(Name, THFieldDef)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a (Name, THFieldDef)
f -> ExpQ -> ExpQ -> ExpQ
appE ExpQ
a (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name, THFieldDef) -> ExpQ
mkArg (Name, THFieldDef)
f) (Name -> ExpQ
conE Name
cName) ([(Name, THFieldDef)] -> ExpQ) -> [(Name, THFieldDef)] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs
(Bool
isFailureUsed, ExpQ
start) <- Name -> [(Name, THFieldDef)] -> ExpQ -> MatchQ -> Q (Bool, ExpQ)
goPrim Name
xs ([Name] -> [THFieldDef] -> [(Name, THFieldDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
patVars [THFieldDef]
fieldDefs) ExpQ
result MatchQ
failure
let failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
locals :: [Q Dec]
locals = if Bool
isFailureUsed then [Q Dec
failureFunc] else []
Name -> [ClauseQ] -> Q Dec
funD 'fromPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB ExpQ
start) [Q Dec]
locals]
let decs :: [Dec]
decs = [Dec
toPurePersistValues', Dec
fromPurePersistValues']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PurePersistField) Type
dataType) [Dec]
decs]
mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedPurePersistFieldInstance THEmbeddedDef
def = do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
let embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types
let fDefs :: [THFieldDef]
fDefs = THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def
Maybe [Type]
context <- [TyVarBndr] -> [THFieldDef] -> Q (Maybe [Type])
paramsPureContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) [THFieldDef]
fDefs
case Maybe [Type]
context of
Maybe [Type]
Nothing -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just [Type]
context' -> Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
embedded (THEmbeddedDef -> Name
thEmbeddedConstructorName THEmbeddedDef
def) [THFieldDef]
fDefs [Type]
context'
mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Just THAutoKeyDef
_ -> do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
Type
keyType <- [t|Key $(pure entity) BackendSpecific|]
Dec
persistName' <- do
Name
a <- String -> Q Name
newName String
"a"
let body :: ExpQ
body = [|"Key" ++ [delim] ++ persistName ((undefined :: Key v u -> v) $(varE a))|]
Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPersistValue|]) []]
Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPersistValue|]) []]
Dec
dbType' <- do
Name
proxy <- String -> Q Name
newName String
"p"
Name
a <- String -> Q Name
newName String
"a"
let e :: ExpQ
e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]
body :: ExpQ
body = [|DbTypePrimitive (getDefaultAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing))|]
Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
keyType) [Dec]
decs]
Maybe THAutoKeyDef
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
mkAutoKeyPrimitivePersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Just THAutoKeyDef
autoKey -> do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
Type
keyType <- [t|Key $(pure entity) BackendSpecific|]
let conName :: Name
conName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
autoKey
Dec
toPrim' <- do
Name
x <- String -> Q Name
newName String
"x"
let body :: ExpQ
body = [|$(varE x)|]
Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
fromPrim' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
conName) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ 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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
keyType) [Dec]
decs,
[Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
keyType,
[Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
keyType
]
Maybe THAutoKeyDef
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkDefaultPurePersistFieldInstance :: Cxt -> Type -> Q Dec
mkDefaultPurePersistFieldInstance :: [Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
typ = do
Dec
toPurePersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPurePersistValues|]) []]
Dec
fromPurePersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPurePersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPurePersistValues|]) []]
let decs :: [Dec]
decs = [Dec
toPurePersistValues', Dec
fromPurePersistValues']
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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PurePersistField) Type
typ) [Dec]
decs
mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance :: [Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
typ = do
Dec
toSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'toSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToSinglePersistValue|]) []]
Dec
fromSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'fromSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromSinglePersistValue|]) []]
let decs :: [Dec]
decs = [Dec
toSinglePersistValue', Dec
fromSinglePersistValue']
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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''SinglePersistField) Type
typ) [Dec]
decs
mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysIsUniqueInstances THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
let constr :: THConstructorDef
constr = [THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head ([THConstructorDef] -> THConstructorDef)
-> [THConstructorDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
[THUniqueKeyDef] -> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Dec) -> Q [Dec])
-> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
Dec
extractUnique' <- do
[(String, Name)]
uniqueFields <- (THFieldDef -> Q (String, Name))
-> [THFieldDef] -> Q [(String, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\THFieldDef
f -> String -> Q Name
newName String
"x" Q Name -> (Name -> Q (String, Name)) -> Q (String, Name)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (String, Name) -> Q (String, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (THFieldDef -> String
thFieldName THFieldDef
f, Name
x)) ([THFieldDef] -> Q [(String, Name)])
-> [THFieldDef] -> Q [(String, Name)]
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique
let mkFieldPat :: THFieldDef -> PatQ
mkFieldPat THFieldDef
f = PatQ -> (Name -> PatQ) -> Maybe Name -> PatQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatQ
wildP Name -> PatQ
varP (Maybe Name -> PatQ) -> Maybe Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (THFieldDef -> String
thFieldName THFieldDef
f) [(String, Name)]
uniqueFields
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
constr) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (THFieldDef -> PatQ) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> PatQ
mkFieldPat ([THFieldDef] -> [PatQ]) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
constr
let body :: ExpQ
body = (ExpQ -> (String, Name) -> ExpQ)
-> ExpQ -> [(String, Name)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
expr (String, Name)
f -> [|$expr $(varE $ snd f)|]) (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique) [(String, Name)]
uniqueFields
Name -> [ClauseQ] -> Q Dec
funD 'extractUnique [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
uniqueNum' <- do
let index :: Maybe Int
index = (THUniqueDef -> Bool) -> [THUniqueDef] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\THUniqueDef
u -> THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
unique String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== THUniqueDef -> String
thUniqueName THUniqueDef
u) ([THUniqueDef] -> Maybe Int) -> [THUniqueDef] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
constr
let uNum :: Int
uNum = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ THUniqueKeyDef -> String
thUniqueKeyName THUniqueKeyDef
unique) Maybe Int
index
Name -> [ClauseQ] -> Q Dec
funD 'uniqueNum [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|uNum|]) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''IsUniqueKey) Type
uniqKeyType) [Dec
extractUnique', Dec
uniqueNum']
mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysEmbeddedInstances THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
([[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
$
[THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyMakeEmbedded ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
uniqKeyType (THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique) [Type]
context
mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPersistFieldInstances THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
[THUniqueKeyDef] -> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Dec) -> Q [Dec])
-> (THUniqueKeyDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
Dec
persistName' <- Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyDbName THUniqueKeyDef
unique) []]
Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|pureToPersistValue|]) []]
Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|pureFromPersistValue|]) []]
Dec
dbType' <- do
Name
a <- String -> Q Name
newName String
"a"
Name
proxy <- String -> Q Name
newName String
"p"
let mkField :: THFieldDef -> ExpQ
mkField THFieldDef
f = do
let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
nvar :: ExpQ
nvar = [|undefined :: $(pure $ thFieldType f)|]
typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
[|(fname, $typ)|]
let embedded :: ExpQ
embedded = [|EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique)|]
e :: ExpQ
e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]
body :: ExpQ
body = [|DbEmbedded $embedded (Just (Left ($e, Just $(lift $ thUniqueKeyName unique)), Nothing, Nothing))|]
Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
a] (ExpQ -> BodyQ
normalB ExpQ
body) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
uniqKeyType) [Dec]
decs
mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
mkUniqueKeysPrimitiveOrPurePersistFieldInstances THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
([[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
$
[THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
Type
uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let conName :: Name
conName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique
Bool
isUniquePrim <- case THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique of
[THFieldDef
uniq] -> Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
uniq
[THFieldDef]
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if Bool
isUniquePrim
then do
Name
x <- String -> Q Name
newName String
"x"
Dec
toPrim' <- do
Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]] (ExpQ -> BodyQ
normalB [|toPrimitivePersistValue $(varE x)|]) []]
Dec
fromPrim' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB [|$(conE conName) (fromPrimitivePersistValue $(varE x))|]) []]
let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ 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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
uniqKeyType) [Dec]
decs,
[Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
context Type
uniqKeyType,
[Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
context Type
uniqKeyType
]
else Type -> Name -> [THFieldDef] -> [Type] -> Q [Dec]
mkPurePersistFieldInstance Type
uniqKeyType Name
conName (THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique) [Type]
context
mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
mkKeyEqShowInstances THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
let keysInfo :: [(String, Int, TypeQ)]
keysInfo =
[(String, Int, TypeQ)]
-> (THAutoKeyDef -> [(String, Int, TypeQ)])
-> Maybe THAutoKeyDef
-> [(String, Int, TypeQ)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\THAutoKeyDef
k -> [(THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
k, Int
1, [t|BackendSpecific|])]) (THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def)
[(String, Int, TypeQ)]
-> [(String, Int, TypeQ)] -> [(String, Int, TypeQ)]
forall a. [a] -> [a] -> [a]
++ (THUniqueKeyDef -> (String, Int, TypeQ))
-> [THUniqueKeyDef] -> [(String, Int, TypeQ)]
forall a b. (a -> b) -> [a] -> [b]
map (\THUniqueKeyDef
k -> (THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
k, [THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([THFieldDef] -> Int) -> [THFieldDef] -> Int
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
k, [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName k)|])) (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def)
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
Type
typ <- [t|Key $(pure entity) $(newName "a" >>= varT)|]
Dec
showsPrec' <-
let mkClause :: (String, Int, c) -> ClauseQ
mkClause (String
cName, Int
fieldsNum, c
_) = do
Name
p <- String -> Q Name
newName String
"p"
[Name]
fields <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
fieldsNum (String -> Q Name
newName String
"x")
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
cName) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fields
showC :: ExpQ
showC = [|showString $(lift $ cName ++ " ")|]
showArgs :: ExpQ
showArgs = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
a ExpQ
b -> [|$a . showString " " . $b|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
a -> [|showsPrec 11 $(varE a)|]) [Name]
fields
body :: ExpQ
body = [|showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs)|]
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
p, PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []
in Name -> [ClauseQ] -> Q Dec
funD 'showsPrec ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((String, Int, TypeQ) -> ClauseQ)
-> [(String, Int, TypeQ)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int, TypeQ) -> ClauseQ
forall c. (String, Int, c) -> ClauseQ
mkClause [(String, Int, TypeQ)]
keysInfo
Dec
eq' <-
let mkClause :: (String, Int, c) -> ClauseQ
mkClause (String
cName, Int
fieldsNum, c
_) = do
let fields :: Q [Name]
fields = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
fieldsNum (String -> Q Name
newName String
"x")
([Name]
fields1, [Name]
fields2) <- ([Name] -> [Name] -> ([Name], [Name]))
-> Q [Name] -> Q [Name] -> Q ([Name], [Name])
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Q [Name]
fields Q [Name]
fields
let mkPat :: [Name] -> PatQ
mkPat = Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
cName) ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP
body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
e1 ExpQ
e2 -> [|$e1 && $e2|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> ExpQ) -> [Name] -> [Name] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n1 Name
n2 -> [|$(varE n1) == $(varE n2)|]) [Name]
fields1 [Name]
fields2
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [[Name] -> PatQ
mkPat [Name]
fields1, [Name] -> PatQ
mkPat [Name]
fields2] (ExpQ -> BodyQ
normalB ExpQ
body) []
clauses :: [ClauseQ]
clauses = ((String, Int, TypeQ) -> ClauseQ)
-> [(String, Int, TypeQ)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int, TypeQ) -> ClauseQ
forall c. (String, Int, c) -> ClauseQ
mkClause [(String, Int, TypeQ)]
keysInfo
noMatch :: [ClauseQ]
noMatch = if [ClauseQ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClauseQ]
clauses Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP] (ExpQ -> BodyQ
normalB [|False|]) []] else []
in Name -> [ClauseQ] -> Q Dec
funD '(==) ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ [ClauseQ]
clauses [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. [a] -> [a] -> [a]
++ [ClauseQ]
noMatch
[Dec]
read' <-
let mkRead :: (String, Int, TypeQ) -> Q Dec
mkRead (String
cName, Int
fieldsNum, TypeQ
u) = do
let key :: ExpQ
key =
(ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a ExpQ
b -> [|$a <*> $b|]) [|$(conE $ mkName cName) <$> R.step R.readPrec|] ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate (Int
fieldsNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [|R.step R.readPrec|]
body :: ExpQ
body = [|R.parens $ R.prec 10 $ R.expectP (R.Ident $(litE $ StringL cName)) >> $key|]
Type
keyType <- [t|Key $(pure entity) $u|]
Dec
readPrec' <- Name -> [ClauseQ] -> Q Dec
funD 'R.readPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
readListPrec' <- Name -> [ClauseQ] -> Q Dec
funD 'R.readListPrec [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|R.readListPrecDefault|]) []]
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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Read) Type
keyType) [Dec
readPrec', Dec
readListPrec']
in ((String, Int, TypeQ) -> Q Dec)
-> [(String, Int, TypeQ)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, Int, TypeQ) -> Q Dec
mkRead [(String, Int, TypeQ)]
keysInfo
[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
$
if [(String, Int, TypeQ)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Int, TypeQ)]
keysInfo
then []
else [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Eq) Type
typ) [Dec
eq'], [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) Type
typ) [Dec
showsPrec']] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
read'
mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
mkEmbeddedInstance THEmbeddedDef
def = do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def
embedded :: Type
embedded = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEmbeddedDef -> Name
thEmbeddedName THEmbeddedDef
def)) [Type]
types
context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEmbeddedDef -> [TyVarBndr]
thEmbeddedTypeParams THEmbeddedDef
def) (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def)
Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
embedded (THEmbeddedDef -> [THFieldDef]
thEmbeddedFields THEmbeddedDef
def) [Type]
context
mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec]
mkEmbeddedInstance' :: Type -> [THFieldDef] -> [Type] -> Q [Dec]
mkEmbeddedInstance' Type
dataType [THFieldDef]
fDefs [Type]
context = do
Dec
selector' <- do
Name
fParam <- String -> Q Name
newName String
"f"
let mkField :: THFieldDef -> Con
mkField THFieldDef
field = [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
fParam) (THFieldDef -> Type
thFieldType THFieldDef
field)] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []
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
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Selector [Type
dataType, Name -> Type
VarT Name
fParam] ((THFieldDef -> Con) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> Con
mkField [THFieldDef]
fDefs) []
Dec
selectorNum' <- do
let mkClause :: t -> THFieldDef -> ClauseQ
mkClause t
fNum THFieldDef
field = [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ t -> ExpQ
forall t. Lift t => t -> ExpQ
lift t
fNum) []
clauses :: [ClauseQ]
clauses = (Int -> THFieldDef -> ClauseQ)
-> [Int] -> [THFieldDef] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> THFieldDef -> ClauseQ
forall t. Lift t => t -> THFieldDef -> ClauseQ
mkClause [Int
0 :: Int ..] [THFieldDef]
fDefs
Name -> [ClauseQ] -> Q Dec
funD 'selectorNum [ClauseQ]
clauses
let decs :: [Dec]
decs = [Dec
selector', Dec
selectorNum']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''Embedded) Type
dataType) [Dec]
decs]
mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructors THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
[THConstructorDef] -> (THConstructorDef -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) ((THConstructorDef -> Q Dec) -> Q [Dec])
-> (THConstructorDef -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \THConstructorDef
c -> do
Name
v <- String -> Q Name
newName String
"v"
let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
c
Type
phantom <- [t|ConstructorMarker $(pure entity)|]
let constr :: Con
constr = [Name] -> [BangType] -> Type -> Con
GadtC [Name
name] [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Type
phantom)
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
$ [Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [] Name
name [Name -> TyVarBndr
plainTV Name
v] [Con
constr] []
mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances THEntityDef
def = (Int -> THConstructorDef -> Q Dec)
-> [Int] -> [THConstructorDef] -> Q [Dec]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> THConstructorDef -> Q Dec
f [Int
0 ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)
where
f :: Int -> THConstructorDef -> Q Dec
f :: Int -> THConstructorDef -> Q Dec
f Int
cNum THConstructorDef
c = CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt []) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Constructor) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
c)) [Q Dec
phantomConstrNum']
where
phantomConstrNum' :: Q Dec
phantomConstrNum' = Name -> [ClauseQ] -> Q Dec
funD 'phantomConstrNum [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|cNum|]) []]
mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
mkEntityUniqueKeysPhantoms THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
([[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
$
[THUniqueKeyDef] -> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]])
-> (THUniqueKeyDef -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
u -> do
Maybe Name
exists <- String -> Q (Maybe Name)
lookupTypeName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u
if Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Name
exists
then do
Name
v <- String -> Q Name
newName String
"v"
let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u
Type
phantom <- [t|UniqueMarker $(pure entity)|]
let constr :: Con
constr = [Name] -> [BangType] -> Type -> Con
GadtC [Name
name] [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Type
phantom)
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [] Name
name [Name -> TyVarBndr
plainTV Name
v] [Con
constr] []]
else [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkPersistEntityInstance :: THEntityDef -> Q [Dec]
mkPersistEntityInstance :: THEntityDef -> Q [Dec]
mkPersistEntityInstance THEntityDef
def = do
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
Dec
key' <- do
Name
uParam <- String -> Q Name
newName String
"u"
[Con]
autoKey <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Maybe THAutoKeyDef
Nothing -> [Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just THAutoKeyDef
k -> do
Type
keyDescr <- [t|BackendSpecific|]
[Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
uParam) Type
keyDescr] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> String
thAutoKeyConstrName THAutoKeyDef
k) [(Bang
notStrict', Name -> Type
ConT ''PersistValue)]]
[Con]
uniques <- [THUniqueKeyDef] -> (THUniqueKeyDef -> Q Con) -> Q [Con]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def) ((THUniqueKeyDef -> Q Con) -> Q [Con])
-> (THUniqueKeyDef -> Q Con) -> Q [Con]
forall a b. (a -> b) -> a -> b
$ \THUniqueKeyDef
unique -> do
Type
uniqType <- [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)|]
let cDef :: THConstructorDef
cDef = [THConstructorDef] -> THConstructorDef
forall a. [a] -> a
head ([THConstructorDef] -> THConstructorDef)
-> [THConstructorDef] -> THConstructorDef
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
uniqFieldNames :: [String]
uniqFieldNames = [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts ([Either String String] -> [String])
-> [Either String String] -> [String]
forall a b. (a -> b) -> a -> b
$ THUniqueDef -> [Either String String]
thUniqueFields (THUniqueDef -> [Either String String])
-> THUniqueDef -> [Either String String]
forall a b. (a -> b) -> a -> b
$ 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
unique) ([THUniqueDef] -> THUniqueDef) -> [THUniqueDef] -> THUniqueDef
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cDef
uniqFields :: [THFieldDef]
uniqFields = [[THFieldDef]] -> [THFieldDef]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[THFieldDef]] -> [THFieldDef]) -> [[THFieldDef]] -> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ ((String -> [THFieldDef]) -> [String] -> [[THFieldDef]])
-> [String] -> (String -> [THFieldDef]) -> [[THFieldDef]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> [THFieldDef]) -> [String] -> [[THFieldDef]]
forall a b. (a -> b) -> [a] -> [b]
map [String]
uniqFieldNames ((String -> [THFieldDef]) -> [[THFieldDef]])
-> (String -> [THFieldDef]) -> [[THFieldDef]]
forall a b. (a -> b) -> a -> b
$ \String
name -> (THFieldDef -> Bool) -> [THFieldDef] -> [THFieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) (String -> Bool) -> (THFieldDef -> String) -> THFieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> String
thFieldName) ([THFieldDef] -> [THFieldDef]) -> [THFieldDef] -> [THFieldDef]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cDef
uniqFields' :: [BangType]
uniqFields' = (THFieldDef -> BangType) -> [THFieldDef] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map (\THFieldDef
f -> (Bang
notStrict', THFieldDef -> Type
thFieldType THFieldDef
f)) [THFieldDef]
uniqFields
Con -> Q Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Q Con) -> Con -> Q Con
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
uParam) Type
uniqType] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyConstrName THUniqueKeyDef
unique) [BangType]
uniqFields'
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
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Key [Type
entity, Name -> Type
VarT Name
uParam] ([Con]
autoKey [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
++ [Con]
uniques) []
Dec
autoKey' <- do
Type
autoType <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Maybe THAutoKeyDef
Nothing -> [t|()|]
Just THAutoKeyDef
_ -> [t|Key $(pure entity) BackendSpecific|]
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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''AutoKey [Type
entity] Type
autoType
Dec
defaultKey' <- do
Type
typ <- case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Just THAutoKeyDef
k | THAutoKeyDef -> Bool
thAutoKeyIsDef THAutoKeyDef
k -> [t|Key $(pure entity) BackendSpecific|]
Maybe THAutoKeyDef
_ -> case (THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyIsDef ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def of
[THUniqueKeyDef
unique] -> [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]
[THUniqueKeyDef]
_ -> [t|()|]
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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''DefaultKey [Type
entity] Type
typ
Dec
isSumType' <- do
let isSumType :: Type
isSumType =
Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$
if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then ''HFalse
else ''HTrue
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
$ Name -> [Type] -> Type -> Dec
mkTySynInstD ''IsSumType [Type
entity] Type
isSumType
Dec
fields' <- do
Name
cParam <- String -> Q Name
newName String
"c"
Name
fParam <- String -> Q Name
newName String
"f"
let mkField :: Name -> THFieldDef -> Con
mkField Name
name THFieldDef
field = [TyVarBndr] -> [Type] -> Con -> Con
ForallC [] [Type -> Type -> Type
equalP' (Name -> Type
VarT Name
cParam) (Name -> Type
ConT Name
name), Type -> Type -> Type
equalP' (Name -> Type
VarT Name
fParam) (THFieldDef -> Type
thFieldType THFieldDef
field)] (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
NormalC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
field) []
let f :: THConstructorDef -> [Con]
f THConstructorDef
cdef = (THFieldDef -> Con) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> THFieldDef -> Con
mkField (Name -> THFieldDef -> Con) -> Name -> THFieldDef -> Con
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> String
thPhantomConstrName THConstructorDef
cdef) ([THFieldDef] -> [Con]) -> [THFieldDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
let constrs :: [Con]
constrs = (THConstructorDef -> [Con]) -> [THConstructorDef] -> [Con]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap THConstructorDef -> [Con]
f ([THConstructorDef] -> [Con]) -> [THConstructorDef] -> [Con]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
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
$ [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [] ''Field [Type
entity, Name -> Type
VarT Name
cParam, Name -> Type
VarT Name
fParam] [Con]
constrs []
Dec
entityDef' <- do
Name
v <- String -> Q Name
newName String
"v"
Name
proxy <- String -> Q Name
newName String
"p"
let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure entity) -> $(pure t)|]
types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
typeParams' :: ExpQ
typeParams' = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|dbType $(varE proxy) ($(mkLambda t) $(varE v))|]) [Type]
types
mkField :: THConstructorDef -> Int -> THFieldDef -> ExpQ
mkField THConstructorDef
c Int
fNum THFieldDef
f = do
Name
a <- String -> Q Name
newName String
"a"
let fname :: String
fname = THFieldDef -> String
thDbFieldName THFieldDef
f
nvar :: ExpQ
nvar =
if Type -> Bool
hasFreeVars (THFieldDef -> Type
thFieldType THFieldDef
f)
then
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
c) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
fNum PatQ
wildP [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ [Name -> PatQ
varP Name
a] [PatQ] -> [PatQ] -> [PatQ]
forall a. [a] -> [a] -> [a]
++ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate ([THFieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PatQ
wildP
wildClause :: [MatchQ]
wildClause = if [THConstructorDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB [|undefined|]) []] else []
in ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
v) (PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
a) [] MatchQ -> [MatchQ] -> [MatchQ]
forall a. a -> [a] -> [a]
: [MatchQ]
wildClause)
else [|undefined :: $(pure $ thFieldType f)|]
typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
[|(fname, $typ)|]
constrs :: ExpQ
constrs = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (THConstructorDef -> ExpQ) -> [THConstructorDef] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map THConstructorDef -> ExpQ
mkConstructorDef ([THConstructorDef] -> [ExpQ]) -> [THConstructorDef] -> [ExpQ]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def
mkConstructorDef :: THConstructorDef -> ExpQ
mkConstructorDef c :: THConstructorDef
c@(THConstructorDef Name
_ String
_ String
name Maybe String
keyName [THFieldDef]
params [THUniqueDef]
conss) = [|ConstructorDef name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss)|]
where
fields :: [(String, ExpQ)]
fields = (Int -> THFieldDef -> (String, ExpQ))
-> [Int] -> [THFieldDef] -> [(String, ExpQ)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i THFieldDef
f -> (THFieldDef -> String
thFieldName THFieldDef
f, THConstructorDef -> Int -> THFieldDef -> ExpQ
mkField THConstructorDef
c Int
i THFieldDef
f)) [Int
0 ..] [THFieldDef]
params
mkConstraint :: THUniqueDef -> ExpQ
mkConstraint (THUniqueDef String
uName UniqueType
uType [Either String String]
uFields) = [|UniqueDef (Just uName) uType $(listE $ map getField uFields)|]
getField :: Either String t -> ExpQ
getField (Left String
fName) = [|Left $(snd $ findOne "field" fst fName fields)|]
getField (Right t
expr) = [|Right expr|]
paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
fullEntityName :: ExpQ
fullEntityName =
if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types
then [|$(stringE $ thDbEntityName def)|]
else [|$(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames)|]
body :: BodyQ
body = ExpQ -> BodyQ
normalB [|EntityDef $fullEntityName $(lift $ thEntitySchema def) $typeParams' $constrs|]
entityPat :: PatQ
entityPat = if [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool) -> [TyVarBndr] -> Bool
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def then PatQ
wildP else Name -> PatQ
varP Name
v
Name -> [ClauseQ] -> Q Dec
funD 'entityDef [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, PatQ
entityPat] BodyQ
body []]
Dec
toEntityPersistValues' <- ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> [Clause] -> Dec
FunD 'toEntityPersistValues) (Q [Clause] -> Q Dec) -> Q [Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$
[(Int, THConstructorDef)]
-> ((Int, THConstructorDef) -> ClauseQ) -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [THConstructorDef] -> [(Int, THConstructorDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([THConstructorDef] -> [(Int, THConstructorDef)])
-> [THConstructorDef] -> [(Int, THConstructorDef)]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def) (((Int, THConstructorDef) -> ClauseQ) -> Q [Clause])
-> ((Int, THConstructorDef) -> ClauseQ) -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ \(Int
cNum, THConstructorDef
c) -> do
(PatQ
pat, ExpQ
body) <- Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
mkToPersistValues (THConstructorDef -> Name
thConstrName THConstructorDef
c) (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c) (\ExpQ
result -> [|(toPrimitivePersistValue ($(lift cNum) :: Int) :) . $result|])
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] (ExpQ -> BodyQ
normalB ExpQ
body) []
Dec
fromEntityPersistValues' <- do
Name
xs <- String -> Q Name
newName String
"xs"
let failureBody :: BodyQ
failureBody = ExpQ -> BodyQ
normalB [|fail (failMessageNamed $(stringE $ show $ thDataName def) $(varE xs))|]
Name
failureName <- String -> Q Name
newName String
"failure"
let failure :: MatchQ
failure = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
failureName) []
[MatchQ]
matches <- [(Integer, THConstructorDef)]
-> ((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Integer] -> [THConstructorDef] -> [(Integer, THConstructorDef)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)) (((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ])
-> ((Integer, THConstructorDef) -> Q MatchQ) -> Q [MatchQ]
forall a b. (a -> b) -> a -> b
$ \(Integer
cNum, THConstructorDef
c) -> do
let cNum' :: PatQ
cNum' = Name -> [PatQ] -> PatQ
conP 'PersistInt64 [Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
cNum]
Name
xs' <- String -> Q Name
newName String
"xs"
(Bool
_, Exp
body) <- Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
mkFromPersistValues Name
failureName Name
xs' (THConstructorDef -> Name
thConstrName THConstructorDef
c) (THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
c)
MatchQ -> Q MatchQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MatchQ -> Q MatchQ) -> MatchQ -> Q MatchQ
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> Name -> PatQ -> PatQ
infixP PatQ
cNum' '(:) (Name -> PatQ
varP Name
xs')) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body) []
let start :: ExpQ
start = ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
xs) ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [MatchQ]
matches [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
failure]
let failureFunc :: Q Dec
failureFunc = Name -> [ClauseQ] -> Q Dec
funD Name
failureName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
failureBody []]
Name -> [ClauseQ] -> Q Dec
funD 'fromEntityPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
xs] (ExpQ -> BodyQ
normalB ExpQ
start) [Q Dec
failureFunc]]
Dec
getUniques' <-
let hasConstraints :: THConstructorDef -> Bool
hasConstraints = Bool -> Bool
not (Bool -> Bool)
-> (THConstructorDef -> Bool) -> THConstructorDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [THUniqueDef] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([THUniqueDef] -> Bool)
-> (THConstructorDef -> [THUniqueDef]) -> THConstructorDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THConstructorDef -> [THUniqueDef]
thConstrUniques
clauses :: [ClauseQ]
clauses = (Int -> THConstructorDef -> ClauseQ)
-> [Int] -> [THConstructorDef] -> [ClauseQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> THConstructorDef -> ClauseQ
forall t. Lift t => t -> THConstructorDef -> ClauseQ
mkClause [Int
0 :: Int ..] (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def)
mkClause :: t -> THConstructorDef -> ClauseQ
mkClause t
cNum THConstructorDef
cdef | Bool -> Bool
not (THConstructorDef -> Bool
hasConstraints THConstructorDef
cdef) = [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
cdef) [PatQ]
pats] (ExpQ -> BodyQ
normalB [|(cNum, [])|]) []
where
pats :: [PatQ]
pats = (THFieldDef -> PatQ) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ -> THFieldDef -> PatQ
forall a b. a -> b -> a
const PatQ
wildP) ([THFieldDef] -> [PatQ]) -> [THFieldDef] -> [PatQ]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
mkClause t
cNum THConstructorDef
cdef = do
let allConstrainedFields :: [String]
allConstrainedFields = [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts ([Either String String] -> [String])
-> [Either String String] -> [String]
forall a b. (a -> b) -> a -> b
$ (THUniqueDef -> [Either String String])
-> [THUniqueDef] -> [Either String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap THUniqueDef -> [Either String String]
thUniqueFields ([THUniqueDef] -> [Either String String])
-> [THUniqueDef] -> [Either String String]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THUniqueDef]
thConstrUniques THConstructorDef
cdef
[Maybe (Name, THFieldDef)]
vars <- (THFieldDef -> Q (Maybe (Name, THFieldDef)))
-> [THFieldDef] -> Q [Maybe (Name, THFieldDef)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\THFieldDef
f -> String -> Q Name
newName String
"x" Q Name
-> (Name -> Q (Maybe (Name, THFieldDef)))
-> Q (Maybe (Name, THFieldDef))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef)))
-> Maybe (Name, THFieldDef) -> Q (Maybe (Name, THFieldDef))
forall a b. (a -> b) -> a -> b
$ if THFieldDef -> String
thFieldName THFieldDef
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
allConstrainedFields then (Name, THFieldDef) -> Maybe (Name, THFieldDef)
forall a. a -> Maybe a
Just (Name
x, THFieldDef
f) else Maybe (Name, THFieldDef)
forall a. Maybe a
Nothing) ([THFieldDef] -> Q [Maybe (Name, THFieldDef)])
-> [THFieldDef] -> Q [Maybe (Name, THFieldDef)]
forall a b. (a -> b) -> a -> b
$ THConstructorDef -> [THFieldDef]
thConstrFields THConstructorDef
cdef
let pat :: PatQ
pat = Name -> [PatQ] -> PatQ
conP (THConstructorDef -> Name
thConstrName THConstructorDef
cdef) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Maybe (Name, THFieldDef) -> PatQ)
-> [Maybe (Name, THFieldDef)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ
-> ((Name, THFieldDef) -> PatQ) -> Maybe (Name, THFieldDef) -> PatQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatQ
wildP (Name -> PatQ
varP (Name -> PatQ)
-> ((Name, THFieldDef) -> Name) -> (Name, THFieldDef) -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> Name
forall a b. (a, b) -> a
fst)) [Maybe (Name, THFieldDef)]
vars
body :: BodyQ
body = ExpQ -> BodyQ
normalB [|(cNum, $(listE $ mapMaybe mkUnique $ thConstrUniques cdef))|]
mkUnique :: THUniqueDef -> Maybe ExpQ
mkUnique (THUniqueDef String
uName UniqueType
_ [Either String String]
fnames) =
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [Either String String] -> [String]
forall a b. [Either a b] -> [b]
rights [Either String String]
fnames
then
let
uFields :: [(Name, THFieldDef)]
uFields = (String -> (Name, THFieldDef)) -> [String] -> [(Name, THFieldDef)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
f -> String
-> ((Name, THFieldDef) -> String)
-> String
-> [(Name, THFieldDef)]
-> (Name, THFieldDef)
forall x a. (Eq x, Show x) => String -> (a -> x) -> x -> [a] -> a
findOne String
"field" (THFieldDef -> String
thFieldName (THFieldDef -> String)
-> ((Name, THFieldDef) -> THFieldDef)
-> (Name, THFieldDef)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, THFieldDef) -> THFieldDef
forall a b. (a, b) -> b
snd) String
f ([(Name, THFieldDef)] -> (Name, THFieldDef))
-> [(Name, THFieldDef)] -> (Name, THFieldDef)
forall a b. (a -> b) -> a -> b
$ [Maybe (Name, THFieldDef)] -> [(Name, THFieldDef)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, THFieldDef)]
vars) ([String] -> [(Name, THFieldDef)])
-> [String] -> [(Name, THFieldDef)]
forall a b. (a -> b) -> a -> b
$ [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String String]
fnames
result :: ExpQ
result = [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues [(Name, THFieldDef)]
uFields
in ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just [|(uName, $result)|]
else Maybe ExpQ
forall a. Maybe a
Nothing
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []
in Name -> [ClauseQ] -> Q Dec
funD 'getUniques [ClauseQ]
clauses
Dec
entityFieldChain' <-
let thFieldNames :: [THFieldDef]
thFieldNames = THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields
clauses :: [ClauseQ]
clauses = (THFieldDef -> ClauseQ) -> [THFieldDef] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map THFieldDef -> ClauseQ
mkClause [THFieldDef]
thFieldNames
mkClause :: THFieldDef -> ClauseQ
mkClause THFieldDef
f = do
Name
fArg <- String -> Q Name
newName String
"f"
Name
proxy <- String -> Q Name
newName String
"p"
let nvar :: ExpQ
nvar = [|(undefined :: Field v c a -> a) $(varE fArg)|]
typ :: ExpQ
typ = THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef
f Name
proxy ExpQ
nvar
body :: ExpQ
body = [|(($(lift $ thDbFieldName f), $typ), [])|]
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ -> PatQ
asP Name
fArg (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THFieldDef -> String
thExprName THFieldDef
f) []] (ExpQ -> BodyQ
normalB ExpQ
body) []
clauses' :: [ClauseQ]
clauses' = if [ClauseQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClauseQ]
clauses then [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB [|undefined|]) []] else [ClauseQ]
clauses
in Name -> [ClauseQ] -> Q Dec
funD 'entityFieldChain [ClauseQ]
clauses'
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let decs :: [Dec]
decs = [Dec
key', Dec
autoKey', Dec
defaultKey', Dec
isSumType', Dec
fields', Dec
entityDef', Dec
toEntityPersistValues', Dec
fromEntityPersistValues', Dec
getUniques', Dec
entityFieldChain']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistEntity) Type
entity) [Dec]
decs]
mkToPurePersistValues :: [(Name, THFieldDef)] -> Q Exp
mkToPurePersistValues :: [(Name, THFieldDef)] -> ExpQ
mkToPurePersistValues [(Name, THFieldDef)]
vars = do
let processField :: (Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ)
processField (Name
fName, THFieldDef
fDef) = do
Bool
isP <- Type -> Q Bool
isPrim (THFieldDef -> Type
thFieldType THFieldDef
fDef)
let field :: ExpQ
field = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) (THFieldDef -> Maybe Name
thFieldConverter THFieldDef
fDef) (Name -> ExpQ
varE Name
fName)
if Bool
isP
then (Maybe (Q Dec), ExpQ) -> Q (Maybe (Q Dec), ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Q Dec)
forall a. Maybe a
Nothing, [|(toPrimitivePersistValue $field :)|])
else String -> Q Name
newName String
"x" Q Name
-> (Name -> Q (Maybe (Q Dec), ExpQ)) -> Q (Maybe (Q Dec), ExpQ)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> (Maybe (Q Dec), ExpQ) -> Q (Maybe (Q Dec), ExpQ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Dec -> Maybe (Q Dec)
forall a. a -> Maybe a
Just (Q Dec -> Maybe (Q Dec)) -> Q Dec -> Maybe (Q Dec)
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
x) (ExpQ -> BodyQ
normalB [|toPurePersistValues $(varE fName)|]) [], Name -> ExpQ
varE Name
x)
([Q Dec]
lets, [ExpQ]
funcs) <- ([(Maybe (Q Dec), ExpQ)] -> ([Q Dec], [ExpQ]))
-> Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Maybe (Q Dec)] -> [Q Dec])
-> ([Maybe (Q Dec)], [ExpQ]) -> ([Q Dec], [ExpQ])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Maybe (Q Dec)] -> [Q Dec]
forall a. [Maybe a] -> [a]
catMaybes (([Maybe (Q Dec)], [ExpQ]) -> ([Q Dec], [ExpQ]))
-> ([(Maybe (Q Dec), ExpQ)] -> ([Maybe (Q Dec)], [ExpQ]))
-> [(Maybe (Q Dec), ExpQ)]
-> ([Q Dec], [ExpQ])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Maybe (Q Dec), ExpQ)] -> ([Maybe (Q Dec)], [ExpQ])
forall a b. [(a, b)] -> ([a], [b])
unzip) (Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ]))
-> Q [(Maybe (Q Dec), ExpQ)] -> Q ([Q Dec], [ExpQ])
forall a b. (a -> b) -> a -> b
$ ((Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ))
-> [(Name, THFieldDef)] -> Q [(Maybe (Q Dec), ExpQ)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, THFieldDef) -> Q (Maybe (Q Dec), ExpQ)
processField [(Name, THFieldDef)]
vars
let result :: ExpQ
result = if [ExpQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExpQ]
funcs then [|id|] else (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
a ExpQ
b -> [|$a . $b|]) [ExpQ]
funcs
if [Q Dec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Q Dec]
lets then ExpQ
result else [Q Dec] -> ExpQ -> ExpQ
letE [Q Dec]
lets ExpQ
result
mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntityPersistFieldInstance THEntityDef
def = case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
Just Either THAutoKeyDef THUniqueKeyDef
defaultKey -> do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
let entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types
Dec
persistName' <- do
Name
v <- String -> Q Name
newName String
"v"
let mkLambda :: Type -> ExpQ
mkLambda Type
t = [|undefined :: $(pure entity) -> $(pure t)|]
let paramNames :: ExpQ
paramNames = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
xs -> [|$p ++ [delim] ++ $xs|]) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Type -> ExpQ) -> [Type] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> [|persistName ($(mkLambda t) $(varE v))|]) [Type]
types
let fullEntityName :: ExpQ
fullEntityName = case [Type]
types of
[] -> [|$(stringE $ thDbEntityName def)|]
[Type]
_ -> [|$(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames)|]
let body :: BodyQ
body = ExpQ -> BodyQ
normalB ExpQ
fullEntityName
let pat :: PatQ
pat = if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
types then PatQ
wildP else Name -> PatQ
varP Name
v
Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
pat] BodyQ
body []]
Bool
isOne <- THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def
let mUniqName :: Maybe Name
mUniqName = (THAutoKeyDef -> Maybe Name)
-> (THUniqueKeyDef -> Maybe Name)
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either THAutoKeyDef -> Maybe Name
forall p a. p -> Maybe a
auto THUniqueKeyDef -> Maybe Name
uniq Either THAutoKeyDef THUniqueKeyDef
defaultKey
where
auto :: p -> Maybe a
auto p
_ = Maybe a
forall a. Maybe a
Nothing
uniq :: THUniqueKeyDef -> Maybe Name
uniq THUniqueKeyDef
u = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
u
Dec
toPersistValues' <- do
let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ case Maybe Name
mUniqName of
Maybe Name
_ | Bool
isOne -> [|singleToPersistValue|]
Just Name
name -> [|toPersistValuesUnique $(conE name)|]
Maybe Name
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"mkEntityPersistFieldInstance: key has no unique type"
Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
body []]
Dec
fromPersistValues' <- do
let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ case Maybe Name
mUniqName of
Maybe Name
_ | Bool
isOne -> [|singleFromPersistValue|]
Just Name
name -> [|fromPersistValuesUnique $(conE name)|]
Maybe Name
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"mkEntityPersistFieldInstance: key has no unique type"
Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] BodyQ
body []]
Dec
dbType' <- do
Name
proxy <- String -> Q Name
newName String
"p"
let body :: ExpQ
body = [|dbType $(varE proxy) . (undefined :: a -> DefaultKey a)|]
Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy] (ExpQ -> BodyQ
normalB ExpQ
body) []]
let context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
entity) [Dec]
decs]
Maybe (Either THAutoKeyDef THUniqueKeyDef)
Nothing -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
mkEntitySinglePersistFieldInstance THEntityDef
def =
THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def Q Bool -> (Bool -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
isOne -> case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
Just Either THAutoKeyDef THUniqueKeyDef
defaultKey | Bool
isOne -> do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types
context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
(ExpQ
to, ExpQ
from) = case Either THAutoKeyDef THUniqueKeyDef
defaultKey of
Left THAutoKeyDef
_ -> ([|toSinglePersistValueAutoKey|], [|fromSinglePersistValueAutoKey|])
Right THUniqueKeyDef
k -> ([|toSinglePersistValueUnique $u|], [|fromSinglePersistValueUnique $u|])
where
u :: ExpQ
u = Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> String
thUniqueKeyPhantomName THUniqueKeyDef
k
Dec
toSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'toSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
to) []]
Dec
fromSinglePersistValue' <- Name -> [ClauseQ] -> Q Dec
funD 'fromSinglePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
from) []]
let decs :: [Dec]
decs = [Dec
toSinglePersistValue', Dec
fromSinglePersistValue']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''SinglePersistField) Type
entity) [Dec]
decs]
Maybe (Either THAutoKeyDef THUniqueKeyDef)
_ -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
mkEntityNeverNullInstance THEntityDef
def = do
let types :: [Type]
types = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType ([TyVarBndr] -> [Type]) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def
entity :: Type
entity = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (THEntityDef -> Name
thDataName THEntityDef
def)) [Type]
types
context :: [Type]
context = [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext (THEntityDef -> [TyVarBndr]
thTypeParams THEntityDef
def) (THEntityDef -> [THConstructorDef]
thConstructors THEntityDef
def [THConstructorDef]
-> (THConstructorDef -> [THFieldDef]) -> [THFieldDef]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THConstructorDef -> [THFieldDef]
thConstrFields)
Bool
isOne <- THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def
[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
$
if Bool
isOne
then [[Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''NeverNull) Type
entity) []]
else []
mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePersistFieldInstance THPrimitiveDef
def = do
let primitive :: Type
primitive = Name -> Type
ConT (THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def)
Dec
persistName' <- do
let body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def
Name -> [ClauseQ] -> Q Dec
funD 'persistName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP] BodyQ
body []]
Dec
fromPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'fromPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primFromPersistValue|]) []]
Dec
toPersistValues' <- Name -> [ClauseQ] -> Q Dec
funD 'toPersistValues [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|primToPersistValue|]) []]
Dec
dbType' <- do
Name
proxy <- String -> Q Name
newName String
"p"
Name
x <- String -> Q Name
newName String
"x"
let body :: ExpQ
body = [|dbType $(varE proxy) $ fst $(varE $ thPrimitiveConverter def) $(varE x)|]
Name -> [ClauseQ] -> Q Dec
funD 'dbType [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
proxy, Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB ExpQ
body) []]
let decs :: [Dec]
decs = [Dec
persistName', Dec
toPersistValues', Dec
fromPersistValues', Dec
dbType']
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ [Type] -> Type -> [Dec] -> Dec
instanceD' [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''PersistField) Type
primitive) [Dec]
decs,
[Type] -> Type -> [Dec] -> Dec
instanceD' [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''NeverNull) Type
primitive) []
]
mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
mkPrimitivePrimitivePersistFieldInstance THPrimitiveDef
def = do
let primitive :: Type
primitive = Name -> Type
ConT (THPrimitiveDef -> Name
thPrimitiveName THPrimitiveDef
def)
Dec
toPrim' <- do
let body :: ExpQ
body = [|toPrimitivePersistValue . fst $(varE $ thPrimitiveConverter def)|]
Name -> [ClauseQ] -> Q Dec
funD 'toPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
Dec
fromPrim' <- do
let body :: ExpQ
body = [|snd $(varE $ thPrimitiveConverter def) . fromPrimitivePersistValue|]
Name -> [ClauseQ] -> Q Dec
funD 'fromPrimitivePersistValue [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
let context :: [a]
context = []
let decs :: [Dec]
decs = [Dec
toPrim', Dec
fromPrim']
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ 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
$ [Type] -> Type -> [Dec] -> Dec
instanceD' [Type]
forall a. [a]
context (Type -> Type -> Type
AppT (Name -> Type
ConT ''PrimitivePersistField) Type
primitive) [Dec]
decs,
[Type] -> Type -> Q Dec
mkDefaultPurePersistFieldInstance [Type]
forall a. [a]
context Type
primitive,
[Type] -> Type -> Q Dec
mkDefaultSinglePersistFieldInstance [Type]
forall a. [a]
context Type
primitive
]
mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
mkMigrateFunction String
name [THEntityDef]
defs = do
let ([THEntityDef]
normal, [THEntityDef]
polymorhpic) = (THEntityDef -> Bool)
-> [THEntityDef] -> ([THEntityDef], [THEntityDef])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TyVarBndr] -> Bool)
-> (THEntityDef -> [TyVarBndr]) -> THEntityDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THEntityDef -> [TyVarBndr]
thTypeParams) [THEntityDef]
defs
[THEntityDef] -> (THEntityDef -> Q ()) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [THEntityDef]
polymorhpic ((THEntityDef -> Q ()) -> Q ()) -> (THEntityDef -> Q ()) -> Q ()
forall a b. (a -> b) -> a -> b
$ \THEntityDef
def -> String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Datatype " 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
" will not be migrated automatically by function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because it has type parameters"
let body :: ExpQ
body = [StmtQ] -> ExpQ
doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (THEntityDef -> StmtQ) -> [THEntityDef] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\THEntityDef
def -> ExpQ -> StmtQ
noBindS [|migrate (undefined :: $(conT $ thDataName def))|]) [THEntityDef]
normal
Dec
sig <- Name -> TypeQ -> Q Dec
sigD (String -> Name
mkName String
name) [t|forall m. PersistBackend m => Migration m|]
Dec
func <- Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
name) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sig, Dec
func]
isDefaultKeyOneColumn :: THEntityDef -> Q Bool
isDefaultKeyOneColumn :: THEntityDef -> Q Bool
isDefaultKeyOneColumn THEntityDef
def = case THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def of
Just (Left THAutoKeyDef
_) -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just (Right THUniqueKeyDef
unique) -> case THUniqueKeyDef -> [THFieldDef]
thUniqueKeyFields THUniqueKeyDef
unique of
[THFieldDef
field] -> Type -> Q Bool
isPrim (Type -> Q Bool) -> Type -> Q Bool
forall a b. (a -> b) -> a -> b
$ THFieldDef -> Type
thFieldType THFieldDef
field
[THFieldDef]
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Maybe (Either THAutoKeyDef THUniqueKeyDef)
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
getDefaultKey THEntityDef
def = case THEntityDef -> Maybe THAutoKeyDef
thAutoKey THEntityDef
def of
Just THAutoKeyDef
k | THAutoKeyDef -> Bool
thAutoKeyIsDef THAutoKeyDef
k -> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. a -> Maybe a
Just (Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef))
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a b. (a -> b) -> a -> b
$ THAutoKeyDef -> Either THAutoKeyDef THUniqueKeyDef
forall a b. a -> Either a b
Left THAutoKeyDef
k
Maybe THAutoKeyDef
_ -> case (THUniqueKeyDef -> Bool) -> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a. (a -> Bool) -> [a] -> [a]
filter THUniqueKeyDef -> Bool
thUniqueKeyIsDef ([THUniqueKeyDef] -> [THUniqueKeyDef])
-> [THUniqueKeyDef] -> [THUniqueKeyDef]
forall a b. (a -> b) -> a -> b
$ THEntityDef -> [THUniqueKeyDef]
thUniqueKeys THEntityDef
def of
[] -> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. Maybe a
Nothing
(THUniqueKeyDef
u : [THUniqueKeyDef]
_) -> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a. a -> Maybe a
Just (Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef))
-> Either THAutoKeyDef THUniqueKeyDef
-> Maybe (Either THAutoKeyDef THUniqueKeyDef)
forall a b. (a -> b) -> a -> b
$ THUniqueKeyDef -> Either THAutoKeyDef THUniqueKeyDef
forall a b. b -> Either a b
Right THUniqueKeyDef
u
#if MIN_VERSION_template_haskell(2, 17, 0)
paramsContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Cxt
#else
paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt
#endif
paramsContext :: [TyVarBndr] -> [THFieldDef] -> [Type]
paramsContext [TyVarBndr]
types [THFieldDef]
fields = Name -> [Type] -> [Type]
classPred ''PersistField [Type]
params [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''SinglePersistField [Type]
maybys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''NeverNull [Type]
maybys
where
classPred :: Name -> [Type] -> [Type]
classPred Name
clazz = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> Name -> [Type] -> Type
classP' Name
clazz [Type
t])
params :: [Type]
params = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType [TyVarBndr]
types
maybys :: [Type]
maybys = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [THFieldDef]
fields [THFieldDef] -> (THFieldDef -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> [Type]
insideMaybe (Type -> [Type]) -> (THFieldDef -> Type) -> THFieldDef -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType
#if MIN_VERSION_template_haskell(2, 17, 0)
paramsPureContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Q (Maybe Cxt)
#else
paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt)
#endif
paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe [Type])
paramsPureContext [TyVarBndr]
types [THFieldDef]
fields = do
let isValidType :: Type -> Q Bool
isValidType (VarT Name
_) = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isValidType Type
t = Type -> Q Bool
isPrim Type
t
[THFieldDef]
invalid <- (THFieldDef -> Q Bool) -> [THFieldDef] -> Q [THFieldDef]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool)
-> (THFieldDef -> Q Bool) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Bool
isValidType (Type -> Q Bool) -> (THFieldDef -> Type) -> THFieldDef -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType) [THFieldDef]
fields
Maybe [Type] -> Q (Maybe [Type])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Type] -> Q (Maybe [Type]))
-> Maybe [Type] -> Q (Maybe [Type])
forall a b. (a -> b) -> a -> b
$ case [THFieldDef]
invalid of
[] -> [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just ([Type] -> Maybe [Type]) -> [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> [Type]
classPred ''PurePersistField [Type]
params [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''PrimitivePersistField [Type]
maybys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Name -> [Type] -> [Type]
classPred ''NeverNull [Type]
maybys
where
params :: [Type]
params = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
extractType [TyVarBndr]
types
classPred :: Name -> [Type] -> [Type]
classPred Name
clazz = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> Name -> [Type] -> Type
classP' Name
clazz [Type
t])
maybys :: [Type]
maybys = [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [THFieldDef]
fields [THFieldDef] -> (THFieldDef -> [Type]) -> [Type]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> [Type]
insideMaybe (Type -> [Type]) -> (THFieldDef -> Type) -> THFieldDef -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THFieldDef -> Type
thFieldType
[THFieldDef]
_ -> Maybe [Type]
forall a. Maybe a
Nothing
#if MIN_VERSION_template_haskell(2, 17, 0)
extractType :: TH.TyVarBndr flag -> Type
extractType (PlainTV name _) = VarT name
extractType (KindedTV name _ _) = VarT name
#else
extractType :: TyVarBndr -> Type
(PlainTV Name
name) = Name -> Type
VarT Name
name
extractType (KindedTV Name
name Type
_) = Name -> Type
VarT Name
name
#endif
#if MIN_VERSION_template_haskell(2, 7, 0)
#define isClassInstance isInstance
#endif
#if !MIN_VERSION_template_haskell(2, 8, 0)
reportWarning :: String -> Q ()
reportWarning = report False
#endif
isPrim :: Type -> Q Bool
isPrim :: Type -> Q Bool
isPrim Type
t | Type -> Bool
hasFreeVars Type
t = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isPrim t :: Type
t@(ConT Name
_) = isClassInstance ''PrimitivePersistField [t]
isPrim (AppT (AppT (ConT Name
key) Type
_) (AppT (AppT Type
_ (ConT Name
typ)) Type
_)) | Name
key Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Key Bool -> Bool -> Bool
&& Name
typ Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''BackendSpecific = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isPrim (AppT (ConT Name
tcon) Type
t) | Name
tcon Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = Type -> Q Bool
isPrim Type
t
isPrim Type
_ = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> a
f a -> a -> a
app = Type -> a
go
where
go :: Type -> a
go ForallT {} = String -> a
forall a. HasCallStack => String -> a
error String
"forall'ed fields are not allowed"
go z :: Type
z@(AppT Type
a Type
b) = Type -> a
f Type
z a -> a -> a
`app` Type -> a
go Type
a a -> a -> a
`app` Type -> a
go Type
b
go z :: Type
z@(SigT Type
t Type
_) = Type -> a
f Type
z a -> a -> a
`app` Type -> a
go Type
t
go Type
z = Type -> a
f Type
z
hasFreeVars :: Type -> Bool
hasFreeVars :: Type -> Bool
hasFreeVars = (Type -> Bool) -> (Bool -> Bool -> Bool) -> Type -> Bool
forall a. (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> Bool
f Bool -> Bool -> Bool
(||)
where
f :: Type -> Bool
f (VarT Name
_) = Bool
True
f Type
_ = Bool
False
insideMaybe :: Type -> [Type]
insideMaybe :: Type -> [Type]
insideMaybe = (Type -> [Type]) -> ([Type] -> [Type] -> [Type]) -> Type -> [Type]
forall a. (Type -> a) -> (a -> a -> a) -> Type -> a
foldType Type -> [Type]
f [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++)
where
f :: Type -> [Type]
f (AppT (ConT Name
c) t :: Type
t@(VarT Name
_)) | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = [Type
t]
f Type
_ = []
spanM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
spanM :: (a -> m Bool) -> [a] -> m ([a], [a])
spanM a -> m Bool
p = [a] -> m ([a], [a])
go
where
go :: [a] -> m ([a], [a])
go [] = ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
go (a
x : [a]
xs) = do
Bool
flg <- a -> m Bool
p a
x
if Bool
flg
then do
([a]
ys, [a]
zs) <- [a] -> m ([a], [a])
go [a]
xs
([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys, [a]
zs)
else ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
mkType :: THFieldDef -> Name -> ExpQ -> ExpQ
mkType :: THFieldDef -> Name -> ExpQ -> ExpQ
mkType THFieldDef {String
Maybe String
Maybe [PSFieldDef String]
Maybe Name
Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
Type
thReferenceParent :: THFieldDef
-> Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
thDefaultValue :: THFieldDef -> Maybe String
thEmbeddedDef :: THFieldDef -> Maybe [PSFieldDef String]
thDbTypeName :: THFieldDef -> Maybe 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
thExprName :: THFieldDef -> String
thFieldName :: THFieldDef -> String
thFieldConverter :: THFieldDef -> Maybe Name
thFieldType :: THFieldDef -> Type
thDbFieldName :: THFieldDef -> String
..} Name
proxy ExpQ
nvar = ExpQ
t3
where
psField :: PSFieldDef String
psField = String
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe [PSFieldDef String]
-> Maybe String
-> Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
-> Maybe String
-> PSFieldDef String
forall str.
str
-> Maybe str
-> Maybe str
-> Maybe str
-> Maybe [PSFieldDef str]
-> Maybe str
-> Maybe
(Maybe ((Maybe str, str), [str]), Maybe ReferenceActionType,
Maybe ReferenceActionType)
-> Maybe str
-> PSFieldDef str
PSFieldDef String
thFieldName (String -> Maybe String
forall a. a -> Maybe a
Just String
thDbFieldName) Maybe String
thDbTypeName (String -> Maybe String
forall a. a -> Maybe a
Just String
thExprName) Maybe [PSFieldDef String]
thEmbeddedDef Maybe String
thDefaultValue Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
thReferenceParent ((Name -> String) -> Maybe Name -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
forall a. Show a => a -> String
show Maybe Name
thFieldConverter)
t1 :: ExpQ
t1 = (ExpQ -> ExpQ)
-> (Name -> ExpQ -> ExpQ) -> Maybe Name -> ExpQ -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExpQ -> ExpQ
forall a. a -> a
id (\Name
convName ExpQ
x -> [|fst $(varE convName) $ $x|]) Maybe Name
thFieldConverter ExpQ
nvar
t2 :: ExpQ
t2 = [|dbType $(varE proxy) $t1|]
t3 :: ExpQ
t3 = case (Maybe String
thDbTypeName, Maybe [PSFieldDef String]
thEmbeddedDef, Maybe String
thDefaultValue, Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
thReferenceParent) of
(Maybe String
Nothing, Maybe [PSFieldDef String]
Nothing, Maybe String
Nothing, Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType)
Nothing) -> ExpQ
t2
(Maybe String, Maybe [PSFieldDef String], Maybe String,
Maybe
(Maybe ((Maybe String, String), [String]),
Maybe ReferenceActionType, Maybe ReferenceActionType))
_ -> [|applyDbTypeSettings $(lift psField) $t2|]
mkTySynInstD :: Name -> [Type] -> Type -> Dec
#if MIN_VERSION_template_haskell(2, 15, 0)
mkTySynInstD :: Name -> [Type] -> Type -> Dec
mkTySynInstD Name
name [Type]
ts Type
t =
TySynEqn -> Dec
TySynInstD (TySynEqn -> Dec) -> TySynEqn -> Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
typ Type
t where
typ :: Type
typ = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
ts
#elif MIN_VERSION_template_haskell(2, 9, 0)
mkTySynInstD name ts t = TySynInstD name $ TySynEqn ts t
#else
mkTySynInstD = TySynInstD
#endif
classP' :: Name -> [Type] -> Pred
#if MIN_VERSION_template_haskell(2, 10, 0)
classP' :: Name -> [Type] -> Type
classP' Name
name [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
ts
#else
classP' = ClassP
#endif
equalP' :: Type -> Type -> Pred
#if MIN_VERSION_template_haskell(2, 10, 0)
equalP' :: Type -> Type -> Type
equalP' Type
t1 Type
t2 = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
EqualityT [Type
t1, Type
t2]
#else
equalP'= EqualP
#endif
instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec
#if MIN_VERSION_template_haskell(2, 11, 0)
instanceD' :: [Type] -> Type -> [Dec] -> Dec
instanceD' = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
#else
instanceD' = InstanceD
#endif
dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec
#if MIN_VERSION_template_haskell(2, 15, 0)
dataInstD' :: [Type] -> Name -> [Type] -> [Con] -> [Name] -> Dec
dataInstD' [Type]
context Name
name [Type]
types [Con]
constrs [Name]
derives =
[Type]
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [Type]
context Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
typ Maybe Type
forall a. Maybe a
Nothing [Con]
constrs [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derives)] where
typ :: Type
typ = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
types
#elif MIN_VERSION_template_haskell(2, 12, 0)
dataInstD' context name types constrs derives =
DataInstD context name types Nothing constrs [DerivClause Nothing (map ConT derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
dataInstD' context name types constrs derives =
DataInstD context name types Nothing constrs (map ConT derives)
#else
dataInstD' = DataInstD
#endif
dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec
#if MIN_VERSION_template_haskell(2, 12, 0)
dataD' :: [Type] -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
dataD' [Type]
context Name
name [TyVarBndr]
types [Con]
constrs [Name]
derives =
[Type]
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [Type]
context Name
name [TyVarBndr]
types Maybe Type
forall a. Maybe a
Nothing [Con]
constrs [Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
dataD' context name types constrs derives =
DataD context name types Nothing constrs (map ConT derives)
#else
dataD' = DataD
#endif
#if MIN_VERSION_template_haskell(2, 11, 0)
notStrict' :: Bang
notStrict' :: Bang
notStrict' = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
#else
notStrict' :: Strict
notStrict' = NotStrict
#endif
#if MIN_VERSION_template_haskell(2, 17, 0)
type TyVarBndr = TH.TyVarBndr ()
#else
type TyVarBndr = TH.TyVarBndr
#endif