X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FGenerics.hs;h=525efdc33af668ae2a1ec7607b2283d953674d98;hb=e0062ebb3e48285f0649cd3ef9d71135829ba965;hp=7de69955dde009b3dc16d10bd9fea6340ca417b8;hpb=576682304c4f358e64129d2e197d5216b4f779be;p=ghc-base.git diff --git a/Data/Generics.hs b/Data/Generics.hs index 7de6995..525efdc 100644 --- a/Data/Generics.hs +++ b/Data/Generics.hs @@ -1,591 +1,54 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics --- Copyright : (c) The University of Glasgow 2001 +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable -- --- Data types for generic definitions (GHC only). +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . To scrap your boilerplate it +-- is sufficient to import the present module, which simply re-exports all +-- themes of the Data.Generics library. -- ----------------------------------------------------------------------------- module Data.Generics ( + -- * All Data.Generics modules + module Data.Generics.Basics, -- primitives + module Data.Generics.Instances, -- instances of Data class + module Data.Generics.Aliases, -- aliases for type case, generic types + module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) + module Data.Generics.Text, -- generic read and show + module Data.Generics.Twins, -- twin traversal, e.g., generic eq + #ifndef __HADDOCK__ - -- * Data types for the sum-of-products type encoding - (:*:)(..), (:+:)(..), Unit(..), + , + -- Data types for the sum-of-products type encoding; + -- included for backwards compatibility; maybe obsolete. + (:*:)(..), (:+:)(..), Unit(..) #endif - -- * Typeable and types-save cast - Typeable(..), cast, sameType, - - -- * The Data class and related types - Data( gmapT, gmapQ, gmapM, - gfoldl, gfoldr, gunfold, - conOf, consOf ), - Constr(..), - - -- * Transformations (T), queries (Q), monadic transformations (Q), - -- and twin transformations (TT) - GenericT, GenericQ, GenericM, - mkT, mkQ, mkM, - extT, extQ, extM, - mkTT, - - -- * Traversal combinators - everything, something, everywhere, everywhereBut, - synthesize, branches, undefineds, - - -- * Generic operations: equality, zip, read, show - geq, gzip, gshow, gread, - - -- * Miscellaneous - match, tick, count, alike - - ) where +------------------------------------------------------------------------------ + import Prelude -- So that 'make depend' works #ifdef __GLASGOW_HASKELL__ +#ifndef __HADDOCK__ + -- Data types for the sum-of-products type encoding; + -- included for backwards compatibility; maybe obsolete. import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) ) #endif +#endif -import Data.Dynamic -import Control.Monad - - - ---------------------------------------------- --- --- Operations involving Typeable only --- ---------------------------------------------- - --- | Apply a function if appropriate or preserve term -mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a -mkT f = case cast f of - Just g -> g - Nothing -> id - --- | Apply a function if appropriate or return a constant -mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Apply a monadic transformation if appropriate; resort to return otherwise -mkM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m) - => (b -> m b) -> a -> m a -mkM f = case cast f of - Just g -> g - Nothing -> return - --- | Extend a transformation -extT :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a -extT f g = case cast g of - Just g' -> g' - Nothing -> f - --- | Extend a query -extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q -extQ f g a = case cast a of - Just b -> g b - Nothing -> f a - --- | Extend a monadic transformation -extM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m) - => (a -> m a) -> (b -> m b) -> a -> m a -extM f g = case cast g of - Just g' -> g' - Nothing -> f - --- | Test two entities to be of the same type -sameType :: (Typeable a, Typeable b) => a -> b -> Bool -sameType (_::a) = False `mkQ` (\(_::a) -> True) - - - --- | Make a twin transformation --- Note: Should be worked on -mkTT :: (Typeable a, Typeable b, Typeable c) - => (a -> a -> a) - -> b -> c -> Maybe c -mkTT (f::a ->a->a) x y = - case (cast x,cast y) of - (Just (x'::a),Just (y'::a)) -> cast (f x' y') - _ -> Nothing - - - - -------------------------------------------------------------------- --- --- The representation of datatype constructors --- To be extended by fixity, associativity, and what else? --- -------------------------------------------------------------------- - --- | Describes a constructor -data Constr = Constr { conString :: String } - - - ---------------------------------------------- --- --- The Data class and its operations --- ---------------------------------------------- - --- A class for traversal - -class Typeable a => Data a where - gmapT :: (forall b. Data b => b -> b) -> a -> a - gmapQ :: (forall a. Data a => a -> u) -> a -> [u] - gmapM :: Monad m => (forall a. Data a => a -> m a) -> a -> m a - - gfoldl :: (forall a b. Data a => c (a -> b) -> a -> c b) - -> (forall g. g -> c g) - -> a -> c a - - gfoldr :: (forall a b. Data a => a -> c (a -> b) -> c b) - -> (forall g. g -> c g) - -> a -> c a - - - -- | Find the constructor - conOf :: a -> Constr - - -- | Does not look at a; Could live in Typeable as well maybe - consOf :: a -> [Constr] - - gunfold :: (forall a b. Data a => c (a -> b) -> c b) - -> (forall g. g -> c g) - -> Constr - -> c a - - -- No default method for gfoldl, gunfold, conOf, consOf - - -- Default methods for gfoldr, gmapT, gmapQ, gmapM, - -- in terms of gfoldl - - gfoldr f z = gfoldl (flip f) z - - gmapT f x = unID (gfoldl k ID x) - where - k (ID c) x = ID (c (f x)) - - gmapQ f x = unQ (gfoldl k (const (Q id)) x) [] - where - k (Q c) x = Q (\rs -> c (f x : rs)) - - gmapM f = gfoldl k return - where - k c x = do c' <- c - x' <- f x - return (c' x') - - - -- Default definition for gfoldl copes with basic datatypes - gfoldl _ z = z - - -{- - A variation for gmapQ using an ordinary constant type constructor. - A problem is here that the associativety might be wrong. - - newtype Phantom x y = Phantom x - runPhantom (Phantom x) = x - - gmapQ f = runPhantom . gfoldl f' z - where - f' r a = Phantom (f a : runPhantom r) - z = const (Phantom []) --} - - --- | Instructive type synonyms -type GenericT = forall a. Data a => a -> a -type GenericQ r = forall a. Data a => a -> r -type GenericM m = forall a. Data a => a -> m a - - --- Auxiliary type constructors for the default methods (not exported) -newtype ID x = ID { unID :: x } -newtype Q r a = Q { unQ :: [r]->[r] } -newtype TQ r a = TQ { unTQ :: ([r]->[r],[GenericQ' r]) } - --- A twin variation on gmapQ --- Note: Nested GenericQ (GenericQ ...) buggy in GHC 5.04 - -tmapQ :: forall r. - (forall a b. (Data a, Data b) => a -> b -> r) - -> (forall a b. (Data a, Data b) => a -> b -> [r]) - -tmapQ g x y = fst (unTQ (gfoldl k z y)) [] - where - k (TQ (c,l)) x = TQ (\rs -> c (unQ' (head l) x:rs), tail l) - z _ = TQ (id,gmapQ (\x -> Q' (g x)) x) - --- A first-class polymorphic version of GenericQ - -data GenericQ' u = Q' { unQ' :: forall a. Data a => a -> u } - - - --- A first-class polymorphic version of GenericM - -data Monad m => GenericM' m = M' { unM' :: forall a. Data a => a -> m a } - --- A type constructor for monadic twin transformations -newtype TM m a = TM { unTM :: (m a,[GenericM' m]) } - --- A twin variation on gmapM - -tmapM :: forall m. Monad m - => (forall a b. (Data a, Data b) => a -> b -> m b) - -> (forall a b. (Data a, Data b) => a -> b -> m b) -tmapM g x y = fst (unTM (gfoldl k z y)) - where - k (TM (f,l)) x = TM (f >>= \f' -> unM' (head l) x >>= return . f',tail l) - z f = TM (return f,gmapQ (\x -> M' (g x)) x) - ---------------------------------------------- --- --- Combinators for data structure traversal --- ---------------------------------------------- - --- | Summarise all nodes in top-down, left-to-right -everything :: Data a - => (r -> r -> r) - -> (forall a. Data a => a -> r) - -> a -> r -everything k f x - = foldl k (f x) (gmapQ (everything k f) x) - - - --- | Look up something by means of a recognizer -something :: (forall a. Data a => a -> Maybe u) - -> (forall a. Data a => a -> Maybe u) -something = everything orElse - - - --- | Left-biased choice -orElse :: Maybe a -> Maybe a -> Maybe a -x `orElse` y = case x of - Just _ -> x - Nothing -> y - - - --- | Some people like folding over the first maybe instead -x `orElse'` y = maybe y Just x - - - --- | Bottom-up synthesis of a data structure -synthesize :: (forall a. Data a => a -> s -> s) - -> (s -> s -> s) - -> s - -> (forall a. Data a => a -> s) -synthesize f o z x = f x (foldr o z (gmapQ (synthesize f o z) x)) - - - --- | Apply a transformation everywhere in bottom-up manner -everywhere :: (forall a. Data a => a -> a) - -> (forall a. Data a => a -> a) -everywhere f = f . gmapT (everywhere f) - - - --- | Variation with stop condition -everywhereBut :: GenericQ Bool - -> GenericT -> GenericT -everywhereBut q f x - | q x = x - | otherwise = f (gmapT (everywhereBut q f) x) - - - --- | Monadic variation -everywhereM :: (Monad m, Data a) - => (forall b. Data b => b -> m b) - -> a -> m a -everywhereM f x = do x' <- gmapM (everywhereM f) x - f x' - - --- | Count immediate subterms -branches :: Data a => a -> Int -branches = length . gmapQ (const ()) - - --- | Construct term with undefined subterms -undefineds :: Data a => Constr -> Maybe a -undefineds i = gunfold (maybe Nothing (\x -> Just (x undefined))) - Just - i - - ---------------------------------------------- --- --- Generic equality, zip, read, show --- ---------------------------------------------- - --- | Generic equality -geq :: forall a. Data a => a -> a -> Bool -geq x y = geq' x y - where - geq' :: forall a b. (Data a, Data b) => a -> b -> Bool - geq' x y = and ( (conString (conOf x) == conString (conOf y)) - : tmapQ geq' x y - ) - - - --- | Generic zip -gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b) - -> (forall a b. (Data a, Data b) => a -> b -> Maybe b) -gzip f x y = - f x y - `orElse` - if conString (conOf x) == conString (conOf y) - then tmapM (gzip f) x y - else Nothing - - --- Generic show -gshow :: Data a => a -> String -gshow t = "(" - ++ conString (conOf t) - ++ concat (gmapQ ((++) " ". gshow) t) - ++ ")" - - - --- The type constructor for unfold a la ReadS from the Prelude -newtype GRead i a = GRead (i -> Maybe (a, i)) -unGRead (GRead x) = x - - - --- Generic read -gread :: Data a => String -> Maybe (a, String) -gread s - = do s' <- return $ dropWhile ((==) ' ') s - guard (not (s' == "")) - guard (head s' == '(') - (c,s'') <- breakConOf (dropWhile ((==) ' ') (tail s')) - (a,s''') <- unGRead (gunfold f z c) s'' - guard (not (s''' == "")) - guard (head s''' == ')') - return (a,tail s''') - where - f cab = GRead (\s -> do (ab,s') <- unGRead cab s - (a,s'') <- gread s' - return (ab a,s'')) - z c = GRead (\s -> Just (c,s)) - - --- Get Constr at front -breakConOf :: String -> Maybe (Constr, String) - --- Assume an infix operators in parantheses -breakConOf ('(':s) - = case break ((==) ')') s of - (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'') - _ -> Nothing - --- Special treatment of multiple token constructors -breakConOf ('[':']':s) = Just (Constr "[]",s) - --- Try lex for ordinary constructor and basic datatypes -breakConOf s - = case lex s of - [(s'@(_:_),s'')] -> Just (Constr s',s'') - _ -> Nothing - - - ---------------------------------------------- --- --- Instances of the Data class --- ---------------------------------------------- - -instance Data Float where - conOf x = Constr (show x) - consOf _ = [] - gunfold f z c = z (read (conString c)) - -instance Data Char where - conOf x = Constr (show x) - consOf _ = [] - gunfold f z c = z (read (conString c)) - -{- overlap -instance Data String where - conOf x = Constr (show x) - consOf _ = [] - gunfold f z = z . read - --} - -instance Data Bool where - conOf False = Constr "False" - conOf True = Constr "True" - consOf _ = [Constr "False",Constr "True"] - gunfold f z (Constr "False") = z False - gunfold f z (Constr "True") = z True - -instance Data a => Data [a] where - gmapT f [] = [] - gmapT f (x:xs) = (f x:f xs) - gmapQ f [] = [] - gmapQ f (x:xs) = [f x,f xs] - gmapM f [] = return [] - gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs') - gfoldl f z [] = z [] - gfoldl f z (x:xs) = z (:) `f` x `f` xs - gfoldr f z [] = z [] - gfoldr f z (x:xs) = f xs (f x (z (:))) - conOf [] = Constr "[]" - conOf (_:_) = Constr "(:)" - gunfold f z (Constr "[]") = z [] - gunfold f z (Constr "(:)") = f (f (z (:))) - consOf _ = [Constr "[]",Constr "(:)"] - - - - -{- ---------------------------------------------------- - Comments illustrating generic instances - - An illustrative instance for a nested datatype - - data Nest a = Box a | Wrap (Nest [a]) - - nestTc = mkTyCon "Nest" - - instance Typeable a => Typeable (Nest a) where - typeOf n = mkAppTy nestTc [typeOf (paratype n)] - where - paratype :: Nest a -> a - paratype _ = undefined - - instance (Data a, Data [a]) => Data (Nest a) where - gmapT f (Box a) = Box (f a) - gmapT f (Wrap w) = Wrap (f w) - gmapQ f (Box a) = [f a] - gmapQ f (Wrap w) = [f w] - gmapM f (Box a) = f a >>= return . Box - gmapM f (Wrap w) = f w >>= return . Wrap - conOf (Box _) = Constr "Box" - conOf (Wrap _) = Constr "Wrap" - consOf _ = map Constr ["Box","Wrap"] - gunfold f z "Box" = f (z Box) - gunfold f z "Wrap" = f (z Wrap) - - - - -- An illustrative instance for local quantors - - instance Data GenericT' where - gmapT f (T' g) = (T' (f g)) - conOf _ = Constr "T'" - consOf _ = map Constr ["T'"] - - - -- test code only - instance Typeable GenericT' where - typeOf _ = undefined - - - - -- The instance for function types - -- needs -fallow-undecidable-instances - -instance Typeable (a -> b) => Data (a -> b) where - gmapT f = id - gmapQ f = const [] - gmapM f = return - conOf _ = Constr "->" - consOf _ = [Constr "->"] --} - - --------------------------------------------------------- --- A first-class polymorphic version of GenericT --- Note: needed because [GenericT] not valid in GHC 5.04 - -{- Comment out for now (SLPJ 17 Apr 03) - -data GenericT' = T' (forall a. Data a => a -> a) -unT' (T' x) = x - --- A type constructor for twin transformations - -newtype IDL r a = IDL (a,[GenericT']) -unIDL (IDL x) = x - - - --- A twin variation on gmapT - -tmapT :: (forall a b. (Data a, Data b) => a -> b -> b) - -> (forall a b. (Data a, Data b) => a -> b -> b) -tmapT g x y = fst (unIDL (gfoldl k z y)) - where - k (IDL (f,l)) x = IDL (f (unT' (head l) x),tail l) - z f = IDL (f,gmapQ (\x -> T' (g x)) x) - - - --- A first-class polymorphic version of GenericQ - -data GenericQ' u = Q' (forall a. Data a => a -> u) -unQ' (Q' x) = x - - - - --} - - - - - --- Compute arity of term constructor - - --- | Turn a predicate into a filter -match :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Maybe a -match f = Nothing `mkQ` (\ a -> if f a then Just a else Nothing) - - - --- | Turn a predicate into a ticker -tick :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Int -tick f = 0 `mkQ` (\a -> if f a then 1 else 0) - - - --- | Turn a ticker into a counter -count :: (Typeable a, Data b) => (a -> Bool) -> b -> Int -count f = everything (+) (tick f) - - - --- | Lift a monomorphic predicate to the polymorphic level -alike :: (Typeable a, Typeable b) => (a -> Bool) -> b -> Bool -alike f = False `mkQ` f +import Data.Generics.Basics +import Data.Generics.Instances +import Data.Generics.Aliases +import Data.Generics.Schemes +import Data.Generics.Text +import Data.Generics.Twins