1 -----------------------------------------------------------------------------
3 -- Module : Data.Generics
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable
11 -- Data types for generic definitions (GHC only).
13 -----------------------------------------------------------------------------
15 module Data.Generics (
16 -- * Data types for the sum-of-products type encoding
17 (:*:)(..), (:+:)(..), Unit(..),
19 -- * Typeable and types-save cast
20 Typeable(..), cast, sameType,
22 -- * The Data class and related types
23 Data( gmapT, gmapQ, gmapM,
24 gfoldl, gfoldr, gunfold,
28 -- * Transformations (T), queries (Q), monadic transformations (Q),
29 -- and twin transformations (TT)
30 GenericT, GenericQ, GenericM,
36 -- * Traversal combinators
37 everything, something, everywhere, everywhereBut,
38 synthesize, branches, undefineds,
40 -- * Generic operations: equality, zip, read, show
41 geq, gzip, gshow, gread,
44 match, tick, count, alike
49 import Prelude -- So that 'make depend' works
51 #ifdef __GLASGOW_HASKELL__
52 import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
60 ---------------------------------------------
62 -- Operations involving Typeable only
64 ---------------------------------------------
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
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
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
87 -- | Extend a transformation
88 extT :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a
89 extT f g = case cast g of
94 extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
95 extQ f g a = case cast a of
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
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)
112 -- | Make a twin transformation
113 -- Note: Should be worked on
114 mkTT :: (Typeable a, Typeable b, Typeable 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')
124 ---------------------------------------------
126 -- The Data class and its operations
128 ---------------------------------------------
130 -- A class for traversal
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
137 gfoldl :: (forall a b. Data a => c (a -> b) -> a -> c b)
138 -> (forall g. g -> c g)
141 gfoldr :: (forall a b. Data a => a -> c (a -> b) -> c b)
142 -> (forall g. g -> c g)
146 -- | Find the constructor
148 -- | Does not look at a; Could live in Typeable as well maybe
149 consOf :: a -> [Constr]
151 gunfold :: (forall a b. Data a => c (a -> b) -> c b)
152 -> (forall g. g -> c g)
157 -- No default method for gfoldl, gunfold, conOf, consOf
159 -- Default methods for gfoldr, gmapT, gmapQ, gmapM,
160 -- in terms of gfoldl
162 gfoldr f z = gfoldl (flip f) z
164 gmapT f x = unID (gfoldl k ID x)
166 k (ID c) x = ID (c (f x))
168 gmapQ f x = unQ (gfoldl k (const (Q id)) x) []
170 k (Q c) x = Q (\rs -> c (f x : rs))
172 gmapM f = gfoldl k return
179 -- Default definition for gfoldl copes with basic datatypes
184 A variation for gmapQ using an ordinary constant type constructor.
185 A problem is here that the associativety might be wrong.
187 newtype Phantom x y = Phantom x
188 runPhantom (Phantom x) = x
190 gmapQ f = runPhantom . gfoldl f' z
192 f' r a = Phantom (f a : runPhantom r)
193 z = const (Phantom [])
197 -- | Describes a constructor
198 data Constr = Constr { conString :: String } -- Will be extended
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
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]) }
211 -- A twin variation on gmapQ
212 -- Note: Nested GenericQ (GenericQ ...) buggy in GHC 5.04
215 (forall a b. (Data a, Data b) => a -> b -> r)
216 -> (forall a b. (Data a, Data b) => a -> b -> [r])
218 tmapQ g x y = fst (unTQ (gfoldl k z y)) []
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)
223 -- A first-class polymorphic version of GenericQ
225 data GenericQ' u = Q' { unQ' :: forall a. Data a => a -> u }
229 -- A first-class polymorphic version of GenericM
231 data Monad m => GenericM' m = M' { unM' :: forall a. Data a => a -> m a }
233 -- A type constructor for monadic twin transformations
234 newtype TM m a = TM { unTM :: (m a,[GenericM' m]) }
236 -- A twin variation on gmapM
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))
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)
246 ---------------------------------------------
248 -- Combinators for data structure traversal
250 ---------------------------------------------
252 -- | Summarise all nodes in top-down, left-to-right
255 -> (forall a. Data a => a -> r)
258 = foldl k (f x) (gmapQ (everything k f) x)
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
269 -- | Left-biased choice
270 orElse :: Maybe a -> Maybe a -> Maybe a
271 x `orElse` y = case x of
277 -- | Some people like folding over the first maybe instead
278 x `orElse'` y = maybe y Just x
282 -- | Bottom-up synthesis of a data structure
283 synthesize :: (forall a. Data a => a -> s -> 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))
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)
298 -- | Variation with stop condition
299 everywhereBut :: GenericQ Bool
300 -> GenericT -> GenericT
303 | otherwise = f (gmapT (everywhereBut q f) x)
307 -- | Monadic variation
308 everywhereM :: (Monad m, Data a)
309 => (forall b. Data b => b -> m b)
311 everywhereM f x = do x' <- gmapM (everywhereM f) x
315 -- | Count immediate subterms
316 branches :: Data a => a -> Int
317 branches = length . gmapQ (const ())
320 -- | Construct term with undefined subterms
321 undefineds :: Data a => Constr -> Maybe a
322 undefineds i = gunfold (maybe Nothing (\x -> Just (x undefined)))
328 ---------------------------------------------
330 -- Generic equality, zip, read, show
332 ---------------------------------------------
334 -- | Generic equality
335 geq :: forall a. Data a => a -> a -> Bool
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)
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)
349 if conString (conOf x) == conString (conOf y)
350 then tmapM (gzip f) x y
355 gshow :: Data a => a -> String
356 gshow t = "(" ++ conString (conOf t) ++ concat (gmapQ ((++) " ". gshow) t) ++ ")"
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
367 gread :: Data a => String -> Maybe (a, String)
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''' == ')')
378 f cab = GRead (\s -> do (ab,s') <- unGRead cab s
381 z c = GRead (\s -> Just (c,s))
382 e = GRead (const Nothing)
385 -- Get Constr at front
386 breakConOf :: String -> Maybe (Constr, String)
388 -- Assume an infix operators in parantheses
390 = case break ((==) ')') s of
391 (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
394 -- Special treatment of multiple token constructors
395 breakConOf ('[':']':s) = Just (Constr "[]",s)
397 -- Try lex for ordinary constructor and basic datatypes
400 [(s'@(_:_),s'')] -> Just (Constr s',s'')
405 ---------------------------------------------
407 -- Instances of the Data class
409 ---------------------------------------------
411 instance Data Float where
412 conOf x = Constr (show x)
414 gunfold f z e c = z (read (conString c))
416 instance Data Char where
417 conOf x = Constr (show x)
419 gunfold f z e c = z (read (conString c))
422 instance Data String where
423 conOf x = Constr (show x)
425 gunfold f z e = z . read
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
437 instance Data a => Data [a] where
439 gmapT f (x:xs) = (f x:f xs)
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')
445 gfoldl f z (x:xs) = z (:) `f` x `f` xs
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 (:)))
453 consOf _ = [Constr "[]",Constr "(:)"]
458 {- ----------------------------------------------------
459 Comments illustrating generic instances
461 An illustrative instance for a nested datatype
463 data Nest a = Box a | Wrap (Nest [a])
465 nestTc = mkTyCon "Nest"
467 instance Typeable a => Typeable (Nest a) where
468 typeOf n = mkAppTy nestTc [typeOf (paratype n)]
470 paratype :: Nest a -> a
471 paratype _ = undefined
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)
489 -- An illustrative instance for local quantors
491 instance Data GenericT' where
492 gmapT f (T' g) = (T' (f g))
498 instance Typeable GenericT' where
503 -- The instance for function types
504 -- needs -fallow-undecidable-instances
506 instance Typeable (a -> b) => Data (a -> b) where
515 --------------------------------------------------------
516 -- A first-class polymorphic version of GenericT
517 -- Note: needed because [GenericT] not valid in GHC 5.04
519 {- Comment out for now (SLPJ 17 Apr 03)
521 data GenericT' = T' (forall a. Data a => a -> a)
524 -- A type constructor for twin transformations
526 newtype IDL r a = IDL (a,[GenericT'])
531 -- A twin variation on gmapT
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))
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)
542 -- A first-class polymorphic version of GenericQ
544 data GenericQ' u = Q' (forall a. Data a => a -> u)
556 -- Compute arity of term constructor
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)
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)
571 -- | Turn a ticker into a counter
572 count :: (Typeable a, Data b) => (a -> Bool) -> b -> Int
573 count f = everything (+) (tick f)
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