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