Data/Generics.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Generics
   4 -- Copyright   :  (c) The University of Glasgow 2001
   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 -- Data types for generic definitions (GHC only).
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Data.Generics (
  16
  17 #ifndef __HADDOCK__
  18         -- * Data types for the sum-of-products type encoding
  19         (:*:)(..), (:+:)(..), Unit(..),
  20 #endif
  21
  22         -- * Typeable and types-save cast
  23         Typeable(..),  cast, sameType,
  24
  25         -- * The Data class and related types
  26         Data( gmapT, gmapQ, gmapM,
  27               gfoldl, gfoldr, gunfold,
  28               conOf, consOf ),
  29         Constr(..),
  30
  31         -- * Transformations (T), queries (Q), monadic transformations (Q),
  32         --   and twin transformations (TT)
  33         GenericT, GenericQ, GenericM,
  34         mkT,  mkQ,  mkM,
  35         extT, extQ, extM,
  36         mkTT,
  37
  38         -- * Traversal combinators
  39         everything, something, everywhere, everywhereBut,
  40         synthesize, branches, undefineds,
  41
  42         -- * Generic operations: equality, zip, read, show
  43         geq, gzip, gshow, gread,
  44
  45         -- * Miscellaneous
  46         match, tick, count, alike
  47
  48
  49  ) where
  50
  51 import Prelude  -- So that 'make depend' works
  52
  53 #ifdef __GLASGOW_HASKELL__
  54 #ifndef __HADDOCK__
  55 import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
  56 #endif
  57 #endif
  58
  59 import Data.Dynamic
  60 import Control.Monad
  61
  62
  63
  64 ---------------------------------------------
  65 --
  66 --      Operations involving Typeable only
  67 --
  68 ---------------------------------------------
  69
  70 -- | Apply a function if appropriate or preserve term
  71 mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
  72 mkT f = case cast f of
  73                Just g -> g
  74                Nothing -> id
  75
  76 -- | Apply a function if appropriate or return a constant
  77 mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
  78 (r `mkQ` br) a = case cast a of
  79                     Just b  -> br b
  80                     Nothing -> r
  81
  82
  83
  84 -- | Apply a monadic transformation if appropriate; resort to return otherwise
  85 mkM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m)
  86     => (b -> m b) -> a -> m a
  87 mkM f = case cast f of
  88           Just g  -> g
  89           Nothing -> return
  90
  91 -- | Extend a transformation
  92 extT :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a
  93 extT f g = case cast g of
  94               Just g' -> g'
  95               Nothing -> f
  96
  97 -- | Extend a query
  98 extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
  99 extQ f g a = case cast a of
 100                 Just b -> g b
 101                 Nothing -> f a
 102
 103 -- | Extend a monadic transformation
 104 extM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m)
 105        => (a -> m a) -> (b -> m b) -> a -> m a
 106 extM f g = case cast g of
 107               Just g' -> g'
 108               Nothing -> f
 109
 110 -- | Test two entities to be of the same type
 111 sameType :: (Typeable a, Typeable b) => a -> b -> Bool
 112 sameType (_::a) = False `mkQ` (\(_::a) -> True)
 113
 114
 115
 116 -- | Make a twin transformation
 117 -- Note: Should be worked on
 118 mkTT :: (Typeable a, Typeable b, Typeable c)
 119      => (a -> a -> a)
 120      -> b -> c -> Maybe c
 121 mkTT (f::a ->a->a) x y =
 122   case (cast x,cast y) of
 123     (Just (x'::a),Just (y'::a)) -> cast (f x' y')
 124     _ -> Nothing
 125
 126
 127
 128
 129 -------------------------------------------------------------------
 130 --
 131 --      The representation of datatype constructors
 132 --      To be extended by fixity, associativity, and what else?
 133 --
 134 -------------------------------------------------------------------
 135
 136 -- | Describes a constructor
 137 data Constr = Constr { conString :: String }
 138
 139
 140
 141 ---------------------------------------------
 142 --
 143 --      The Data class and its operations
 144 --
 145 ---------------------------------------------
 146
 147 -- A class for traversal
 148
 149 class Typeable a => Data a where
 150   gmapT   :: (forall b. Data b => b -> b) -> a -> a
 151   gmapQ   :: (forall a. Data a => a -> u) -> a -> [u]
 152   gmapM   :: Monad m => (forall a. Data a => a -> m a) -> a -> m a
 153
 154   gfoldl  :: (forall a b. Data a => c (a -> b) -> a -> c b)
 155           -> (forall g. g -> c g)
 156           -> a -> c a
 157
 158   gfoldr  :: (forall a b. Data a => a -> c (a -> b) -> c b)
 159           -> (forall g. g -> c g)
 160           -> a -> c a
 161
 162
 163   -- | Find the constructor
 164   conOf   :: a -> Constr
 165
 166   -- | Does not look at a; Could live in Typeable as well maybe
 167   consOf  :: a -> [Constr]
 168
 169   gunfold :: (forall a b. Data a => c (a -> b) -> c b)
 170           -> (forall g. g -> c g)
 171           -> Constr
 172           -> c a
 173
 174   -- No default method for gfoldl, gunfold, conOf, consOf
 175
 176   -- Default methods for gfoldr, gmapT, gmapQ, gmapM,
 177   -- in terms of gfoldl
 178
 179   gfoldr f z = gfoldl (flip f) z
 180
 181   gmapT f x = unID (gfoldl k ID x)
 182     where
 183       k (ID c) x = ID (c (f x))
 184
 185   gmapQ f x = unQ (gfoldl k (const (Q id)) x) []
 186     where
 187       k (Q c) x = Q (\rs -> c (f x : rs))
 188
 189   gmapM f = gfoldl k return
 190           where
 191             k c x = do c' <- c
 192                        x' <- f x
 193                        return (c' x')
 194
 195
 196   -- Default definition for gfoldl copes with basic datatypes
 197   gfoldl _ z = z
 198
 199
 200 {-
 201  A variation for gmapQ using an ordinary constant type constructor.
 202  A problem is here that the associativety might be wrong.
 203
 204   newtype Phantom x y = Phantom x
 205   runPhantom (Phantom x) = x
 206
 207   gmapQ f = runPhantom . gfoldl f' z
 208    where
 209     f' r a = Phantom (f a : runPhantom r)
 210     z  = const (Phantom [])
 211 -}
 212
 213
 214 -- | Instructive type synonyms
 215 type GenericT = forall a. Data a => a -> a
 216 type GenericQ r = forall a. Data a => a -> r
 217 type GenericM m = forall a. Data a => a -> m a
 218
 219
 220 -- Auxiliary type constructors for the default methods (not exported)
 221 newtype ID x = ID { unID :: x }
 222 newtype Q r a = Q { unQ  :: [r]->[r] }
 223 newtype TQ r a = TQ { unTQ :: ([r]->[r],[GenericQ' r]) }
 224
 225 -- A twin variation on gmapQ
 226 -- Note: Nested GenericQ (GenericQ ...) buggy in GHC 5.04
 227
 228 tmapQ :: forall r.
 229          (forall a b. (Data a, Data b) => a -> b -> r)
 230       -> (forall a b. (Data a, Data b) => a -> b -> [r])
 231
 232 tmapQ g x y = fst (unTQ (gfoldl k z y)) []
 233     where
 234       k (TQ (c,l)) x = TQ (\rs -> c (unQ' (head l) x:rs), tail l)
 235       z _            = TQ (id,gmapQ (\x -> Q' (g x)) x)
 236
 237 -- A first-class polymorphic version of GenericQ
 238
 239 data GenericQ' u = Q' { unQ' :: forall a. Data a => a -> u }
 240
 241
 242
 243 -- A first-class polymorphic version of GenericM
 244
 245 data Monad m => GenericM' m = M' { unM' :: forall a. Data a => a -> m a }
 246
 247 -- A type constructor for monadic twin transformations
 248 newtype TM m a = TM { unTM :: (m a,[GenericM' m]) }
 249
 250 -- A twin variation on gmapM
 251
 252 tmapM :: forall m. Monad m
 253       => (forall a b. (Data a, Data b) => a -> b -> m b)
 254       -> (forall a b. (Data a, Data b) => a -> b -> m b)
 255 tmapM g x y = fst (unTM (gfoldl k z y))
 256   where
 257     k (TM (f,l)) x = TM (f >>= \f' -> unM' (head l) x >>= return . f',tail l)
 258     z f            = TM (return f,gmapQ (\x -> M' (g x)) x)
 259
 260 ---------------------------------------------
 261 --
 262 --      Combinators for data structure traversal
 263 --
 264 ---------------------------------------------
 265
 266 -- | Summarise all nodes in top-down, left-to-right
 267 everything :: Data a
 268            => (r -> r -> r)
 269            -> (forall a. Data a => a -> r)
 270            -> a -> r
 271 everything k f x
 272      = foldl k (f x) (gmapQ (everything k f) x)
 273
 274
 275
 276 -- | Look up something by means of a recognizer
 277 something :: (forall a. Data a => a -> Maybe u)
 278           -> (forall a. Data a => a -> Maybe u)
 279 something = everything orElse
 280
 281
 282
 283 -- | Left-biased choice
 284 orElse :: Maybe a -> Maybe a -> Maybe a
 285 x `orElse` y = case x of
 286                 Just _  -> x
 287                 Nothing -> y
 288
 289
 290
 291 -- | Some people like folding over the first maybe instead
 292 x `orElse'` y = maybe y Just x
 293
 294
 295
 296 -- | Bottom-up synthesis of a data structure
 297 synthesize :: (forall a. Data a => a -> s -> s)
 298            -> (s -> s -> s)
 299            -> s
 300            -> (forall a. Data a => a -> s)
 301 synthesize f o z x = f x (foldr o z (gmapQ (synthesize f o z) x))
 302
 303
 304
 305 -- | Apply a transformation everywhere in bottom-up manner
 306 everywhere :: (forall a. Data a => a -> a)
 307            -> (forall a. Data a => a -> a)
 308 everywhere f = f . gmapT (everywhere f)
 309
 310
 311
 312 -- | Variation with stop condition
 313 everywhereBut :: GenericQ Bool
 314               -> GenericT -> GenericT
 315 everywhereBut q f x
 316     | q x       = x
 317     | otherwise = f (gmapT (everywhereBut q f) x)
 318
 319
 320
 321 -- | Monadic variation
 322 everywhereM :: (Monad m, Data a)
 323             => (forall b. Data b => b -> m b)
 324             -> a -> m a
 325 everywhereM f x = do x' <- gmapM (everywhereM f) x
 326                      f x'
 327
 328
 329 -- | Count immediate subterms
 330 branches :: Data a => a -> Int
 331 branches = length . gmapQ (const ())
 332
 333
 334 -- |  Construct term with undefined subterms
 335 undefineds :: Data a => Constr -> Maybe a
 336 undefineds i =  gunfold (maybe Nothing (\x -> Just (x undefined)))
 337                         Just
 338                         i
 339
 340
 341 ---------------------------------------------
 342 --
 343 --      Generic equality, zip, read, show
 344 --
 345 ---------------------------------------------
 346
 347 -- | Generic equality
 348 geq :: forall a. Data a => a -> a -> Bool
 349 geq x y = geq' x y
 350  where
 351   geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
 352   geq' x y = and ( (conString (conOf x) == conString (conOf y))
 353                  : tmapQ geq' x y
 354                  )
 355
 356
 357
 358 -- | Generic zip
 359 gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 360      -> (forall a b. (Data a, Data b) => a -> b -> Maybe b)
 361 gzip f x y =
 362   f x y
 363   `orElse`
 364   if conString (conOf x) == conString (conOf y)
 365    then tmapM (gzip f) x y
 366    else Nothing
 367
 368
 369 -- Generic show
 370 gshow :: Data a => a -> String
 371 gshow t =    "("
 372           ++ conString (conOf t)
 373           ++ concat (gmapQ ((++) " ". gshow) t)
 374           ++ ")"
 375
 376
 377
 378 -- The type constructor for unfold a la ReadS from the Prelude
 379 newtype GRead i a = GRead (i -> Maybe (a, i))
 380 unGRead (GRead x) = x
 381
 382
 383
 384 -- Generic read
 385 gread :: Data a => String -> Maybe (a, String)
 386 gread s
 387  = do s' <- return $ dropWhile ((==) ' ') s
 388       guard (not (s' == ""))
 389       guard (head s' == '(')
 390       (c,s'')  <- breakConOf (dropWhile ((==) ' ') (tail s'))
 391       (a,s''') <- unGRead (gunfold f z c) s''
 392       guard (not (s''' == ""))
 393       guard (head s''' == ')')
 394       return (a,tail s''')
 395  where
 396   f cab = GRead (\s -> do (ab,s') <- unGRead cab s
 397                           (a,s'')  <- gread s'
 398                           return (ab a,s''))
 399   z c = GRead (\s -> Just (c,s))
 400
 401
 402 -- Get Constr at front
 403 breakConOf :: String -> Maybe (Constr, String)
 404
 405 -- Assume an infix operators in parantheses
 406 breakConOf ('(':s)
 407  = case break ((==) ')') s of
 408      (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
 409      _ -> Nothing
 410
 411 -- Special treatment of multiple token constructors
 412 breakConOf ('[':']':s) = Just (Constr "[]",s)
 413
 414 -- Try lex for ordinary constructor and basic datatypes
 415 breakConOf s
 416  = case lex s of
 417      [(s'@(_:_),s'')] -> Just (Constr s',s'')
 418      _ -> Nothing
 419
 420
 421
 422 ---------------------------------------------
 423 --
 424 --      Instances of the Data class
 425 --
 426 ---------------------------------------------
 427
 428 instance Data Float where
 429  conOf x = Constr (show x)
 430  consOf _ = []
 431  gunfold f z c = z (read (conString c))
 432
 433 instance Data Char where
 434  conOf x = Constr (show x)
 435  consOf _ = []
 436  gunfold f z c = z (read (conString c))
 437
 438 {-       overlap
 439 instance Data String where
 440  conOf x = Constr (show x)
 441  consOf _ = []
 442  gunfold f z = z . read
 443
 444 -}
 445
 446 instance Data Bool where
 447  conOf False = Constr "False"
 448  conOf True  = Constr "True"
 449  consOf _    = [Constr "False",Constr "True"]
 450  gunfold f z (Constr "False") = z False
 451  gunfold f z (Constr "True")  = z True
 452
 453 instance Data a => Data [a] where
 454   gmapT  f   []     = []
 455   gmapT  f   (x:xs) = (f x:f xs)
 456   gmapQ  f   []     = []
 457   gmapQ  f   (x:xs) = [f x,f xs]
 458   gmapM  f   []     = return []
 459   gmapM  f   (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
 460   gfoldl f z []     = z []
 461   gfoldl f z (x:xs) = z (:) `f` x `f` xs
 462   gfoldr f z []     = z []
 463   gfoldr f z (x:xs) = f xs (f x (z (:)))
 464   conOf [] = Constr "[]"
 465   conOf (_:_) = Constr "(:)"
 466   gunfold f z (Constr "[]")  = z []
 467   gunfold f z (Constr "(:)") = f (f (z (:)))
 468   consOf _ = [Constr "[]",Constr "(:)"]
 469
 470
 471
 472
 473 {- ----------------------------------------------------
 474         Comments illustrating generic instances
 475
 476    An illustrative instance for a nested datatype
 477
 478    data Nest a = Box a | Wrap (Nest [a])
 479
 480     nestTc = mkTyCon "Nest"
 481
 482     instance Typeable a => Typeable (Nest a) where
 483       typeOf n = mkAppTy nestTc [typeOf (paratype n)]
 484        where
 485         paratype :: Nest a -> a
 486         paratype _ = undefined
 487
 488    instance (Data a, Data [a]) => Data (Nest a) where
 489     gmapT f (Box a)  = Box (f a)
 490     gmapT f (Wrap w) = Wrap (f w)
 491     gmapQ f (Box a)  = [f a]
 492     gmapQ f (Wrap w) = [f w]
 493     gmapM f (Box a)  = f a >>= return . Box
 494     gmapM f (Wrap w) = f w >>= return . Wrap
 495     conOf (Box _) = Constr "Box"
 496     conOf (Wrap _) = Constr "Wrap"
 497     consOf _ = map Constr ["Box","Wrap"]
 498     gunfold f z "Box"  = f (z Box)
 499     gunfold f z "Wrap" = f (z Wrap)
 500
 501
 502
 503    -- An illustrative instance for local quantors
 504
 505    instance Data GenericT' where
 506     gmapT f (T' g) = (T' (f g))
 507     conOf _ = Constr "T'"
 508     consOf _ = map Constr ["T'"]
 509
 510
 511    -- test code only
 512    instance Typeable GenericT' where
 513     typeOf _ = undefined
 514
 515
 516
 517    -- The instance for function types
 518    -- needs -fallow-undecidable-instances
 519
 520 instance Typeable (a -> b) => Data (a -> b) where
 521  gmapT f = id
 522  gmapQ f = const []
 523  gmapM f = return
 524  conOf _ = Constr "->"
 525  consOf _ = [Constr "->"]
 526 -}
 527
 528
 529 --------------------------------------------------------
 530 -- A first-class polymorphic version of GenericT
 531 -- Note: needed because [GenericT] not valid in GHC 5.04
 532
 533 {-      Comment out for now (SLPJ 17 Apr 03)
 534
 535 data GenericT' = T' (forall a. Data a => a -> a)
 536 unT' (T' x) = x
 537
 538 -- A type constructor for twin transformations
 539
 540 newtype IDL r a = IDL (a,[GenericT'])
 541 unIDL (IDL x) = x
 542
 543
 544
 545 -- A twin variation on gmapT
 546
 547 tmapT :: (forall a b. (Data a, Data b) => a -> b -> b)
 548       -> (forall a b. (Data a, Data b) => a -> b -> b)
 549 tmapT g x y = fst (unIDL (gfoldl k z y))
 550   where
 551     k (IDL (f,l)) x = IDL (f (unT' (head l) x),tail l)
 552     z f             = IDL (f,gmapQ (\x -> T' (g x)) x)
 553
 554
 555
 556 -- A first-class polymorphic version of GenericQ
 557
 558 data GenericQ' u = Q' (forall a. Data a => a -> u)
 559 unQ' (Q' x) = x
 560
 561
 562
 563
 564 -}
 565
 566
 567
 568
 569
 570 -- Compute arity of term constructor
 571
 572
 573 -- | Turn a predicate into a filter
 574 match :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Maybe a
 575 match f = Nothing `mkQ` (\ a -> if f a then Just a else Nothing)
 576
 577
 578
 579 -- | Turn a predicate into a ticker
 580 tick :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Int
 581 tick f = 0 `mkQ` (\a -> if f a then 1 else 0)
 582
 583
 584
 585 -- | Turn a ticker into a counter
 586 count :: (Typeable a, Data b) => (a -> Bool) -> b -> Int
 587 count f = everything (+) (tick f)
 588
 589
 590
 591 -- | Lift a monomorphic predicate to the polymorphic level
 592 alike :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Bool
 593 alike f = False `mkQ` f