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