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