groundhog-th 0.5.0 → 0.5.1

raw patch · 5 files changed

+46/−36 lines, 5 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• Database/Groundhog/TH.hs +19/−15
• Database/Groundhog/TH/CodeGen.hs +9/−8
• Database/Groundhog/TH/Settings.hs +13/−12
• changelog +4/−0
• groundhog-th.cabal +1/−1

@@ -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

@@ -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) []]

@@ -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

@@ -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 

@@ -1,5 +1,5 @@ name:            groundhog-th-version:         0.5.0+version:         0.5.1 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>