1 -----------------------------------------------------------------------------
3 -- Module : Data.Generics.Twins
4 -- Copyright : (c) The University of Glasgow, CWI 2001--2004
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable (local universal quantification)
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.
16 -----------------------------------------------------------------------------
18 module Data.Generics.Twins (
20 -- * Generic folds and maps that also accumulate
28 -- * Mapping combinators for twin traversal
33 -- * Typical twin traversals
40 ------------------------------------------------------------------------------
45 import Data.Generics.Basics
46 import Data.Generics.Aliases
48 #ifdef __GLASGOW_HASKELL__
49 import Prelude hiding ( GT )
52 ------------------------------------------------------------------------------
55 ------------------------------------------------------------------------------
57 -- Generic folds and maps that also accumulate
59 ------------------------------------------------------------------------------
61 {--------------------------------------------------------------
63 A list map can be elaborated to perform accumulation.
64 In the same sense, we can elaborate generic maps over terms.
66 We recall the type of map:
67 map :: (a -> b) -> [a] -> [b]
69 We recall the type of an accumulating map (see Data.List):
70 mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
72 Applying the same scheme we obtain an accumulating gfoldl.
74 --------------------------------------------------------------}
76 -- | gfoldl with accumulation
79 => (forall d r. Data d => a -> c (d -> r) -> d -> (a, c r))
80 -> (forall g. a -> g -> (a, c g))
83 gfoldlAccum k z a d = unA (gfoldl k' z' d) a
85 k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)
86 z' f = A (\a -> z a f)
89 -- | A type constructor for accumulation
90 newtype A a c d = A { unA :: a -> (a, c d) }
93 -- | gmapT with accumulation
95 => (forall d. Data d => a -> d -> (a,d))
97 gmapAccumT f a d = let (a',d') = gfoldlAccum k z a d
100 k a (ID c) d = let (a',d') = f a d
105 -- | gmapM with accumulation
106 gmapAccumM :: (Data d, Monad m)
107 => (forall d. Data d => a -> d -> (a, m d))
108 -> a -> d -> (a, m d)
109 gmapAccumM f = gfoldlAccum k z
111 k a c d = let (a',d') = f a d
112 in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))
113 z a x = (a, return x)
116 -- | gmapQl with accumulation
117 gmapAccumQl :: Data d
120 -> (forall d. Data d => a -> d -> (a,r'))
122 gmapAccumQl o r f a d = let (a',r) = gfoldlAccum k z a d
125 k a (CONST c) d = let (a',r') = f a d
126 in (a', CONST (c `o` r'))
130 -- | gmapQr with accumulation
131 gmapAccumQr :: Data d
134 -> (forall d. Data d => a -> d -> (a,r'))
136 gmapAccumQr o r f a d = let (a',l) = gfoldlAccum k z a d
139 k a (Qr c) d = let (a',r') = f a d
140 in (a', Qr (\r -> c (r' `o` r)))
144 -- | gmapQ with accumulation
146 => (forall d. Data d => a -> d -> (a,q))
147 -> a -> d -> (a, [q])
148 gmapAccumQ f = gmapAccumQr (:) [] f
152 ------------------------------------------------------------------------------
154 -- Helper type constructors
156 ------------------------------------------------------------------------------
159 -- | The identity type constructor needed for the definition of gmapAccumT
160 newtype ID x = ID { unID :: x }
163 -- | The constant type constructor needed for the definition of gmapAccumQl
164 newtype CONST c a = CONST { unCONST :: c }
167 -- | The type constructor needed for the definition of gmapAccumQr
168 newtype Qr r a = Qr { unQr :: r -> r }
172 ------------------------------------------------------------------------------
174 -- Mapping combinators for twin traversal
176 ------------------------------------------------------------------------------
179 -- | Twin map for transformation
180 gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)
181 gzipWithT f x y = case gmapAccumT perkid funs y of
183 _ -> error "gzipWithT"
185 perkid a d = (tail a, unGT (head a) d)
186 funs = gmapQ (\k -> GT (f k)) x
190 -- | Twin map for monadic transformation
191 gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
192 gzipWithM f x y = case gmapAccumM perkid funs y of
194 _ -> error "gzipWithM"
196 perkid a d = (tail a, unGM (head a) d)
197 funs = gmapQ (\k -> GM (f k)) x
200 -- | Twin map for queries
201 gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
202 gzipWithQ f x y = case gmapAccumQ perkid funs y of
204 _ -> error "gzipWithQ"
206 perkid a d = (tail a, unGQ (head a) d)
207 funs = gmapQ (\k -> GQ (f k)) x
211 ------------------------------------------------------------------------------
213 -- Typical twin traversals
215 ------------------------------------------------------------------------------
217 -- | Generic equality: an alternative to \"deriving Eq\"
218 geq :: Data a => a -> a -> Bool
222 Testing for equality of two terms goes like this. Firstly, we
223 establish the equality of the two top-level datatype
224 constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
225 to compare the two lists of immediate subterms.
227 (Note for the experts: the type of the worker geq' is rather general
228 but precision is recovered via the restrictive type of the top-level
229 operation geq. The imprecision of geq' is caused by the type system's
230 unability to express the type equivalence for the corresponding
231 couples of immediate subterms from the two given input terms.)
237 geq' :: GenericQ (GenericQ Bool)
238 geq' x y = (toConstr x == toConstr y)
239 && and (gzipWithQ geq' x y)
242 -- | Generic zip controlled by a function with type-specific branches
243 gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)
244 -- See testsuite/.../Generics/gzip.hs for an illustration
248 if toConstr x == toConstr y
249 then gzipWithM (gzip f) x y