Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 5 commits
  • 3 files changed
  • 0 comments
  • 1 contributor
Mar 14, 2013
Roman Cheplyaka Change TH name for the context 106e49f
Roman Cheplyaka Use getDataInfo in deriveGTraversable b0298fe
Roman Cheplyaka Change constraint generation algorithm
Now the algorithm is this:

* Generate GTraversable constraint for every type parameter
* Generate 'c' constraint for types of all data constructor fields

(previously, we generated 'c' constraints only for type parameters)
6ab0d81
Roman Cheplyaka Make 'c' superclass of GTraversable d12da16
Roman Cheplyaka Change constraint generation algorithm
GTraversable constraints are generated for every field type, except the type for
which we're deriving the instance

'c' constraints are generated for every field type, plus the type for
which we're deriving the instance
137eacd
2  Data/Generics/Traversable/Core.hs
@@ -4,7 +4,7 @@ module Data.Generics.Traversable.Core where
4 4
 import GHC.Exts (Constraint)
5 5
 import Control.Applicative
6 6
 
7  
-class GTraversable (c :: * -> Constraint) a where
  7
+class c a => GTraversable (c :: * -> Constraint) a where
8 8
   -- | Applicative traversal over (a subset of) immediate subterms. This is
9 9
   -- a generic version of 'traverse' from "Data.Traversable".
10 10
   --
18  Data/Generics/Traversable/Instances.hs
@@ -7,14 +7,14 @@ import Data.Generics.Traversable.Core
7 7
 import Data.Generics.Traversable.TH
8 8
 import Control.Applicative
9 9
 
10  
-instance GTraversable c ()
11  
-instance GTraversable c Bool
12  
-instance GTraversable c Int
13  
-instance GTraversable c Integer
14  
-instance GTraversable c Float
15  
-instance GTraversable c Double
16  
-instance GTraversable c Char
17  
-instance GTraversable c Ordering
  10
+instance c () => GTraversable c ()
  11
+instance c Bool => GTraversable c Bool
  12
+instance c Int => GTraversable c Int
  13
+instance c Integer => GTraversable c Integer
  14
+instance c Float => GTraversable c Float
  15
+instance c Double => GTraversable c Double
  16
+instance c Char => GTraversable c Char
  17
+instance c Ordering => GTraversable c Ordering
18 18
 
19 19
 deriveGTraversable ''Maybe
20 20
 deriveGTraversable ''Either
@@ -22,7 +22,7 @@ deriveGTraversable ''(,)
22 22
 deriveGTraversable ''(,,)
23 23
 
24 24
 -- Uniform instance for lists
25  
-instance (GTraversable c a, c a) => GTraversable c [a] where
  25
+instance (GTraversable c a, c a, c [a]) => GTraversable c [a] where
26 26
   gtraverse f = go where
27 27
     go [] = pure []
28 28
     go (x:xs) = (:) <$> f x <*> go xs
39  Data/Generics/Traversable/TH.hs
@@ -12,6 +12,7 @@ import Language.Haskell.TH
12 12
 import Control.Monad
13 13
 import Data.Generics.Traversable.Core
14 14
 import Control.Applicative
  15
+import Data.List
15 16
 
16 17
 err s = error $ "Data.Generics.Traversable.TH: " ++ s
17 18
 
@@ -41,7 +42,7 @@ gtraverseExpr typeName = do
41 42
     lam = lamE [varP f, varP x] $ caseE (varE x) matches
42 43
 
43 44
     -- Con a1 ... -> pure Con <*> f a1 <*> ...
44  
-    mkMatch (c, n)
  45
+    mkMatch (c, n, _)
45 46
      = do args <- replicateM n (newName "arg")
46 47
           let
47 48
             applyF e arg =
@@ -71,42 +72,32 @@ gtraverseExpr typeName = do
71 72
 deriveGTraversable :: Name -> Q [Dec]
72 73
 deriveGTraversable name = do
73 74
   info <- reify name
74  
-  ctx <- newName "cxt"
  75
+  ctx <- newName "c"
75 76
 
76  
-  let
77  
-    decl =
78  
-      case info of
79  
-        TyConI d -> d
80  
-        _ -> error ("can't be used on anything but a type constructor of an algebraic data type")
81  
-
82  
-    (typeName, typeParams, _) =
83  
-      case decl of
84  
-        DataD    _ n ps cs _ -> (n, map varName ps, map conA cs)
85  
-        NewtypeD _ n ps c  _ -> (n, map varName ps, [conA c])
86  
-        _ -> err ("not a data type declaration: " ++ show decl)
  77
+  (typeName, typeParams, constructors) <- getDataInfo name
87 78
 
88  
-    appliedType = foldl appT (conT typeName) $ map varT typeParams
  79
+  let
  80
+    appliedType = foldl AppT (ConT typeName) $ map VarT typeParams
89 81
 
90 82
     -- instance (...) => GTraversable ctx MyType where { ... }
91 83
     inst =
92  
-      instanceD context (conT ''GTraversable `appT` varT ctx `appT` appliedType) [ do
  84
+      instanceD context (conT ''GTraversable `appT` varT ctx `appT` pure appliedType) [ do
93 85
           -- gtraverse = ...
94  
-          funD 'gtraverse [ clause [] (normalB $ gtraverseExpr typeName) [] ] 
  86
+          funD 'gtraverse [ clause [] (normalB $ gtraverseExpr typeName) [] ]
95 87
         ]
96 88
 
97  
-    context = cxt $ concatMap mkCxt typeParams
  89
+    context = sequence $ gtraversableContext ++ userContext
  90
+
  91
+    types = filter (/= appliedType) $ nub [ t | (_,_,ts) <- constructors, t <- ts ]
98 92
 
99  
-    mkCxt name =
100  
-      let tv = varT name
101  
-      in [ classP ''GTraversable [varT ctx, tv]
102  
-         , classP ctx [tv]
103  
-         ]
  93
+    userContext = [ classP ctx [pure t] | t <- appliedType : types ]
  94
+    gtraversableContext = [ classP ''GTraversable [varT ctx, pure t] | t <- types ]
104 95
 
105 96
   sequence [inst]
106 97
 
107  
-conA (NormalC c xs)   = (c, length xs)
  98
+conA (NormalC c xs)   = (c, length xs, map snd xs)
108 99
 conA (InfixC x1 c x2) = conA (NormalC c [x1, x2])
109 100
 conA (ForallC _ _ c)  = conA c
110  
-conA (RecC c xs)      = (c, length xs)
  101
+conA (RecC c xs)      = (c, length xs, map (\(_,_,t)->t) xs)
111 102
 varName (PlainTV n) = n
112 103
 varName (KindedTV n _) = n

No commit comments for this range

Something went wrong with that request. Please try again.