Data/Generics.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Generics
   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, ralf@cwi.nl
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- Generic programming in Haskell;
  12 -- see <http://www.cs.vu.nl/boilerplate/>.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Data.Generics (
  17
  18         -- The Typeable class and the type-safe cast operation;
  19         -- re-exported for convenience
  20         Typeable(..), cast,
  21
  22         -- * Prime types of generic functions
  23         GenericT, GenericQ, GenericM, GenericB,
  24
  25         -- * Combinators to \"make\" generic functions
  26         mkT, mkQ, mkM, mkF, mkB,
  27         extT, extQ, extM, extF, extB,
  28
  29         -- * The Data class for folding and unfolding constructor applications
  30         Data(
  31               gfoldl,
  32               gunfold,
  33               conOf,
  34               consOf
  35             ),
  36
  37         -- * Typical generic maps defined in terms of gfoldl
  38
  39         gmapT,
  40         gmapQ,
  41         gmapM,
  42         gmapF,
  43
  44         -- * The Constr datatype for describing datatype constructors
  45         Constr(..),
  46
  47         -- * Frequently used generic traversal schemes
  48         everywhere,
  49         everywhere',
  50         everywhereBut,
  51         everywhereM,
  52         somewhere,
  53         everything,
  54         listify,
  55         something,
  56         synthesize,
  57
  58         -- * Generic operations such as show, equality, read
  59         glength,
  60         gcount,
  61         garity,
  62         gundefineds,
  63         gnodecount,
  64         gtypecount,
  65         gshow,
  66         geq,
  67         gzip,
  68         gread,
  69
  70         -- * Miscellaneous further combinators
  71         sameType, orElse, recoverF, recoverQ, choiceF, choiceQ
  72
  73 #ifndef __HADDOCK__
  74         ,
  75         -- Data types for the sum-of-products type encoding;
  76         -- included for backwards compatibility; maybe obsolete
  77         (:*:)(..), (:+:)(..), Unit(..)
  78 #endif
  79
  80  ) where
  81
  82 ------------------------------------------------------------------------------
  83
  84 import Prelude  -- So that 'make depend' works
  85
  86 #ifdef __GLASGOW_HASKELL__
  87 #ifndef __HADDOCK__
  88 import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
  89 #endif
  90 #endif
  91
  92 import Data.Maybe
  93 import Data.Dynamic
  94 import Control.Monad
  95
  96
  97
  98 ------------------------------------------------------------------------------
  99 --
 100 --      Prime types of generic functions
 101 --
 102 ------------------------------------------------------------------------------
 103
 104 -- | Generic transformations,
 105 --   i.e., take an \"a\" and return an \"a\"
 106 --
 107 type GenericT = forall a. Data a => a -> a
 108
 109
 110 -- | Generic queries of type \"r\",
 111 --   i.e., take any \"a\" and return an \"r\"
 112 --
 113 type GenericQ r = forall a. Data a => a -> r
 114
 115
 116 -- | Generic monadic transformations,
 117 --   i.e., take an \"a\" and compute an \"a\"
 118 --
 119 type GenericM m = forall a. Data a => a -> m a
 120
 121
 122 -- | Generic builders with input i,
 123 --   i.e., take an \"i\" and compute a pair of type (a,i)
 124 --
 125 type GenericB m i = forall a. Data a => i -> m (a,i)
 126
 127
 128
 129 ------------------------------------------------------------------------------
 130 --
 131 --      Combinators to "make" generic functions
 132 --      We use type-safe cast in a number of ways to make generic functions.
 133 --
 134 ------------------------------------------------------------------------------
 135
 136 -- | Make a generic transformation;
 137 --   start from a type-specific case;
 138 --   preserve the term otherwise
 139 --
 140 mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
 141 mkT f = case cast f of
 142                Just g -> g
 143                Nothing -> id
 144
 145
 146 -- | Make a generic query;
 147 --   start from a type-specific case;
 148 --   return a constant otherwise
 149 --
 150 mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
 151 (r `mkQ` br) a = case cast a of
 152                     Just b  -> br b
 153                     Nothing -> r
 154
 155
 156 -- | Make a generic monadic transformation;
 157 --   start from a type-specific case;
 158 --   resort to return otherwise
 159 --
 160 mkM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m)
 161     => (b -> m b) -> a -> m a
 162 mkM f = case cast f of
 163           Just g  -> g
 164           Nothing -> return
 165
 166
 167 {-
 168
 169 For the remaining definitions, we stick to a more concise style, i.e.,
 170 we fold maybies with "maybe" instead of case ... of ..., and we also
 171 use a point-free style whenever possible.
 172
 173 -}
 174
 175
 176 -- | Make a generic monadic transformation for MonadPlus;
 177 --   use \"const mzero\" (i.e., failure) instead of return as default.
 178 --
 179 mkF :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), MonadPlus m)
 180     => (b -> m b) -> a -> m a
 181 mkF = maybe (const mzero) id . cast
 182
 183
 184 -- | Make a generic builder;
 185 --   start from a type-specific ase;
 186 --   resort to no build (i.e., mzero) otherwise
 187 --
 188 mkB :: (Typeable a, Typeable b,
 189         Typeable i,
 190         Typeable (m (a,i)), Typeable (m (b,i)),
 191         MonadPlus m)
 192     => (i -> m (b,i)) -> i -> m (a,i)
 193 mkB = maybe (const mzero) id . cast
 194
 195
 196 -- | Extend a generic transformation by a type-specific case
 197 extT :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a
 198 extT f = maybe f id . cast
 199
 200
 201 -- | Extend a generic query by a type-specific case
 202 extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
 203 extQ f g a = maybe (f a) g (cast a)
 204
 205
 206 -- | Extend a generic monadic transformation by a type-specific case
 207 extM :: (Typeable a, Typeable b,
 208          Typeable (m a), Typeable (m b),
 209          Monad m)
 210      => (a -> m a) -> (b -> m b) -> a -> m a
 211 extM f = maybe f id . cast
 212
 213
 214 -- | Extend a generic MonadPlus transformation by a type-specific case
 215 extF :: (Typeable a, Typeable b,
 216          Typeable (m a), Typeable (m b),
 217          MonadPlus m)
 218      => (a -> m a) -> (b -> m b) -> a -> m a
 219 extF = extM
 220
 221
 222 -- | Extend a generic builder by a type-specific case
 223 extB :: (Typeable a, Typeable b,
 224          Typeable i,
 225          Typeable (m (a,i)), Typeable (m (b,i)),
 226          MonadPlus m)
 227      => (i -> m (a,i)) -> (i -> m (b,i)) -> i -> m (a,i)
 228 extB f = maybe f id . cast
 229
 230
 231
 232 ------------------------------------------------------------------------------
 233 --
 234 --      The Data class
 235 --
 236 ------------------------------------------------------------------------------
 237
 238 {-
 239
 240 The Data class comprehends two important primitives "gfoldl" and
 241 "gunfold" for folding and unfolding constructor applications, say
 242 terms. Besides, there are helpers "conOf" and "consOf" for retrieving
 243 constructors from terms and types. Finally, typical ways of mapping
 244 over immediate subterms are defined as "gmap" combinators in terms
 245 of gfoldl. A generic programmer does not necessarily need to use
 246 the ingenious gfoldl/gunfold couple but rather the "gmap" combinators.
 247
 248 -}
 249
 250 class Typeable a => Data a where
 251
 252 {-
 253
 254 Folding constructor applications ("gfoldl")
 255
 256 The combinator takes two arguments "f" and "z" to fold over a term
 257 "x".  The result type is parametric via a type constructor "c" in the
 258 type of "gfoldl". The purpose of "z" is to define how the empty
 259 constructor application is folded. So "z" is like the neutral / start
 260 element for list folding. The purpose of "f" is to define how the
 261 nonempty constructor application is folded. That is, "f" takes the
 262 folded "tail" of the constructor application and its head, i.e., an
 263 immediate subterm, and combines them in some way. See the Data
 264 instances in this file which illustrate gfoldl. Conclusion: the type
 265 of gfoldl is a headache, but operationally it is simple generalisation
 266 of a list fold.
 267
 268 -}
 269
 270   -- | Left-associative fold operation for constructor applications
 271   gfoldl  :: (forall a b. Data a => c (a -> b) -> a -> c b)
 272           -> (forall g. g -> c g)
 273           -> a -> c a
 274
 275 {-
 276
 277 Unfolding constructor applications ("gunfold")
 278
 279 The combinator takes alike "gfoldl" two arguments "f" and "z", but
 280 this time its about constructing (say, unfolding) constructor
 281 applications rather than folding. The input for unfolding is primarily
 282 an opaque representation of the desired constructor, which is
 283 essentially a string representation of the constructor. (It is in the
 284 responsibility of the programmer not to attempt unfolding invalid
 285 constructors.  This is like the side condition that a programmer must
 286 not apply the "head" function to the empty list.) Besides the
 287 constructor, we also have to provide the "input" for constructing
 288 immediate subterms. This is anticipated via the type constructor "c"
 289 in the type of "gunfold". For example, in the case of a generic read
 290 function, "c" models string-processing functions. So "z" defines how
 291 to construct the empty constructor application, and "f" takes an
 292 incomplete constructor application to add more immediate subterm.
 293 Conclusion: the type of gunfoldl and what it does is a headache, but
 294 operationally it is a simple generalisation of the underappreciated
 295 list unfold.
 296
 297 -}
 298
 299   -- | Unfold operation to build terms from constructors and others
 300   gunfold :: (forall a b. Data a => c (a -> b) -> c b)
 301           -> (forall g. g -> c g)
 302           -> Constr
 303           -> c a
 304
 305   -- Default definition for gfoldl
 306   -- which copes immediately with basic datatypes
 307   --
 308   gfoldl _ z = z
 309
 310   -- | Obtain the constructor from a given term
 311   conOf   :: a -> Constr
 312
 313   -- | List all constructors for a given type
 314   consOf  :: a -> [Constr]
 315
 316
 317
 318 ------------------------------------------------------------------------------
 319 --
 320 --      Typical generic maps defined in terms of gfoldl
 321 --
 322 ------------------------------------------------------------------------------
 323
 324 {-
 325
 326 The combinators gmapT, gmapQ, gmapM, gmapF can all be defined in terms
 327 of gfoldl. We provide corresponding default definitions leaving open
 328 the opportunity to provide datatype-specific definitions if needed.
 329
 330 (Also, the inclusion of the gmap combinators as members of class Data
 331 allows the programmer or the compiler to derive specialised, and maybe
 332 more efficient code per datatype. Note: gfoldl is more higher-order
 333 than the gmap combinators. This is subject to ongoing benchmarking
 334 experiments.)
 335
 336 Conceptually, the definition of the gmap combinators in terms of the
 337 primitive gfoldl requires the identification of the gfoldl function
 338 arguments. Technically, we also need to identify the type constructor
 339 c used all over the type of gfoldl.
 340
 341 -}
 342
 343   -- | A generic transformation that maps over the immediate subterms
 344   gmapT   :: (forall b. Data b => b -> b) -> a -> a
 345
 346   -- Use an identity datatype constructor ID (see below)
 347   -- to instantiate the type constructor c in the type of gfoldl,
 348   -- and perform injections ID and projections unID accordingly.
 349   --
 350   gmapT f x = unID (gfoldl k ID x)
 351     where
 352       k (ID c) x = ID (c (f x))
 353
 354
 355   -- | A generic query that processes the immediate subterms and returns a list
 356   gmapQ   :: (forall a. Data a => a -> u) -> a -> [u]
 357
 358   -- Use a phantom + function datatype constructor Q (see below),
 359   -- to instantiate the type constructor c in the type of gfoldl,
 360   -- and perform injections Q and projections unQ accordingly.
 361   --
 362   gmapQ f x = unQ (gfoldl k (const (Q id)) x) []
 363     where
 364       k (Q c) x = Q (\rs -> c (f x : rs))
 365
 366
 367   -- | A generic monadic transformation that maps over the immediate subterms
 368   gmapM   :: Monad m => (forall a. Data a => a -> m a) -> a -> m a
 369
 370   -- Use immediately the monad datatype constructor
 371   -- to instantiate the type constructor c in the type of gfoldl,
 372   -- so injection and projection is done by return and >>=.
 373   --
 374   gmapM f = gfoldl k return
 375     where
 376       k c x = do c' <- c
 377                  x' <- f x
 378                  return (c' x')
 379
 380
 381   -- | Transformation of at least one immediate subterm does not fail
 382   gmapF :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
 383
 384   -- Use a datatype constructor F (see below)
 385   -- to instantiate the type constructor c in the type of gfoldl.
 386   --
 387   gmapF f x = unF (gfoldl k z x) >>= \(x',b) ->
 388               if b then return x' else mzero
 389     where
 390       z g = F (return (g,False))
 391       k (F c) x
 392         = F ( c >>= \(h,b) ->
 393               (f x >>= \x' -> return (h x',True))
 394               `mplus` return (h x, b)
 395             )
 396
 397
 398 -- | The identity type constructor needed for the definition of gmapT
 399 newtype ID x = ID { unID :: x }
 400
 401
 402 -- | A phantom datatype constructor used in definition of gmapQ;
 403 --   the function-typed component is needed to mediate between
 404 --   left-associative constructor application vs. right-associative lists.
 405 --
 406 newtype Q r a = Q { unQ  :: [r] -> [r] }
 407
 408
 409 -- | A pairing type constructor needed for the definition of gmapF;
 410 -- we keep track of the fact if a subterm was ever transformed successfully.
 411 newtype F m x = F { unF :: m (x, Bool) }
 412
 413
 414
 415 ------------------------------------------------------------------------------
 416 --
 417 --      The Constr datatype for describing datatype constructors
 418 --      To be extended by fixity, associativity, and maybe others.
 419 --
 420 ------------------------------------------------------------------------------
 421
 422 -- | Description of datatype constructors
 423 data Constr = Constr { conString :: String } deriving (Eq, Typeable)
 424
 425
 426 {-
 427
 428 It is interesting to observe that we can determine the arity of a
 429 constructor without further meta-information. To this end, we use
 430 gunfold to construct a term from a given constructor while leaving the
 431 subterms undefined; see "gundefineds" below. Here we instantiate the
 432 type constructor c of the gunfold type by the identity type
 433 constructor ID. In a subsequent step we determine the number of
 434 subterms by folding as captured in the generic operation "glength"
 435 elsewhere in this module. Note that we need a type argument to specify
 436 the intended type of the constructor.
 437
 438 -}
 439
 440
 441 -- | Compute arity of a constructor against a type argument
 442 garity :: Data a => (a -> ()) -> Constr -> Int
 443 garity ta = glength . gundefineds ta
 444
 445
 446 -- | Construct a term from a constructor with undefined subterms
 447 gundefineds :: Data a => (a -> ()) -> Constr -> a
 448 gundefineds (_::a -> ()) = (unID :: ID a -> a)
 449                          . gunfold ((\f -> ID (f undefined)) . unID) ID
 450
 451
 452
 453 ------------------------------------------------------------------------------
 454 --
 455 --      Frequently used generic traversal schemes
 456 --
 457 ------------------------------------------------------------------------------
 458
 459 -- | Apply a transformation everywhere in bottom-up manner
 460 everywhere :: (forall a. Data a => a -> a)
 461            -> (forall a. Data a => a -> a)
 462
 463 -- Use gmapT to recurse into immediate subterms;
 464 -- recall: gmapT preserves the outermost constructor;
 465 -- post-process recursively transformed result via f
 466 --
 467 everywhere f = f . gmapT (everywhere f)
 468
 469
 470 -- | Apply a transformation everywhere in top-down manner
 471 everywhere' :: (forall a. Data a => a -> a)
 472             -> (forall a. Data a => a -> a)
 473
 474 -- Arguments of (.) are flipped compared to everywhere
 475 everywhere' f = gmapT (everywhere' f) . f
 476
 477
 478 -- | Variation on everywhere with an extra stop condition
 479 everywhereBut :: GenericQ Bool -> GenericT -> GenericT
 480
 481 -- Guarded to let traversal cease if predicate q holds for x
 482 everywhereBut q f x
 483     | q x       = x
 484     | otherwise = f (gmapT (everywhereBut q f) x)
 485
 486
 487 -- | Monadic variation on everywhere
 488 everywhereM :: Monad m => GenericM m -> GenericM m
 489
 490 -- Bottom-up order is also reflected in order of do-actions
 491 everywhereM f x = do x' <- gmapM (everywhereM f) x
 492                      f x'
 493
 494
 495 -- | Apply a monadic transformation at least somewhere
 496 somewhere :: MonadPlus m => GenericM m -> GenericM m
 497
 498 -- We try "f" in top-down manner, but descent into "x" when we fail
 499 -- at the root of the term. The transformation fails if "f" fails
 500 -- everywhere, say succeeds nowhere.
 501 --
 502 somewhere f x = f x `mplus` gmapF (somewhere f) x
 503
 504
 505 -- | Summarise all nodes in top-down, left-to-right order
 506 everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
 507
 508 -- Apply f to x to summarise top-level node;
 509 -- use gmapQ to recurse into immediate subterms;
 510 -- use ordinary foldl to reduce list of intermediate results
 511 --
 512 everything k f x
 513   = foldl k (f x) (gmapQ (everything k f) x)
 514
 515
 516 -- | Get a list of all entities that meet a predicate
 517 listify :: Typeable r => (r -> Bool) -> GenericQ [r]
 518 listify p
 519   = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))
 520
 521
 522 -- | Look up a subterm by means of a maybe-typed filter
 523 something :: GenericQ (Maybe u) -> GenericQ (Maybe u)
 524
 525 -- "something" can be defined in terms of "everything"
 526 -- when a suitable "choice" operator is used for reduction
 527 --
 528 something = everything orElse
 529
 530
 531 -- | Bottom-up synthesis of a data structure;
 532 --   1st argument z is the initial element for the synthesis;
 533 --   2nd argument o is for reduction of results from subterms;
 534 --   3rd argument f updates the sythesised data according to the given term
 535 --
 536 synthesize :: s  -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
 537 synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
 538
 539
 540
 541 -----------------------------------------------------------------------------
 542 --
 543 --      "Twin" variations on gmapT, gmapQ. gmapM,
 544 --      i.e., these combinators take two terms at the same time.
 545 --      They are needed for multi-parameter traversal as generic equality.
 546 --      They are not exported.
 547 --
 548 -----------------------------------------------------------------------------
 549
 550 {-
 551
 552 We need type constructors for twin traversal as we needed type
 553 constructor for the ordinary gmap combinators. These type constructors
 554 again serve for the instantiation of the type constructor c used in
 555 the definition of gfoldl. The type constructors for twin traversal are
 556 elaborations of the type constructors ID, Q and monads that were used
 557 for the ordinary gmap combinators. More precisely, we use a pairing
 558 technique to always attach an additional component to the results of
 559 folding. This additional component carries the list of generic
 560 functions to be used for the intermediate subterms encountered during
 561 folding.
 562
 563 -}
 564
 565 newtype TT r a = TT { unTT :: (a,[GenericT']) }
 566 newtype TQ r a = TQ { unTQ :: ([r]->[r],[GenericQ' r]) }
 567 newtype TM m a = TM { unTM :: (m a,[GenericM' m]) }
 568
 569
 570 -- First-class polymorphic versions of GenericT/GenericQ/GenericM;
 571 -- they are referenced in TQ amd TM above
 572 --
 573 data GenericT' = T' { unT' :: forall a. Data a => a -> a }
 574 data GenericQ' u = Q' { unQ' :: forall a. Data a => a -> u }
 575 data Monad m => GenericM' m = M' { unM' :: forall a. Data a => a -> m a }
 576
 577
 578 {-
 579
 580 A twin variation on gmapT, where the pattern "GenericQ GenericT"
 581 expresses that the argument terms x and y are processed rather
 582 independently. So firstly, x is "queried" with a generic
 583 transformation as intermediate result, and secondly, this generic
 584 transformation is applied to y.
 585
 586 -}
 587
 588 tmapT :: GenericQ GenericT -> GenericQ GenericT
 589 tmapT g x y = fst (unTT (gfoldl k z y))
 590   where
 591     k (TT (f,l)) x = TT (f (unT' (head l) x),tail l)
 592     z f            = TT (f,gmapQ (\x -> T' (g x)) x)
 593
 594
 595
 596 -- A twin variation on gmapQ
 597
 598 tmapQ :: forall r.
 599          (forall a b. (Data a, Data b) => a -> b -> r)
 600       -> (forall a b. (Data a, Data b) => a -> b -> [r])
 601
 602 tmapQ g x y = fst (unTQ (gfoldl k z y)) []
 603     where
 604       k (TQ (c,l)) x = TQ (\rs -> c (unQ' (head l) x:rs), tail l)
 605       z _            = TQ (id,gmapQ (\x -> Q' (g x)) x)
 606
 607
 608 -- A twin variation on gmapM
 609
 610 tmapM :: forall m. Monad m
 611       => (forall a b. (Data a, Data b) => a -> b -> m b)
 612       -> (forall a b. (Data a, Data b) => a -> b -> m b)
 613 tmapM g x y = fst (unTM (gfoldl k z y))
 614   where
 615     k (TM (f,l)) x = TM (f >>= \f' -> unM' (head l) x >>= return . f',tail l)
 616     z f            = TM (return f,gmapQ (\x -> M' (g x)) x)
 617
 618
 619
 620 ------------------------------------------------------------------------------
 621 --
 622 --      Generic operations such as show, equality, read
 623 --
 624 ------------------------------------------------------------------------------
 625
 626 -- | Count the number of immediate subterms of the given term
 627 glength :: GenericQ Int
 628 glength = length . gmapQ (const ())
 629
 630
 631 -- | Determine the number of all suitable nodes in a given term
 632 gcount :: GenericQ Bool -> GenericQ Int
 633 gcount p =  everything (+) (\x -> if p x then 1 else 0)
 634
 635
 636 -- | Determine the number of all nodes in a given term
 637 gnodecount :: GenericQ Int
 638 gnodecount = gcount (const True)
 639
 640
 641 -- | Determine the number of nodes of a given type in a given term
 642 gtypecount :: Typeable a => (a -> ()) -> GenericQ Int
 643 gtypecount f = gcount (False `mkQ` (const True . f))
 644
 645
 646 -- | Generic show: an alternative to \"deriving Show\"
 647 gshow :: Data a => a -> String
 648
 649 -- This is a prefix-show using surrounding "(" and ")",
 650 -- where we recurse into subterms with gmapQ.
 651 --
 652 gshow = ( \t ->
 653                 "("
 654              ++ conString (conOf t)
 655              ++ concat (gmapQ ((++) " " . gshow) t)
 656              ++ ")"
 657         ) `extQ` (show :: String -> String)
 658
 659
 660 -- | Generic equality: an alternative to \"deriving Eq\"
 661 geq :: Data a => a -> a -> Bool
 662
 663 {-
 664
 665 Testing for equality of two terms goes like this. Firstly, we
 666 establish the equality of the two top-level datatype
 667 constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
 668 to compare the two lists of immediate subterms.
 669
 670 (Note for the experts: the type of the worker geq' is rather general
 671 but precision is recovered via the restrictive type of the top-level
 672 operation geq. The imprecision of geq' is caused by the type system's
 673 unability to express the type equivalence for the corresponding
 674 couples of immediate subterms from the two given input terms.)
 675
 676 -}
 677
 678 geq x y = geq' x y
 679  where
 680   geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
 681   geq' x y = and ( (conString (conOf x) == conString (conOf y))
 682                  : tmapQ geq' x y
 683                  )
 684
 685
 686 -- | Generic zip controlled by a function with type-specific branches
 687 gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 688      -> (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 689
 690 -- See testsuite/.../Generics/gzip.hs for an illustration
 691 gzip f x y =
 692   f x y
 693   `orElse`
 694   if conString (conOf x) == conString (conOf y)
 695    then tmapM (gzip f) x y
 696    else Nothing
 697
 698
 699 -- | The type constructor for gunfold a la ReadS from the Haskell 98 Prelude;
 700 --   we don't use lists here for simplicity but only maybes.
 701 newtype GRead i a = GRead (i -> Maybe (a, i))
 702 unGRead (GRead x) = x
 703
 704
 705 -- | Generic read: an alternative to \"deriving Read\"
 706 gread :: GenericB Maybe String
 707
 708 {-
 709
 710 This is a read operation which insists on prefix notation.  (The
 711 Haskell 98 read deals with infix operators as well. We will be able to
 712 deal with such special cases as well as sonn as we include fixity
 713 information into the definition of "Constr".)  We use gunfold to
 714 "parse" the input. To be precise, gunfold is used for all result types
 715 except String. The type-specific case for String uses basic String
 716 read. Another source of customisation would be to properly deal with
 717 infix operators subject to the capture of that information in the
 718 definition of Constr. The "gread" combinator properly checks the
 719 validity of constructors before invoking gunfold in order to rule
 720 out run-time errors.
 721
 722 -}
 723
 724 gread = gdefault `extB` scase
 725
 726  where
 727
 728   -- a specific case for strings
 729   scase s = case reads s of
 730               [x::(String,String)] -> Just x
 731               _ -> Nothing
 732
 733   -- the generic default of gread
 734   gdefault s =
 735     do s' <- return $ dropWhile ((==) ' ') s
 736        guard (not (s' == ""))
 737        guard (head s' == '(')
 738        (c,s'')  <- prefixConstr (dropWhile ((==) ' ') (tail s'))
 739        u <- return undefined
 740        guard (or [consOf u == [], c `elem` consOf u])
 741        (a,s''') <- unGRead (gunfold f z c) s''
 742        _ <- return $ constrainTypes a u
 743        guard (not (s''' == ""))
 744        guard (head s''' == ')')
 745        return (a, tail s''')
 746
 747   -- To force two types to be the same
 748   constrainTypes :: a -> a -> ()
 749   constrainTypes _ _ = ()
 750
 751   -- Argument f for unfolding
 752   f :: Data a => GRead String (a -> b) -> GRead String b
 753   f x = GRead (\s -> do (r,s') <- unGRead x s
 754                         (t,s'')  <- gread s'
 755                         return (r t,s''))
 756
 757   -- Argument z for unfolding
 758   z ::  forall g. g -> GRead String g
 759   z g = GRead (\s -> return (g,s))
 760
 761   -- Get Constr at front of string
 762   prefixConstr :: String -> Maybe (Constr, String)
 763
 764   -- Assume an infix operators in parantheses
 765   prefixConstr ('(':s)
 766     = case break ((==) ')') s of
 767         (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
 768         _ -> Nothing
 769
 770   -- Special treatment of multiple token constructors
 771   prefixConstr ('[':']':s) = Just (Constr "[]",s)
 772
 773   -- Try lex for ordinary constructor and basic datatypes
 774   prefixConstr s
 775     = case lex s of
 776         [(s'@(_:_),s'')] -> Just (Constr s',s'')
 777         _ -> Nothing
 778
 779
 780
 781 ------------------------------------------------------------------------------
 782 --
 783 --      Instances of the Data class
 784 --
 785 ------------------------------------------------------------------------------
 786
 787 -- Basic datatype Int; folding and unfolding is trivial
 788 instance Data Int where
 789  conOf x = Constr (show x)
 790  consOf _ = []
 791  gunfold f z c = z (read (conString c))
 792
 793 -- Another basic datatype instance
 794 instance Data Integer where
 795  conOf x = Constr (show x)
 796  consOf _ = []
 797  gunfold f z c = z (read (conString c))
 798
 799 -- Another basic datatype instance
 800 instance Data Float where
 801  conOf x = Constr (show x)
 802  consOf _ = []
 803  gunfold f z c = z (read (conString c))
 804
 805 -- Another basic datatype instance
 806 instance Data Char where
 807  conOf x = Constr (show x)
 808  consOf _ = []
 809  gunfold f z c = z (read (conString c))
 810
 811 {-
 812
 813 Commented out;
 814 subject to inclusion of a missing Typeable instance
 815
 816 -- Another basic datatype instance
 817 instance Data Rational where
 818  conOf x = Constr (show x)
 819  consOf _ = []
 820  gunfold f z c = z (read (conString c))
 821
 822 -}
 823
 824 -- Bool as a kind of enumeration type
 825 instance Data Bool where
 826  conOf False = Constr "False"
 827  conOf True  = Constr "True"
 828  consOf _    = [Constr "False",Constr "True"]
 829  gunfold f z (Constr "False") = z False
 830  gunfold f z (Constr "True")  = z True
 831
 832 {-
 833
 834 We should better not fold over characters in a string for efficiency.
 835 However, the following instance would clearly overlap with the
 836 instance for polymorphic lists. Given the current scheme of allowing
 837 overlapping instances, this would imply that ANY module that imports
 838 Data.Generics would need to explicitly and generally allow overlapping
 839 instances. This is prohibitive and calls for a more constrained model
 840 of allowing overlapping instances. The present instance would also be
 841 more sensible for UNFOLDING. In the definition of gread, we still
 842 obtained the favoured behaviour by using a type-specific case for
 843 String.
 844
 845 -- instance Data String where
 846  conOf x = Constr (show x)
 847  consOf _ = []
 848  gunfold f z c = z (read (conString c))
 849
 850 -}
 851
 852 -- Cons-lists are terms with two immediate subterms. Hence, the gmap
 853 -- combinators do NOT coincide with the list fold/map combinators.
 854 --
 855 instance Data a => Data [a] where
 856   gmapT  f   []     = []
 857   gmapT  f   (x:xs) = (f x:f xs)
 858   gmapQ  f   []     = []
 859   gmapQ  f   (x:xs) = [f x,f xs]
 860   gmapM  f   []     = return []
 861   gmapM  f   (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
 862   gfoldl f z []     = z []
 863   gfoldl f z (x:xs) = z (:) `f` x `f` xs
 864   conOf [] = Constr "[]"
 865   conOf (_:_) = Constr "(:)"
 866   consOf _ = [Constr "[]",Constr "(:)"]
 867   gunfold f z (Constr "[]")  = z []
 868   gunfold f z (Constr "(:)") = f (f (z (:)))
 869
 870 -- Yet enother polymorphic datatype constructor
 871 instance Data a => Data (Maybe a) where
 872  gfoldl f z Nothing  = z Nothing
 873  gfoldl f z (Just x) = z Just `f` x
 874  conOf Nothing  = Constr "Nothing"
 875  conOf (Just _) = Constr "Just"
 876  consOf _ = [Constr "Nothing", Constr "Just"]
 877  gunfold f z c | conString c == "Nothing" = z Nothing
 878  gunfold f z c | conString c == "Just"    = f (z Just)
 879
 880 -- Yet enother polymorphic datatype constructor
 881 instance (Data a, Data b) => Data (a,b) where
 882  gfoldl f z (a,b) = z (,) `f` a `f` b
 883  conOf _ = Constr "(,)"
 884  consOf _ = [Constr "(,)"]
 885  gunfold f z c | conString c == "(,)" = f (f (z (,)))
 886
 887 -- Functions are treated as "non-compound" data regarding folding while
 888 -- unfolding is out of reach, maybe not anymore with Template Haskell.
 889 --
 890 instance (Typeable a, Typeable b) => Data (a -> b) where
 891  conOf _ = Constr "->"
 892  consOf _ = [Constr "->"]
 893  gunfold _ _ _ = undefined
 894
 895
 896
 897 ------------------------------------------------------------------------------
 898 --
 899 --      Miscellaneous
 900 --
 901 ------------------------------------------------------------------------------
 902
 903 -- | Test for two objects to agree on the type
 904 sameType :: (Typeable a, Typeable b) => a -> b -> Bool
 905 sameType (_::a) = maybe False (\(_::a) -> True) . cast
 906
 907
 908 -- | Left-biased choice on maybes (non-strict in right argument)
 909 orElse :: Maybe a -> Maybe a -> Maybe a
 910 x `orElse` y = maybe y Just x
 911
 912
 913 -- Another definition of orElse
 914 -- where the folding over maybies as defined by maybe is inlined
 915 -- to ease readability
 916 --
 917 x `orElse'` y = case x of
 918                   Just _  -> x
 919                   Nothing -> y
 920
 921
 922 {-
 923
 924 The following variations take "orElse" to the function
 925 level. Furthermore, we generalise from "Maybe" to any
 926 "MonadPlus". This makes sense for monadic transformations and
 927 queries. We say that the resulting combinators modell choice. We also
 928 provide a prime example of choice, that is, recovery from failure. In
 929 the case of transformations, we recover via return whereas for
 930 queries a given constant is returned.
 931
 932 -}
 933
 934 -- | Choice for monadic transformations
 935 choiceF :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
 936 choiceF f g x = f x `mplus` g x
 937
 938
 939 -- | Choice for monadic queries
 940 choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)
 941 choiceQ f g x = f x `mplus` g x
 942
 943
 944 -- | Recover from the failure of monadic transformation by identity
 945 recoverF :: MonadPlus m => GenericM m -> GenericM m
 946 recoverF f = f `choiceF` return
 947
 948
 949 -- | Recover from the failure of monadic query by a constant
 950 recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)
 951 recoverQ r f = f `choiceQ` const (return r)