module Database.Groundhog.TH
(
mkPersist
, groundhog
, groundhogFile
, CodegenConfig(..)
, defaultCodegenConfig
, NamingStyle(..)
, suffixNamingStyle
, persistentNamingStyle
, conciseNamingStyle
) where
import Database.Groundhog.Core (delim)
import Database.Groundhog.Generic
import Database.Groundhog.TH.CodeGen
import Database.Groundhog.TH.Settings
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (StrictType, VarStrictType, Lift(..))
import Language.Haskell.TH.Quote
import Control.Monad (forM, forM_, when, unless, liftM2)
import Data.ByteString.Char8 (pack)
import Data.Char (toUpper, toLower, isSpace)
import Data.Either (lefts)
import Data.List (nub, (\\))
import Data.Maybe (fromMaybe, isNothing)
import Data.Yaml (decodeEither)
data CodegenConfig = CodegenConfig {
namingStyle :: NamingStyle
, migrationFunction :: Maybe String
}
defaultCodegenConfig :: CodegenConfig
defaultCodegenConfig = CodegenConfig suffixNamingStyle Nothing
data NamingStyle = NamingStyle {
mkDbEntityName :: String -> String
, mkEntityKeyName :: String -> String
, mkPhantomName :: String -> String -> Int -> String
, mkUniqueKeyPhantomName :: String -> String -> String -> String
, mkUniqueKeyConstrName :: String -> String -> String -> String
, mkUniqueKeyDbName :: String -> String -> String -> String
, mkDbConstrName :: String -> String -> Int -> String
, mkDbConstrAutoKeyName :: String -> String -> Int -> String
, mkDbFieldName :: String -> String -> Int -> String -> Int -> String
, mkExprFieldName :: String -> String -> Int -> String -> Int -> String
, mkExprSelectorName :: String -> String -> String -> Int -> String
, mkNormalFieldName :: String -> String -> Int -> Int -> String
, mkNormalDbFieldName :: String -> String -> Int -> Int -> String
, mkNormalExprFieldName :: String -> String -> Int -> Int -> String
, mkNormalExprSelectorName :: String -> String -> Int -> String
}
suffixNamingStyle :: NamingStyle
suffixNamingStyle = NamingStyle {
mkDbEntityName = \dName -> dName
, mkEntityKeyName = \dName -> dName ++ "Key"
, mkPhantomName = \_ cName _ -> cName ++ "Constructor"
, mkUniqueKeyPhantomName = \_ _ uName -> firstLetter toUpper uName
, mkUniqueKeyConstrName = \_ _ uName -> firstLetter toUpper uName ++ "Key"
, mkUniqueKeyDbName = \_ _ uName -> "Key" ++ [delim] ++ firstLetter toUpper uName
, mkDbConstrName = \_ cName _ -> cName
, mkDbConstrAutoKeyName = \_ _ _ -> "id"
, mkDbFieldName = \_ _ _ fName _ -> fName
, mkExprFieldName = \_ _ _ fName _ -> firstLetter toUpper fName ++ "Field"
, mkExprSelectorName = \_ _ fName _ -> firstLetter toUpper fName ++ "Selector"
, mkNormalFieldName = \_ cName _ fNum -> firstLetter toLower cName ++ show fNum
, mkNormalDbFieldName = \_ cName _ fNum -> firstLetter toLower cName ++ show fNum
, mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum ++ "Field"
, mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum ++ "Selector"
}
persistentNamingStyle :: NamingStyle
persistentNamingStyle = suffixNamingStyle {
mkExprFieldName = \_ cName _ fName _ -> cName ++ firstLetter toUpper fName
, mkExprSelectorName = \_ cName fName _ -> cName ++ firstLetter toUpper fName
, mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum
, mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum
}
conciseNamingStyle :: NamingStyle
conciseNamingStyle = suffixNamingStyle {
mkExprFieldName = \_ _ _ fName _ -> firstLetter toUpper fName
, mkExprSelectorName = \_ _ fName _ -> firstLetter toUpper fName
, mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum
, mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum
}
mkPersist :: CodegenConfig -> PersistDefinitions -> Q [Dec]
mkPersist CodegenConfig{..} (PersistDefinitions defs) = do
let duplicates = notUniqueBy id $ map (either psDataName psEmbeddedName) defs
unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates
defs' <- forM defs $ \def -> do
let name = mkName $ either psDataName psEmbeddedName def
info <- reify name
return $ case info of
TyConI x -> case x of
d@DataD{} -> case def of
Left ent -> either error Left $ validateEntity $ applyEntitySettings namingStyle ent $ mkTHEntityDefWith namingStyle d
Right emb -> either error Right $ validateEmbedded $ applyEmbeddedSettings emb $ mkTHEmbeddedDefWith namingStyle d
NewtypeD{} -> error "Newtypes are not supported"
_ -> error $ "Unknown declaration type: " ++ show name ++ " " ++ show x
_ -> error $ "Only datatypes can be processed: " ++ show name
decs <- mapM (either mkEntityDecs mkEmbeddedDecs) defs'
migrateFunc <- maybe (return []) (\name -> mkMigrateFunction name (lefts defs')) migrationFunction
return $ migrateFunc ++ concat decs
applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef
applyEntitySettings style settings def@(THEntityDef{..}) =
def { dbEntityName = fromMaybe dbEntityName $ psDbEntityName settings
, thAutoKey = thAutoKey'
, thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') $ psUniqueKeys settings
, thConstructors = thConstructors'
} where
thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) $ psAutoKey settings
thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors settings where
thConstructors'' = maybe id (\_ -> zipWith putAutoKey [0..]) thAutoKey' thConstructors
putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase dataName) (nameBase thConstrName) cNum}
mkUniqueKey' = mkUniqueKey style (nameBase dataName) (head thConstructors')
f = foldr $ replaceOne "constructor" psConstrName (nameBase . thConstrName) applyConstructorSettings
mkUniqueKey :: NamingStyle -> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef
mkUniqueKey style@NamingStyle{..} dName cDef@THConstructorDef{..} PSUniqueKeyDef{..} = key where
key = THUniqueKeyDef {
thUniqueKeyName = psUniqueKeyName
, thUniqueKeyPhantomName = fromMaybe (mkUniqueKeyPhantomName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyPhantomName
, thUniqueKeyConstrName = fromMaybe (mkUniqueKeyConstrName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyConstrName
, thUniqueKeyDbName = fromMaybe (mkUniqueKeyDbName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyDbName
, thUniqueKeyFields = maybe uniqueFields (f uniqueFields) psUniqueKeyFields
, thUniqueKeyMakeEmbedded = fromMaybe False psUniqueKeyMakeEmbedded
, thUniqueKeyIsDef = fromMaybe False psUniqueKeyIsDef
}
f = foldr $ replaceOne "unique field" psFieldName fieldName applyFieldSettings
uniqueFields = mkFieldsForUniqueKey style dName key cDef
applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings def@(THAutoKeyDef{..}) settings =
def { thAutoKeyConstrName = fromMaybe thAutoKeyConstrName $ psAutoKeyConstrName settings
, thAutoKeyIsDef = fromMaybe thAutoKeyIsDef $ psAutoKeyIsDef settings
}
applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings settings def@(THConstructorDef{..}) =
def { thPhantomConstrName = fromMaybe thPhantomConstrName $ psPhantomConstrName settings
, dbConstrName = fromMaybe dbConstrName $ psDbConstrName settings
, thDbAutoKeyName = fromMaybe thDbAutoKeyName $ psDbAutoKeyName settings
, thConstrFields = maybe thConstrFields (f thConstrFields) $ psConstrFields settings
, thConstrUniques = fromMaybe thConstrUniques $ psConstrUniques settings
} where
f = foldr $ replaceOne "field" psFieldName fieldName applyFieldSettings
applyFieldSettings :: PSFieldDef -> THFieldDef -> THFieldDef
applyFieldSettings settings def@(THFieldDef{..}) =
def { dbFieldName = fromMaybe dbFieldName $ psDbFieldName settings
, exprName = fromMaybe exprName $ psExprName settings
, embeddedDef = psEmbeddedDef settings
}
applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings settings def@(THEmbeddedDef{..}) =
def { dbEmbeddedName = fromMaybe dbEmbeddedName $ psDbEmbeddedName settings
, embeddedFields = maybe embeddedFields (f embeddedFields) $ psEmbeddedFields settings
} where
f = foldr $ replaceOne "field" psFieldName fieldName applyFieldSettings
mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (psUniqueFields uniqueDef) [0..] where
findField name = findOne "field" id fieldName name $ thConstrFields cDef
uniqueDef = findOne "unique" id psUniqueName (thUniqueKeyName uniqueKey) $ thConstrUniques cDef
setSelector f i = f {exprName = mkExprSelectorName style dName (thUniqueKeyConstrName uniqueKey) (fieldName f) i}
notUniqueBy :: Eq b => (a -> b) -> [a] -> [b]
notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs'
assertUnique :: (Monad m, Eq b, Show b) => (a -> b) -> [a] -> String -> m ()
assertUnique f xs what = case notUniqueBy f xs of
[] -> return ()
ys -> fail $ "All " ++ what ++ " must be unique: " ++ show ys
assertSpaceFree :: Monad m => String -> String -> m ()
assertSpaceFree s what = when (any isSpace s) $ fail $ "Spaces in " ++ what ++ " are not allowed: " ++ show s
validateEntity :: THEntityDef -> Either String THEntityDef
validateEntity def = do
let constrs = thConstructors def
assertUnique thPhantomConstrName constrs "constructor phantom name"
assertUnique dbConstrName constrs "constructor db name"
forM_ constrs $ \cdef -> do
let fields = thConstrFields cdef
assertSpaceFree (thPhantomConstrName cdef) "constructor phantom name"
assertUnique exprName fields "expr field name in a constructor"
assertUnique dbFieldName fields "db field name in a constructor"
forM_ fields $ \fdef -> assertSpaceFree (exprName fdef) "field expr name"
case filter (\(PSUniqueDef _ cfields) -> null cfields) $ thConstrUniques cdef of
[] -> return ()
ys -> fail $ "Constraints must have at least one field: " ++ show ys
when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $
fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (dataName def)
if length constrs > 1 && not (null $ thUniqueKeys def)
then fail $ "Unique keys may exist only for datatypes with single constructor: " ++ show (dataName def)
else
let uniqueNames = map psUniqueName $ thConstrUniques $ head constrs
in forM_ (thUniqueKeys def) $ \cKey -> unless (thUniqueKeyName cKey `elem` uniqueNames) $
fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (dataName def)
when (null (thUniqueKeys def) && isNothing (thAutoKey def)) $
fail $ "A datatype must have either an auto key or unique keys: " ++ show (dataName def)
let defaults = maybe False thAutoKeyIsDef (thAutoKey def) : map thUniqueKeyIsDef (thUniqueKeys def)
when (length (filter id defaults) /= 1) $
fail $ "A datatype must have exactly one default key: " ++ show (dataName def)
return def
validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded def = do
let fields = embeddedFields def
assertUnique exprName fields "expr field name in an embedded datatype"
assertUnique dbFieldName fields "db field name in an embedded datatype"
forM_ fields $ \fdef -> assertSpaceFree (exprName fdef) "field expr name"
return def
mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDefWith NamingStyle{..} (DataD _ dName typeVars cons _) =
THEntityDef dName (mkDbEntityName dName') (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where
constrs = zipWith mkConstr [0..] cons
dName' = nameBase dName
mkConstr cNum c = case c of
NormalC name params -> mkConstr' name $ zipWith (mkField (nameBase name)) params [0..]
RecC name params -> mkConstr' name $ zipWith (mkVarField (nameBase name)) params [0..]
InfixC{} -> error $ "Types with infix constructors are not supported" ++ show dName
ForallC{} -> error $ "Types with existential quantification are not supported" ++ show dName
where
mkConstr' name params = THConstructorDef name (apply mkPhantomName) (apply mkDbConstrName) Nothing params [] where
apply f = f dName' (nameBase name) cNum
mkField :: String -> StrictType -> Int -> THFieldDef
mkField cName (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) (apply mkNormalExprFieldName) t Nothing where
apply f = f dName' cName cNum fNum
mkVarField :: String -> VarStrictType -> Int -> THFieldDef
mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) (apply mkExprFieldName) t Nothing where
apply f = f dName' cName cNum fName' fNum
fName' = nameBase fName
mkTHEntityDefWith _ _ = error "Only datatypes can be processed"
mkTHEmbeddedDefWith :: NamingStyle -> Dec -> THEmbeddedDef
mkTHEmbeddedDefWith (NamingStyle{..}) (DataD _ dName typeVars cons _) =
THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where
dName' = nameBase dName
(cName, fields) = case cons of
[cons'] -> case cons' of
NormalC name params -> (name, zipWith (mkField (nameBase name)) params [0..])
RecC name params -> (name, zipWith (mkVarField (nameBase name)) params [0..])
InfixC{} -> error $ "Types with infix constructors are not supported" ++ show dName
ForallC{} -> error $ "Types with existential quantification are not supported" ++ show dName
_ -> error $ "An embedded datatype must have exactly one constructor: " ++ show dName
mkField :: String -> StrictType -> Int -> THFieldDef
mkField cName' (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) (mkNormalExprSelectorName dName' cName' fNum) t Nothing where
apply f = f dName' cName' 0 fNum
mkVarField :: String -> VarStrictType -> Int -> THFieldDef
mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) (mkExprSelectorName dName' cName' fName' fNum) t Nothing where
apply f = f dName' cName' 0 fName' fNum
fName' = nameBase fName
mkTHEmbeddedDefWith _ _ = error "Only datatypes can be processed"
firstLetter :: (Char -> Char) -> String -> String
firstLetter f s = f (head s):tail s
--keys:
--constructors:
--definitions:
groundhog :: QuasiQuoter
groundhog = QuasiQuoter { quoteExp = parseDefinitions
, quotePat = error "groundhog: pattern quasiquoter"
, quoteType = error "groundhog: type quasiquoter"
, quoteDec = error "groundhog: declaration quasiquoter"
}
groundhogFile :: QuasiQuoter
groundhogFile = quoteFile groundhog
parseDefinitions :: String -> Q Exp
parseDefinitions s = either fail lift result where
result = decodeEither $ pack s :: Either String PersistDefinitions
mkEntityDecs :: THEntityDef -> Q [Dec]
mkEntityDecs def = do
decs <- fmap concat $ sequence
[ mkEntityPhantomConstructors def
, mkEntityPhantomConstructorInstances def
, mkAutoKeyPersistFieldInstance def
, mkAutoKeyPrimitivePersistFieldInstance def
, mkEntityUniqueKeysPhantoms def
, mkUniqueKeysIsUniqueInstances def
, mkUniqueKeysEmbeddedInstances def
, mkUniqueKeysPersistFieldInstances def
, mkUniqueKeysPrimitiveOrPurePersistFieldInstances def
, mkKeyEqShowInstances def
, mkEntityPersistFieldInstance def
, mkEntitySinglePersistFieldInstance def
, mkPersistEntityInstance def
, mkEntityNeverNullInstance def
]
return decs
mkEmbeddedDecs :: THEmbeddedDef -> Q [Dec]
mkEmbeddedDecs def = do
decs <- fmap concat $ sequence
[ mkEmbeddedPersistFieldInstance def
, mkEmbeddedPurePersistFieldInstance def
, mkEmbeddedInstance def
]
return decs