[project @ 2004-02-25 21:20:04 by ralf]

Follow-up fix triggered by yesterday's major scrap your boilerplate commit.

diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs
index e28a623..3c03f56 100644 (file)
--- a/Data/Generics/Aliases.hs
+++ b/Data/Generics/Aliases.hs
@@ -46,11 +46,11 @@ module Data.Generics.Aliases (
         gunfoldB,
         gunfoldR,
 
-       -- * Type extension for lists
-       extListT, 
-       extListM,
-       extListQ,
-       extListR
+       -- * Type extension for unary type constructors
+       ext1T, 
+       ext1M,
+       ext1Q,
+       ext1R
 
   ) where
 
@@ -260,9 +260,9 @@ data Generic' c = Generic' { unGeneric' :: Generic c }
 
 
 -- | Other first-class polymorphic wrappers
-newtype GenericT'   = GenericT' { unGenericT' :: Data a => a -> a }
-newtype GenericQ' r = GenericQ' { unGenericQ' :: GenericQ r }
-newtype GenericM' m = GenericM' { unGenericM' :: Data a => a -> m a }
+newtype GenericT'   = GT { unGT :: Data a => a -> a }
+newtype GenericQ' r = GQ { unGQ :: GenericQ r }
+newtype GenericM' m = GM { unGM :: Data a => a -> m a }
 
 
 -- | Left-biased choice on maybies
@@ -331,41 +331,41 @@ gunfoldR c f = gmapM (const f) $ fromConstr c
 
 ------------------------------------------------------------------------------
 --
---     Type extension for lists
+--     Type extension for unary type constructors
 --
 ------------------------------------------------------------------------------
 
 
--- | Type extension of transformations for lists
-extListT :: Data d
-         => (forall d. Data d => d -> d)
-         -> (forall d. Data d => [d] -> [d])
-         -> d -> d
-extListT def ext = unT ((T def) `ext1` (T ext))
+-- | Type extension of transformations for unary type constructors
+ext1T :: (Data d, Typeable1 t)
+      => (forall d. Data d => d -> d)
+      -> (forall d. Data d => t d -> t d)
+      -> d -> d
+ext1T def ext = unT ((T def) `ext1` (T ext))
 
 
--- | Type extension of monadic transformations for lists
-extListM :: (Monad m, Data d)
-         => (forall d. Data d => d -> m d)
-         -> (forall d. Data d => [d] -> m [d])
-         -> d -> m d
-extListM def ext = unM ((M def) `ext1` (M ext))
+-- | Type extension of monadic transformations for type constructors
+ext1M :: (Monad m, Data d, Typeable1 t)
+      => (forall d. Data d => d -> m d)
+      -> (forall d. Data d => t d -> m (t d))
+      -> d -> m d
+ext1M def ext = unM ((M def) `ext1` (M ext))
 
 
--- | Type extension of queries for lists
-extListQ :: Data d
-         => (d -> q)
-         -> (forall d. Data d => [d] -> q)
-         -> d -> q
-extListQ def ext = unQ ((Q def) `ext1` (Q ext))
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable1 t)
+      => (d -> q)
+      -> (forall d. Data d => t d -> q)
+      -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
 
 
--- | Type extension of readers for lists
-extListR :: (Monad m, Data d)
-         => m d
-         -> (forall d. Data d => m [d])
-         -> m d
-extListR def ext = unR ((R def) `ext1` (R ext))
+-- | Type extension of readers for type constructors
+ext1R :: (Monad m, Data d, Typeable1 t)
+      => m d
+      -> (forall d. Data d => m (t d))
+      -> m d
+ext1R def ext = unR ((R def) `ext1` (R ext))
 
 
 

diff --git a/Data/Generics/Text.hs b/Data/Generics/Text.hs
index ccef471..b6ce518 100644 (file)
--- a/Data/Generics/Text.hs
+++ b/Data/Generics/Text.hs
@@ -28,7 +28,6 @@ import Prelude
 #endif
 import Control.Monad
 import Data.Maybe
-import Data.Typeable
 import Data.Generics.Basics
 import Data.Generics.Aliases
 import Text.ParserCombinators.ReadP
@@ -68,22 +67,26 @@ gread = readP_to_S gread'
 
  where
 
+  -- Helper for recursive read
   gread' :: Data a => ReadP a
-  gread' = gdefault `extR` scase
-
+  gread' = allButString `extR` stringCase
 
    where
 
     -- A specific case for strings
-    scase :: ReadP String
-    scase = readS_to_P reads
+    stringCase :: ReadP String
+    stringCase = readS_to_P reads
 
+    -- Determine result type
+    myDataType = dataTypeOf (getArg allButString)
+     where
+      getArg :: ReadP a -> a
+      getArg = undefined
 
     -- The generic default for gread
-    -- gdefault :: Data a => ReadP a
-    gdefault =
+    allButString =
       do
-               -- Drop "  (  "
+               -- Drop "  (  "
          skipSpaces                    -- Discard leading space
          char '('                      -- Parse '('
          skipSpaces                    -- Discard following space
@@ -100,29 +103,22 @@ gread = readP_to_S gread'
 
          return x
 
-     where
-
-       -- Get the datatype for the type at hand;
-       -- use gdefault to provide the type at hand.
-       myDataTypeOf :: Data a => ReadP a -> DataType
-       myDataTypeOf (_::ReadP a) = dataTypeOf (undefined::a)
-
-       -- Turn string into constructor driven by gdefault's type,
-       -- failing in the monad if it isn't a constructor of this data type
-       str2con :: String -> ReadP Constr       
-       str2con = maybe mzero return
-                . stringCon (myDataTypeOf gdefault)
+    -- Turn string into constructor driven by the requested result type,
+    -- failing in the monad if it isn't a constructor of this data type
+    str2con :: String -> ReadP Constr  
+    str2con = maybe mzero return
+            . stringCon myDataType
 
-       -- Get a Constr's string at the front of an input string
-       parseConstr :: ReadP String
-       parseConstr =  
+    -- Get a Constr's string at the front of an input string
+    parseConstr :: ReadP String
+    parseConstr =  
                string "[]"     -- Compound lexeme "[]"
           <++  infixOp        -- Infix operator in parantheses
           <++  readS_to_P lex  -- Ordinary constructors and literals
 
-       -- Handle infix operators such as (:)
-       infixOp :: ReadP String
-        infixOp = do c1  <- char '('
-                     str <- munch1 (not . (==) ')')
-                    c2  <- char ')'
-                    return $ [c1] ++ str ++ [c2]
+    -- Handle infix operators such as (:)
+    infixOp :: ReadP String
+    infixOp = do c1  <- char '('
+                 str <- munch1 (not . (==) ')')
+                c2  <- char ')'
+                 return $ [c1] ++ str ++ [c2]

diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs
index 866c5f3..99989bf 100644 (file)
--- a/Data/Generics/Twins.hs
+++ b/Data/Generics/Twins.hs
@@ -45,6 +45,10 @@ import Prelude
 import Data.Generics.Basics
 import Data.Generics.Aliases
 
+#ifdef __GLASGOW_HASKELL__
+import Prelude hiding ( GT )
+#endif
+
 ------------------------------------------------------------------------------
 
 
@@ -83,8 +87,7 @@ gfoldlAccum k z a d = unA (gfoldl k' z' d) a
 
 
 -- | A type constructor for accumulation
-newtype A a c d = A (a -> (a, c d))
-unA (A f) = f
+newtype A a c d = A { unA :: a -> (a, c d) }
 
 
 -- | gmapT with accumulation
@@ -99,7 +102,7 @@ gmapAccumT f a d = let (a',d') = gfoldlAccum k z a d
   z a x = (a, ID x)
 
 
--- | gmapT with accumulation
+-- | gmapM with accumulation
 gmapAccumM :: (Data d, Monad m)
            => (forall d. Data d => a -> d -> (a, m d))
            -> a -> d -> (a, m d)
@@ -179,8 +182,8 @@ gzipWithT f x y = case gmapAccumT perkid funs y of
                     ([], c) -> c
                     _       -> error "gzipWithT" 
  where
-  perkid a d = (tail a, unGenericT' (head a) d)
-  funs = gmapQ (\k -> GenericT' (f k)) x
+  perkid a d = (tail a, unGT (head a) d)
+  funs = gmapQ (\k -> GT (f k)) x
 
 
 
@@ -190,18 +193,18 @@ gzipWithM f x y = case gmapAccumM perkid funs y of
                     ([], c) -> c
                     _       -> error "gzipWithM" 
  where
-  perkid a d = (tail a, unGenericM' (head a) d)
-  funs = gmapQ (\k -> GenericM' (f k)) x
+  perkid a d = (tail a, unGM (head a) d)
+  funs = gmapQ (\k -> GM (f k)) x
 
 
--- | Twin map for monadic transformation 
+-- | Twin map for queries
 gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
 gzipWithQ f x y = case gmapAccumQ perkid funs y of
                    ([], r) -> r
                    _       -> error "gzipWithQ" 
  where
-  perkid a d = (tail a, unGenericQ' (head a) d)
-  funs = gmapQ (\k -> GenericQ' (f k)) x
+  perkid a d = (tail a, unGQ (head a) d)
+  funs = gmapQ (\k -> GQ (f k)) x