groundhog-th 0.3.1 → 0.4.0

raw patch · 4 files changed

+84/−59 lines, 4 filesdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

• Database/Groundhog/TH.hs +34/−7
• Database/Groundhog/TH/CodeGen.hs +31/−26
• Database/Groundhog/TH/Settings.hs +17/−24
• groundhog-th.cabal +2/−2

@@ -16,6 +16,8 @@   , suffixNamingStyle   , persistentNamingStyle   , conciseNamingStyle+  , lowerCaseSuffixNamingStyle+  , toUnderscore   ) where  import Database.Groundhog.Core (delim, UniqueType(..))@@ -27,7 +29,7 @@ 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.Char (isUpper, isLower, isSpace, isDigit, toUpper, toLower) import Data.Either (lefts) import Data.List (nub, (\\)) import Data.Maybe (fromMaybe, isJust, isNothing)@@ -161,6 +163,15 @@   , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum } +-- | The generated Haskell names of phantom types (constructors, fields, etc.) are the same as with suffixNamingStyle. But the table names and columns are converted from camelCase to underscore_lower_case with `toUnderscore`.+lowerCaseSuffixNamingStyle :: NamingStyle+lowerCaseSuffixNamingStyle = suffixNamingStyle {+    mkDbEntityName = \dName -> toUnderscore dName+  , mkDbConstrName = \_ cName _ -> toUnderscore cName+  , mkDbFieldName = \_ _ _ fName _ -> toUnderscore fName+  , mkNormalDbFieldName = \_ cName _ fNum -> toUnderscore $ cName ++ show fNum+}+ -- | Creates the auxiliary structures.  -- Particularly, it creates GADT 'Field' data instance for referring to the fields in expressions and phantom types for data constructors. -- The default names of auxiliary datatypes and names used in database are generated using the naming style and can be changed via configuration.@@ -238,8 +249,8 @@       , thExprName = fromMaybe thExprName psExprName       , thDbTypeName = psDbTypeName       , thEmbeddedDef = psEmbeddedDef-      , thFieldOnDelete = psFieldOnDelete-      , thFieldOnUpdate = psFieldOnUpdate+      , thDefaultValue = psDefaultValue+      , thReferenceParent = psReferenceParent       }  applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef@@ -369,6 +380,15 @@ firstLetter :: (Char -> Char) -> String -> String firstLetter 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+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 "" = ""+ -- $settingsDoc -- Groundhog needs to analyze the datatypes and create the auxiliary definitions before it can work with them. -- We use YAML-based settings to list the datatypes and adjust the result of their introspection.@@ -425,7 +445,17 @@ --          - name: foo                  # The name as in constructor record. If constructor is not a record, the name is created by 'mkNormalFieldName'. For example, the fields in constructor SomeConstr would have names someConstr0 and someConstr1 by default. --            dbName: foo                # Column name --            exprName: FooField         # Name of a field used in expressions---            \# type: varchar            # This would result in having field type DbOther \"varchar\" instead of DbString. Value of this attribute will be used by DB backend for migration+--          \# type: varchar              # This would result in having field type DbOther \"varchar\" instead of DbString. Value of this attribute will be used by DB backend for migration+--          \# default: foo_value         # The default value for column in the clause+--          \# reference:                 # This is explicit reference to a parent table not mapped by Groundhog+--          \#   schema: myschema         # Optional schema+--          \#   table: mytable           # Name of the parent table+--          \#   columns: [mytable_id]    # Parent columns. If the current field is embedded, e.g., a tuple, it will be a composite key+--          \#   onDelete: cascade        # Defines ON DELETE clause of references. It can have values: no action, restrict, cascade, set null, set default+--          \#   onUpdate: restrict       # Defines ON UPDATE+--          \# onDelete: cascade          # Clauses onDelete and onUpdate can be set outside of reference too. This is deprecated and kept for compatibility+--          \# If onDelete or onUpdate are omitted, the database will choose the action automatically. Note that it may differ across databases.+--          \# For example, MySQL has \"restrict\" by default, but in PostgreSQL it is \"no action\". --          - name: bar --            dbName: bar --            exprName: BarField@@ -433,9 +463,6 @@ --          - name: next --            dbName: next --            exprName: NextField---            \# If these clauses are omitted, the database will define action automatically. Note that it may differ across databases. For example, MySQL has \"restrict\" by default, but in PostgreSQL it is \"no action\"---            \# onDelete: cascade        # Defines ON DELETE clause of references. It can have values: no action, restrict, cascade, set null, set default---            \# onUpdate: set null       # Defines ON UPDATE --        uniques: --          - name: someconstraint --            type: constraint           # The type can be be \"constraint\", \"index\", or \"primary\"

@@ -88,7 +88,7 @@             typ = mkType f nvar
         [| (fname, $typ) |]
     let pat = if null $ thEmbeddedTypeParams def then wildP else varP v
-    funD 'dbType $ [ clause [pat] (normalB [| DbEmbedded $ EmbeddedDef False $(listE $ zipWith mkField [0..] (thEmbeddedFields def)) |]) [] ]
+    funD 'dbType $ [ clause [pat] (normalB [| DbEmbedded (EmbeddedDef False $(listE $ zipWith mkField [0..] $ thEmbeddedFields def)) Nothing |]) [] ]
 
   let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
   let decs = [persistName', toPersistValues', fromPersistValues', dbType']
@@ -192,7 +192,8 @@     fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []]
     dbType' <- do
       a <- newName "a"
-      let body = [| DbEntity Nothing Nothing Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |]
+      let e = [| entityDef ((undefined :: Key v a -> v) $(varE a)) |]
+          body = [| DbTypePrimitive DbAutoKey False Nothing (Just (Left ($e, Nothing), Nothing, Nothing)) |]
       funD 'dbType [clause [varP a] (normalB body) []]
     
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
@@ -239,9 +240,6 @@   let constr = head $ thConstructors def
   forM (thUniqueKeys def) $ \unique -> do
     uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
-    uniqueConstr' <- do
-      typ <- conT $ mkName $ thPhantomConstrName constr
-      return $ TySynInstD ''UniqueConstr [uniqKeyType] typ
     extractUnique' <- do
       uniqueFields <- mapM (\f -> newName "x" >>= \x -> return (thFieldName f, x)) $ thUniqueKeyFields unique
       let mkFieldPat f = maybe wildP varP $ lookup (thFieldName f) uniqueFields
@@ -253,7 +251,7 @@       let uNum = maybe (error $ "mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " ++ thUniqueKeyName unique) id index
       funD 'uniqueNum [clause [wildP] (normalB [| uNum |]) []]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
-    return $ InstanceD context (AppT (ConT ''IsUniqueKey) uniqKeyType) [uniqueConstr', extractUnique', uniqueNum']
+    return $ InstanceD context (AppT (ConT ''IsUniqueKey) uniqKeyType) [extractUnique', uniqueNum']
 
 mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysEmbeddedInstances def = do
@@ -283,7 +281,8 @@               typ = mkType f nvar
           [| (fname, $typ) |]
       let embedded = [| EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique) |]
-      let body = [| DbEntity (Just ($embedded, $(lift $ thUniqueKeyName unique))) Nothing Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |]
+          e = [| entityDef ((undefined :: Key v a -> v) $(varE a)) |]
+          body = [| DbEmbedded $embedded (Just (Left ($e, Just $(lift $ thUniqueKeyName unique)), Nothing, Nothing)) |]
       funD 'dbType [clause [varP a] (normalB body) []]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let decs = [persistName', toPersistValues', fromPersistValues', dbType']
@@ -379,19 +378,22 @@ mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
 mkEntityPhantomConstructorInstances def = sequence $ zipWith f [0..] $ thConstructors def where
   f :: Int -> THConstructorDef -> Q Dec
-  f cNum c = instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName $ thPhantomConstrName c)) [phantomConstrName', phantomConstrNum'] where
-    phantomConstrName' = funD 'phantomConstrName [clause [wildP] (normalB $ stringE $ thDbConstrName c) []]
+  f cNum c = instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName $ thPhantomConstrName c)) [phantomConstrNum'] where
     phantomConstrNum' = funD 'phantomConstrNum [clause [wildP] (normalB $ [| cNum |]) []]
 
 mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
 mkEntityUniqueKeysPhantoms def = do
   let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
-  forM (thUniqueKeys def) $ \u -> do
-    v <- newName "v"
-    let name = mkName $ thUniqueKeyPhantomName u
-    phantom <- [t| UniqueMarker $(return entity) |]
-    let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
-    dataD (cxt []) name [PlainTV v] [return constr] []
+  fmap concat $ forM (thUniqueKeys def) $ \u -> do
+    exists <- lookupTypeName $ thUniqueKeyPhantomName u
+    if exists == Nothing
+      then do
+        v <- newName "v"
+        let name = mkName $ thUniqueKeyPhantomName u
+        phantom <- [t| UniqueMarker $(return entity) |]
+        let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
+        sequence [dataD (cxt []) name [PlainTV v] [return constr] []]
+      else return []
     
 mkPersistEntityInstance :: THEntityDef -> Q [Dec]
 mkPersistEntityInstance def = do
@@ -426,6 +428,12 @@               in  [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |]
     typ <- [t| Key $(return entity) $keyType |]
     return $ TySynInstD ''DefaultKey [entity] typ
+
+  isSumType' <- do
+    let isSumType = ConT $ if length (thConstructors def) == 1
+          then ''HFalse
+          else ''HTrue
+    return $ TySynInstD ''IsSumType [entity] isSumType
   
   fields' <- do
     cParam <- newName "c"
@@ -527,7 +535,7 @@     in funD 'entityFieldChain clauses
 
   let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
-  let decs = [key', autoKey', defaultKey', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain']
+  let decs = [key', autoKey', defaultKey', isSumType', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain']
   return $ [InstanceD context (AppT (ConT ''PersistEntity) entity) decs]
 
 mkToPurePersistValues :: Name -> [(Name, Type)] -> Q Exp
@@ -713,13 +721,10 @@       else return ([], x:xs)
 
 mkType :: THFieldDef -> ExpQ -> ExpQ
-mkType f nvar = case thDbTypeName f of
-  Just name -> [| DbOther $ OtherTypeDef $ const $(lift name) |]
-  Nothing -> t3 where
-    t1 = [| dbType $nvar |]
-    t2 = case (thFieldOnDelete f, thFieldOnUpdate f) of
-      (Nothing, Nothing) -> t1
-      (onDel, onUpd) -> [| applyReferencesSettings $(lift onDel) $(lift onUpd) $t1 |]
-    t3 = case thEmbeddedDef f of
-      Nothing -> t2
-      Just emb -> [| applyEmbeddedDbTypeSettings $(lift emb) $t2 |]
+mkType THFieldDef{..} nvar = t2 where
+  psField = PSFieldDef thFieldName (Just thDbFieldName) thDbTypeName (Just thExprName) thEmbeddedDef thDefaultValue thReferenceParent
+  t1 = [| dbType $nvar |]
+  -- if there are any type settings, apply them in runtime
+  t2 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of
+    (Nothing, Nothing, Nothing, Nothing) -> t1
+    _ -> [| applyDbTypeSettings $(lift psField) $t1 |]

@@ -14,14 +14,13 @@   , PSEmbeddedDef(..)
   , PSConstructorDef(..)
   , PSFieldDef(..)
-  , PSEmbeddedFieldDef(..)
   , PSUniqueDef(..)
   , PSUniqueKeyDef(..)
   , PSAutoKeyDef(..)
   ) where
 
 import Database.Groundhog.Core (UniqueType(..), ReferenceActionType(..))
-import Database.Groundhog.Generic (PSEmbeddedFieldDef(..))
+import Database.Groundhog.Generic (PSFieldDef(..))
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Control.Applicative
@@ -70,9 +69,9 @@   , thDbTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50)
   , thExprName :: String -- BarField
   , thFieldType :: Type
-  , thEmbeddedDef :: Maybe [PSEmbeddedFieldDef]
-  , thFieldOnDelete :: Maybe ReferenceActionType
-  , thFieldOnUpdate :: Maybe ReferenceActionType
+  , thEmbeddedDef :: Maybe [PSFieldDef]
+  , thDefaultValue :: Maybe String
+  , thReferenceParent :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType)
 } deriving Show
 
 data THUniqueDef = THUniqueDef {
@@ -115,16 +114,6 @@   , psConstrUniques :: Maybe [PSUniqueDef]
 } deriving Show
 
-data PSFieldDef = PSFieldDef {
-    psFieldName :: String -- bar
-  , psDbFieldName :: Maybe String -- SQLbar
-  , psDbTypeName :: Maybe String -- inet, NUMERIC(5,2), VARCHAR(50)
-  , psExprName :: Maybe String -- BarField
-  , psEmbeddedDef :: Maybe [PSEmbeddedFieldDef]
-  , psFieldOnDelete :: Maybe ReferenceActionType
-  , psFieldOnUpdate :: Maybe ReferenceActionType
-} deriving Show
-
 data PSUniqueDef = PSUniqueDef {
     psUniqueName :: String
   , psUniqueType :: Maybe UniqueType
@@ -174,10 +163,7 @@   lift SetDefault = [| SetDefault |]
 
 instance Lift PSFieldDef where
-  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psFieldOnDelete) $(lift psFieldOnUpdate) |]
-
-instance Lift PSEmbeddedFieldDef where
-  lift (PSEmbeddedFieldDef {..}) = [| PSEmbeddedFieldDef $(lift psEmbeddedFieldName) $(lift psDbEmbeddedFieldName) $(lift psDbEmbeddedTypeName) $(lift psSubEmbedded) |]
+  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psDefaultValue) $(lift psReferenceParent) |]
 
 instance Lift PSUniqueKeyDef where
   lift (PSUniqueKeyDef {..}) = [| PSUniqueKeyDef $(lift psUniqueKeyName) $(lift psUniqueKeyPhantomName) $(lift psUniqueKeyConstrName) $(lift psUniqueKeyDbName) $(lift psUniqueKeyFields) $(lift psUniqueKeyMakeEmbedded) $(lift psUniqueKeyIsDef) |]
@@ -248,11 +234,18 @@       Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x
 
 instance FromJSON PSFieldDef where
-  parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "onDelete" <*> v .:? "onUpdate"
-  parseJSON _          = mzero
-
-instance FromJSON PSEmbeddedFieldDef where
-  parseJSON (Object v) = PSEmbeddedFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "embeddedType"
+  parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings where
+    mkRefSettings = do
+      ref <- v .:? "reference"
+      (parent, onDel, onUpd) <- case ref of
+        Just (Object r) -> (,,) <$> parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate" where
+          parentRef = optional ((,,) <$> r .:? "schema" <*> r .: "table" <*> r .: "columns")
+        _ -> pure (Nothing, Nothing, Nothing)
+      -- this temporary solution uses onDelete and onUpdate both from inside reference object (preferred) and from field level (for compatibility)
+      (onDel', onUpd') <- (,) <$> v .:? "onDelete" <*> v .:? "onUpdate"
+      pure $ case (parent, onDel <|> onDel', onUpd <|> onUpd') of
+        (Nothing, Nothing, Nothing) -> Nothing
+        refSettings -> Just refSettings
   parseJSON _          = mzero
 
 instance FromJSON PSUniqueKeyDef where

@@ -1,5 +1,5 @@ name:            groundhog-th-version:         0.3.1+version:         0.4.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -14,7 +14,7 @@ library     build-depends:   base                     >= 4         && < 5                    , bytestring               >= 0.9-                   , groundhog                >= 0.3.1     && < 0.4.0+                   , groundhog                >= 0.4.0     && < 0.5.0                    , template-haskell                    , time                     >= 1.1.4                    , containers               >= 0.2