module Database.Groundhog.TH
(
mkPersist
, groundhog
, groundhogFile
, CodegenConfig(..)
, defaultCodegenConfig
, NamingStyle(..)
, suffixNamingStyle
, persistentNamingStyle
, conciseNamingStyle
, lowerCaseSuffixNamingStyle
, toUnderscore
) 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 (isUpper, isLower, isSpace, isDigit, toUpper, toLower)
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
}
lowerCaseSuffixNamingStyle :: NamingStyle
lowerCaseSuffixNamingStyle = suffixNamingStyle {
mkDbEntityName = \dName -> toUnderscore dName
, mkDbConstrName = \_ cName _ -> toUnderscore cName
, mkDbFieldName = \_ _ _ fName _ -> toUnderscore fName
, mkNormalDbFieldName = \_ cName _ fNum -> toUnderscore $ 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
, thDefaultValue = psDefaultValue
, thReferenceParent = psReferenceParent
}
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
toUnderscore :: String -> String
toUnderscore = map toLower . go where
go (x:y:z:xs) | isUpper x && isUpper y && isLower z = x:'_':y:go (z:xs)
go (x:y:xs) | (isLower x || isDigit x) && isUpper y = x:'_':y:go xs
go (x:xs) = x:go xs
go "" = ""
--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