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