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         -- * The idiom for multi-parameter traversal
  21         gzipWith,
  22
  23         -- * Mapping combinators with an additional list
  24         gzipWithT,
  25         gzipWithM,
  26         gzipWithQ,
  27         gzipWithQl,
  28         gzipWithQr,
  29
  30         -- * Mapping combinators for twin traversal
  31         tmapT,
  32         tmapM,
  33         tmapQ,
  34
  35
  36         -- * Typical twin traversals
  37         geq,
  38         gzip
  39
  40   ) where
  41
  42
  43 ------------------------------------------------------------------------------
  44
  45 #ifdef __HADDOCK__
  46 import Prelude
  47 #endif
  48 import Data.Generics.Basics
  49 import Data.Generics.Aliases
  50
  51 ------------------------------------------------------------------------------
  52
  53
  54 ------------------------------------------------------------------------------
  55 --
  56 --      The idiom for multi-parameter traversal
  57 --
  58 ------------------------------------------------------------------------------
  59
  60 {-
  61
  62 gfoldl and friends so far facilitated traversal of a single term. We
  63 will now consider an idiom gfoldlWith to traverse two terms
  64 semi-simultaneously. By cascasding this idiom, we can also traverse
  65 more than two terms. The gfoldlWith primitive completes gfoldl in a
  66 way that is similar to the well-known couple map and
  67 zipWith. Basically, gfoldlWith takes an additional argument, namely a
  68 list, and this list is traversed simultaneously with the immediate
  69 subterms of a given term.
  70
  71 -}
  72
  73
  74 -- | gfoldl with an additional list
  75 gzipWith :: Data a
  76          => (forall a b. Data a => d -> c (a -> b) -> a -> c b)
  77          -> (forall g. g -> c g)
  78          -> [d]
  79          -> a
  80          -> c a
  81
  82 gzipWith k z l x = case gfoldl k' z' x of { WITH _ c -> c }
  83  where
  84    k' (WITH (h:t) c) y = WITH t (k h c y)
  85    k' (WITH []    _) _ = error "gzipWith"
  86    z' f                = WITH l (z f)
  87
  88
  89 -- | A type constructor for folding over the extra list
  90 data WITH q c a   = WITH [q] (c a)
  91
  92
  93
  94 ------------------------------------------------------------------------------
  95 --
  96 --      Mapping combinators with an additional list
  97 --
  98 ------------------------------------------------------------------------------
  99
 100
 101 -- | gmapT with an additional list
 102 gzipWithT :: Data a
 103           => (forall a. Data a => b -> a -> a)
 104           -> [b]
 105           -> a
 106           -> a
 107
 108 gzipWithT f l = unID . gzipWith k ID l
 109   where
 110     k b (ID c) x = ID $ c $ f b x
 111
 112
 113 -- | gmapM with an additional list
 114 gzipWithM :: (Data a, Monad m)
 115           => (forall a. Data a => b -> a -> m a)
 116           -> [b]
 117           -> a
 118           -> m a
 119
 120 gzipWithM f = gzipWith k return
 121   where
 122     k b c x = do c' <- c
 123                  x' <- f b x
 124                  return (c' x')
 125
 126
 127 -- | gmapQl with an additional list
 128 gzipWithQl :: Data a
 129            => (r -> r -> r)
 130            -> r
 131            -> (forall a. Data a => b -> a -> r)
 132            -> [b]
 133            -> a
 134            -> r
 135
 136 gzipWithQl o r f l = unCONST . gzipWith k z l
 137   where
 138     k b (CONST c) x = CONST (c `o` f b x)
 139     z _ = CONST r
 140
 141
 142 -- | gmapQr with an additional list
 143 gzipWithQr :: Data a
 144            => (r' -> r -> r)
 145            -> r
 146            -> (forall a. Data a => b -> a -> r')
 147            -> [b]
 148            -> a
 149            -> r
 150
 151 gzipWithQr o r f l x = unQr (gzipWith k z l x) r
 152     where
 153       k b (Qr c) x = Qr (\r -> c (f b x `o` r))
 154       z _ = Qr id
 155
 156
 157 -- | gmapQ with an additional list
 158 gzipWithQ :: Data a
 159       => (forall a. Data a => b -> a -> u)
 160       -> [b]
 161       -> a
 162       -> [u]
 163
 164 gzipWithQ f = gzipWithQr (:) [] f
 165
 166
 167
 168 ------------------------------------------------------------------------------
 169 --
 170 --      Helper type constructors
 171 --
 172 ------------------------------------------------------------------------------
 173
 174
 175
 176 -- | The identity type constructor needed for the definition of gzipWithT
 177 newtype ID x = ID { unID :: x }
 178
 179
 180 -- | The constant type constructor needed for the definition of gzipWithQl
 181 newtype CONST c a = CONST { unCONST :: c }
 182
 183
 184 -- | The type constructor needed for the definition of gzipWithQr
 185 newtype Qr r a = Qr { unQr  :: r -> r }
 186
 187
 188
 189 ------------------------------------------------------------------------------
 190 --
 191 --      Mapping combinators for twin traversal
 192 --
 193 ------------------------------------------------------------------------------
 194
 195
 196 -- | Twin map for transformation
 197 tmapT :: GenericQ (GenericT) -> GenericQ (GenericT)
 198 tmapT f x y =
 199   gzipWithT unGenericT'
 200             (gmapQ (\x -> GenericT' (f x)) x)
 201             y
 202
 203
 204 -- | Twin map for monadic transformation
 205 tmapM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
 206 tmapM f x y =
 207   gzipWithM unGenericM'
 208             (gmapQ (\x -> GenericM' (f x)) x)
 209             y
 210
 211
 212 -- | Twin map for monadic transformation
 213 tmapQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
 214 tmapQ f x y =
 215   gzipWithQ unGenericQ'
 216             (gmapQ (\x -> GenericQ' (f x)) x)
 217             y
 218
 219
 220
 221 ------------------------------------------------------------------------------
 222 --
 223 --      Typical twin traversals
 224 --
 225 ------------------------------------------------------------------------------
 226
 227 -- | Generic equality: an alternative to \"deriving Eq\"
 228 geq :: Data a => a -> a -> Bool
 229
 230 {-
 231
 232 Testing for equality of two terms goes like this. Firstly, we
 233 establish the equality of the two top-level datatype
 234 constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
 235 to compare the two lists of immediate subterms.
 236
 237 (Note for the experts: the type of the worker geq' is rather general
 238 but precision is recovered via the restrictive type of the top-level
 239 operation geq. The imprecision of geq' is caused by the type system's
 240 unability to express the type equivalence for the corresponding
 241 couples of immediate subterms from the two given input terms.)
 242
 243 -}
 244
 245 geq x y = geq' x y
 246   where
 247     geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
 248     geq' x y = and ( (toConstr x == toConstr y)
 249                    : tmapQ geq' x y
 250                    )
 251
 252
 253 -- | Generic zip controlled by a function with type-specific branches
 254 gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 255      -> (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 256
 257
 258 -- See testsuite/.../Generics/gzip.hs for an illustration
 259 gzip f x y =
 260   f x y
 261   `orElse`
 262   if toConstr x == toConstr y
 263     then tmapM (gzip f) x y
 264     else Nothing