module Database.Groundhog.TH
(
mkPersist
, groundhog
, groundhogFile
, CodegenConfig(..)
, defaultCodegenConfig
, NamingStyle(..)
, suffixNamingStyle
, persistentNamingStyle
, conciseNamingStyle
) where
import Database.Groundhog.Core (delim, UniqueType(..))
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, isJust, isNothing)
import Data.Yaml as Y(decodeHelper, ParseException(..))
import qualified Text.Libyaml as Y
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 PSEntityDef{..} def@(THEntityDef{..}) =
def { thDbEntityName = fromMaybe thDbEntityName psDbEntityName
, thEntitySchema = psEntitySchema
, thAutoKey = thAutoKey'
, thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') psUniqueKeys
, thConstructors = thConstructors'
} where
thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) psAutoKey
thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors where
thConstructors'' = maybe id (\_ -> zipWith putAutoKey [0..]) thAutoKey' thConstructors
putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase thDataName) (nameBase thConstrName) cNum}
mkUniqueKey' = mkUniqueKey style (nameBase thDataName) (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 thFieldName applyFieldSettings
uniqueFields = mkFieldsForUniqueKey style dName key cDef
applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings def@(THAutoKeyDef{..}) PSAutoKeyDef{..} =
def { thAutoKeyConstrName = fromMaybe thAutoKeyConstrName psAutoKeyConstrName
, thAutoKeyIsDef = fromMaybe thAutoKeyIsDef psAutoKeyIsDef
}
applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings PSConstructorDef{..} def@(THConstructorDef{..}) =
def { thPhantomConstrName = fromMaybe thPhantomConstrName psPhantomConstrName
, thDbConstrName = fromMaybe thDbConstrName psDbConstrName
, thDbAutoKeyName = fromMaybe thDbAutoKeyName psDbAutoKeyName
, thConstrFields = maybe thConstrFields (f thConstrFields) psConstrFields
, thConstrUniques = maybe thConstrUniques (map convertUnique) psConstrUniques
} where
f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings
convertUnique (PSUniqueDef uName uType uFields) = THUniqueDef uName (fromMaybe UniqueConstraint uType) uFields
applyFieldSettings :: PSFieldDef -> THFieldDef -> THFieldDef
applyFieldSettings PSFieldDef{..} def@(THFieldDef{..}) =
def { thDbFieldName = fromMaybe thDbFieldName psDbFieldName
, thExprName = fromMaybe thExprName psExprName
, thDbTypeName = psDbTypeName
, thEmbeddedDef = psEmbeddedDef
, thFieldOnDelete = psFieldOnDelete
, thFieldOnUpdate = psFieldOnUpdate
}
applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings PSEmbeddedDef{..} def@(THEmbeddedDef{..}) =
def { thDbEmbeddedName = fromMaybe thDbEmbeddedName psDbEmbeddedName
, thEmbeddedFields = maybe thEmbeddedFields (f thEmbeddedFields) psEmbeddedFields
} where
f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings
mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (thUniqueFields uniqueDef) [0..] where
findField name = findOne "field" id thFieldName name $ thConstrFields cDef
uniqueDef = findOne "unique" id thUniqueName (thUniqueKeyName uniqueKey) $ thConstrUniques cDef
setSelector f i = f {thExprName = mkExprSelectorName style dName (thUniqueKeyConstrName uniqueKey) (thFieldName 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 thDbConstrName constrs "constructor db name"
forM_ constrs $ \cdef -> do
let fields = thConstrFields cdef
assertSpaceFree (thPhantomConstrName cdef) "constructor phantom name"
assertUnique thExprName fields "expr field name in a constructor"
assertUnique thDbFieldName fields "db field name in a constructor"
mapM_ validateField fields
case filter (\(THUniqueDef _ _ uFields) -> null uFields) $ 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 (thDataName def)
if length constrs > 1 && not (null $ thUniqueKeys def)
then fail $ "Unique keys may exist only for datatypes with single constructor: " ++ show (thDataName def)
else
let uniqueNames = map thUniqueName $ thConstrUniques $ head constrs
in forM_ (thUniqueKeys def) $ \cKey -> unless (thUniqueKeyName cKey `elem` uniqueNames) $
fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def)
let primaryConstraints = length $ filter ((== UniquePrimary) . thUniqueType) $ concatMap thConstrUniques constrs
if length constrs > 1
then when (primaryConstraints > 0) $
fail $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def)
else when (primaryConstraints + maybe 0 (const 1) (thAutoKey def) > 1) $
fail $ "A datatype may have either an auto key or one custom primary key constraint : " ++ show (thDataName def)
when (null (thUniqueKeys def) && isNothing (thAutoKey def)) $
fail $ "A datatype must have either an auto key or unique keys: " ++ show (thDataName 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 (thDataName def)
return def
validateField :: THFieldDef -> Either String ()
validateField fDef = do
assertSpaceFree (thExprName fDef) "field expr name"
when (isJust (thDbTypeName fDef) && isJust (thEmbeddedDef fDef)) $
fail $ "A field may not have both type and embeddedType: " ++ show (thFieldName fDef)
validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded def = do
let fields = thEmbeddedFields def
assertUnique thExprName fields "expr field name in an embedded datatype"
assertUnique thDbFieldName fields "db field name in an embedded datatype"
mapM_ validateField fields
return def
mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDefWith NamingStyle{..} (DataD _ dName typeVars cons _) =
THEntityDef dName (mkDbEntityName dName') Nothing (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) Nothing (apply mkNormalExprFieldName) t Nothing Nothing Nothing where
apply f = f dName' cName cNum fNum
mkVarField :: String -> VarStrictType -> Int -> THFieldDef
mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (apply mkExprFieldName) t Nothing Nothing 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) Nothing (mkNormalExprSelectorName dName' cName' fNum) t Nothing Nothing Nothing where
apply f = f dName' cName' 0 fNum
mkVarField :: String -> VarStrictType -> Int -> THFieldDef
mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (mkExprSelectorName dName' cName' fName' fNum) t Nothing Nothing 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 = do
result <- runIO $ decodeHelper (Y.decode $ pack s)
case result of
Left err -> case err of
InvalidYaml (Just (Y.YamlParseException problem context mark)) -> fail $ unlines
[ "YAML parse error: " ++ problem
, "Context: " ++ context
, "At line: " ++ show (Y.yamlLine mark)
, lines s !! Y.yamlLine mark
, replicate (Y.yamlColumn mark) ' ' ++ "^"
]
_ -> fail $ show err
Right (Left err) -> fail err
Right (Right result') -> lift (result' :: 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