From cbe03dd16fb2cef514c19281fc6b673612da8792 Mon Sep 17 00:00:00 2001 From: ralf Date: Sun, 23 Nov 2003 12:25:03 +0000 Subject: [PATCH] [project @ 2003-11-23 12:25:02 by ralf] Refactored some alias for generic builders and readers. Worked out some interested stuff for reification of type structures. --- Data/Generics/Aliases.hs | 133 +++++++++++++++++------ Data/Generics/Basics.hs | 19 ---- Data/Generics/Reify.hs | 265 ++++++++++++++++++++++++++++++++++++++++------ Data/Generics/Text.hs | 8 +- 4 files changed, 339 insertions(+), 86 deletions(-) diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index b1bcd96..c3badad 100644 --- a/Data/Generics/Aliases.hs +++ b/Data/Generics/Aliases.hs @@ -18,14 +18,15 @@ module Data.Generics.Aliases ( -- * Combinators to \"make\" generic functions via cast - mkT, mkQ, mkM, mkMp, mkB, - extT, extQ, extM, extMp, extB, + mkT, mkQ, mkM, mkMp, mkR, + extT, extQ, extM, extMp, extB, extR, -- * Type synonyms for generic function types GenericT, GenericQ, GenericM, GenericB, + GenericR, Generic, Generic'(..), @@ -36,7 +37,11 @@ module Data.Generics.Aliases ( recoverMp, recoverQ, choiceMp, - choiceQ + choiceQ, + + -- * Operators for (over-appreciated) unfolding + gunfoldB, + gunfoldR ) where @@ -57,7 +62,12 @@ import Data.Generics.Basics -- start from a type-specific case; -- preserve the term otherwise -- -mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a +mkT :: ( Typeable a + , Typeable b + ) + => (b -> b) + -> a + -> a mkT f = case cast f of Just g -> g Nothing -> id @@ -67,7 +77,13 @@ mkT f = case cast f of -- start from a type-specific case; -- return a constant otherwise -- -mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r @@ -77,11 +93,13 @@ mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r -- start from a type-specific case; -- resort to return otherwise -- -mkM :: ( Monad m, - Typeable a, - Typeable b +mkM :: ( Monad m + , Typeable a + , Typeable b ) - => (b -> m b) -> a -> m a + => (b -> m b) + -> a + -> m a mkM f = case castarr f of Just g -> g Nothing -> return @@ -99,11 +117,13 @@ 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. -- -mkMp :: ( MonadPlus m, - Typeable a, - Typeable b +mkMp :: ( MonadPlus m + , Typeable a + , Typeable b ) - => (b -> m b) -> a -> m a + => (b -> m b) + -> a + -> m a mkMp = maybe (const mzero) id . castarr @@ -111,50 +131,69 @@ mkMp = maybe (const mzero) id . castarr -- start from a type-specific ase; -- resort to no build (i.e., mzero) otherwise -- -mkB :: ( MonadPlus m, - Typeable a, - Typeable b +mkR :: ( MonadPlus m + , Typeable a + , Typeable b ) => m b -> m a -mkB = maybe mzero id . castss +mkR = maybe mzero id . castss -- | Extend a generic transformation by a type-specific case -extT :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a +extT :: ( Typeable a + , Typeable b + ) + => (a -> a) + -> (b -> b) + -> a + -> a extT f = maybe f id . cast -- | Extend a generic query by a type-specific case -extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q extQ f g a = maybe (f a) g (cast a) -- | Extend a generic monadic transformation by a type-specific case -extM :: ( Monad m, - Typeable a, - Typeable b +extM :: ( Monad m + , Typeable a + , Typeable b ) => (a -> m a) -> (b -> m b) -> a -> m a extM f = maybe f id . castarr -- | Extend a generic MonadPlus transformation by a type-specific case -extMp :: ( MonadPlus m, - Typeable a, - Typeable b +extMp :: ( MonadPlus m + , Typeable a + , Typeable b ) => (a -> m a) -> (b -> m b) -> a -> m a extMp = extM +-- | Extend a generic builder +extB :: ( Typeable a + , Typeable b + ) + => a -> b -> a +extB a = maybe a id . cast + --- | Extend a generic builder by a type-specific case -extB :: (Monad m, - Typeable a, - Typeable b +-- | Extend a generic reader +extR :: ( Monad m + , Typeable a + , Typeable b ) => m a -> m b -> m a -extB f = maybe f id . castss +extR f = maybe f id . castss ------------------------------------------------------------------------------ @@ -182,10 +221,16 @@ type GenericQ r = forall a. Data a => a -> r type GenericM m = forall a. Data a => a -> m a --- | Generic monadic builders with input i, +-- | Generic builders +-- i.e., produce an \"a\". +-- +type GenericB = forall a. Data a => a + + +-- | Generic readers, say monadic builders, -- i.e., produce an \"a\" with the help of a monad \"m\". -- -type GenericB m = forall a. Data a => m a +type GenericR m = forall a. Data a => m a -- | The general scheme underlying generic functions @@ -239,3 +284,27 @@ recoverMp f = f `choiceMp` return -- | Recover from the failure of monadic query by a constant recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r) recoverQ r f = f `choiceQ` const (return r) + + + +------------------------------------------------------------------------------ +-- +-- Generic unfolding +-- +------------------------------------------------------------------------------ + +-- | Construct an initial term with undefined immediate subterms +-- and then map over the skeleton to fill in proper terms. +gunfoldB :: Data a + => Constr + -> (forall a. Data a => a) + -> a +gunfoldB c f = gmapT (const f) (fromConstr c) + + +-- | Monadic variation on \"gunfoldB\" +gunfoldR :: (Monad m, Data a) + => Constr + -> (forall a. Data a => m a) + -> m a +gunfoldR c f = gmapM (const f) $ fromConstr c diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs index 09e7022..3732e56 100644 --- a/Data/Generics/Basics.hs +++ b/Data/Generics/Basics.hs @@ -56,9 +56,6 @@ module Data.Generics.Basics ( gmapMp, gmapMo, - -- * Generic unfolding defined in terms of gfoldl and fromConstr - gunfoldM -- :: Monad m => ... -> m a - ) where @@ -601,19 +598,3 @@ instance (Typeable a, Typeable b) => Data (a -> b) where toConstr _ = FunConstr fromConstr _ = undefined dataTypeOf _ = FunType - - ------------------------------------------------------------------------------- --- --- Generic unfolding --- ------------------------------------------------------------------------------- - --- | Construct an initial with undefined immediate subterms --- and then map over the skeleton to fill in proper terms. --- -gunfoldM :: (Monad m, Data a) - => Constr - -> (forall a. Data a => m a) - -> m a -gunfoldM c f = gmapM (const f) $ fromConstr c diff --git a/Data/Generics/Reify.hs b/Data/Generics/Reify.hs index b5a9998..867a552 100644 --- a/Data/Generics/Reify.hs +++ b/Data/Generics/Reify.hs @@ -10,7 +10,9 @@ -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module provides --- some preliminary support to compute on types. +-- some preliminary support some sort of structural reflection. This +-- module is presumably less common sense that most other boilerplate +-- modules. Also, it is a bit less easy-going. -- ----------------------------------------------------------------------------- @@ -20,24 +22,33 @@ module Data.Generics.Reify ( TypeVal, -- view type "a" as "a -> ()" typeVal, -- :: TypeVal a sameType, -- two type values are the same - typeValOf, -- :: a -> TypeVal a - undefinedType, -- :: TypeVal a -> a + val2type, -- :: a -> TypeVal a + type2val, -- :: TypeVal a -> a withType, -- :: a -> TypeVal a -> a argType, -- :: (a -> b) -> TypeVal a resType, -- :: (a -> b) -> TypeVal b paraType, -- :: t a -> TypeVal a TypeFun, -- functions on types GTypeFun, -- polymorphic functions on types + extType, -- extend a function on types -- * Generic operations to reify terms glength, gcount, gnodecount, gtypecount, + gfindtype, -- * Generic operations to reify types - constrArity, - typeReachableFrom + gmapType, -- query all constructors of a type + gmapConstr, -- query all subterm types of a constructor + constrArity, -- compute arity of constructor + gmapSubtermTypes, -- query all subterm types of a type + gmapSubtermTypesConst, -- variation on gmapSubtermTypes + gcountSubtermTypes, -- count all types of immediate subterms + reachableType, -- test for reachability on types + depthOfType, -- compute minimum depth of type + depthOfConstr -- compute minimum depth of constructor ) where @@ -80,18 +91,18 @@ typeVal = const () -- | Test for type equivalence sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool -sameType tva tvb = typeOf (undefinedType tva) == - typeOf (undefinedType tvb) +sameType tva tvb = typeOf (type2val tva) == + typeOf (type2val tvb) -- | Map a value to its type -typeValOf :: a -> TypeVal a -typeValOf _ = typeVal +val2type :: a -> TypeVal a +val2type _ = typeVal -- | Stipulate this idiom! -undefinedType :: TypeVal a -> a -undefinedType _ = undefined +type2val :: TypeVal a -> a +type2val _ = undefined -- | Constrain a type @@ -127,6 +138,11 @@ type TypeFun a r = TypeVal a -> r type GTypeFun r = forall a. Data a => TypeFun a r +-- | Extend a type function +extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r +extType f = maybe f id . cast + + ------------------------------------------------------------------------------ -- @@ -155,6 +171,18 @@ gtypecount :: Typeable a => (a -> ()) -> GenericQ Int gtypecount f = gcount (False `mkQ` (const True . f)) +-- | Find (unambiguously) an immediate subterm of a given type +gfindtype :: (Data x, Data y) => x -> Maybe y +gfindtype = singleton + . foldl unJust [] + . gmapQ (Nothing `mkQ` Just) + where + unJust l (Just x) = x:l + unJust l Nothing = l + singleton [s] = Just s + singleton _ = Nothing + + ------------------------------------------------------------------------------ -- @@ -162,27 +190,202 @@ gtypecount f = gcount (False `mkQ` (const True . f)) -- ------------------------------------------------------------------------------ --- | Compute arity of a constructor against a type argument -constrArity :: Data a => (a -> ()) -> Constr -> Int -constrArity ta c = glength $ withType (fromConstr c) ta +-- | Query all constructors of a given type --- --- Reachability relation on types: --- Test if nodes of type "a" are reachable from nodes of type "b". --- This is a naive, inefficient encoding. --- As of writing, it does not even cope with recursive types. --- -typeReachableFrom :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool -typeReachableFrom (a::TypeVal a) (b::TypeVal b) = - or ( sameType a b - : map (recurse . fromConstr) (dataTypeCons $ dataTypeOf b) - ) +gmapType :: ([(Constr,r')] -> r) + -> GTypeFun (Constr -> r') + -> GTypeFun r + +gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a) + = + o $ zip cons query + + where + + -- All constructors of the given type + cons :: [Constr] + cons = dataTypeCons $ dataTypeOf $ type2val t + + -- Query constructors + query :: [r'] + query = map (f t) cons + + +-- | Query all subterm types of a given constructor + +gmapConstr :: ([r] -> r') + -> GTypeFun r + -> GTypeFun (Constr -> r') + +gmapConstr (o::[r] -> r') f (t::TypeVal a) c + = + o $ query + + where + + -- Term for the given constructor + term :: a + term = fromConstr c + + -- Query subterm types + query :: [r] + query = gmapQ (f . val2type) term + + +-- | Compute arity of a given constructor +constrArity :: GTypeFun (Constr -> Int) +constrArity t c = glength $ withType (fromConstr c) t + + +-- | Query all immediate subterm types of a given type +gmapSubtermTypes :: (Data a, Typeable r) + => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r +gmapSubtermTypes o (r::r) f (t::TypeVal a) + = + reduce (concat (map (gmapQ (query . val2type)) terms)) + (GTypeFun' f) + + where + + -- All constructors of the given type + cons :: [Constr] + cons = dataTypeCons $ dataTypeOf $ type2val t + + -- Terms for all constructors + terms :: [a] + terms = map fromConstr cons + + -- Query a subterm type + query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r) + query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f))) + + -- Constant out given type + disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r + disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r + + -- Reduce all subterm types + reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r + reduce [] _ = r + reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g)) + + +-- First-class polymorphic variation on GTypeFun +newtype GTypeFun' r = GTypeFun' (GTypeFun r) +unGTypeFun' (GTypeFun' f) = f + + +-- | Query all immediate subterm types. +-- There is an extra argument to "constant out" the type at hand. +-- This can be used to avoid cycles. + +gmapSubtermTypesConst :: (Data a, Typeable r) + => (r -> r -> r) + -> r + -> GTypeFun r + -> TypeVal a + -> r +gmapSubtermTypesConst o (r::r) f (t::TypeVal a) + = + gmapSubtermTypes o r f' t where + f' :: GTypeFun r + f' = f `extType` \(_::TypeVal a) -> r + + +-- Count all distinct subterm types +gcountSubtermTypes :: Data a => TypeVal a -> Int +gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1) + + +-- | A simplied variation on gmapSubtermTypes. +-- Weakness: no awareness of doubles. +-- Strength: easy to comprehend as it uses gmapType and gmapConstr. + +_gmapSubtermTypes :: (Data a, Typeable r) + => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r +_gmapSubtermTypes o (r::r) f + = + gmapType otype (gmapConstr oconstr f) + + where + + otype :: [(Constr,r)] -> r + otype = foldr (\x y -> snd x `o` y) r + + oconstr :: [r] -> r + oconstr = foldr o r + + +-- | Reachability relation on types, i.e., +-- test if nodes of type "a" are reachable from nodes of type "b". +-- The relation is defined to be reflexive. + +reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool +reachableType (a::TypeVal a) (b::TypeVal b) + = + or [ sameType a b + , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b + ] + + +-- | Depth of a datatype as the constructor with the minimum depth. +-- The outermost "Nothing" denotes a type without constructors. +-- The innermost "Nothing" denotes potentially infinite. + +depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int)) +depthOfType p (t::TypeVal a) + = + gmapType o f t + + where + + o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int) + o l = if null l then Nothing else Just (foldr1 min' l) + + f :: GTypeFun (Constr -> Maybe Int) + f = depthOfConstr p' + + -- Specific minimum operator + min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int) + min' x (_, Nothing) = x + min' (_, Nothing) x = x + min' (c, Just i) (c', Just i') | i <= i' = (c, Just i) + min' (c, Just i) (c', Just i') = (c', Just i') + + -- Updated predicate for unblocked types + p' :: GTypeFun Bool + p' = p `extType` \(_::TypeVal a) -> False + + +-- | Depth of a constructor. +-- Depth is viewed as the maximum depth of all subterm types + 1. +-- "Nothing" denotes potentially infinite. + +depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int) +depthOfConstr p (t::TypeVal a) c + = + gmapConstr o f t c + + where + + o :: [Maybe Int] -> Maybe Int + o = inc' . foldr max' (Just 0) + + f :: GTypeFun (Maybe Int) + f t' = if p t' + then + case depthOfType p t' of + Nothing -> Just 0 + Just (_, x) -> x + else Nothing + + -- Specific maximum operator + max' Nothing _ = Nothing + max' _ Nothing = Nothing + max' (Just i) (Just i') | i >= i' = Just i + max' (Just i) (Just i') = Just i' - -- See if a is reachable from immediate subterms of a kind of b - recurse :: b -> Bool - recurse = or - . gmapQ ( typeReachableFrom a - . typeValOf - ) + -- Specific increment operator + inc' Nothing = Nothing + inc' (Just i) = Just (i+1) diff --git a/Data/Generics/Text.hs b/Data/Generics/Text.hs index 3cb10ee..87b0828 100644 --- a/Data/Generics/Text.hs +++ b/Data/Generics/Text.hs @@ -57,8 +57,8 @@ gread :: Data a => ReadS a This is a read operation which insists on prefix notation. (The 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 +and precedence as well.) We use gunfoldR to "parse" the input. To be +precise, gunfoldR is used for all types except String. The type-specific case for String uses basic String read. -} @@ -68,7 +68,7 @@ gread = readP_to_S gread' where gread' :: Data a => ReadP a - gread' = gdefault `extB` scase + gread' = gdefault `extR` scase where @@ -90,7 +90,7 @@ gread = readP_to_S gread' -- Do the real work str <- parseConstr -- Get a lexeme for the constructor con <- str2con str -- Convert it to a Constr (may fail) - x <- gunfoldM con gread' -- Read the children + x <- gunfoldR con gread' -- Read the children -- Drop " ) " skipSpaces -- Discard leading space -- 1.7.10.4