[project @ 2003-05-30 09:19:39 by simonpj]

[ghc-base.git] / Data / Generics.hs

diff --git a/Data/Generics.hs b/Data/Generics.hs
index 5ae52c8..e63d04a 100644 (file)
--- a/Data/Generics.hs
+++ b/Data/Generics.hs
@@ -8,13 +8,16 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- Data types for generic definitions.
+-- Data types for generic definitions (GHC only).
 --
 -----------------------------------------------------------------------------
 
 module Data.Generics ( 
+
+#ifndef __HADDOCK__
        -- * Data types for the sum-of-products type encoding
        (:*:)(..), (:+:)(..), Unit(..),
+#endif
 
        -- * Typeable and types-save cast
        Typeable(..),  cast, sameType, 
@@ -32,7 +35,6 @@ module Data.Generics (
        extT, extQ, extM,
        mkTT,
 
-
        -- * Traversal combinators
        everything, something, everywhere, everywhereBut,
        synthesize, branches, undefineds,
@@ -49,8 +51,10 @@ module Data.Generics (
 import Prelude -- So that 'make depend' works
 
 #ifdef __GLASGOW_HASKELL__
+#ifndef __HADDOCK__
 import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )
 #endif
+#endif
 
 import Data.Dynamic
 import Control.Monad
@@ -121,6 +125,19 @@ mkTT (f::a ->a->a) x y =
 
 
 
+
+-------------------------------------------------------------------
+--
+--     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
@@ -145,12 +162,12 @@ class Typeable a => Data a where
 
   -- | 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
 
@@ -194,9 +211,6 @@ class Typeable a => Data a where
 -}
  
 
--- | 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
@@ -321,7 +335,6 @@ branches = length . gmapQ (const ())
 undefineds :: Data a => Constr -> Maybe a
 undefineds i =  gunfold (maybe Nothing (\x -> Just (x undefined)))
                         Just
-                        Nothing
                         i
 
 
@@ -336,7 +349,9 @@ 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)
+  geq' x y = and ( (conString (conOf x) == conString (conOf y))
+                 : tmapQ geq' x y
+                 )
 
 
 
@@ -353,7 +368,10 @@ gzip f x y =
 
 -- Generic show
 gshow :: Data a => a -> String
-gshow t = "(" ++ conString (conOf t) ++ concat (gmapQ ((++) " ". gshow) t) ++ ")"
+gshow t =    "("
+          ++ conString (conOf t)
+          ++ concat (gmapQ ((++) " ". gshow) t)
+          ++ ")"
 
 
 
@@ -370,7 +388,7 @@ gread s
       guard (not (s' == ""))
       guard (head s' == '(')
       (c,s'')  <- breakConOf (dropWhile ((==) ' ') (tail s'))
-      (a,s''') <- unGRead (gunfold f z e c) s''
+      (a,s''') <- unGRead (gunfold f z c) s''
       guard (not (s''' == "")) 
       guard (head s''' == ')')
       return (a,tail s''')
@@ -379,7 +397,6 @@ gread s
                           (a,s'')  <- gread s'
                           return (ab a,s''))
   z c = GRead (\s -> Just (c,s))
-  e   = GRead (const Nothing)
 
 
 -- Get Constr at front
@@ -411,18 +428,18 @@ breakConOf s
 instance Data Float where
  conOf x = Constr (show x)
  consOf _ = []
- gunfold f z e c = z (read (conString c))
+ gunfold f z c = z (read (conString c))
 
 instance Data Char where
  conOf x = Constr (show x)
  consOf _ = []
- gunfold f z e c = z (read (conString c))
+ gunfold f z c = z (read (conString c))
 
 {-      overlap
 instance Data String where
  conOf x = Constr (show x)
  consOf _ = []
- gunfold f z e = z . read
+ gunfold f z = z . read
 
 -}
 
@@ -430,9 +447,8 @@ 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
+ gunfold f z (Constr "False") = z False
+ gunfold f z (Constr "True")  = z True
 
 instance Data a => Data [a] where
   gmapT  f   []     = []
@@ -447,9 +463,8 @@ instance Data a => Data [a] where
   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
+  gunfold f z (Constr "[]")  = z []
+  gunfold f z (Constr "(:)") = f (f (z (:)))
   consOf _ = [Constr "[]",Constr "(:)"]
 
 
@@ -477,12 +492,11 @@ instance Data a => Data [a] where
     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
+    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)
    
    
    
@@ -490,8 +504,8 @@ instance Data a => Data [a] where
    
    instance Data GenericT' where
     gmapT f (T' g) = (T' (f g))
-    conOf _ = "T'"
-    consOf _ = ["T'"]
+    conOf _ = Constr "T'"
+    consOf _ = map Constr ["T'"]
    
    
    -- test code only
@@ -507,8 +521,8 @@ instance Typeable (a -> b) => Data (a -> b) where
  gmapT f = id
  gmapQ f = const []
  gmapM f = return
- conOf _ = "->"
- consOf _ = ["->"]
+ conOf _ = Constr "->"
+ consOf _ = [Constr "->"]
 -}
 
 
@@ -577,6 +591,3 @@ 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
-
-
-