From: simonpj <unknown>
Date: Thu, 17 Apr 2003 16:51:43 +0000 (+0000)
Subject: [project @ 2003-04-17 16:51:43 by simonpj]
X-Git-Tag: nhc98-1-18-release~680
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=950ea620c19650754db3ae6058be71f0cdb89bb5;p=ghc-base.git

[project @ 2003-04-17 16:51:43 by simonpj]
Add lots of new generics stuff
---

diff --git a/Data/Generics.hs b/Data/Generics.hs
index 1a3496d..5ae52c8 100644
--- a/Data/Generics.hs
+++ b/Data/Generics.hs
@@ -13,11 +13,570 @@
 -----------------------------------------------------------------------------
 
 module Data.Generics ( 
-	(:*:)(..), (:+:)(..), Unit(..)
+	-- * Data types for the sum-of-products type encoding
+	(:*:)(..), (:+:)(..), Unit(..),
+
+	-- * 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
+import Prelude	-- So that 'make depend' works
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
 #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 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)
+          -> c a
+          -> 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 [])
+-}
+ 
+
+-- | Describes a constructor
+data Constr = Constr { conString :: String }		-- Will be extended
+
+-- | 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
+                        Nothing
+                        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 e 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))
+  e   = GRead (const Nothing)
+
+
+-- 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 e c = z (read (conString c))
+
+instance Data Char where
+ conOf x = Constr (show x)
+ consOf _ = []
+ gunfold f z e c = z (read (conString c))
+
+{-	 overlap
+instance Data String where
+ conOf x = Constr (show x)
+ consOf _ = []
+ gunfold f z e = z . read
+
+-}
+
+instance Data Bool where
+ conOf False = Constr "False"
+ conOf True  = Constr "True"
+ consOf _    = [Constr "False",Constr "True"]
+ gunfold f z e (Constr "False") = z False
+ gunfold f z e (Constr "True")  = z True
+ gunfold _ _ e _       = e
+
+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 e (Constr "[]")  = z []
+  gunfold f z e (Constr "(:)") = f (f (z (:)))
+  gunfold _ _ e _     = e
+  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 _) = "Box"
+    conOf (Wrap _) = "Wrap"
+    consOf _ = ["Box","Wrap"]
+    gunfold f z e "Box"  = f (z Box)
+    gunfold f z e "Wrap" = f (z Wrap)
+    gunfold _ _ e _      = e
+   
+   
+   
+   -- An illustrative instance for local quantors
+   
+   instance Data GenericT' where
+    gmapT f (T' g) = (T' (f g))
+    conOf _ = "T'"
+    consOf _ = ["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 _ = "->"
+ consOf _ = ["->"]
+-}
+
+
+--------------------------------------------------------
+-- 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
+
+
+