Data/Generics/Twins.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   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)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (local universal quantification)
  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 #ifdef __GLASGOW_HASKELL__
  49 import Prelude hiding ( GT )
  50 #endif
  51
  52 ------------------------------------------------------------------------------
  53
  54
  55 ------------------------------------------------------------------------------
  56 --
  57 --      Generic folds and maps that also accumulate
  58 --
  59 ------------------------------------------------------------------------------
  60
  61 {--------------------------------------------------------------
  62
  63 A list map can be elaborated to perform accumulation.
  64 In the same sense, we can elaborate generic maps over terms.
  65
  66 We recall the type of map:
  67 map :: (a -> b) -> [a] -> [b]
  68
  69 We recall the type of an accumulating map (see Data.List):
  70 mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
  71
  72 Applying the same scheme we obtain an accumulating gfoldl.
  73
  74 --------------------------------------------------------------}
  75
  76 -- | gfoldl with accumulation
  77
  78 gfoldlAccum :: Data d
  79             => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))
  80             -> (forall g. a -> g -> (a, c g))
  81             -> a -> d -> (a, c d)
  82
  83 gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0
  84  where
  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)
  87
  88
  89 -- | A type constructor for accumulation
  90 newtype A a c d = A { unA :: a -> (a, c d) }
  91
  92
  93 -- | gmapT with accumulation
  94 gmapAccumT :: Data d
  95            => (forall e. Data e => a -> e -> (a,e))
  96            -> a -> d -> (a, d)
  97 gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0
  98                      in (a1, unID d1)
  99  where
 100   k a (ID c) d = let (a',d') = f a d
 101                   in (a', ID (c d'))
 102   z a x = (a, ID x)
 103
 104
 105 -- | gmapM with accumulation
 106 gmapAccumM :: (Data d, Monad m)
 107            => (forall e. Data e => a -> e -> (a, m e))
 108            -> a -> d -> (a, m d)
 109 gmapAccumM f = gfoldlAccum k z
 110  where
 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)
 114
 115
 116 -- | gmapQl with accumulation
 117 gmapAccumQl :: Data d
 118             => (r -> r' -> r)
 119             -> r
 120             -> (forall e. Data e => a -> e -> (a,r'))
 121             -> a -> d -> (a, r)
 122 gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0
 123                            in (a1, unCONST r1)
 124  where
 125   k a (CONST c) d = let (a', r) = f a d
 126                      in (a', CONST (c `o` r))
 127   z a _ = (a, CONST r0)
 128
 129
 130 -- | gmapQr with accumulation
 131 gmapAccumQr :: Data d
 132             => (r' -> r -> r)
 133             -> r
 134             -> (forall e. Data e => a -> e -> (a,r'))
 135             -> a -> d -> (a, r)
 136 gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0
 137                            in (a1, unQr l r0)
 138  where
 139   k a (Qr c) d = let (a',r') = f a d
 140                   in (a', Qr (\r -> c (r' `o` r)))
 141   z a _ = (a, Qr id)
 142
 143
 144 -- | gmapQ with accumulation
 145 gmapAccumQ :: Data d
 146            => (forall e. Data e => a -> e -> (a,q))
 147            -> a -> d -> (a, [q])
 148 gmapAccumQ f = gmapAccumQr (:) [] f
 149
 150
 151
 152 ------------------------------------------------------------------------------
 153 --
 154 --      Helper type constructors
 155 --
 156 ------------------------------------------------------------------------------
 157
 158
 159 -- | The identity type constructor needed for the definition of gmapAccumT
 160 newtype ID x = ID { unID :: x }
 161
 162
 163 -- | The constant type constructor needed for the definition of gmapAccumQl
 164 newtype CONST c a = CONST { unCONST :: c }
 165
 166
 167 -- | The type constructor needed for the definition of gmapAccumQr
 168 newtype Qr r a = Qr { unQr  :: r -> r }
 169
 170
 171
 172 ------------------------------------------------------------------------------
 173 --
 174 --      Mapping combinators for twin traversal
 175 --
 176 ------------------------------------------------------------------------------
 177
 178
 179 -- | Twin map for transformation
 180 gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)
 181 gzipWithT f x y = case gmapAccumT perkid funs y of
 182                     ([], c) -> c
 183                     _       -> error "gzipWithT"
 184  where
 185   perkid a d = (tail a, unGT (head a) d)
 186   funs = gmapQ (\k -> GT (f k)) x
 187
 188
 189
 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
 193                     ([], c) -> c
 194                     _       -> error "gzipWithM"
 195  where
 196   perkid a d = (tail a, unGM (head a) d)
 197   funs = gmapQ (\k -> GM (f k)) x
 198
 199
 200 -- | Twin map for queries
 201 gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
 202 gzipWithQ f x y = case gmapAccumQ perkid funs y of
 203                    ([], r) -> r
 204                    _       -> error "gzipWithQ"
 205  where
 206   perkid a d = (tail a, unGQ (head a) d)
 207   funs = gmapQ (\k -> GQ (f k)) x
 208
 209
 210
 211 ------------------------------------------------------------------------------
 212 --
 213 --      Typical twin traversals
 214 --
 215 ------------------------------------------------------------------------------
 216
 217 -- | Generic equality: an alternative to \"deriving Eq\"
 218 geq :: Data a => a -> a -> Bool
 219
 220 {-
 221
 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.
 226
 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.)
 232
 233 -}
 234
 235 geq x0 y0 = geq' x0 y0
 236   where
 237     geq' :: GenericQ (GenericQ Bool)
 238     geq' x y =     (toConstr x == toConstr y)
 239                 && and (gzipWithQ geq' x y)
 240
 241
 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
 245 gzip f x y =
 246   f x y
 247   `orElse`
 248   if toConstr x == toConstr y
 249     then gzipWithM (gzip f) x y
 250     else Nothing