diff --git a/Database/Groundhog/TH.hs b/Database/Groundhog/TH.hs --- a/Database/Groundhog/TH.hs +++ b/Database/Groundhog/TH.hs @@ -18,6 +18,7 @@ , conciseNamingStyle , lowerCaseSuffixNamingStyle , toUnderscore + , firstChar ) where import Database.Groundhog.Core (delim, UniqueType(..)) @@ -106,16 +107,16 @@ 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 + , 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 _ -> 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 + , 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" } @@ -136,8 +137,8 @@ -- > ... persistentNamingStyle :: NamingStyle persistentNamingStyle = suffixNamingStyle { - mkExprFieldName = \_ cName _ fName _ -> cName ++ firstLetter toUpper fName - , mkExprSelectorName = \_ cName fName _ -> cName ++ firstLetter toUpper fName + 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 } @@ -158,8 +159,8 @@ -- > ... conciseNamingStyle :: NamingStyle conciseNamingStyle = suffixNamingStyle { - mkExprFieldName = \_ _ _ fName _ -> firstLetter toUpper fName - , mkExprSelectorName = \_ _ fName _ -> firstLetter toUpper fName + mkExprFieldName = \_ _ _ fName _ -> firstChar toUpper fName + , mkExprSelectorName = \_ _ fName _ -> firstChar toUpper fName , mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum } @@ -274,7 +275,7 @@ applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef applyPrimitiveSettings PSPrimitiveDef{..} def@(THPrimitiveDef{..}) = def { thPrimitiveDbName = fromMaybe thPrimitiveDbName psPrimitiveDbName - , thPrimitiveStringRepresentation = fromMaybe thPrimitiveStringRepresentation psPrimitiveStringRepresentation + , thPrimitiveStringEnumRepresentation = fromMaybe thPrimitiveStringEnumRepresentation psPrimitiveStringEnumRepresentation } mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef] @@ -319,7 +320,10 @@ 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 + 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) $ fail $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def) @@ -400,8 +404,8 @@ dName' = nameBase dName mkTHPrimitiveDef _ _ = error "Only datatypes can be processed" -firstLetter :: (Char -> Char) -> String -> String -firstLetter f s = f (head s):tail s +firstChar :: (Char -> Char) -> String -> String +firstChar f s = f (head s):tail s -- | Transforms string from camelCase to lower_case_underscore naming convention. -- ColumnName -> column_name, parseURL -> parse_url, FieldIEEE754Floating -> field_ieee754_floating diff --git a/Database/Groundhog/TH/CodeGen.hs b/Database/Groundhog/TH/CodeGen.hs --- a/Database/Groundhog/TH/CodeGen.hs +++ b/Database/Groundhog/TH/CodeGen.hs @@ -536,14 +536,15 @@ entityFieldChain' <- let thFieldNames = thConstructors def >>= thConstrFields - clauses = map (\f -> mkChain f >>= \(fArg, body) -> clause [asP fArg $ conP (mkName $ thExprName f) []] (normalB body) []) thFieldNames - mkChain f = do + clauses = map mkClause thFieldNames + mkClause f = do fArg <- newName "f" let nvar = [| (undefined :: Field v c a -> a) $(varE fArg) |] typ = mkType f nvar - let body = [| (($(lift $ thDbFieldName f), $typ), []) |] - return (fArg, body) - in funD 'entityFieldChain clauses + body = [| (($(lift $ thDbFieldName f), $typ), []) |] + clause [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'] @@ -642,7 +643,7 @@ fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []] toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| primToPersistValue |]) []] dbType' <- do - let typ = if thPrimitiveStringRepresentation def + let typ = if thPrimitiveStringEnumRepresentation def then [| DbTypePrimitive DbString False Nothing Nothing |] else [| DbTypePrimitive DbInt32 False Nothing Nothing |] funD 'dbType $ [ clause [wildP] (normalB typ) [] ] @@ -657,7 +658,7 @@ toPrim' <- do proxy <- newName "p" x <- newName "x" - let value = if thPrimitiveStringRepresentation def + let value = if thPrimitiveStringEnumRepresentation def then [| show $(varE x) |] else [| fromEnum $(varE x) |] body = [| toPrimitivePersistValue $(varE proxy) $value |] @@ -666,7 +667,7 @@ proxy <- newName "p" x <- newName "x" let value = [| fromPrimitivePersistValue $(varE proxy) $(varE x) |] - body = if thPrimitiveStringRepresentation def + body = if thPrimitiveStringEnumRepresentation def then [| read $value |] else [| toEnum $value |] funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []] diff --git a/Database/Groundhog/TH/Settings.hs b/Database/Groundhog/TH/Settings.hs --- a/Database/Groundhog/TH/Settings.hs +++ b/Database/Groundhog/TH/Settings.hs @@ -56,15 +56,15 @@ data THEmbeddedDef = THEmbeddedDef { thEmbeddedName :: Name , thEmbeddedConstructorName :: Name - , thDbEmbeddedName :: String -- used only to set polymorphic part of name of its container + , thDbEmbeddedName :: String -- ^ It is used only to set polymorphic part of name of its container , thEmbeddedTypeParams :: [TyVarBndr] , thEmbeddedFields :: [THFieldDef] } deriving Show data THPrimitiveDef = THPrimitiveDef { thPrimitiveName :: Name - , thPrimitiveDbName :: String -- used only to set polymorphic part of name of its container - , thPrimitiveStringRepresentation :: Bool -- store in database as string using Show/Read instances or as integer using Enum instance + , thPrimitiveDbName :: String -- ^ It is used only to set polymorphic part of name of its container + , thPrimitiveStringEnumRepresentation :: Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False). } deriving Show data THConstructorDef = THConstructorDef { @@ -90,16 +90,17 @@ data THUniqueDef = THUniqueDef { thUniqueName :: String , thUniqueType :: UniqueType - , thUniqueFields :: [String] + , thUniqueFields :: [String] -- ^ Names of fields, not column names, i.e, thFieldName } deriving Show data THUniqueKeyDef = THUniqueKeyDef { thUniqueKeyName :: String , thUniqueKeyPhantomName :: String , thUniqueKeyConstrName :: String - , thUniqueKeyDbName :: String -- used only to set polymorphic part of name of its container + , thUniqueKeyDbName :: String -- ^ It is used only to set polymorphic part of name of its container + -- | It should repeat fields from THUniqueDef but it may give different settings for them. It is done to allow foreign key fields to be different from parent fields of the entity. These fields are used for creating a the key constructor and instances for it. For example, it can have a default value, or even a different type (INT8 may reference INT4). , thUniqueKeyFields :: [THFieldDef] - , thUniqueKeyMakeEmbedded :: Bool -- whether to make it an instance of Embedded + , thUniqueKeyMakeEmbedded :: Bool -- ^ If True, make it an instance of Embedded , thUniqueKeyIsDef :: Bool } deriving Show @@ -114,14 +115,14 @@ data PSEmbeddedDef = PSEmbeddedDef { psEmbeddedName :: String - , psDbEmbeddedName :: Maybe String -- used only to set polymorphic part of name of its container + , psDbEmbeddedName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container , psEmbeddedFields :: Maybe [PSFieldDef] } deriving Show data PSPrimitiveDef = PSPrimitiveDef { psPrimitiveName :: String - , psPrimitiveDbName :: Maybe String -- used only to set polymorphic part of name of its container - , psPrimitiveStringRepresentation :: Maybe Bool -- store in database as string using Show/Read instances or as integer using Enum instance + , psPrimitiveDbName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container + , psPrimitiveStringEnumRepresentation :: Maybe Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False). } deriving Show data PSConstructorDef = PSConstructorDef { @@ -160,7 +161,7 @@ lift (PSPrimitiveDef' e) = [| PSPrimitiveDef' e |] instance Lift PSPrimitiveDef where - lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveStringRepresentation) |] + lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveStringEnumRepresentation) |] instance Lift PersistDefinitions where lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |] @@ -180,7 +181,7 @@ instance Lift UniqueType where lift UniqueConstraint = [| UniqueConstraint |] lift UniqueIndex = [| UniqueIndex |] - lift UniquePrimary = [| UniquePrimary |] + lift (UniquePrimary x) = [| UniquePrimary $(lift x) |] instance Lift ReferenceActionType where lift NoAction = [| NoAction |] @@ -252,7 +253,7 @@ instance FromJSON UniqueType where parseJSON o = do x <- parseJSON o - let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary)] + let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary False)] case lookup x vals of Just a -> return a Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +0.5.1 +* Export firstChar for creating user naming styles +* Support entities with no fields + 0.5.0 * Compatibility with GHC 7.8 diff --git a/groundhog-th.cabal b/groundhog-th.cabal --- a/groundhog-th.cabal +++ b/groundhog-th.cabal @@ -1,5 +1,5 @@ name: groundhog-th -version: 0.5.0 +version: 0.5.1 license: BSD3 license-file: LICENSE author: Boris Lykah