From a1f5912fe0c0c73e87e1c7e254e4ea9a6060effd Mon Sep 17 00:00:00 2001 From: ralf Date: Sat, 26 Jul 2003 12:44:00 +0000 Subject: [PATCH] [project @ 2003-07-26 12:43:58 by ralf] Renamed Data/Generics/Strings to .../Text. Implemented generic read by using Text/ParserCombinators/ReadP. This is now how it really should look like. Did some more refactoring in the modules of Data/Generics. I consider the library relatively stable by now. Very experimental stuff is only in Data/Generics/Reify.hs ( I was a bit too optimistic yesterday regarding the commitibility of Data/Generics. SPJ wanted me to use Text/ParserCombinators/ReadP for generic read what I did, which revealed a funny compiler bug. SPJ will probably report on this very soon. The compiler does not panic if I turn ReadP from a newtype into a datatype, what I have temporarily done. I hope this is Ok for the moment. ) --- Data/Generics.hs | 27 +++--- Data/Generics/Aliases.hs | 47 ++++------ Data/Generics/Basics.hs | 4 +- Data/Generics/Counts.hs | 58 ------------ Data/Generics/Reify.hs | 186 +++++++++++++++++++++++++++++++++++++++ Data/Generics/Shortcuts.hs | 42 --------- Data/Generics/Strings.hs | 179 ------------------------------------- Data/Generics/Text.hs | 127 ++++++++++++++++++++++++++ Data/Generics/Types.hs | 75 ---------------- Data/Typeable.hs | 128 +++++++++------------------ Text/ParserCombinators/ReadP.hs | 7 +- 11 files changed, 397 insertions(+), 483 deletions(-) delete mode 100644 Data/Generics/Counts.hs create mode 100644 Data/Generics/Reify.hs delete mode 100644 Data/Generics/Shortcuts.hs delete mode 100644 Data/Generics/Strings.hs create mode 100644 Data/Generics/Text.hs delete mode 100644 Data/Generics/Types.hs diff --git a/Data/Generics.hs b/Data/Generics.hs index cc32172..788c152 100644 --- a/Data/Generics.hs +++ b/Data/Generics.hs @@ -15,19 +15,21 @@ module Data.Generics ( - -- * Re-export all relevant modules - module Data.Generics.Basics, - module Data.Generics.Aliases, - module Data.Generics.Schemes, - module Data.Generics.Twins, - module Data.Generics.Strings, - module Data.Generics.Counts, - module Data.Generics.Types + -- * To scrap your boilerplate it is sufficient to import this module. + -- This module does nothing more than import all themes of the + -- Data.Generics library. + -- + module Data.Generics.Basics, -- primitives + module Data.Generics.Aliases, -- aliases for type case, generic types + 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 stuff #ifndef __HADDOCK__ , -- Data types for the sum-of-products type encoding; - -- included for backwards compatibility; maybe obsolete + -- included for backwards compatibility; maybe obsolete. (:*:)(..), (:+:)(..), Unit(..) #endif @@ -39,6 +41,8 @@ import Prelude -- So that 'make depend' works #ifdef __GLASGOW_HASKELL__ #ifndef __HADDOCK__ + -- Data types for the sum-of-products type encoding; + -- included for backwards compatibility; maybe obsolete. import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) ) #endif #endif @@ -46,7 +50,6 @@ import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) ) import Data.Generics.Basics import Data.Generics.Aliases import Data.Generics.Schemes +import Data.Generics.Text import Data.Generics.Twins -import Data.Generics.Strings -import Data.Generics.Counts -import Data.Generics.Types +import Data.Generics.Reify diff --git a/Data/Generics/Aliases.hs b/Data/Generics/Aliases.hs index 2aa8755..72574bf 100644 --- a/Data/Generics/Aliases.hs +++ b/Data/Generics/Aliases.hs @@ -76,13 +76,11 @@ mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r -- resort to return otherwise -- mkM :: ( Monad m, - Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) + Typeable a, + Typeable b ) => (b -> m b) -> a -> m a -mkM f = case cast f of +mkM f = case castarr f of Just g -> g Nothing -> return @@ -101,12 +99,10 @@ use a point-free style whenever possible. -- mkMp :: ( MonadPlus m, Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) + Typeable b ) - => (b -> m b) -> a -> m a -mkMp = maybe (const mzero) id . cast + => (b -> m b) -> a -> m a +mkMp = maybe (const mzero) id . castarr -- | Make a generic builder; @@ -115,12 +111,10 @@ mkMp = maybe (const mzero) id . cast -- mkB :: ( MonadPlus m, Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) + Typeable b ) => m b -> m a -mkB = maybe mzero id . cast +mkB = maybe mzero id . castss -- | Extend a generic transformation by a type-specific case @@ -134,34 +128,31 @@ extQ f g a = maybe (f a) g (cast a) -- | Extend a generic monadic transformation by a type-specific case -extM :: (Typeable a, Typeable b, - Typeable (m a), Typeable (m b), - Monad m) +extM :: ( Monad m, + Typeable a, + Typeable b + ) => (a -> m a) -> (b -> m b) -> a -> m a -extM f = maybe f id . cast +extM f = maybe f id . castarr -- | Extend a generic MonadPlus transformation by a type-specific case extMp :: ( MonadPlus m, Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) + Typeable b ) - => (a -> m a) -> (b -> m b) -> a -> m a + => (a -> m a) -> (b -> m b) -> a -> m a extMp = extM -- | Extend a generic builder by a type-specific case -extB :: ( Monad m, - Typeable a, - Typeable b, - Typeable (m a), - Typeable (m b) +extB :: (Monad m, + Typeable a, + Typeable b ) => m a -> m b -> m a -extB f = maybe f id . cast +extB f = maybe f id . castss ------------------------------------------------------------------------------ diff --git a/Data/Generics/Basics.hs b/Data/Generics/Basics.hs index a39a35f..ad16067 100644 --- a/Data/Generics/Basics.hs +++ b/Data/Generics/Basics.hs @@ -509,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] + gmapQ f [] = [] + gmapQ 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 deleted file mode 100644 index bb2c5d6..0000000 --- a/Data/Generics/Counts.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Counts --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- 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 . --- ------------------------------------------------------------------------------ - -module Data.Generics.Counts ( - - -- * Generic operations for counting terms - glength, - gcount, - gnodecount, - gtypecount - - ) where - ------------------------------------------------------------------------------- - - -import Data.Generics.Basics -import Data.Generics.Aliases -import Data.Generics.Schemes - - ------------------------------------------------------------------------------- --- --- Generic operations for counting terms --- ------------------------------------------------------------------------------- - - --- | Count the number of immediate subterms of the given term -glength :: GenericQ Int -glength = length . gmapQ (const ()) - - --- | Determine the number of all suitable nodes in a given term -gcount :: GenericQ Bool -> GenericQ Int -gcount p = everything (+) (\x -> if p x then 1 else 0) - - --- | Determine the number of all nodes in a given term -gnodecount :: GenericQ Int -gnodecount = gcount (const True) - - --- | Determine the number of nodes of a given type in a given term -gtypecount :: Typeable a => (a -> ()) -> GenericQ Int -gtypecount f = gcount (False `mkQ` (const True . f)) diff --git a/Data/Generics/Reify.hs b/Data/Generics/Reify.hs new file mode 100644 index 0000000..76d1ebb --- /dev/null +++ b/Data/Generics/Reify.hs @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Reify +-- Copyright : (c) The University of Glasgow, CWI 2001--2003 +-- 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 . +-- +----------------------------------------------------------------------------- + +module Data.Generics.Reify ( + + -- * Types as values + TypeVal, -- view type "a" as "a -> ()" + typeVal, -- :: TypeVal a + sameType, -- two type values are the same + typeValOf, -- :: a -> TypeVal a + undefinedType, -- :: 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 + + -- * Generic operations to reify terms + glength, + gcount, + gnodecount, + gtypecount, + + -- * Generic operations to reify types + constrArity, + typeReachableFrom + + ) where + + +------------------------------------------------------------------------------ + + +import Data.Generics.Basics +import Data.Generics.Aliases +import Data.Generics.Schemes + + + +------------------------------------------------------------- +-- +-- Types as values +-- +------------------------------------------------------------- + +{- + +This group provides a style of encoding types as values and using +them. This style is seen as an alternative to the pragmatic style used +in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined" +to denote a type argument. This pragmatic style suffers from lack +of robustness: one feels tempted to pattern match on undefineds. +Maybe Data.Typeable.typeOf etc. should be rewritten accordingly. + +-} + + +-- | Type as values to stipulate use of undefineds +type TypeVal a = a -> () + + +-- | The value that denotes a type +typeVal :: TypeVal a +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) + + +-- | Map a value to its type +typeValOf :: a -> TypeVal a +typeValOf _ = typeVal + + +-- | Stipulate this idiom! +undefinedType :: TypeVal a -> a +undefinedType _ = undefined + + +-- | Constrain a type +withType :: a -> TypeVal a -> a +withType x _ = x + + +-- | The argument type of a function +argType :: (a -> b) -> TypeVal a +argType _ = typeVal + + +-- | The result type of a function +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 +-- +type TypeFun a r = TypeVal a -> r + + + +-- Generic type functions, +-- i.e., functions mapping types to values +-- +type GTypeFun r = forall a. Typeable a => TypeFun a r + + + +------------------------------------------------------------------------------ +-- +-- Generic operations to reify terms +-- +------------------------------------------------------------------------------ + + +-- | Count the number of immediate subterms of the given term +glength :: GenericQ Int +glength = length . gmapQ (const ()) + + +-- | Determine the number of all suitable nodes in a given term +gcount :: GenericQ Bool -> GenericQ Int +gcount p = everything (+) (\x -> if p x then 1 else 0) + + +-- | Determine the number of all nodes in a given term +gnodecount :: GenericQ Int +gnodecount = gcount (const True) + + +-- | Determine the number of nodes of a given type in a given term +gtypecount :: Typeable a => (a -> ()) -> GenericQ Int +gtypecount f = gcount (False `mkQ` (const True . f)) + + + +------------------------------------------------------------------------------ +-- +-- Generic operations to reify types +-- +------------------------------------------------------------------------------ + +-- | Compute arity of a constructor against a type argument +constrArity :: Data a => (a -> ()) -> Constr -> Int +constrArity ta c = glength $ withType (fromConstr c) ta + + +-- +-- 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) + ) + where + + -- See if a is reachable from immediate subterms of a kind of b + recurse :: b -> Bool + recurse = or + . gmapQ ( typeReachableFrom a + . typeValOf + ) diff --git a/Data/Generics/Shortcuts.hs b/Data/Generics/Shortcuts.hs deleted file mode 100644 index 11ff84c..0000000 --- a/Data/Generics/Shortcuts.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Shortcuts --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- 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 . --- ------------------------------------------------------------------------------ - -module Data.Generics.Shortcuts ( - - -- * Cut-off traversal - everywhere1RT' - - ) where - ------------------------------------------------------------------------------ - - -import Data.Generics.Basics -import Data.Generics.Aliases -import Data.Generics.Types - - ------------------------------------------------------------------------------ - - --- Run-time cut-off for top-down traversal with one specific type case. --- This is only for illustrative purposes. --- The naive approach here is prohibitively inefficient. --- -everywhere1RT' :: (Data a, Data b) => (a -> a) -> b -> b -everywhere1RT' f t = - if not $ typeReachableFrom (argType f) (typeValOf t) - then t - else gmapT (everywhere1RT' f) (mkT f t) diff --git a/Data/Generics/Strings.hs b/Data/Generics/Strings.hs deleted file mode 100644 index 1037d95..0000000 --- a/Data/Generics/Strings.hs +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Strings --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- 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 . --- ------------------------------------------------------------------------------ - -module Data.Generics.Strings ( - - -- * Generic operations for string representations of terms - gshow, - gread - - ) where - ------------------------------------------------------------------------------- - -import Control.Monad -import Data.Maybe -import Data.Typeable -import Data.Generics.Basics -import Data.Generics.Aliases - - - --- | Generic show: an alternative to \"deriving Show\" -gshow :: Data a => a -> String - --- This is a prefix-show using surrounding "(" and ")", --- where we recurse into subterms with gmapQ. --- -gshow = ( \t -> - "(" - ++ conString (toConstr t) - ++ concat (gmapQ ((++) " " . gshow) t) - ++ ")" - ) `extQ` (show :: String -> String) - - --- | 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)) 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) - ) - -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 :: Data a => String -> Maybe (a, String) - -{- - -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 -type-specific case for String uses basic String read. - --} - - -gread = unGRead gread' - - where - - gread' :: Data a => GRead a - gread' = gdefault `extB` scase - - where - - -- a specific case for strings - scase :: GRead String - scase = GRead ( \s -> case reads s of - [x::(String,String)] -> Just x - _ -> Nothing - ) - - -- the generic default for gread - gdefault :: Data a => GRead a - gdefault = - do - -- Drop " ( " - trafo $ dropWhile ((==) ' ') -- Discard leading space - query $ not . (==) "" -- Check result is not empty - query $ (==) '(' . head -- ...and that it begins with ( - trafo $ tail -- Discard the '(' - trafo $ dropWhile ((==) ' ') -- ...and following white space - - -- 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 - - -- Drop " )" - trafo $ dropWhile ((==) ' ') - query $ not . (==) "" - query $ (==) ')' . head - trafo $ tail - return x - - where - get_data_type :: GRead a -> DataType - get_data_type (thing :: GRead a) = dataTypeOf (typeVal::a) - - str2con :: String -> GRead Constr - -- Turn string into constructor driven by gdefault's type, - -- failing in the monad if it isn't a constructor of this data type - str2con = maybe mzero return . stringCon (get_data_type gdefault) - -{- - foo = - do s' <- return $ dropWhile ((==) ' ') s - guard (not (s' == "")) - guard (head s' == '(') - (c,s'') <- parseConstr (dropWhile ((==) ' ') (tail s')) - u <- return undefined - dt <- return $ dataTypeOf u - case stringCon dt c of - Nothing -> error "Data.Generics.String: gread failed" - Just c' -> - gunfoldm c' gread - - guard ( or [ maxConIndex (dataTypeOf u) == 0 - , c `elem` constrsOf u - ] - ) - (a,s''') <- unGRead (gunfold f z c) s'' - _ <- return $ constrainTypes a u - 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 - - parseConstr = GRead ( \s -> case s of - - -- Infix operators are prefixed in parantheses - ('(':s) -> case break ((==) ')') s of - (s'@(_:_),(')':s'')) -> Just ("(" ++ s' ++ ")", s'') - _ -> Nothing - - -- Special treatment of multiple token constructors - ('[':']':s) -> Just ("[]",s) - - -- Try lex for ordinary constructor and basic datatypes - s -> case lex s of - [(s'@(_:_),s'')] -> Just (s',s'') - _ -> Nothing - - ) - diff --git a/Data/Generics/Text.hs b/Data/Generics/Text.hs new file mode 100644 index 0000000..fbea73b --- /dev/null +++ b/Data/Generics/Text.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Text +-- Copyright : (c) The University of Glasgow, CWI 2001--2003 +-- 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 . +-- +----------------------------------------------------------------------------- + +module Data.Generics.Text ( + + -- * Generic operations for string representations of terms + gshow, + gread + + ) where + +------------------------------------------------------------------------------ + + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Generics.Basics +import Data.Generics.Aliases +import Text.ParserCombinators.ReadP + + +------------------------------------------------------------------------------ + + +-- | Generic show: an alternative to \"deriving Show\" +gshow :: Data a => a -> String + +-- This is a prefix-show using surrounding "(" and ")", +-- where we recurse into subterms with gmapQ. +-- +gshow = ( \t -> + "(" + ++ conString (toConstr t) + ++ concat (gmapQ ((++) " " . gshow) t) + ++ ")" + ) `extQ` (show :: String -> String) + + + +-- | Generic read: an alternative to \"deriving Read\" +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 +type-specific case for String uses basic String read. + +-} + +gread = readP_to_S gread' + + where + + gread' :: Data a => ReadP a + gread' = gdefault `extB` scase + + + where + + -- A specific case for strings + scase :: ReadP String + scase = readS_to_P reads + + + -- The generic default for gread + -- gdefault :: Data a => ReadP a + gdefault = + do + -- Drop " ( " + skipSpaces -- Discard leading space + char '(' -- Parse '(' + skipSpaces -- Discard following space + + -- 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 + + -- Drop " ) " + skipSpaces -- Discard leading space + char ')' -- Parse ')' + skipSpaces -- Discard following space + + return x + + where + + -- Get the datatype for the type at hand; + -- use gdefault to provide the type at hand. + myDataTypeOf :: Data a => ReadP a -> DataType + myDataTypeOf (_::ReadP a) = dataTypeOf (undefined::a) + + -- Turn string into constructor driven by gdefault's type, + -- failing in the monad if it isn't a constructor of this data type + str2con :: String -> ReadP Constr + str2con = maybe mzero return + . stringCon (myDataTypeOf gdefault) + + -- Get a Constr's string at the front of an input string + parseConstr :: ReadP String + parseConstr = + string "[]" -- Compound lexeme "[]" + <++ infixOp -- Infix operator in parantheses + <++ readS_to_P lex -- Ordinary constructors and literals + + -- Handle infix operators such as (:) + infixOp :: ReadP String + infixOp = do c1 <- char '(' + str <- munch1 (not . (==) ')') + c2 <- char ')' + return $ [c1] ++ str ++ [c2] diff --git a/Data/Generics/Types.hs b/Data/Generics/Types.hs deleted file mode 100644 index caa0fc8..0000000 --- a/Data/Generics/Types.hs +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Types --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- 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 . --- ------------------------------------------------------------------------------ - -module Data.Generics.Types ( - - -- * Generic operations to reify types - constrArity, - typeReachableFrom, - - ) where - - ------------------------------------------------------------------------------- - - -import Data.Generics.Basics -import Data.Generics.Aliases -import Data.Generics.Counts - - - --- Generic type functions, --- i.e., functions mapping types to values --- -type GTypeFun r = forall a. Typeable a => TypeFun a r - - - ------------------------------------------------------------------------------- --- --- Compute arity of a constructor against a type argument --- ------------------------------------------------------------------------------- - - -constrArity :: Data a => (a -> ()) -> Constr -> Int -constrArity ta c = glength $ withType (fromConstr c) ta - - ------------------------------------------------------------------------------- --- --- 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) - ) - where - - -- See if a is reachable from immediate subterms of a kind of b - recurse :: b -> Bool - recurse = or - . gmapQ ( typeReachableFrom a - . typeValOf - ) diff --git a/Data/Typeable.hs b/Data/Typeable.hs index c88920c..34da504 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -26,9 +26,10 @@ module Data.Typeable -- * The Typeable class Typeable( typeOf ), -- :: a -> TypeRep - -- * Type-safe cast and other clients + -- * Type-safe cast cast, -- :: (Typeable a, Typeable b) => a -> Maybe b - sameType, -- two type values are the same + castss, -- a cast for kind "* -> *" + castarr, -- another convenient variation -- * Type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable @@ -38,18 +39,7 @@ module Data.Typeable mkTyCon, -- :: String -> TyCon mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep - applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep - - -- * Types as values - TypeVal, -- view type "a" as "a -> ()" - typeVal, -- :: TypeVal a - typeValOf, -- :: a -> TypeVal a - undefinedType, -- :: 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 + applyTy -- :: TypeRep -> TypeRep -> Maybe TypeRep ) where @@ -238,7 +228,7 @@ class Typeable a where ------------------------------------------------------------- -- --- Type-safe cast and other clients +-- Type-safe cast -- ------------------------------------------------------------- @@ -246,16 +236,44 @@ class Typeable a where cast :: (Typeable a, Typeable b) => a -> Maybe b cast x = r where - r = if typeOf x == typeOf (fromJust r) then - Just (unsafeCoerce x) - else - Nothing + r = if typeOf x == typeOf (fromJust r) + then Just $ unsafeCoerce x + else Nothing --- | Test for type equivalence -sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool -sameType tva tvb = typeOf (undefinedType tva) == - typeOf (undefinedType tvb) +-- | A convenient variation for kind "* -> *" +castss :: (Typeable a, Typeable b) => t a -> Maybe (t b) +castss x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: t c -> c + get = undefined + + +-- | Another variation +castarr :: (Typeable a, Typeable b, Typeable c, Typeable d) + => (a -> t b) -> Maybe (c -> t d) +castarr x = r + where + r = if typeOf (get x) == typeOf (get (fromJust r)) + then Just $ unsafeCoerce x + else Nothing + get :: (e -> t f) -> (e, f) + get = undefined + +{- + +The variations castss and castarr are arguably not really needed. +Let's discuss castss in some detail. To get rid of castss, we can +require "Typeable (t a)" and "Typeable (t b)" rather than just +"Typeable a" and "Typeable b". In that case, the ordinary cast would +work. Eventually, all kinds of library instances should become +Typeable. (There is another potential use of variations as those given +above. It allows quantification on type constructors. + +-} ------------------------------------------------------------- @@ -325,69 +343,6 @@ instance (Typeable a, Typeable b) => Typeable (a -> b) where (typeOf ((undefined :: (a -> b) -> b) f)) -------------------------------------------------------------- --- --- Types as values --- -------------------------------------------------------------- - -{- - -This group provides a style of encoding types as values and using -them. This style is seen as an alternative to the pragmatic style used -in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined" -to denote a type argument. This pragmatic style suffers from lack -of robustness: one feels tempted to pattern match on undefineds. -Maybe Data.Typeable.typeOf etc. should be rewritten accordingly. - --} - - --- | Type as values to stipulate use of undefineds -type TypeVal a = a -> () - - --- | The value that denotes a type -typeVal :: TypeVal a -typeVal = const () - - --- | Map a value to its type -typeValOf :: a -> TypeVal a -typeValOf _ = typeVal - - --- | Stipulate this idiom! -undefinedType :: TypeVal a -> a -undefinedType _ = undefined - - --- | Constrain a type -withType :: a -> TypeVal a -> a -withType x _ = x - - --- | The argument type of a function -argType :: (a -> b) -> TypeVal a -argType _ = typeVal - - --- | The result type of a function -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 --- -type TypeFun a r = TypeVal a -> r - - ------------------------------------------------------- -- @@ -428,6 +383,7 @@ INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef") #endif + --------------------------------------------- -- -- Internals diff --git a/Text/ParserCombinators/ReadP.hs b/Text/ParserCombinators/ReadP.hs index c05b983..f478230 100644 --- a/Text/ParserCombinators/ReadP.hs +++ b/Text/ParserCombinators/ReadP.hs @@ -120,7 +120,12 @@ instance MonadPlus P where -- --------------------------------------------------------------------------- -- The ReadP type -newtype ReadP a = R (forall b . (a -> P b) -> P b) +-- newtype temporarily turned into data +-- until compiler bug as found on 26 July 2003 is fixed; +-- contact SPJ or ralf@cwi.nl +-- +data ReadP a = R (forall b . (a -> P b) -> P b) +-- newtype ReadP a = R (forall b . (a -> P b) -> P b) -- Functor, Monad, MonadPlus -- 1.7.10.4