groundhog-th 0.3.0.2 → 0.3.1
raw patch · 3 files changed
+56/−59 lines, 3 filesdep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: groundhog
API changes (from Hackage documentation)
Files
- Database/Groundhog/TH.hs +6/−5
- Database/Groundhog/TH/CodeGen.hs +48/−52
- groundhog-th.cabal +2/−2
Database/Groundhog/TH.hs view
@@ -404,7 +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+-- \# schema: public # 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\"@@ -420,18 +420,19 @@ -- - name: First # Mandatory. Constructor name -- phantomName: FooBarConstructor # Constructor phantom type name used to guarantee type safety -- dbName: First # Name of constructor table which is created only for datatypes with multiple constructors+-- keyDbName: id # Name for the primary key column -- fields: # List of constructor fields. If you don't change a field, you can omit it -- - 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--- thExprName: FooField # Name of a field used in expressions+-- 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 -- - name: bar -- dbName: bar--- thExprName: BarField+-- exprName: BarField -- # For some databases \"type: integer\" would be appropriate -- - name: next -- dbName: next--- thExprName: NextField+-- 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@@ -526,7 +527,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
@@ -214,9 +214,25 @@ fromPrim' <- funD 'fromPrimitivePersistValue [clause [wildP] (normalB $ conE conName) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) let decs = [toPrim', fromPrim'] - return [InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs] + sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs + , mkDefaultPurePersistFieldInstance context keyType + , mkDefaultSinglePersistFieldInstance context keyType] _ -> return [] +mkDefaultPurePersistFieldInstance :: Cxt -> Type -> Q Dec +mkDefaultPurePersistFieldInstance context typ = do + toPurePersistValues' <- funD 'toPurePersistValues [clause [] (normalB [| primToPurePersistValues |]) []] + fromPurePersistValues' <- funD 'fromPurePersistValues [clause [] (normalB [| primFromPurePersistValues |]) []] + let decs = [toPurePersistValues', fromPurePersistValues'] + return $ InstanceD context (AppT (ConT ''PurePersistField) typ) decs + +mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec +mkDefaultSinglePersistFieldInstance context typ = do + toSinglePersistValue' <- funD 'toSinglePersistValue [clause [] (normalB [| primToSinglePersistValue |]) []] + fromSinglePersistValue' <- funD 'fromSinglePersistValue [clause [] (normalB [| primFromSinglePersistValue |]) []] + let decs = [toSinglePersistValue', fromSinglePersistValue'] + return $ InstanceD context (AppT (ConT ''SinglePersistField) typ) decs + mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec] mkUniqueKeysIsUniqueInstances def = do let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def @@ -291,49 +307,43 @@ funD 'toPrimitivePersistValue [clause [varP proxy, conP conName [varP x]] (normalB [| toPrimitivePersistValue $(varE proxy) $(varE x) |]) []] fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE proxy) $(varE x)) |]) []] let decs = [toPrim', fromPrim'] - return [InstanceD context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs] + sequence [ return $ InstanceD context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs + , mkDefaultPurePersistFieldInstance context uniqKeyType + , mkDefaultSinglePersistFieldInstance context uniqKeyType] else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context mkKeyEqShowInstances :: THEntityDef -> Q [Dec] mkKeyEqShowInstances def = do let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - let mkShowInstance typ cName fieldsNum = do - showsPrec' <- do - p <- newName "p" - fields <- replicateM fieldsNum (newName "x") - let pat = conP (mkName cName) $ map varP fields - --let shownArgs = foldr1 (\a b -> [| $a ++ $b |]) $ map (\a -> [| show $(varE a) |]) fields - --let body = [| $(lift $ cName ++ " ") ++ $shownArgs |] - - let showC = [| showString $(lift $ cName ++ " ") |] - let showArgs = foldr1 (\a b -> [| $a . showString " " . $b |]) $ map (\a -> [| showsPrec 11 $(varE a) |]) fields - let body = [| showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs) |] - funD 'showsPrec [clause [varP p, pat] (normalB body) []] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [showsPrec'] - return $ InstanceD context (AppT (ConT ''Show) typ) decs - let mkEqInstance typ cName fieldsNum = do - eq' <- do - let fields = replicateM fieldsNum (newName "x") - (fields1, fields2) <- liftM2 (,) fields fields - let mkPat = conP (mkName cName) . map varP - let body = foldr1 (\e1 e2 -> [| $e1 && $e2 |]) $ zipWith (\n1 n2 -> [| $(varE n1) == $(varE n2) |]) fields1 fields2 - funD '(==) [clause [mkPat fields1, mkPat fields2] (normalB body) []] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [eq'] - return $ InstanceD context (AppT (ConT ''Eq) typ) decs + let forKeys f = maybe [] (\k -> [f (thAutoKeyConstrName k) 1]) (thAutoKey def) + ++ map (\k -> f (thUniqueKeyConstrName k) (length $ thUniqueKeyFields k)) (thUniqueKeys def) + + showsPrec' <- let + mkClause cName fieldsNum = do + p <- newName "p" + fields <- replicateM fieldsNum (newName "x") + let pat = conP (mkName cName) $ map varP fields + showC = [| showString $(lift $ cName ++ " ") |] + showArgs = foldr1 (\a b -> [| $a . showString " " . $b |]) $ map (\a -> [| showsPrec 11 $(varE a) |]) fields + body = [| showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs) |] + clause [varP p, pat] (normalB body) [] + in funD 'showsPrec $ forKeys mkClause - autoKeyInstance <- case thAutoKey def of - Nothing -> return [] - Just autoKey -> do - keyType <- [t| Key $(return entity) BackendSpecific |] - mapM (\f -> f keyType (thAutoKeyConstrName autoKey) 1) [mkShowInstance, mkEqInstance] - uniqsInstances <- forM (thUniqueKeys def) $ \unique -> do - uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - let fieldsNum = length $ thUniqueKeyFields unique - mapM (\f -> f uniqKeyType (thUniqueKeyConstrName unique) fieldsNum) [mkShowInstance, mkEqInstance] - return $ autoKeyInstance ++ concat uniqsInstances + eq' <- let + mkClause cName fieldsNum = do + let fields = replicateM fieldsNum (newName "x") + (fields1, fields2) <- liftM2 (,) fields fields + let mkPat = conP (mkName cName) . map varP + body = foldr1 (\e1 e2 -> [| $e1 && $e2 |]) $ zipWith (\n1 n2 -> [| $(varE n1) == $(varE n2) |]) fields1 fields2 + clause [mkPat fields1, mkPat fields2] (normalB body) [] + clauses = forKeys mkClause + noMatch = if length clauses > 1 then [clause [wildP, wildP] (normalB [| False |]) []] else [] + in funD '(==) $ clauses ++ noMatch + let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) + typ <- [t| Key $(return entity) $(newName "a" >>= varT) |] + return $ [InstanceD context (AppT (ConT ''Eq) typ) [eq'], InstanceD context (AppT (ConT ''Show) typ) [showsPrec']] + mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec] mkEmbeddedInstance def = do let types = map extractType $ thEmbeddedTypeParams def @@ -701,13 +711,7 @@ (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) |] @@ -719,11 +723,3 @@ t3 = case thEmbeddedDef f of Nothing -> t2 Just emb -> [| applyEmbeddedDbTypeSettings $(lift emb) $t2 |] - - {- - - applyEmbeddedDbTypeSettings - (1, 2) Embedded - Key Entity Embedded - Entity PersistEntity - -}
groundhog-th.cabal view
@@ -1,5 +1,5 @@ name: groundhog-th-version: 0.3.0.2+version: 0.3.1 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.0 && < 0.4.0+ , groundhog >= 0.3.1 && < 0.4.0 , template-haskell , time >= 1.1.4 , containers >= 0.2