{-# LANGUAGE TemplateHaskell, RecordWildCards, CPP #-}
module Database.Groundhog.TH
(
mkPersist
, groundhog
, groundhogFile
, CodegenConfig(..)
, defaultCodegenConfig
, defaultMkEntityDecs
, defaultMkEmbeddedDecs
, defaultMkPrimitiveDecs
, NamingStyle(..)
, suffixNamingStyle
, persistentNamingStyle
, conciseNamingStyle
, lowerCaseSuffixNamingStyle
, toUnderscore
, firstChar
, mkTHEntityDef
, mkTHEmbeddedDef
, mkTHPrimitiveDef
, applyEntitySettings
, applyEmbeddedSettings
, applyPrimitiveSettings
, showReadConverter
, enumConverter
) 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.Applicative
import Control.Monad (forM, forM_, when, unless, liftM2)
import Data.Char (isUpper, isLower, isSpace, isDigit, toUpper, toLower)
import Data.List (nub, (\\))
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.String
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml as Y (decodeHelper, ParseException(..))
import qualified Text.Libyaml as Y
data CodegenConfig = CodegenConfig {
namingStyle :: NamingStyle
, migrationFunction :: Maybe String
, mkEntityDecs :: [[THEntityDef] -> Q [Dec]]
, mkEmbeddedDecs :: [[THEmbeddedDef] -> Q [Dec]]
, mkPrimitiveDecs :: [[THPrimitiveDef] -> Q [Dec]]
}
defaultCodegenConfig :: CodegenConfig
defaultCodegenConfig = CodegenConfig suffixNamingStyle Nothing [defaultMkEntityDecs] [defaultMkEmbeddedDecs] [defaultMkPrimitiveDecs]
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 -> firstChar toUpper uName
, mkUniqueKeyConstrName = \_ _ uName -> firstChar toUpper uName ++ "Key"
, mkUniqueKeyDbName = \_ _ uName -> "Key" ++ [delim] ++ firstChar toUpper uName
, mkDbConstrName = \_ cName _ -> cName
, mkDbConstrAutoKeyName = \_ _ _ -> "id"
, mkDbFieldName = \_ _ _ fName _ -> fName
, mkExprFieldName = \_ _ _ fName _ -> firstChar toUpper fName ++ "Field"
, mkExprSelectorName = \_ _ fName _ -> firstChar toUpper fName ++ "Selector"
, mkNormalFieldName = \_ cName _ fNum -> firstChar toLower cName ++ show fNum
, mkNormalDbFieldName = \_ cName _ fNum -> firstChar 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 ++ firstChar toUpper fName
, mkExprSelectorName = \_ cName fName _ -> cName ++ firstChar toUpper fName
, mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum
, mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum
}
conciseNamingStyle :: NamingStyle
conciseNamingStyle = suffixNamingStyle {
mkExprFieldName = \_ _ _ fName _ -> firstChar toUpper fName
, mkExprSelectorName = \_ _ fName _ -> firstChar 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{..} = do
let duplicates = notUniqueBy id $
map psDataName psEntities ++ map psEmbeddedName psEmbeddeds ++ map psPrimitiveName psPrimitives
unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates
let getDecl name = do
info <- reify $ mkName name
return $ case info of
TyConI d -> d
_ -> error $ "Only datatypes can be processed: " ++ name
entities <- forM psEntities $ \e ->
either error id . validateEntity . applyEntitySettings namingStyle e . mkTHEntityDef namingStyle <$> getDecl (psDataName e)
embeddeds <- forM psEmbeddeds $ \e ->
either error id . validateEmbedded . applyEmbeddedSettings e . mkTHEmbeddedDef namingStyle <$> getDecl (psEmbeddedName e)
primitives <- forM psPrimitives $ \e ->
applyPrimitiveSettings e . mkTHPrimitiveDef namingStyle <$> getDecl (psPrimitiveName e)
let mkEntityDecs' = maybe id (\name -> (mkMigrateFunction name:)) migrationFunction $ mkEntityDecs
fmap concat $ sequence $ map ($ entities) mkEntityDecs' ++ map ($ embeddeds) mkEmbeddedDecs ++ map ($ primitives) mkPrimitiveDecs
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'' = map checkAutoKey thConstructors
checkAutoKey cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = thAutoKey' >> thDbAutoKeyName}
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 = psDbAutoKeyName <|> thDbAutoKeyName
, 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 String -> THFieldDef -> THFieldDef
applyFieldSettings PSFieldDef{..} def@(THFieldDef{..}) =
def { thDbFieldName = fromMaybe thDbFieldName psDbFieldName
, thExprName = fromMaybe thExprName psExprName
, thDbTypeName = psDbTypeName
, thEmbeddedDef = psEmbeddedDef
, thDefaultValue = psDefaultValue
, thReferenceParent = psReferenceParent
, thFieldConverter = fmap mkName psFieldConverter
}
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
applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef
applyPrimitiveSettings PSPrimitiveDef{..} def@(THPrimitiveDef{..}) =
def { thPrimitiveDbName = fromMaybe thPrimitiveDbName psPrimitiveDbName
, thPrimitiveConverter = mkName psPrimitiveConverter
}
mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (thUniqueFields uniqueDef) [0..] where
findField (Left name) = findOne "field" thFieldName name $ thConstrFields cDef
findField (Right expr) = error $ "A unique key may not contain expressions: " ++ expr
uniqueDef = findOne "unique" 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 :: (Eq b, Show b) => (a -> b) -> [a] -> String -> Either String ()
assertUnique f xs what = case notUniqueBy f xs of
[] -> return ()
ys -> Left $ "All " ++ what ++ " must be unique: " ++ show ys
assertSpaceFree :: String -> String -> Either String ()
assertSpaceFree s what = when (any isSpace s) $ Left $ "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 -> Left $ "Constraints must have at least one field: " ++ show ys
when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $
Left $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) ++ ": " ++ show (thDbAutoKeyName cdef) ++ " - " ++ show (thAutoKey def)
if length constrs > 1 && not (null $ thUniqueKeys def)
then Left $ "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) $
Left $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def)
let isPrimary x = case x of
UniquePrimary _ -> True
_ -> False
primaryConstraints = length $ filter (isPrimary . thUniqueType) $ concatMap thConstrUniques constrs
if length constrs > 1
then when (primaryConstraints > 0) $
Left $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def)
else when (primaryConstraints + maybe 0 (const 1) (thAutoKey def) > 1) $
Left $ "A datatype cannot have more than one primary key constraint: " ++ show (thDataName def)
let keyDefaults = maybe id ((:) . thAutoKeyIsDef) (thAutoKey def) $ map thUniqueKeyIsDef (thUniqueKeys def)
when (not (null keyDefaults) && length (filter id keyDefaults) /= 1) $
Left $ "A datatype with keys must have 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)) $
Left $ "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
mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDef NamingStyle{..} dec = THEntityDef dName (mkDbEntityName dName') Nothing autokey [] typeVars constrs where
(dName, typeVars, cons) = fromDataD dec
constrs = zipWith mkConstr [0..] cons
dName' = nameBase dName
autokey = Just $ THAutoKeyDef (mkEntityKeyName dName') True
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..]
_ -> error $ "Only regular types and records are supported" ++ show dName
where
mkConstr' name params = THConstructorDef name (apply mkPhantomName) (apply mkDbConstrName) (Just $ apply mkDbConstrAutoKeyName) 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 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 Nothing where
apply f = f dName' cName cNum fName' fNum
fName' = nameBase fName
mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef
mkTHEmbeddedDef (NamingStyle{..}) dec = THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where
(dName, typeVars, cons) = fromDataD dec
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..])
_ -> error $ "Only regular types and records are 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 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 Nothing where
apply f = f dName' cName' 0 fName' fNum
fName' = nameBase fName
mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef
mkTHPrimitiveDef (NamingStyle{..}) dec = THPrimitiveDef dName (mkDbEntityName dName') 'showReadConverter where
dName = case dec of
#if MIN_VERSION_template_haskell(2, 11, 0)
DataD _ dName _ _ _ _ -> dName
NewtypeD _ dName _ _ _ _ -> dName
#else
DataD _ dName _ _ _ -> dName
NewtypeD _ dName _ _ _ -> dName
#endif
_ -> error $ "Only datatypes and newtypes can be declared as primitive: " ++ show dec
dName' = nameBase dName
showReadConverter :: (Show a, Read a) => (a -> String, String -> a)
showReadConverter = (show, read)
enumConverter :: Enum a => (a -> Int, Int -> a)
enumConverter = (fromEnum, toEnum)
firstChar :: (Char -> Char) -> String -> String
firstChar 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 "" = ""
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 $ encodeUtf8 $ fromString 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)
defaultMkEntityDecs :: [THEntityDef] -> Q [Dec]
defaultMkEntityDecs = fmap concat . mapM (\def -> do
decs <- fmap concat $ sequence $ map ($ def)
[ mkEntityPhantomConstructors
, mkEntityPhantomConstructorInstances
, mkAutoKeyPersistFieldInstance
, mkAutoKeyPrimitivePersistFieldInstance
, mkEntityUniqueKeysPhantoms
, mkUniqueKeysIsUniqueInstances
, mkUniqueKeysEmbeddedInstances
, mkUniqueKeysPersistFieldInstances
, mkUniqueKeysPrimitiveOrPurePersistFieldInstances
, mkKeyEqShowInstances
, mkEntityPersistFieldInstance
, mkEntitySinglePersistFieldInstance
, mkPersistEntityInstance
, mkEntityNeverNullInstance
]
return decs)
defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec]
defaultMkEmbeddedDecs = fmap concat . mapM (\def -> do
decs <- fmap concat $ sequence $ map ($ def)
[ mkEmbeddedPersistFieldInstance
, mkEmbeddedPurePersistFieldInstance
, mkEmbeddedInstance
]
return decs)
defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec]
defaultMkPrimitiveDecs = fmap concat . mapM (\def -> do
decs <- fmap concat $ sequence $ map ($ def)
[ mkPrimitivePersistFieldInstance
, mkPrimitivePrimitivePersistFieldInstance
]
return decs)
fromDataD :: InstanceDec -> (Name, [TyVarBndr], [Con])
fromDataD d = case d of
#if MIN_VERSION_template_haskell(2, 11, 0)
(DataD _ dName typeVars _ constrs _) -> (dName, typeVars, constrs)
#else
(DataD _ dName typeVars constrs _) -> (dName, typeVars, constrs)
#endif
d -> error $ "Only datatypes can be processed: " ++ show d