groundhog-th 0.2.0 → 0.3.0
raw patch · 4 files changed
+99/−45 lines, 4 filesdep ~groundhog
Dependency ranges changed: groundhog
Files
- Database/Groundhog/TH.hs +24/−8
- Database/Groundhog/TH/CodeGen.hs +40/−24
- Database/Groundhog/TH/Settings.hs +31/−9
- groundhog-th.cabal +4/−4
Database/Groundhog/TH.hs view
@@ -187,6 +187,7 @@ 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'@@ -237,6 +238,8 @@ , thExprName = fromMaybe thExprName psExprName , thDbTypeName = psDbTypeName , thEmbeddedDef = psEmbeddedDef+ , thFieldOnDelete = psFieldOnDelete+ , thFieldOnUpdate = psFieldOnUpdate } applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef@@ -288,6 +291,12 @@ 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) -- check that if unique keys = [] there is auto key when (null (thUniqueKeys def) && isNothing (thAutoKey def)) $ fail $ "A datatype must have either an auto key or unique keys: " ++ show (thDataName def)@@ -313,7 +322,7 @@ mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef mkTHEntityDefWith NamingStyle{..} (DataD _ dName typeVars cons _) =- THEntityDef dName (mkDbEntityName dName') (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where+ THEntityDef dName (mkDbEntityName dName') Nothing (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where constrs = zipWith mkConstr [0..] cons dName' = nameBase dName @@ -327,10 +336,10 @@ 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 where+ 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 where+ 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"@@ -349,10 +358,10 @@ _ -> 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 where+ 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 where+ 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"@@ -371,7 +380,7 @@ -- Unless the property is marked as mandatory, it can be omitted. In this case value created by the NamingStyle will be used. -- -- @---data Settable = First {foo :: String, bar :: Int} deriving (Eq, Show)+--data Settable = First {foo :: String, bar :: Int, next :: Maybe (Key Settable BackendSpecific)} deriving (Eq, Show) -- -- \-- The declaration with defaulted names --@@ -395,6 +404,7 @@ -- # The list elements start with hyphen+space. Keys are separated from values by a colon+space. See full definition at http://yaml.org/spec/1.2/spec.html. -- - entity: Settable # Mandatory. Entity datatype name -- dbName: Settable # Name of the main table+-- schema: null # Name of the schema to which the table belongs -- autoKey: # Description of the autoincremented key for data family Key instance -- constrName: SettableKey # Name of constructor -- default: true # The default key is used when entity is referenced without key wrapper. E.g., \"field :: SomeData\" instead of \"field :: Key SomeData keytype\"@@ -419,9 +429,15 @@ -- dbName: bar -- thExprName: BarField -- # For some databases \"type: integer\" would be appropriate+-- - name: next+-- dbName: next+-- thExprName: 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 either \"constraint\" or \"index\"+-- type: constraint # The type can be be \"constraint\", \"index\", or \"primary\" -- fields: [foo, bar] # List of constructor parameter names. Not DB names(!) -- |] -- @@@ -510,7 +526,7 @@ , mkPersistEntityInstance def , mkEntityNeverNullInstance def ]--- runIO $ putStrLn $ pprint decs+ -- runIO $ putStrLn $ pprint decs return decs mkEmbeddedDecs :: THEmbeddedDef -> Q [Dec]
Database/Groundhog/TH/CodeGen.hs view
@@ -85,10 +85,7 @@ then let pat = conP (thEmbeddedConstructorName def) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thEmbeddedFields def) - fNum - 1) wildP in caseE (varE v) $ [match pat (normalB $ varE a) []] else [| undefined :: $(return $ thFieldType f) |] - typ = case (thEmbeddedDef f, thDbTypeName f) of - (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |] - (_, Just name) -> [| DbOther $(lift name) |] - _ -> [| dbType $nvar |] + 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)) |]) [] ] @@ -195,7 +192,7 @@ fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []] dbType' <- do a <- newName "a" - let body = [| DbEntity Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |] + let body = [| DbEntity Nothing Nothing Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |] funD 'dbType [clause [varP a] (normalB body) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) @@ -267,13 +264,10 @@ let mkField f = do let fname = thDbFieldName f nvar = [| undefined :: $(return $ thFieldType f) |] - typ = case (thEmbeddedDef f, thDbTypeName f) of - (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |] - (_, Just name) -> [| DbOther $(lift name) |] - _ -> [| dbType $nvar |] + typ = mkType f nvar [| (fname, $typ) |] let embedded = [| EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique) |] - let body = [| DbEntity (Just ($embedded, $(lift $ thUniqueKeyName unique))) $ entityDef ((undefined :: Key v a -> v) $(varE a)) |] + let body = [| DbEntity (Just ($embedded, $(lift $ thUniqueKeyName unique))) Nothing Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |] funD 'dbType [clause [varP a] (normalB body) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) let decs = [persistName', toPersistValues', fromPersistValues', dbType'] @@ -444,10 +438,7 @@ wildClause = if length (thConstructors def) > 1 then [match wildP (normalB [| undefined |]) []] else [] in caseE (varE v) $ [match pat (normalB $ varE a) []] ++ wildClause else [| undefined :: $(return $ thFieldType f) |] - typ = case (thEmbeddedDef f, thDbTypeName f) of - (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |] - (_, Just name) -> [| DbOther $(lift name) |] - _ -> [| dbType $nvar |] + typ = mkType f nvar [| (fname, $typ) |] let constrs = listE $ zipWith mkConstructorDef [0..] $ thConstructors def mkConstructorDef cNum c@(THConstructorDef _ _ name keyName params conss) = [| ConstructorDef cNum name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss) |] where @@ -462,7 +453,7 @@ True -> [| $(stringE $ thDbEntityName def) |] False -> [| $(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames) |] - let body = normalB [| EntityDef $fullEntityName $typeParams' $constrs |] + let body = normalB [| EntityDef $fullEntityName $(lift $ thEntitySchema def) $typeParams' $constrs |] let pat = if null $ thTypeParams def then wildP else varP v funD 'entityDef $ [ clause [pat] body [] ] @@ -520,10 +511,7 @@ mkChain f = do fArg <- newName "f" let nvar = [| (undefined :: Field v c a -> a) $(varE fArg) |] - typ = case (thEmbeddedDef f, thDbTypeName f) of - (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |] - (_, Just name) -> [| DbOther $(lift name) |] - _ -> [| dbType $nvar |] + typ = mkType f nvar let body = [| (($(lift $ thDbFieldName f), $typ), []) |] return (fArg, body) in funD 'entityFieldChain clauses @@ -583,10 +571,7 @@ _ -> error "mkEntityPersistFieldInstance: key has no unique type" funD 'fromPersistValues $ [ clause [] body []] - dbType' <- do - x <- newName "x" - let keyType = maybe [t| BackendSpecific |] (\(u, _) -> [t| Unique $u |]) uniqInfo - funD 'dbType $ [clause [varP x] (normalB [| dbType $ (undefined :: a -> Key a $keyType) $(varE x) |]) []] + dbType' <- funD 'dbType $ [clause [] (normalB [| dbType . (undefined :: a -> DefaultKey a) |]) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) let decs = [persistName', toPersistValues', fromPersistValue', dbType'] @@ -622,7 +607,7 @@ mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec] mkMigrateFunction name defs = do let (normal, polymorhpic) = partition (null . thTypeParams) defs - forM_ polymorhpic $ \def -> report False $ "Datatype " ++ show (thDataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters" + forM_ polymorhpic $ \def -> reportWarning $ "Datatype " ++ show (thDataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters" let body = doE $ map (\def -> noBindS [| migrate (undefined :: $(conT $ thDataName def)) |]) normal sig <- sigD (mkName name) [t| PersistBackend m => Migration m |] func <- funD (mkName name) [clause [] (normalB body) []] @@ -672,6 +657,11 @@ #define isClassInstance isInstance #endif +#if !MIN_VERSION_template_haskell(2, 8, 0) +reportWarning :: String -> Q () +reportWarning = report False +#endif + isPrim :: Type -> Q Bool -- we cannot use simply isClassInstance because it crashes on type vars and in this case -- class PrimitivePersistField a @@ -711,3 +701,29 @@ (ys, zs) <- go xs return (x:ys, zs) else return ([], x:xs) +{- +mkType :: THFieldDef -> ExpQ -> ExpQ +mkType f nvar = case (thEmbeddedDef f, thDbTypeName f) of + (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar) |] + (_, Just name) -> [| DbOther $ OtherTypeDef $ const $(lift name) |] + _ -> [| dbType $nvar |] +-} +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 |] + + {- + + applyEmbeddedDbTypeSettings + (1, 2) Embedded + Key Entity Embedded + Entity PersistEntity + -}
Database/Groundhog/TH/Settings.hs view
@@ -20,7 +20,7 @@ , PSAutoKeyDef(..) ) where -import Database.Groundhog.Core (UniqueType(..)) +import Database.Groundhog.Core (UniqueType(..), ReferenceActionType(..)) import Database.Groundhog.Generic (PSEmbeddedFieldDef(..)) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -35,6 +35,7 @@ data THEntityDef = THEntityDef { thDataName :: Name -- SomeData , thDbEntityName :: String -- SQLSomeData + , thEntitySchema :: Maybe String , thAutoKey :: Maybe THAutoKeyDef , thUniqueKeys :: [THUniqueKeyDef] , thTypeParams :: [TyVarBndr] @@ -70,6 +71,8 @@ , thExprName :: String -- BarField , thFieldType :: Type , thEmbeddedDef :: Maybe [PSEmbeddedFieldDef] + , thFieldOnDelete :: Maybe ReferenceActionType + , thFieldOnUpdate :: Maybe ReferenceActionType } deriving Show data THUniqueDef = THUniqueDef { @@ -91,6 +94,7 @@ data PSEntityDef = PSEntityDef { psDataName :: String -- SomeData , psDbEntityName :: Maybe String -- SQLSomeData + , psEntitySchema :: Maybe String , psAutoKey :: Maybe (Maybe PSAutoKeyDef) -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings , psUniqueKeys :: Maybe [PSUniqueKeyDef] , psConstructors :: Maybe [PSConstructorDef] @@ -117,6 +121,8 @@ , 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 { @@ -144,7 +150,7 @@ lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |] instance Lift PSEntityDef where - lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psAutoKey) $(lift psUniqueKeys) $(lift psConstructors) |] + lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psEntitySchema) $(lift psAutoKey) $(lift psUniqueKeys) $(lift psConstructors) |] instance Lift PSEmbeddedDef where lift (PSEmbeddedDef {..}) = [| PSEmbeddedDef $(lift psEmbeddedName) $(lift psDbEmbeddedName) $(lift psEmbeddedFields) |] @@ -158,9 +164,17 @@ instance Lift UniqueType where lift UniqueConstraint = [| UniqueConstraint |] lift UniqueIndex = [| UniqueIndex |] + lift UniquePrimary = [| UniquePrimary |] +instance Lift ReferenceActionType where + lift NoAction = [| NoAction |] + lift Restrict = [| Restrict |] + lift Cascade = [| Cascade |] + lift SetNull = [| SetNull |] + lift SetDefault = [| SetDefault |] + instance Lift PSFieldDef where - lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) |] + 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) |] @@ -202,7 +216,7 @@ parseJSON _ = mzero instance FromJSON PSEntityDef where - parseJSON (Object v) = PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors" + parseJSON (Object v) = PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors" parseJSON _ = mzero instance FromJSON PSEmbeddedDef where @@ -220,13 +234,21 @@ instance FromJSON UniqueType where parseJSON o = do x <- parseJSON o - case (x :: String) of - "constraint" -> return UniqueConstraint - "index" -> return UniqueIndex - _ -> fail "parseJSON: UniqueType must be either \"constraint\" or \"index\"" + let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary)] + case lookup x vals of + Just a -> return a + Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x +instance FromJSON ReferenceActionType where + parseJSON o = do + x <- parseJSON o + let vals = [("no action", NoAction), ("restrict", Restrict), ("cascade", Cascade), ("set null", SetNull), ("set default", SetDefault)] + case lookup x vals of + Just a -> return a + 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" + parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "onDelete" <*> v .:? "onUpdate" parseJSON _ = mzero instance FromJSON PSEmbeddedFieldDef where
groundhog-th.cabal view
@@ -1,11 +1,11 @@ name: groundhog-th-version: 0.2.0+version: 0.3.0 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com> maintainer: Boris Lykah <lykahb@gmail.com>-synopsis: Type-safe ADT-database mapping library.-description: This library helps to generate boilerplate for Groundhog datatypes+synopsis: Type-safe datatype-database mapping library.+description: This library helps to generate instances for Groundhog datatypes. category: Database stability: Non-stable cabal-version: >= 1.6@@ -14,7 +14,7 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9- , groundhog >= 0.2.0 && < 0.3.0+ , groundhog >= 0.3.0 && < 0.4.0 , template-haskell , time >= 1.1.4 , containers >= 0.2