groundhog-th 0.7.0 → 0.7.0.1

raw patch · 3 files changed

+71/−34 lines, 3 filesdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

Database/Groundhog/TH/CodeGen.hs +63/−33
changelog +7/−0
groundhog-th.cabal +1/−1

Database/Groundhog/TH/CodeGen.hs view

@@ -29,11 +29,13 @@ import Database.Groundhog.TH.Settings
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
+import Control.Applicative
 import Control.Arrow (second)
 import Control.Monad (liftM, liftM2, forM, forM_, foldM, filterM, replicateM)
 import Data.Either (lefts, rights)
 import Data.List (findIndex, nub, partition)
 import Data.Maybe (catMaybes, mapMaybe)
+import qualified Text.Read as R
 
 mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedPersistFieldInstance def = do
@@ -119,12 +121,12 @@         return $ doE $ stmts ++ [noBindS expr]
       goPrim xs vars = do
         xs' <- newName "xs"
-        (prim, rest) <- spanM (isPrim . snd) vars
+        (prims, rest) <- spanM (isPrim . snd) vars
         body' <- case rest of
           [] -> return [| return ($result, $(varE xs')) |]
           _  -> goField xs' rest
-        let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prim) (normalB body') []
-        return $ if null prim
+        let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prims) (normalB body') []
+        return $ if null prims
           then caseE (varE xs) [m]
           else caseE (varE xs) [m, failure]
   body <- goPrim values allVars
@@ -151,14 +153,14 @@       return (isFailureUsed, letE stmts expr)
     goPrim xs vars result failure proxy = do
       xs' <- newName "xs"
-      (prim, rest) <- spanM (isPrim . snd) vars
+      (prims, rest) <- spanM (isPrim . snd) vars
       (isFailureUsed, body') <- case rest of
         [] -> return (False, [| ($result, $(varE xs')) |])
         _  -> goField xs' rest result failure proxy
-      let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prim) (normalB body') []
-      return $ if not (null prim)
-         then (True, caseE (varE xs) [m, failure])
-         else (isFailureUsed, caseE (varE xs) [m])
+      let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prims) (normalB body') []
+      return $ if null prims
+         then (isFailureUsed, caseE (varE xs) [m])
+         else (True, caseE (varE xs) [m, failure])
     mkArg proxy (fname, t) = isPrim t >>= \isP -> (if isP then [| fromPrimitivePersistValue $(varE proxy) $(varE fname) |] else (varE fname))
     in do
       xs <- newName "xs"
@@ -326,11 +328,13 @@ mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
 mkKeyEqShowInstances def = do
   let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
-  let keysInfo = maybe [] (\k -> [(thAutoKeyConstrName k, 1)]) (thAutoKey def)
-               ++ map (\k -> (thUniqueKeyConstrName k, length $ thUniqueKeyFields k)) (thUniqueKeys def)
+  let keysInfo = maybe [] (\k -> [(thAutoKeyConstrName k, 1, [t| BackendSpecific |])]) (thAutoKey def)
+               ++ map (\k -> (thUniqueKeyConstrName k, length $ thUniqueKeyFields k, [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName k) |])) (thUniqueKeys def)
+  let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+  typ <- [t| Key $(return entity) $(newName "a" >>= varT) |]
 
   showsPrec' <- let
-    mkClause (cName, fieldsNum) = do
+    mkClause (cName, fieldsNum, _) = do
       p <- newName "p"
       fields <- replicateM fieldsNum (newName "x")
       let pat = conP (mkName cName) $ map varP fields
@@ -341,7 +345,7 @@     in funD 'showsPrec $ map mkClause keysInfo
     
   eq' <- let
-    mkClause (cName, fieldsNum) = do
+    mkClause (cName, fieldsNum, _) = do
       let fields = replicateM fieldsNum (newName "x")
       (fields1, fields2) <- liftM2 (,) fields fields
       let mkPat = conP (mkName cName) . map varP
@@ -351,29 +355,39 @@     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) |]
+  read' <- let
+    mkRead (cName, fieldsNum, u) = do
+      let key = foldl (\a b -> [| $a <*> $b |]) [| $(conE $ mkName cName) <$> R.step R.readPrec |]
+            $ replicate (fieldsNum - 1) [| R.step R.readPrec |]
+          func = lamE [conP 'R.Ident [litP $ StringL cName]] key
+          body = [| R.parens $ R.prec 10 $ R.lexP >>= $func |]
+      keyType <- [t| Key $(return entity) $u |]
+      readPrec' <- funD 'R.readPrec [clause [] (normalB body) []]
+      readListPrec' <- funD 'R.readListPrec [clause [] (normalB [| R.readListPrecDefault |]) []]
+      return $ InstanceD context (AppT (ConT ''Read) keyType) [readPrec', readListPrec']
+    in mapM mkRead keysInfo
+
   return $ if null keysInfo
     then []
-    else [InstanceD context (AppT (ConT ''Eq) typ) [eq'], InstanceD context (AppT (ConT ''Show) typ) [showsPrec']]
+    else [InstanceD context (AppT (ConT ''Eq) typ) [eq'], InstanceD context (AppT (ConT ''Show) typ) [showsPrec']] ++ read'
 
 mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedInstance def = do
   let types = map extractType $ thEmbeddedTypeParams def
-  let embedded = foldl AppT (ConT (thEmbeddedName def)) types
-  let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
+      embedded = foldl AppT (ConT (thEmbeddedName def)) types
+      context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
   mkEmbeddedInstance' embedded (thEmbeddedFields def) context
   
 mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec]
 mkEmbeddedInstance' dataType fDefs context = do
   selector' <- do
     fParam <- newName "f"
-    let mkField field = ForallC [] ([EqualP (VarT fParam) (thFieldType field)]) $ NormalC (mkName $ thExprName field) []
+    let mkField field = ForallC [] ([equalP' (VarT fParam) (thFieldType field)]) $ NormalC (mkName $ thExprName field) []
     return $ DataInstD [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []
 
   selectorNum' <- do
     let mkClause fNum field = clause [conP (mkName $ thExprName field) []] (normalB $ lift fNum) []
-    let clauses = zipWith mkClause [0 :: Int ..] fDefs
+        clauses = zipWith mkClause [0 :: Int ..] fDefs
     funD 'selectorNum clauses
 
   let decs = [selector', selectorNum']
@@ -386,7 +400,7 @@     v <- newName "v"
     let name = mkName $ thPhantomConstrName c
     phantom <- [t| ConstructorMarker $(return entity) |]
-    let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
+    let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
     return $ DataD [] name [PlainTV v] [constr] []
   
 mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
@@ -405,7 +419,7 @@         v <- newName "v"
         let name = mkName $ thUniqueKeyPhantomName u
         phantom <- [t| UniqueMarker $(return entity) |]
-        let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
+        let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
         return [DataD [] name [PlainTV v] [constr] []]
       else return []
     
@@ -419,14 +433,14 @@       Nothing -> return []
       Just k -> do
         keyDescr <- [t| BackendSpecific |]
-        return [ForallC [] [EqualP (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(NotStrict, ConT ''PersistValue)]]
+        return [ForallC [] [equalP' (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(NotStrict, ConT ''PersistValue)]]
     uniques <- forM (thUniqueKeys def) $ \unique -> do
       uniqType <- [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |]
       let cDef = head $ thConstructors def
           uniqFieldNames = lefts $ thUniqueFields $ findOne "unique" thUniqueName (thUniqueKeyName unique) $ thConstrUniques cDef
           uniqFields = concat $ flip map uniqFieldNames $ \name -> (filter ((== name) . thFieldName) $ thConstrFields cDef)
           uniqFields' = map (\f -> (NotStrict, thFieldType f)) uniqFields
-      return $ ForallC [] [EqualP (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'
+      return $ ForallC [] [equalP' (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'
     return $ DataInstD [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []
 
   autoKey' <- do
@@ -452,7 +466,7 @@   fields' <- do
     cParam <- newName "c"
     fParam <- newName "f"
-    let mkField name field = ForallC [] [EqualP (VarT cParam) (ConT name), EqualP (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) []
+    let mkField name field = ForallC [] [equalP' (VarT cParam) (ConT name), equalP' (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) []
     let f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrFields cdef
     let constrs = concatMap f $ thConstructors def
     return $ DataInstD [] ''Field [entity, VarT cParam, VarT fParam] constrs []
@@ -652,7 +666,7 @@ 
 mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
 mkPrimitivePersistFieldInstance def = do
-  let prim = ConT (thPrimitiveName def)
+  let primitive = ConT (thPrimitiveName def)
   persistName' <- do
     let body = normalB $ stringE $ nameBase $ thPrimitiveName def
     funD 'persistName $ [ clause [wildP] body [] ]
@@ -664,13 +678,13 @@           else [| DbTypePrimitive DbInt32  False Nothing Nothing |]
     funD 'dbType $ [ clause [wildP, wildP] (normalB typ) [] ]
   let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-  return [ InstanceD [] (AppT (ConT ''PersistField) prim) decs
-         , InstanceD [] (AppT (ConT ''NeverNull) prim) []
+  return [ InstanceD [] (AppT (ConT ''PersistField) primitive) decs
+         , InstanceD [] (AppT (ConT ''NeverNull) primitive) []
          ]
 
 mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
 mkPrimitivePrimitivePersistFieldInstance def = do
-  let prim = ConT (thPrimitiveName def)
+  let primitive = ConT (thPrimitiveName def)
   toPrim' <- do
     proxy <- newName "p"
     x <- newName "x"
@@ -689,9 +703,9 @@     funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []]
   let context = []
   let decs = [toPrim', fromPrim']
-  sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) prim) decs
-           , mkDefaultPurePersistFieldInstance context prim
-           , mkDefaultSinglePersistFieldInstance context prim]
+  sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) primitive) decs
+           , mkDefaultPurePersistFieldInstance context primitive
+           , mkDefaultSinglePersistFieldInstance context primitive]
 
 mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
 mkMigrateFunction name defs = do
@@ -718,7 +732,7 @@ 
 paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt
 paramsContext types fields = classPred ''PersistField params ++ classPred ''SinglePersistField maybys ++ classPred ''NeverNull maybys where
-  classPred clazz = map (\t -> ClassP clazz [t])
+  classPred clazz = map (\t -> classP' clazz [t])
   -- every type must be an instance of PersistField
   params = map extractType types
   -- all datatype fields also must be instances of PersistField
@@ -734,7 +748,7 @@   return $ case invalid of
     [] -> Just $ classPred ''PurePersistField params ++ classPred ''PrimitivePersistField maybys ++ classPred ''NeverNull maybys where
           params = map extractType types
-          classPred clazz = map (\t -> ClassP clazz [t])
+          classPred clazz = map (\t -> classP' clazz [t])
           -- all datatype fields also must be instances of PersistField
           -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
           -- so that (Maybe param) is an instance of PersistField
@@ -810,3 +824,19 @@ #else
   TySynInstD name ts t
 #endif
+
+classP' :: Name -> [Type] -> Pred
+classP' name ts =
+#if MIN_VERSION_template_haskell(2, 10, 0)
+  foldl AppT (ConT name) ts
+#else
+  ClassP name ts
+#endif
+
+equalP' :: Type -> Type -> Pred
+equalP' t1 t2 =
+#if MIN_VERSION_template_haskell(2, 10, 0)
+  foldl AppT EqualityT [t1, t2]
+#else
+  EqualP t1 t2
+#endif

changelog view

@@ -1,3 +1,10 @@+0.7.0.1+* Compatibility with template-haskell-2.10++0.7.0+* Instances of ToJSON for settings+* Refactoring and export of some utility functions+ 0.6.0 * Entities without keys. It can be useful for many-to-many tables which hold keys but are not referenced * Entity and fields descriptions are parameterized so that they can be promoted

groundhog-th.cabal view

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