X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FGenerics%2FTwins.hs;h=4045c2eac6cea4f32ff2dd2f47a8f9df1c179657;hb=fb80d56c0b7617261c93a808e9001bbb25a7562e;hp=08a1b03aaeee598210a0de6374315510ffe6e894;hpb=b6ef4d7236a944f4ffed7aaa0fa8fcfe18cb77b9;p=ghc-base.git diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs index 08a1b03..4045c2e 100644 --- a/Data/Generics/Twins.hs +++ b/Data/Generics/Twins.hs @@ -1,12 +1,12 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Twins --- 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 -- Stability : experimental --- Portability : non-portable +-- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module @@ -15,19 +15,24 @@ -- ----------------------------------------------------------------------------- -module Data.Generics.Twins ( +module Data.Generics.Twins ( - -- * The idiom of multi-parameter traversal - tfoldl, + -- * Generic folds and maps that also accumulate + gfoldlAccum, + gmapAccumT, + gmapAccumM, + gmapAccumQl, + gmapAccumQr, + gmapAccumQ, - -- * Twin mapping combinators - tmapT, - tmapQl, - tmapM, + -- * Mapping combinators for twin traversal + gzipWithT, + gzipWithM, + gzipWithQ, - -- * Prime examples of twin traversal - geq, - gzip + -- * Typical twin traversals + geq, + gzip ) where @@ -40,104 +45,172 @@ import Prelude import Data.Generics.Basics import Data.Generics.Aliases +#ifdef __GLASGOW_HASKELL__ +import Prelude hiding ( GT ) +#endif + ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- --- The idiom of multi-parameter traversal +-- Generic folds and maps that also accumulate -- ------------------------------------------------------------------------------ -{- +{-------------------------------------------------------------- -The fact that we traverse two terms semi-simultaneously is reflected -by the nested generic function type that occurs as the result type of -tfoldl. By "semi-simultaneously", we mean that we first fold over the -first term and compute a LIST of generic functions to be folded over -the second term. So the outermost generic function type is GenericQ -because we compute a list of generic functions which is a kind of -query. The inner generic function type is parameterised in a type -constructor c so that we can instantiate twin traversal for -transformations (T), queries (Q), and monadic transformations (M). -The combinator tfoldl is also parameterised by a nested generic -function which serves as the function to be mapped over the first term -to get the functions to be mapped over the second term. The combinator -tfoldl is further parameterised by gfoldl-like parameters k and z -which however need to be lifted to k' and z' such that plain term -traversal is combined with list traversal (of the list of generic -functions). That is, the essence of multi-parameter term traversal is -a single term traversal interleaved with a list fold. As the -definition of k' and z' details, the list fold can be arranged by the -ingredients of the term fold. To this end, we use a designated TWIN -datatype constructor which pairs a given type constructor c with a -list of generic functions. +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] + +We recall the type of an accumulating map (see Data.List): +mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) + +Applying the same scheme we obtain an accumulating gfoldl. + +--------------------------------------------------------------} + +-- | gfoldl with accumulation + +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) + + +-- | A type constructor for accumulation +newtype A a c d = A { unA :: a -> (a, c d) } + + +-- | 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) -tfoldl :: (forall a b. Data a => c (a -> b) -> c a -> c b) - -> (forall g. g -> c g) - -> GenericQ (Generic c) - -> GenericQ (Generic c) -tfoldl k z t xs ys = case gfoldl k' z' ys of { TWIN _ c -> c } +-- | gmapM 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 - 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) + k a (Qr c) d = let (a',r') = f a d + in (a', Qr (\r -> c (r' `o` r))) + z a _ = (a, Qr id) --- Pairing ID, CONST, m or others with lists of generic functions -data TWIN c a = TWIN [Generic' c] (c a) +-- | gmapQ with accumulation +gmapAccumQ :: Data d + => (forall d. Data d => a -> d -> (a,q)) + -> a -> d -> (a, [q]) +gmapAccumQ f = gmapAccumQr (:) [] f ------------------------------------------------------------------------------ -- --- Twin mapping combinators +-- Helper type constructors -- ------------------------------------------------------------------------------ -tmapT :: GenericQ (GenericT) -> GenericQ (GenericT) -tmapT f x y = unID $ tfoldl k z f' x y - where - f' x y = ID $ f x y - k (ID c) (ID x) = ID (c x) - z = ID + +-- | The identity type constructor needed for the definition of gmapAccumT +newtype ID x = ID { unID :: x } -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) - z _ = CONST r +-- | 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 gmapAccumQr +newtype Qr r a = Qr { unQr :: r -> r } + + + +------------------------------------------------------------------------------ +-- +-- Mapping combinators for twin traversal +-- +------------------------------------------------------------------------------ -tmapM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) -tmapM f x y = tfoldl k z f x y +-- | Twin map for transformation +gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) +gzipWithT f x y = case gmapAccumT perkid funs y of + ([], c) -> c + _ -> error "gzipWithT" where - k c x = do c' <- c - x' <- x - return $ c' x' - z = return + perkid a d = (tail a, unGT (head a) d) + funs = gmapQ (\k -> GT (f k)) x --- The identity type constructor needed for the definition of tmapT -newtype ID x = ID { unID :: x } +-- | Twin map for monadic transformation +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, unGM (head a) d) + funs = gmapQ (\k -> GM (f k)) x --- The constant type constructor needed for the definition of tmapQl -newtype CONST c a = CONST { unCONST :: c } + +-- | 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, unGQ (head a) d) + funs = gmapQ (\k -> GQ (f k)) x ------------------------------------------------------------------------------ -- --- Prime examples of twin traversal +-- Typical twin traversals -- ------------------------------------------------------------------------------ @@ -160,22 +233,18 @@ couples of immediate subterms from the two given input terms.) -} 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) - , tmapQl (\b1 b2 -> and [b1,b2]) True geq' x y - ] + where + geq' :: GenericQ (GenericQ Bool) + geq' x y = (toConstr x == toConstr 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) - - +gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) -- See testsuite/.../Generics/gzip.hs for an illustration -gzip f x y = +gzip f x y = f x y `orElse` if toConstr x == toConstr y - then tmapM (gzip f) x y - else Nothing + then gzipWithM (gzip f) x y + else Nothing