[project @ 2004-02-24 19:51:11 by ralf]
[packages/random.git] / Data / Generics / Twins.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Data.Generics.Twins
4 -- Copyright : (c) The University of Glasgow, CWI 2001--2003
5 -- License : BSD-style (see the file libraries/base/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable
10 --
11 -- \"Scrap your boilerplate\" --- Generic programming in Haskell
12 -- See <http://www.cs.vu.nl/boilerplate/>. The present module
13 -- provides support for multi-parameter traversal, which is also
14 -- demonstrated with generic operations like equality.
15 --
16 -----------------------------------------------------------------------------
17
18 module Data.Generics.Twins (
19
20 -- * Generic folds and maps that also accumulate
21 gfoldlAccum,
22 gmapAccumT,
23 gmapAccumM,
24 gmapAccumQl,
25 gmapAccumQr,
26 gmapAccumQ,
27
28 -- * Mapping combinators for twin traversal
29 gzipWithT,
30 gzipWithM,
31 gzipWithQ,
32
33 -- * Typical twin traversals
34 geq,
35 gzip
36
37 ) where
38
39
40 ------------------------------------------------------------------------------
41
42 #ifdef __HADDOCK__
43 import Prelude
44 #endif
45 import Data.Generics.Basics
46 import Data.Generics.Aliases
47
48 ------------------------------------------------------------------------------
49
50
51 ------------------------------------------------------------------------------
52 --
53 -- Generic folds and maps that also accumulate
54 --
55 ------------------------------------------------------------------------------
56
57 {--------------------------------------------------------------
58
59 A list map can be elaborated to perform accumulation.
60 In the same sense, we can elaborate generic maps over terms.
61
62 We recall the type of map:
63 map :: (a -> b) -> [a] -> [b]
64
65 We recall the type of an accumulating map (see Data.List):
66 mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
67
68 Applying the same scheme we obtain an accumulating gfoldl.
69
70 --------------------------------------------------------------}
71
72 -- | gfoldl with accumulation
73
74 gfoldlAccum :: Data d
75 => (forall d r. Data d => a -> c (d -> r) -> d -> (a, c r))
76 -> (forall g. a -> g -> (a, c g))
77 -> a -> d -> (a, c d)
78
79 gfoldlAccum k z a d = unA (gfoldl k' z' d) a
80 where
81 k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)
82 z' f = A (\a -> z a f)
83
84
85 -- | A type constructor for accumulation
86 newtype A a c d = A (a -> (a, c d))
87 unA (A f) = f
88
89
90 -- | gmapT with accumulation
91 gmapAccumT :: Data d
92 => (forall d. Data d => a -> d -> (a,d))
93 -> a -> d -> (a, d)
94 gmapAccumT f a d = let (a',d') = gfoldlAccum k z a d
95 in (a',unID d')
96 where
97 k a (ID c) d = let (a',d') = f a d
98 in (a', ID (c d'))
99 z a x = (a, ID x)
100
101
102 -- | gmapT with accumulation
103 gmapAccumM :: (Data d, Monad m)
104 => (forall d. Data d => a -> d -> (a, m d))
105 -> a -> d -> (a, m d)
106 gmapAccumM f = gfoldlAccum k z
107 where
108 k a c d = let (a',d') = f a d
109 in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))
110 z a x = (a, return x)
111
112
113 -- | gmapQl with accumulation
114 gmapAccumQl :: Data d
115 => (r -> r' -> r)
116 -> r
117 -> (forall d. Data d => a -> d -> (a,r'))
118 -> a -> d -> (a, r)
119 gmapAccumQl o r f a d = let (a',r) = gfoldlAccum k z a d
120 in (a',unCONST r)
121 where
122 k a (CONST c) d = let (a',r') = f a d
123 in (a', CONST (c `o` r'))
124 z a _ = (a, CONST r)
125
126
127 -- | gmapQr with accumulation
128 gmapAccumQr :: Data d
129 => (r' -> r -> r)
130 -> r
131 -> (forall d. Data d => a -> d -> (a,r'))
132 -> a -> d -> (a, r)
133 gmapAccumQr o r f a d = let (a',l) = gfoldlAccum k z a d
134 in (a',unQr l r)
135 where
136 k a (Qr c) d = let (a',r') = f a d
137 in (a', Qr (\r -> c (r' `o` r)))
138 z a _ = (a, Qr id)
139
140
141 -- | gmapQ with accumulation
142 gmapAccumQ :: Data d
143 => (forall d. Data d => a -> d -> (a,q))
144 -> a -> d -> (a, [q])
145 gmapAccumQ f = gmapAccumQr (:) [] f
146
147
148
149 ------------------------------------------------------------------------------
150 --
151 -- Helper type constructors
152 --
153 ------------------------------------------------------------------------------
154
155
156 -- | The identity type constructor needed for the definition of gmapAccumT
157 newtype ID x = ID { unID :: x }
158
159
160 -- | The constant type constructor needed for the definition of gmapAccumQl
161 newtype CONST c a = CONST { unCONST :: c }
162
163
164 -- | The type constructor needed for the definition of gmapAccumQr
165 newtype Qr r a = Qr { unQr :: r -> r }
166
167
168
169 ------------------------------------------------------------------------------
170 --
171 -- Mapping combinators for twin traversal
172 --
173 ------------------------------------------------------------------------------
174
175
176 -- | Twin map for transformation
177 gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)
178 gzipWithT f x y = case gmapAccumT perkid funs y of
179 ([], c) -> c
180 _ -> error "gzipWithT"
181 where
182 perkid a d = (tail a, unGenericT' (head a) d)
183 funs = gmapQ (\k -> GenericT' (f k)) x
184
185
186
187 -- | Twin map for monadic transformation
188 gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
189 gzipWithM f x y = case gmapAccumM perkid funs y of
190 ([], c) -> c
191 _ -> error "gzipWithM"
192 where
193 perkid a d = (tail a, unGenericM' (head a) d)
194 funs = gmapQ (\k -> GenericM' (f k)) x
195
196
197 -- | Twin map for monadic transformation
198 gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
199 gzipWithQ f x y = case gmapAccumQ perkid funs y of
200 ([], r) -> r
201 _ -> error "gzipWithQ"
202 where
203 perkid a d = (tail a, unGenericQ' (head a) d)
204 funs = gmapQ (\k -> GenericQ' (f k)) x
205
206
207
208 ------------------------------------------------------------------------------
209 --
210 -- Typical twin traversals
211 --
212 ------------------------------------------------------------------------------
213
214 -- | Generic equality: an alternative to \"deriving Eq\"
215 geq :: Data a => a -> a -> Bool
216
217 {-
218
219 Testing for equality of two terms goes like this. Firstly, we
220 establish the equality of the two top-level datatype
221 constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
222 to compare the two lists of immediate subterms.
223
224 (Note for the experts: the type of the worker geq' is rather general
225 but precision is recovered via the restrictive type of the top-level
226 operation geq. The imprecision of geq' is caused by the type system's
227 unability to express the type equivalence for the corresponding
228 couples of immediate subterms from the two given input terms.)
229
230 -}
231
232 geq x y = geq' x y
233 where
234 geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
235 geq' x y = (toConstr x == toConstr y)
236 && and (gzipWithQ geq' x y)
237
238
239 -- | Generic zip controlled by a function with type-specific branches
240 gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b)
241 -> (forall a b. (Data a, Data b) => a -> b -> Maybe b)
242
243 -- See testsuite/.../Generics/gzip.hs for an illustration
244 gzip f x y =
245 f x y
246 `orElse`
247 if toConstr x == toConstr y
248 then gzipWithM (gzip f) x y
249 else Nothing