From cac0e3754bc4bc693d0092a05bdcda77059e0b05 Mon Sep 17 00:00:00 2001 From: ralf Date: Sat, 14 Feb 2004 18:18:48 +0000 Subject: [PATCH] [project @ 2004-02-14 18:18:46 by ralf] Refactored the approach to Twin Traversal. Added some illustrative treatment of polymorphic lists. --- Data/Generics.hs | 4 +- Data/Generics/Aliases.hs | 8 ++ Data/Generics/Basics.hs | 29 +++++- Data/Generics/List.hs | 71 +++++++++++++++ Data/Generics/Twins.hs | 225 +++++++++++++++++++++++++++++++--------------- 5 files changed, 264 insertions(+), 73 deletions(-) create mode 100644 Data/Generics/List.hs diff --git a/Data/Generics.hs b/Data/Generics.hs index 16c5027..58c5698 100644 --- a/Data/Generics.hs +++ b/Data/Generics.hs @@ -23,7 +23,8 @@ module Data.Generics ( module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) module Data.Generics.Text, -- generic read and show module Data.Generics.Twins, -- twin traversal, e.g., generic eq - module Data.Generics.Reify -- experimental reification theme + module Data.Generics.Reify, -- experimental reification theme + module Data.Generics.List -- mapping over polymorphic lists #ifndef __HADDOCK__ , @@ -52,3 +53,4 @@ import Data.Generics.Schemes import Data.Generics.Text import Data.Generics.Twins import Data.Generics.Reify +import Data.Generics.List diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index 5ab0859..a8c59cc 100644 --- a/Data/Generics/Aliases.hs +++ b/Data/Generics/Aliases.hs @@ -29,6 +29,9 @@ module Data.Generics.Aliases ( GenericR, Generic, Generic'(..), + GenericT'(..), + GenericQ'(..), + GenericM'(..), -- * Inredients of generic functions orElse, @@ -246,6 +249,11 @@ type Generic c = forall a. Data a => a -> c a 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 } + -- | Left-biased choice on maybies orElse :: Maybe a -> Maybe a -> Maybe a diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs index c03dff1..cb0ef4b 100644 --- a/Data/Generics/Basics.hs +++ b/Data/Generics/Basics.hs @@ -52,6 +52,7 @@ module Data.Generics.Basics ( gmapQ, gmapQl, gmapQr, + gmapQi, gmapM, gmapMp, gmapMo, @@ -209,11 +210,20 @@ unit. where 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 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 } + where + k (COUNT i' q) a = COUNT (i'+1) (if i==i' then Just (f a) else q) + z f = COUNT 0 Nothing + + -- | A generic monadic transformation that maps over the immediate subterms gmapM :: Monad m => (forall a. Data a => a -> m a) -> a -> m a @@ -282,6 +292,10 @@ newtype ID x = ID { unID :: x } newtype CONST c a = CONST { unCONST :: c } +-- | Type constructor for adding counters to queries +data COUNT q a = COUNT Int (Maybe q) + + -- | The type constructor used in definition of gmapQr newtype Qr r a = Qr { unQr :: r -> r } @@ -491,7 +505,20 @@ instance Data Rational where dataTypeOf _ = StringType -- --- Bool as the most trivial algebraic datatype; +-- () as the most trivial algebraic datatype; +-- define top-level definitions for representations. +-- + +emptyTupleConstr = mkConstr 1 "()" Prefix +unitDataType = mkDataType [emptyTupleConstr] + +instance Data () where + toConstr _ = emptyTupleConstr + fromConstr c | conIndex c == 1 = () + dataTypeOf _ = unitDataType + +-- +-- Bool as another trivial algebraic datatype; -- define top-level definitions for representations. -- diff --git a/Data/Generics/List.hs b/Data/Generics/List.hs new file mode 100644 index 0000000..278a76f --- /dev/null +++ b/Data/Generics/List.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.List +-- 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 +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . The present module illustrates +-- one possible treatment of polymorphic datatypes for specialising +-- generic functions. +-- +----------------------------------------------------------------------------- + +module Data.Generics.List ( + + -- * Processing polymorphic lists + isList, + isNil, + isCons, + lgmapQ + + + ) where + + +------------------------------------------------------------------------------ + +#ifdef __HADDOCK__ +import Prelude +#endif +import Data.Maybe +import Data.Generics.Basics + +------------------------------------------------------------- +-- +-- Processing polymorphic lists +-- +------------------------------------------------------------- + + +-- | Test for list datatype +isList :: Data a => a -> Bool +isList x = typerepTyCon (typeOf x) == + typerepTyCon (typeOf (undefined::[()])) + + +-- | Test for nil +isNil :: Data a => a -> Bool +isNil x = toConstr x == toConstr ([]::[()]) + + +-- | Test for cons +isCons :: Data a => a -> Bool +isCons x = toConstr x == toConstr (():[]) + + +-- | gmapQ for polymorphic lists; Nothing for other than lists +lgmapQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> Maybe [q] +lgmapQ f x = + if not $ isList x + then Nothing + else Just ( if isNil x + then [] + else if isCons x + then ( gmapQi 0 f x : gmapQi 1 (fromJust . lgmapQ f) x ) + else error "lgmapQ" + ) diff --git a/Data/Generics/Twins.hs b/Data/Generics/Twins.hs index 08a1b03..d432289 100644 --- a/Data/Generics/Twins.hs +++ b/Data/Generics/Twins.hs @@ -17,15 +17,23 @@ module Data.Generics.Twins ( - -- * The idiom of multi-parameter traversal - tfoldl, + -- * The idiom for multi-parameter traversal + gzipWith, - -- * Twin mapping combinators + -- * Mapping combinators with an additional list + gzipWithT, + gzipWithM, + gzipWithQ, + gzipWithQl, + gzipWithQr, + + -- * Mapping combinators for twin traversal tmapT, - tmapQl, - tmapM, + tmapM, + tmapQ, + - -- * Prime examples of twin traversal + -- * Typical twin traversals geq, gzip @@ -45,99 +53,174 @@ import Data.Generics.Aliases ------------------------------------------------------------------------------ -- --- The idiom of multi-parameter traversal +-- The idiom for multi-parameter traversal -- ------------------------------------------------------------------------------ {- -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. +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. -} -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 } +-- | 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 - 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' (WITH (h:t) c) y = WITH t (k h c y) + k' (WITH [] _) _ = error "gzipWith" + z' f = WITH l (z f) --- Pairing ID, CONST, m or others with lists of generic functions -data TWIN c a = TWIN [Generic' c] (c a) +-- | A type constructor for folding over the extra list +data WITH q c a = WITH [q] (c a) ------------------------------------------------------------------------------ -- --- Twin mapping combinators +-- Mapping combinators with an additional list -- ------------------------------------------------------------------------------ -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 +-- | gmapT with an additional list +gzipWithT :: Data a + => (forall a. Data a => b -> a -> a) + -> [b] + -> a + -> a -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 +gzipWithT f l = unID . gzipWith k ID l + where + k b (ID c) x = ID $ c $ f b x -tmapM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) -tmapM f x y = tfoldl k z f x y - where - k c x = do c' <- c - x' <- x - return $ c' x' - z = return +-- | gmapM with an additional list +gzipWithM :: (Data a, Monad m) + => (forall a. Data a => b -> a -> m a) + -> [b] + -> a + -> m a + +gzipWithM f = gzipWith k return + where + k b c x = do c' <- c + x' <- f b x + return (c' x') + + +-- | 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 + + +-- | gmapQr with an additional list +gzipWithQr :: Data a + => (r' -> r -> r) + -> r + -> (forall a. Data a => b -> a -> r') + -> [b] + -> a + -> r + +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 + + +-- | gmapQ with an additional list +gzipWithQ :: Data a + => (forall a. Data a => b -> a -> u) + -> [b] + -> a + -> [u] + +gzipWithQ f = gzipWithQr (:) [] f + + + +------------------------------------------------------------------------------ +-- +-- Helper type constructors +-- +------------------------------------------------------------------------------ --- The identity type constructor needed for the definition of tmapT + +-- | The identity type constructor needed for the definition of gzipWithT newtype ID x = ID { unID :: x } --- The constant type constructor needed for the definition of tmapQl +-- | The constant type constructor needed for the definition of gzipWithQl newtype CONST c a = CONST { unCONST :: c } +-- | The type constructor needed for the definition of gzipWithQr +newtype Qr r a = Qr { unQr :: r -> r } + + + +------------------------------------------------------------------------------ +-- +-- Mapping combinators for twin traversal +-- +------------------------------------------------------------------------------ + + +-- | Twin map for transformation +tmapT :: GenericQ (GenericT) -> GenericQ (GenericT) +tmapT f x y = + gzipWithT unGenericT' + (gmapQ (\x -> GenericT' (f x)) x) + y + + +-- | 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 + + +-- | 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 + + ------------------------------------------------------------------------------ -- --- Prime examples of twin traversal +-- Typical twin traversals -- ------------------------------------------------------------------------------ @@ -160,11 +243,11 @@ 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' :: forall a b. (Data a, Data b) => a -> b -> Bool + geq' x y = and ( (toConstr x == toConstr y) + : tmapQ geq' x y + ) -- | Generic zip controlled by a function with type-specific branches @@ -177,5 +260,5 @@ gzip f x y = f x y `orElse` if toConstr x == toConstr y - then tmapM (gzip f) x y - else Nothing + then tmapM (gzip f) x y + else Nothing -- 1.7.10.4