From e04b91f4203df5bf342349b26665442618a69589 Mon Sep 17 00:00:00 2001 From: ralf Date: Fri, 25 Jul 2003 14:36:50 +0000 Subject: [PATCH] [project @ 2003-07-25 14:36:38 by ralf] Data.Generics is up and running again! The testsuite is passed 100% successful. Much of the Data.Generics code looks better. So the transition to a new Data class and the deriving support is completed. Some detailed changes: - Rolled back type change for gmapQ. (We rather added gmapQl and gmapQr.) - Renamed gmapF and other "F" to Mp like MonadPlus. - Reconstructed gread. --- Data/Generics/Aliases.hs | 44 +++++++-------- Data/Generics/Basics.hs | 91 +++++++++++++++++++------------ Data/Generics/Counts.hs | 2 +- Data/Generics/Schemes.hs | 8 +-- Data/Generics/Strings.hs | 136 ++++++++++++++++++++++++++-------------------- Data/Generics/Twins.hs | 18 +++--- Data/Generics/Types.hs | 2 +- Data/Typeable.hs | 6 ++ 8 files changed, 174 insertions(+), 133 deletions(-) diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index ceb70c9..2aa8755 100644 --- a/Data/Generics/Aliases.hs +++ b/Data/Generics/Aliases.hs @@ -16,8 +16,8 @@ module Data.Generics.Aliases ( -- * Combinators to \"make\" generic functions via cast - mkT, mkQ, mkM, mkF, mkB, - extT, extQ, extM, extF, extB, + mkT, mkQ, mkM, mkMp, mkB, + extT, extQ, extM, extMp, extB, -- * Type synonyms for generic function types GenericT, @@ -31,9 +31,9 @@ module Data.Generics.Aliases ( orElse, -- * Function combinators on generic functions - recoverF, + recoverMp, recoverQ, - choiceF, + choiceMp, choiceQ ) where @@ -99,14 +99,14 @@ use a point-free style whenever possible. -- | Make a generic monadic transformation for MonadPlus; -- use \"const mzero\" (i.e., failure) instead of return as default. -- -mkF :: ( MonadPlus m, - Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) - ) +mkMp :: ( MonadPlus m, + Typeable a, + Typeable b, + Typeable (m a), + Typeable (m b) + ) => (b -> m b) -> a -> m a -mkF = maybe (const mzero) id . cast +mkMp = maybe (const mzero) id . cast -- | Make a generic builder; @@ -142,14 +142,14 @@ extM f = maybe f id . cast -- | Extend a generic MonadPlus transformation by a type-specific case -extF :: ( MonadPlus m, - Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) - ) +extMp :: ( MonadPlus m, + Typeable a, + Typeable b, + Typeable (m a), + Typeable (m b) + ) => (a -> m a) -> (b -> m b) -> a -> m a -extF = extM +extMp = extM @@ -229,8 +229,8 @@ queries a given constant is returned. -} -- | Choice for monadic transformations -choiceF :: MonadPlus m => GenericM m -> GenericM m -> GenericM m -choiceF f g x = f x `mplus` g x +choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m +choiceMp f g x = f x `mplus` g x -- | Choice for monadic queries @@ -239,8 +239,8 @@ choiceQ f g x = f x `mplus` g x -- | Recover from the failure of monadic transformation by identity -recoverF :: MonadPlus m => GenericM m -> GenericM m -recoverF f = f `choiceF` return +recoverMp :: MonadPlus m => GenericM m -> GenericM m +recoverMp f = f `choiceMp` return -- | Recover from the failure of monadic query by a constant diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs index e0d6dad..a39a35f 100644 --- a/Data/Generics/Basics.hs +++ b/Data/Generics/Basics.hs @@ -49,9 +49,10 @@ module Data.Generics.Basics ( -- * Generic maps defined in terms of gfoldl gmapT, gmapQ, - gmapL, + gmapQl, + gmapQr, gmapM, - gmapF, + gmapMp, -- * Generic unfolding defined in terms of gfoldl and fromConstr gunfoldM -- :: Monad m => ... -> m a @@ -146,9 +147,9 @@ fold. {- -The combinators gmapT, gmapQ, gmapL, gmapM, gmapF can all be defined -in terms of gfoldl. We provide corresponding default definitions -leaving open the opportunity to provide datatype-specific definitions. +The combinators gmapT, gmapQ, gmapM, ... can all be defined in terms +of gfoldl. We provide corresponding default definitions leaving open +the opportunity to provide datatype-specific definitions. (The inclusion of the gmap combinators as members of class Data allows the programmer or the compiler to derive specialised, and maybe more @@ -177,24 +178,40 @@ arguments. Technically, we also need to identify the type constructor k (ID c) x = ID (c (f x)) - -- | A generic query with monoid-like operators - gmapQ :: (r -> r -> r) -> r -> (forall a. Data a => a -> r) -> a -> r - gmapQ o r f = unCONST . gfoldl k z + -- | A generic query with a left-associative binary operator + gmapQl :: (r -> r' -> r) -> r -> (forall a. Data a => a -> r') -> a -> r + gmapQl o r f = unCONST . gfoldl k z where k c x = CONST $ (unCONST c) `o` f x z _ = CONST r +{- - -- | A generic query that processes the immediate subterms and returns a list - gmapL :: (forall a. Data a => a -> u) -> a -> [u] +In the definition of gmapQ? combinators, we use phantom type +constructors for the "c" in the type of "gfoldl" because the result +type of a query does not involve the (polymorphic) type of the term +argument. In the definition of gmapQl we simply use the plain constant +type constructor because gfoldl is left-associative anyway and so it +is readily suited to fold a left-associative binary operation over the +immediate subterms. In the definition of gmapQr, extra effort is +needed. We use a higher-order accumulation trick to mediate between +left-associative constructor application vs. right-associative binary +operation (e.g., (:)). When the query is meant to compute a value of +type r, then the result type withing generic folding is r -> r. So the +result of folding is a function to which we finally pass the right +unit. - -- Use a phantom + function datatype constructor QL (see below), - -- to instantiate the type constructor c in the type of gfoldl, - -- and perform injections QL and projections unQL accordingly. - -- - gmapL f x = unQL (gfoldl k (const (QL id)) x) [] +-} + + -- | A generic query with a right-associative binary operator + gmapQr :: (r' -> r -> r) -> r -> (forall a. Data a => a -> r') -> a -> r + gmapQr o r f x = unQr (gfoldl k (const (Qr id)) x) r where - k (QL c) x = QL (\rs -> c (f x : rs)) + k (Qr c) x = Qr (\r -> c (f x `o` r)) + + -- | A generic query that processes the immediate subterms and returns a list + gmapQ :: (forall a. Data a => a -> u) -> a -> [u] + gmapQ f = gmapQr (:) [] f -- | A generic monadic transformation that maps over the immediate subterms @@ -212,17 +229,22 @@ arguments. Technically, we also need to identify the type constructor -- | Transformation of at least one immediate subterm does not fail - gmapF :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a + gmapMp :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a - -- Use a datatype constructor F (see below) - -- to instantiate the type constructor c in the type of gfoldl. - -- - gmapF f x = unFAIL (gfoldl k z x) >>= \(x',b) -> - if b then return x' else mzero +{- + +The type constructor that we use here simply keeps track of the fact +if we already succeeded for an immediate subterm; see Mp below. To +this end, we couple the monadic computation with a Boolean. + +-} + + gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero where - z g = FAIL (return (g,False)) - k (FAIL c) x - = FAIL ( c >>= \(h,b) -> + z g = Mp (return (g,False)) + k (Mp c) x + = Mp ( c >>= \(h,b) -> (f x >>= \x' -> return (h x',True)) `mplus` return (h x, b) ) @@ -232,20 +254,16 @@ arguments. Technically, we also need to identify the type constructor newtype ID x = ID { unID :: x } --- | The constant type constructor needed for the definition of gmapQ +-- | The constant type constructor needed for the definition of gmapQl newtype CONST c a = CONST { unCONST :: c } --- | A phantom datatype constructor used in definition of gmapL; --- the function-typed component is needed to mediate between --- left-associative constructor application vs. right-associative lists. --- -newtype QL r a = QL { unQL :: [r] -> [r] } +-- | The type constructor used in definition of gmapQr +newtype Qr r a = Qr { unQr :: r -> r } --- | A pairing type constructor needed for the definition of gmapF; --- we keep track of the fact if a subterm was ever transformed successfully. -newtype FAIL m x = FAIL { unFAIL :: m (x, Bool) } +-- | The type constructor used in definition of gmapMp +newtype Mp m x = Mp { unMp :: m (x, Bool) } @@ -375,6 +393,7 @@ conIndex _ = undefined stringCon :: DataType -> String -> Maybe Constr stringCon (DataType cs) str = worker cs where + worker [] = Nothing worker (c:cs) = case c of (DataConstr _ str' _) -> if str == str' @@ -490,8 +509,8 @@ instance Data a => Data [a] where -- gmapT f [] = [] gmapT f (x:xs) = (f x:f xs) - gmapL f [] = [] - gmapL f (x:xs) = [f x,f xs] +-- gmapL f [] = [] +-- gmapL f (x:xs) = [f x,f xs] gmapM f [] = return [] gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs') diff --git a/Data/Generics/Counts.hs b/Data/Generics/Counts.hs index 0fc3f6f..bb2c5d6 100644 --- a/Data/Generics/Counts.hs +++ b/Data/Generics/Counts.hs @@ -40,7 +40,7 @@ import Data.Generics.Schemes -- | Count the number of immediate subterms of the given term glength :: GenericQ Int -glength = length . gmapL (const ()) +glength = length . gmapQ (const ()) -- | Determine the number of all suitable nodes in a given term diff --git a/Data/Generics/Schemes.hs b/Data/Generics/Schemes.hs index fd10942..532a94e 100644 --- a/Data/Generics/Schemes.hs +++ b/Data/Generics/Schemes.hs @@ -79,18 +79,18 @@ somewhere :: MonadPlus m => GenericM m -> GenericM m -- at the root of the term. The transformation fails if "f" fails -- everywhere, say succeeds nowhere. -- -somewhere f x = f x `mplus` gmapF (somewhere f) x +somewhere f x = f x `mplus` gmapMp (somewhere f) x -- | Summarise all nodes in top-down, left-to-right order everything :: (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; --- use gmapL to recurse into immediate subterms; +-- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results -- everything k f x - = foldl k (f x) (gmapL (everything k f) x) + = foldl k (f x) (gmapQ (everything k f) x) -- | Get a list of all entities that meet a predicate @@ -114,4 +114,4 @@ something = everything orElse -- 3rd argument f updates the sythesised data according to the given term -- synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s -synthesize z o f x = f x (foldr o z (gmapL (synthesize z o f) x)) +synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x)) diff --git a/Data/Generics/Strings.hs b/Data/Generics/Strings.hs index 1111e26..00bc030 100644 --- a/Data/Generics/Strings.hs +++ b/Data/Generics/Strings.hs @@ -40,7 +40,7 @@ gshow :: Data a => a -> String gshow = ( \t -> "(" ++ conString (toConstr t) - ++ concat (gmapL ((++) " " . gshow) t) + ++ concat (gmapQ ((++) " " . gshow) t) ++ ")" ) `extQ` (show :: String -> String) @@ -48,65 +48,95 @@ gshow = ( \t -> -- | The type constructor for gunfold a la ReadS from the Prelude; -- we don't use lists here for simplicity but only maybes. -- -newtype GRead a = GRead (String -> Maybe (a, String)) +newtype GRead a = GRead (String -> Maybe (a, String)) deriving Typeable unGRead (GRead x) = x -{- + -- | Turn GRead into a monad. instance Monad GRead where return x = GRead (\s -> Just (x, s)) (GRead f) >>= g = GRead (\s -> maybe Nothing (\(a,s') -> unGRead (g a) s') - f s + (f s) ) --} + +instance MonadPlus GRead where + mzero = GRead (\_ -> Nothing) + mplus = undefined + + +-- | Special parsing operators +trafo f = GRead (\s -> Just ((), f s)) +query f = GRead (\s -> if f s then Just ((), s) else Nothing) + -- | Generic read: an alternative to \"deriving Read\" -gread :: GenericB Maybe +gread :: Data a => String -> Maybe (a, String) {- This is a read operation which insists on prefix notation. (The -Haskell 98 read deals with infix operators as well. We will be able to -deal with such special cases as well as sonn as we include fixity -information into the definition of "Constr".) We use gunfold to -"parse" the input. To be precise, gunfold is used for all result types -except String. The type-specific case for String uses basic String -read. Another source of customisation would be to properly deal with -infix operators subject to the capture of that information in the -definition of Constr. The "gread" combinator properly checks the -validity of constructors before invoking gunfold in order to rule -out run-time errors. +Haskell 98 read deals with infix operators subject to associativity +and precedence as well.) We use gunfoldM to "parse" the input. To be +precise, gunfoldM is used for all types except String. The +type-specific case for String uses basic String read. -} -gread = undefined -{- -gdefault `extB` scase +gread = unGRead gread' where - -- a specific case for strings - scase s = case reads s of - [x::(String,String)] -> Just x - _ -> Nothing - - -- the generic default of gread - gdefault s = undefined - --} - + gread' :: GenericB GRead + gread' = gdefault `extB` scase + + where + + -- a specific case for strings + scase = GRead ( \s -> case reads s of + [x::(String,String)] -> Just x + _ -> Nothing + ) + + -- the generic default for gread + gdefault = + do + trafo $ dropWhile ((==) ' ') + query $ not . (==) "" + query $ (==) '(' . head + trafo $ tail + trafo $ dropWhile ((==) ' ') + str <- parseConstr + con <- str2con str + x <- gunfoldM con gread' + trafo $ dropWhile ((==) ' ') + query $ not . (==) "" + query $ (==) ')' . head + trafo $ tail + return x + + where + -- Turn string into constructor driven by gdefault's type + str2con = maybe mzero return + . + ( stringCon -- look up constructor at hand + $ dataTypeOf -- get handle on all constructurs + $ undefinedType -- turn type value into undefined + $ paraType -- get a handle on a in m a + $ gdefault -- use as type argument + ) {- + foo = do s' <- return $ dropWhile ((==) ' ') s guard (not (s' == "")) guard (head s' == '(') - (c,s'') <- prefixConstr (dropWhile ((==) ' ') (tail s')) + (c,s'') <- parseConstr (dropWhile ((==) ' ') (tail s')) u <- return undefined dt <- return $ dataTypeOf u case stringCon dt c of - Nothing -> error "Generics: gread failed" + Nothing -> error "Data.Generics.String: gread failed" Just c' -> gunfoldm c' gread @@ -119,39 +149,25 @@ gdefault `extB` scase guard (not (s''' == "")) guard (head s''' == ')') return (a, tail s''') +-} + -- Get a Constr's string at the front of an input string + parseConstr :: GRead String - -- To force two types to be the same - constrainTypes :: a -> a -> () - constrainTypes _ _ = () - - -- Argument f for unfolding - f :: Data a => GRead (a -> b) -> GRead b - f x = GRead (\s -> do (r,s') <- unGRead x s - (t,s'') <- gread s' - return (r t,s'')) - - -- Argument z for unfolding - z :: forall g. g -> GRead g - z g = GRead (\s -> return (g,s)) - + parseConstr = GRead ( \s -> case s of - -- Get Constr at front of string - prefixConstr :: String -> Maybe (Constr, String) + -- Infix operators are prefixed in parantheses + ('(':s) -> case break ((==) ')') s of + (s'@(_:_),(')':s'')) -> Just ("(" ++ s' ++ ")", s'') + _ -> Nothing - -- Assume an infix operators in parantheses - prefixConstr ('(':s) - = case break ((==) ')') s of - (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'') - _ -> Nothing + -- Special treatment of multiple token constructors + ('[':']':s) -> Just ("[]",s) - -- Special treatment of multiple token constructors - prefixConstr ('[':']':s) = Just (Constr "[]",s) + -- Try lex for ordinary constructor and basic datatypes + s -> case lex s of + [(s'@(_:_),s'')] -> Just (s',s'') + _ -> Nothing - -- Try lex for ordinary constructor and basic datatypes - prefixConstr s - = case lex s of - [(s'@(_:_),s'')] -> Just (Constr s',s'') - _ -> Nothing + ) --} \ No newline at end of file diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs index 2ec582d..3376774 100644 --- a/Data/Generics/Twins.hs +++ b/Data/Generics/Twins.hs @@ -20,7 +20,7 @@ module Data.Generics.Twins ( -- * Twin mapping combinators tmapT, - tmapQ, + tmapQl, tmapM, -- * Prime examples of twin traversal @@ -79,7 +79,7 @@ tfoldl :: (forall a b. Data a => c (a -> b) -> c a -> c b) tfoldl k z t xs ys = case gfoldl k' z' ys of { TWIN _ c -> c } where - l = gmapL (\x -> Generic' (t x)) xs + l = gmapQ (\x -> Generic' (t x)) xs k' (TWIN (r:rs) c) y = TWIN rs (k c (unGeneric' r y)) z' f = TWIN l (z f) @@ -103,11 +103,11 @@ tmapT f x y = unID $ tfoldl k z f' x y z = ID -tmapQ :: (r -> r -> r) - -> r - -> GenericQ (GenericQ r) - -> GenericQ (GenericQ r) -tmapQ o r f x y = unCONST $ tfoldl k z f' x y +tmapQl :: (r -> r -> r) + -> r + -> GenericQ (GenericQ r) + -> GenericQ (GenericQ r) +tmapQl o r f x y = unCONST $ tfoldl k z f' x y where f' x y = CONST $ f x y k (CONST c) (CONST x) = CONST (c `o` x) @@ -127,7 +127,7 @@ tmapM f x y = tfoldl k z f x y newtype ID x = ID { unID :: x } --- The constant type constructor needed for the definition of tmapQ +-- The constant type constructor needed for the definition of tmapQl newtype CONST c a = CONST { unCONST :: c } @@ -160,7 +160,7 @@ geq x y = geq' x y where geq' :: forall a b. (Data a, Data b) => a -> b -> Bool geq' x y = and [ (toConstr x == toConstr y) - , tmapQ (\b1 b2 -> and [b1,b2]) True geq' x y + , tmapQl (\b1 b2 -> and [b1,b2]) True geq' x y ] diff --git a/Data/Generics/Types.hs b/Data/Generics/Types.hs index d97d49d..caa0fc8 100644 --- a/Data/Generics/Types.hs +++ b/Data/Generics/Types.hs @@ -70,6 +70,6 @@ typeReachableFrom (a::TypeVal a) (b::TypeVal b) = -- See if a is reachable from immediate subterms of a kind of b recurse :: b -> Bool recurse = or - . gmapL ( typeReachableFrom a + . gmapQ ( typeReachableFrom a . typeValOf ) diff --git a/Data/Typeable.hs b/Data/Typeable.hs index c224fdd..c88920c 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -48,6 +48,7 @@ module Data.Typeable withType, -- :: a -> TypeVal a -> a argType, -- :: (a -> b) -> TypeVal a resType, -- :: (a -> b) -> TypeVal b + paraType, -- :: t a -> TypeVal a TypeFun -- functions on types ) where @@ -376,6 +377,11 @@ resType :: (a -> b) -> TypeVal b resType _ = typeVal +-- | The parameter type of type constructor +paraType :: t a -> TypeVal a +paraType _ = typeVal + + -- Type functions, -- i.e., functions mapping types to values -- -- 1.7.10.4