From c965627e2ab998114be853ce9c1a7c006aca8e12 Mon Sep 17 00:00:00 2001 From: ralf Date: Wed, 25 Feb 2004 21:20:04 +0000 Subject: [PATCH] [project @ 2004-02-25 21:20:04 by ralf] Follow-up fix triggered by yesterday's major scrap your boilerplate commit. --- Data/Generics/Aliases.hs | 66 +++++++++++++++++++++++----------------------- Data/Generics/Text.hs | 54 ++++++++++++++++++------------------- Data/Generics/Twins.hs | 23 +++++++++------- 3 files changed, 71 insertions(+), 72 deletions(-) diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index e28a623..3c03f56 100644 --- 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 --- 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 --- 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 -- 1.7.10.4