{-# LANGUAGE TemplateHaskell, RecordWildCards, DoAndIfThenElse, ExplicitForAll, StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
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 Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.TH.Settings
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Control.Applicative
import Control.Arrow (first)
import Control.Monad (liftM, liftM2, forM, forM_, filterM, replicateM, zipWithM)
import Data.Either (lefts, rights)
import Data.List (findIndex, nub, partition)
import Data.Maybe (catMaybes, mapMaybe)
import qualified GHC.Read as R
import qualified Text.Read.Lex as R
import qualified Text.ParserCombinators.ReadPrec 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 :: $(forallT (thEmbeddedTypeParams def) (cxt []) [t| $(return embedded) -> $(return t) |]) |]
let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
let fullEmbeddedName = case null types of
True -> [| $(stringE $ thDbEmbeddedName def) |]
False -> [| $(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)) >> return (a, [])) undefined |]
failureFunc = funD failureName [clause [] failureBody []]
locals = if isFailureUsed then [failureFunc] else []
funD 'fromPersistValues [clause [varP xs] (normalB $ return 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 :: $(return $ 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']
return $ [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 return (Nothing, [| (toPrimitivePersistValue $field:) |])
else newName "x" >>= \x -> return (Just $ bindS (varP x) [| toPersistValues $field |], varE x)
(binds, funcs) <- liftM (first catMaybes . unzip) $ zipWithM processField patVars fieldDefs
let pat = conP constrName $ map varP patVars
result = [| return $ $(processResult $ if null funcs then [| id |] else foldr1 (\a b -> [|$a . $b|]) funcs) |]
body = if null binds then result else doE $ binds ++ [noBindS result]
return (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 (liftM not . isPrim . thFieldType . snd) vars
xss <- liftM (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
[] -> [| return ($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 <- liftM or $ mapM (isPrim . thFieldType) fieldDefs
return (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 (liftM not . isPrim . thFieldType . snd) vars
xss <- liftM (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
return (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
[] -> return (False, [| ($result, $(varE xs')) |])
_ -> goField xs' rest result failure
let m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') []
return $ 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']
return $ [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 -> return []
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 $(return 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']
return [instanceD' context (AppT (ConT ''PersistField) keyType) decs]
_ -> return []
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 $(return 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 [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) keyType) decs
, mkDefaultPurePersistFieldInstance context keyType
, mkDefaultSinglePersistFieldInstance context keyType]
_ -> return []
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']
return $ 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']
return $ 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 $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
extractUnique' <- do
uniqueFields <- mapM (\f -> newName "x" >>= \x -> return (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 = maybe (error $ "mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " ++ thUniqueKeyName unique) id index
funD 'uniqueNum [clause [wildP] (normalB [| uNum |]) []]
let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
return $ 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
liftM concat $ forM (filter thUniqueKeyMakeEmbedded $ thUniqueKeys def) $ \unique -> do
uniqKeyType <- [t| Key $(return 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 $(return 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 :: $(return $ 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']
return $ 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
liftM concat $ forM (thUniqueKeys def) $ \unique -> do
uniqKeyType <- [t| Key $(return 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
_ -> return 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 [ return $ 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 $(return 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 $(return entity) $u |]
readPrec' <- funD 'R.readPrec [clause [] (normalB body) []]
readListPrec' <- funD 'R.readListPrec [clause [] (normalB [| R.readListPrecDefault |]) []]
return $ instanceD' context (AppT (ConT ''Read) keyType) [readPrec', readListPrec']
in mapM mkRead keysInfo
return $ 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) []
return $ 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']
return $ [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 $(return entity) |]
let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
return $ dataD' [] name [PlainTV v] [constr] []
mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
mkEntityPhantomConstructorInstances def = sequence $ zipWith 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 exists == Nothing
then do
v <- newName "v"
let name = mkName $ thUniqueKeyPhantomName u
phantom <- [t| UniqueMarker $(return entity) |]
let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
return [dataD' [] name [PlainTV v] [constr] []]
else return []
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 -> return []
Just k -> do
keyDescr <- [t| BackendSpecific |]
return [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
return $ ForallC [] [equalP' (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'
return $ dataInstD' [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []
autoKey' <- do
autoType <- case thAutoKey def of
Nothing -> [t| () |]
Just _ -> [t| Key $(return entity) BackendSpecific |]
return $ mkTySynInstD ''AutoKey [entity] autoType
defaultKey' <- do
typ <- case thAutoKey def of
Just k | thAutoKeyIsDef k -> [t| Key $(return entity) BackendSpecific |]
_ -> case filter thUniqueKeyIsDef $ thUniqueKeys def of
[unique] -> [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
_ -> [t| () |]
return $ mkTySynInstD ''DefaultKey [entity] typ
isSumType' <- do
let isSumType = ConT $ if length (thConstructors def) == 1
then ''HFalse
else ''HTrue
return $ 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
return $ dataInstD' [] ''Field [entity, VarT cParam, VarT fParam] constrs []
entityDef' <- do
v <- newName "v"
proxy <- newName "p"
let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return 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 :: $(return $ 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 = case null types of
True -> [| $(stringE $ thDbEntityName def) |]
False -> [| $(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' <- liftM (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)
return $ match (infixP cNum' '(:) (varP xs')) (normalB $ return 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 -> return $ 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
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']
return $ [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 return (Nothing, [| (toPrimitivePersistValue $field:) |])
else newName "x" >>= \x -> return (Just $ valD (varP x) (normalB [| toPurePersistValues $(varE fName) |]) [], varE x)
(lets, funcs) <- liftM (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 :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |]
let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
let fullEntityName = case null types of
True -> [| $(stringE $ thDbEntityName def) |]
False -> [| $(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 uniqInfo = either auto uniq defaultKey where
auto _ = Nothing
uniq u = let name = mkName $ thUniqueKeyPhantomName u in Just $ (conT name, conE name)
toPersistValues' <- do
let body = normalB $ case uniqInfo of
_ | isOne -> [| singleToPersistValue |]
Just u -> [| toPersistValuesUnique $(snd u) |]
_ -> error "mkEntityPersistFieldInstance: key has no unique type"
funD 'toPersistValues $ [ clause [] body [] ]
fromPersistValues' <- do
let body = normalB $ case uniqInfo of
_ | isOne -> [| singleFromPersistValue |]
Just u -> [| fromPersistValuesUnique $(snd u) |]
_ -> 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']
return $ [instanceD' context (AppT (ConT ''PersistField) entity) decs]
Nothing -> return []
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']
return [instanceD' context (AppT (ConT ''SinglePersistField) entity) decs]
_ -> return []
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
return $ 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']
return [ 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 $ [return $ 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) []]
return [sig, func]
isDefaultKeyOneColumn :: THEntityDef -> Q Bool
isDefaultKeyOneColumn def = case getDefaultKey def of
Just (Left _) -> return True
Just (Right unique) | (length $ thUniqueKeyFields unique) == 1 ->
isPrim $ thFieldType $ head $ thUniqueKeyFields unique
_ -> return 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
paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt
paramsContext types fields = classPred ''PersistField params ++ classPred ''SinglePersistField maybys ++ classPred ''NeverNull maybys where
classPred clazz = map (\t -> classP' clazz [t])
params = map extractType types
maybys = nub $ fields >>= insideMaybe . thFieldType
paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt)
paramsPureContext types fields = do
let isValidType (VarT _) = return True
isValidType t = isPrim t
invalid <- filterM (liftM not . isValidType . thFieldType) fields
return $ 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])
maybys = nub $ fields >>= insideMaybe . thFieldType
_ -> Nothing
extractType :: TyVarBndr -> Type
extractType (PlainTV name) = VarT name
extractType (KindedTV name _) = VarT name
#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 t | hasFreeVars t = return False
isPrim t@(ConT _) = isClassInstance ''PrimitivePersistField [t]
isPrim (AppT (AppT (ConT key) _) (AppT (AppT _ (ConT typ)) _)) | key == ''Key && typ == ''BackendSpecific = return True
isPrim (AppT (ConT tcon) t) | tcon == ''Maybe = isPrim t
isPrim _ = return False
foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
foldType f (<>) = go where
go (ForallT _ _ _) = error "forall'ed fields are not allowed"
go z@(AppT a b) = f z <> go a <> go b
go z@(SigT t _) = f z <> 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 [] = return ([], [])
go (x:xs) = do
flg <- p x
if flg then do
(ys, zs) <- go xs
return (x:ys, zs)
else return ([], 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 |]
t3 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of
(Nothing, Nothing, Nothing, Nothing) -> t2
_ -> [| applyDbTypeSettings $(lift psField) $t2 |]
mkTySynInstD :: Name -> [Type] -> Type -> Dec
mkTySynInstD name ts t =
#if MIN_VERSION_template_haskell(2, 15, 0)
TySynInstD $ TySynEqn Nothing typ t where
typ = foldl AppT (ConT name) ts
#elif MIN_VERSION_template_haskell(2, 9, 0)
TySynInstD name $ TySynEqn ts t
#else
TySynInstD name ts t
#endif
classP' :: Name -> [Type] -> Pred
classP' name ts =
#if MIN_VERSION_template_haskell(2, 10, 0)
foldl AppT (ConT name) ts
#else
ClassP name ts
#endif
equalP' :: Type -> Type -> Pred
equalP' t1 t2 =
#if MIN_VERSION_template_haskell(2, 10, 0)
foldl AppT EqualityT [t1, t2]
#else
EqualP t1 t2
#endif
instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec
instanceD' =
#if MIN_VERSION_template_haskell(2, 11, 0)
InstanceD Nothing
#else
InstanceD
#endif
dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec
dataInstD' cxt name types constrs derives =
#if MIN_VERSION_template_haskell(2, 15, 0)
DataInstD cxt 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 cxt name types Nothing constrs [DerivClause Nothing (map ConT derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
DataInstD cxt name types Nothing constrs (map ConT derives)
#else
DataInstD cxt name types constrs derives
#endif
dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec
dataD' cxt name types constrs derives =
#if MIN_VERSION_template_haskell(2, 12, 0)
DataD cxt name types Nothing constrs [DerivClause Nothing (map ConT derives)]
#elif MIN_VERSION_template_haskell(2, 11, 0)
DataD cxt name types Nothing constrs (map ConT derives)
#else
DataD cxt name types constrs derives
#endif
#if MIN_VERSION_template_haskell(2, 11, 0)
notStrict' :: Bang
notStrict' = Bang NoSourceUnpackedness NoSourceStrictness
#else
notStrict' :: Strict
notStrict' = NotStrict
#endif