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