From d2ddca1e0024bc2a12fb0e721c9b2eeaaca68c4d Mon Sep 17 00:00:00 2001 From: ralf Date: Tue, 24 Feb 2004 19:51:12 +0000 Subject: [PATCH] [project @ 2004-02-24 19:51:11 by ralf] Twin traversal is now based on accumulating maps. Added polymorphic type extension for type constructors. --- Data/Generics/Aliases.hs | 91 ++++++++++++++++-- Data/Generics/Basics.hs | 49 ++++++++-- Data/Generics/Twins.hs | 236 ++++++++++++++++++++++------------------------ 3 files changed, 232 insertions(+), 144 deletions(-) diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index a8c59cc..e28a623 100644 --- a/Data/Generics/Aliases.hs +++ b/Data/Generics/Aliases.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Aliases --- Copyright : (c) The University of Glasgow, CWI 2001--2003 +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org @@ -44,7 +44,13 @@ module Data.Generics.Aliases ( -- * Operators for (over-appreciated) unfolding gunfoldB, - gunfoldR + gunfoldR, + + -- * Type extension for lists + extListT, + extListM, + extListQ, + extListR ) where @@ -103,9 +109,7 @@ mkM :: ( Monad m => (b -> m b) -> a -> m a -mkM f = case castarr f of - Just g -> g - Nothing -> return +mkM = extM return {- @@ -127,7 +131,7 @@ mkMp :: ( MonadPlus m => (b -> m b) -> a -> m a -mkMp = maybe (const mzero) id . castarr +mkMp = extM (const mzero) -- | Make a generic builder; @@ -139,7 +143,12 @@ mkR :: ( MonadPlus m , Typeable b ) => m b -> m a -mkR = maybe mzero id . castss +mkR f = mzero `extR` f + + +-- | Flexible type extension +ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a +ext0 def ext = maybe def id (cast0 ext) -- | Extend a generic transformation by a type-specific case @@ -170,7 +179,7 @@ extM :: ( Monad m , Typeable b ) => (a -> m a) -> (b -> m b) -> a -> m a -extM f = maybe f id . castarr +extM def ext = unM ((M def) `ext0` (M ext)) -- | Extend a generic MonadPlus transformation by a type-specific case @@ -196,7 +205,8 @@ extR :: ( Monad m , Typeable b ) => m a -> m b -> m a -extR f = maybe f id . castss +extR def ext = unR ((R def) `ext0` (R ext)) + ------------------------------------------------------------------------------ @@ -238,7 +248,7 @@ type GenericR m = forall a. Data a => m a -- | The general scheme underlying generic functions -- assumed by gfoldl; there are isomorphisms such as --- GenericT = Generic ID. +-- GenericT = Generic T. -- type Generic c = forall a. Data a => a -> c a @@ -316,3 +326,64 @@ gunfoldR :: (Monad m, Data a) -> (forall a. Data a => m a) -> m a gunfoldR c f = gmapM (const f) $ fromConstr c + + + +------------------------------------------------------------------------------ +-- +-- Type extension for lists +-- +------------------------------------------------------------------------------ + + +-- | 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 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 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 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 constructors for type-level lambdas +-- +------------------------------------------------------------------------------ + + +-- | The type constructor for transformations +newtype T x = T { unT :: x -> x } + +-- | The type constructor for transformations +newtype M m x = M { unM :: x -> m x } + +-- | The type constructor for queries +newtype Q q x = Q { unQ :: x -> q } + +-- | The type constructor for readers +newtype R m x = R { unR :: m x } diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs index cb0ef4b..e7c8c76 100644 --- a/Data/Generics/Basics.hs +++ b/Data/Generics/Basics.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Basics --- Copyright : (c) The University of Glasgow, CWI 2001--2003 +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org @@ -24,8 +24,9 @@ module Data.Generics.Basics ( gfoldl, -- :: ... -> a -> c a toConstr, -- :: a -> Constr fromConstr, -- :: Constr -> a - dataTypeOf -- :: a -> DataType - + dataTypeOf, -- :: a -> DataType + ext1, -- type extension for unary type constructors + ext2 -- type extension for binary type constructors ), -- * Constructor representations @@ -69,6 +70,8 @@ import Data.Typeable import Data.Maybe import Control.Monad + + ------------------------------------------------------------------------------ -- -- The Data class @@ -123,7 +126,6 @@ fold. -- gfoldl _ z = z - -- | Obtaining the constructor from a given datum. -- For proper terms, this is meant to be the top-level constructor. -- Primitive datatypes are here viewed as potentially infinite sets of @@ -140,6 +142,29 @@ fold. dataTypeOf :: a -> DataType + +------------------------------------------------------------------------------ +-- +-- Type extension for unary and binary type constructors +-- +------------------------------------------------------------------------------ + + -- | Type extension for unary type constructors + ext1 :: Typeable1 t + => c a + -> (forall a. Data a => c (t a)) + -> c a + + ext1 def ext = def + + + -- | Type extension for binary type constructors + ext2 :: Typeable2 t + => c a + -> (forall a b. (Data a, Data b) => c (t a b)) -> c a + ext2 def ext = def + + ------------------------------------------------------------------------------ -- -- Typical generic maps defined in terms of gfoldl @@ -218,10 +243,10 @@ unit. -- | A generic query that processes one child by index (zero-based) gmapQi :: Int -> (forall a. Data a => a -> u) -> a -> u - gmapQi i f x = case gfoldl k z x of { COUNT _ (Just q) -> q } + gmapQi i f x = case gfoldl k z x of { Qi _ (Just q) -> q } where - k (COUNT i' q) a = COUNT (i'+1) (if i==i' then Just (f a) else q) - z f = COUNT 0 Nothing + k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q) + z f = Qi 0 Nothing -- | A generic monadic transformation that maps over the immediate subterms @@ -293,7 +318,7 @@ newtype CONST c a = CONST { unCONST :: c } -- | Type constructor for adding counters to queries -data COUNT q a = COUNT Int (Maybe q) +data Qi q a = Qi Int (Maybe q) -- | The type constructor used in definition of gmapQr @@ -553,6 +578,8 @@ instance Data a => Data [a] where 1 -> [] 2 -> undefined:undefined dataTypeOf _ = listDataType + ext1 def ext = maybe def id (cast1 ext) + -- -- The gmaps are given as an illustration. @@ -584,6 +611,7 @@ instance Data a => Data (Maybe a) where 1 -> Nothing 2 -> Just undefined dataTypeOf _ = maybeDataType + ext1 def ext = maybe def id (cast1 ext) -- @@ -600,6 +628,7 @@ instance (Data a, Data b) => Data (a,b) where fromConstr c = case conIndex c of 1 -> (undefined,undefined) dataTypeOf _ = productDataType + ext2 def ext = maybe def id (cast2 ext) -- @@ -646,6 +675,7 @@ instance (Data a, Data b) => Data (Either a b) where 1 -> Left undefined 2 -> Right undefined dataTypeOf _ = eitherDataType + ext2 def ext = maybe def id (cast2 ext) {- @@ -669,7 +699,8 @@ instance Data String where -} -- A last resort for functions -instance (Typeable a, Typeable b) => Data (a -> b) where +instance (Data a, Data b) => Data (a -> b) where toConstr _ = FunConstr fromConstr _ = undefined dataTypeOf _ = FunType + ext2 def ext = maybe def id (cast2 ext) diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs index c12e8c9..866c5f3 100644 --- a/Data/Generics/Twins.hs +++ b/Data/Generics/Twins.hs @@ -17,21 +17,18 @@ module Data.Generics.Twins ( - -- * The idiom for multi-parameter traversal - gzipWith, - - -- * Mapping combinators with an additional list - gzipWithT, - gzipWithM, - gzipWithQ, - gzipWithQl, - gzipWithQr, + -- * Generic folds and maps that also accumulate + gfoldlAccum, + gmapAccumT, + gmapAccumM, + gmapAccumQl, + gmapAccumQr, + gmapAccumQ, -- * Mapping combinators for twin traversal - tmapT, - tmapM, - tmapQ, - + gzipWithT, + gzipWithM, + gzipWithQ, -- * Typical twin traversals geq, @@ -53,115 +50,99 @@ import Data.Generics.Aliases ------------------------------------------------------------------------------ -- --- The idiom for multi-parameter traversal +-- Generic folds and maps that also accumulate -- ------------------------------------------------------------------------------ -{- - -gfoldl and friends so far facilitated traversal of a single term. We -will now consider an idiom gfoldlWith to traverse two terms -semi-simultaneously. By cascasding this idiom, we can also traverse -more than two terms. The gfoldlWith primitive completes gfoldl in a -way that is similar to the well-known couple map and -zipWith. Basically, gfoldlWith takes an additional argument, namely a -list, and this list is traversed simultaneously with the immediate -subterms of a given term. - --} - +{-------------------------------------------------------------- --- | gfoldl with an additional list -gzipWith :: Data a - => (forall a b. Data a => d -> c (a -> b) -> a -> c b) - -> (forall g. g -> c g) - -> [d] - -> a - -> c a - -gzipWith k z l x = case gfoldl k' z' x of { WITH _ c -> c } - where - k' (WITH (h:t) c) y = WITH t (k h c y) - k' (WITH [] _) _ = error "gzipWith" - z' f = WITH l (z f) - - --- | A type constructor for folding over the extra list -data WITH q c a = WITH [q] (c a) - - - ------------------------------------------------------------------------------- --- --- Mapping combinators with an additional list --- ------------------------------------------------------------------------------- +A list map can be elaborated to perform accumulation. +In the same sense, we can elaborate generic maps over terms. +We recall the type of map: +map :: (a -> b) -> [a] -> [b] --- | gmapT with an additional list -gzipWithT :: Data a - => (forall a. Data a => b -> a -> a) - -> [b] - -> a - -> a +We recall the type of an accumulating map (see Data.List): +mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) -gzipWithT f l = unID . gzipWith k ID l - where - k b (ID c) x = ID $ c $ f b x +Applying the same scheme we obtain an accumulating gfoldl. +--------------------------------------------------------------} --- | gmapM with an additional list -gzipWithM :: (Data a, Monad m) - => (forall a. Data a => b -> a -> m a) - -> [b] - -> a - -> m a +-- | gfoldl with accumulation -gzipWithM f = gzipWith k return - where - k b c x = do c' <- c - x' <- f b x - return (c' x') +gfoldlAccum :: Data d + => (forall d r. Data d => a -> c (d -> r) -> d -> (a, c r)) + -> (forall g. a -> g -> (a, c g)) + -> a -> d -> (a, c d) +gfoldlAccum k z a d = unA (gfoldl k' z' d) a + where + k' c y = A (\a -> let (a', c') = unA c a in k a' c' y) + z' f = A (\a -> z a f) --- | gmapQl with an additional list -gzipWithQl :: Data a - => (r -> r -> r) - -> r - -> (forall a. Data a => b -> a -> r) - -> [b] - -> a - -> r -gzipWithQl o r f l = unCONST . gzipWith k z l - where - k b (CONST c) x = CONST (c `o` f b x) - z _ = CONST r +-- | A type constructor for accumulation +newtype A a c d = A (a -> (a, c d)) +unA (A f) = f --- | gmapQr with an additional list -gzipWithQr :: Data a - => (r' -> r -> r) - -> r - -> (forall a. Data a => b -> a -> r') - -> [b] - -> a - -> r +-- | gmapT with accumulation +gmapAccumT :: Data d + => (forall d. Data d => a -> d -> (a,d)) + -> a -> d -> (a, d) +gmapAccumT f a d = let (a',d') = gfoldlAccum k z a d + in (a',unID d') + where + k a (ID c) d = let (a',d') = f a d + in (a', ID (c d')) + z a x = (a, ID x) -gzipWithQr o r f l x = unQr (gzipWith k z l x) r - where - k b (Qr c) x = Qr (\r -> c (f b x `o` r)) - z _ = Qr id +-- | gmapT with accumulation +gmapAccumM :: (Data d, Monad m) + => (forall d. Data d => a -> d -> (a, m d)) + -> a -> d -> (a, m d) +gmapAccumM f = gfoldlAccum k z + where + k a c d = let (a',d') = f a d + in (a', d' >>= \d'' -> c >>= \c' -> return (c' d'')) + z a x = (a, return x) + + +-- | gmapQl with accumulation +gmapAccumQl :: Data d + => (r -> r' -> r) + -> r + -> (forall d. Data d => a -> d -> (a,r')) + -> a -> d -> (a, r) +gmapAccumQl o r f a d = let (a',r) = gfoldlAccum k z a d + in (a',unCONST r) + where + k a (CONST c) d = let (a',r') = f a d + in (a', CONST (c `o` r')) + z a _ = (a, CONST r) + + +-- | gmapQr with accumulation +gmapAccumQr :: Data d + => (r' -> r -> r) + -> r + -> (forall d. Data d => a -> d -> (a,r')) + -> a -> d -> (a, r) +gmapAccumQr o r f a d = let (a',l) = gfoldlAccum k z a d + in (a',unQr l r) + where + k a (Qr c) d = let (a',r') = f a d + in (a', Qr (\r -> c (r' `o` r))) + z a _ = (a, Qr id) --- | gmapQ with an additional list -gzipWithQ :: Data a - => (forall a. Data a => b -> a -> u) - -> [b] - -> a - -> [u] -gzipWithQ f = gzipWithQr (:) [] f +-- | gmapQ with accumulation +gmapAccumQ :: Data d + => (forall d. Data d => a -> d -> (a,q)) + -> a -> d -> (a, [q]) +gmapAccumQ f = gmapAccumQr (:) [] f @@ -172,16 +153,15 @@ gzipWithQ f = gzipWithQr (:) [] f ------------------------------------------------------------------------------ - --- | The identity type constructor needed for the definition of gzipWithT +-- | The identity type constructor needed for the definition of gmapAccumT newtype ID x = ID { unID :: x } --- | The constant type constructor needed for the definition of gzipWithQl +-- | The constant type constructor needed for the definition of gmapAccumQl newtype CONST c a = CONST { unCONST :: c } --- | The type constructor needed for the definition of gzipWithQr +-- | The type constructor needed for the definition of gmapAccumQr newtype Qr r a = Qr { unQr :: r -> r } @@ -194,27 +174,34 @@ newtype Qr r a = Qr { unQr :: r -> r } -- | Twin map for transformation -tmapT :: GenericQ (GenericT) -> GenericQ (GenericT) -tmapT f x y = - gzipWithT unGenericT' - (gmapQ (\x -> GenericT' (f x)) x) - y +gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) +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 + -- | Twin map for monadic transformation -tmapM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) -tmapM f x y = - gzipWithM unGenericM' - (gmapQ (\x -> GenericM' (f x)) x) - y +gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) +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 -- | Twin map for monadic transformation -tmapQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) -tmapQ f x y = - gzipWithQ unGenericQ' - (gmapQ (\x -> GenericQ' (f x)) x) - y +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 @@ -246,18 +233,17 @@ geq x y = geq' x y where geq' :: forall a b. (Data a, Data b) => a -> b -> Bool geq' x y = (toConstr x == toConstr y) - && and (tmapQ geq' x y) + && and (gzipWithQ geq' x y) -- | Generic zip controlled by a function with type-specific branches gzip :: (forall a b. (Data a, Data b) => a -> b -> Maybe b) -> (forall a b. (Data a, Data b) => a -> b -> Maybe b) - -- See testsuite/.../Generics/gzip.hs for an illustration gzip f x y = f x y `orElse` if toConstr x == toConstr y - then tmapM (gzip f) x y + then gzipWithM (gzip f) x y else Nothing -- 1.7.10.4