Major refactoring of Data/Generics.
This also affects the compiler (because of deriving issues).
This is an intermediate commit.
The library is supposed to compile fine.
But the deriving stuff for Data needs to be revised.
The testsuite for Data/Generics will not pass.
gread is broken at the moment.
So it is strongly recommended not to cvs upd for a few hours or a day.
Detailed description of changes:
- Split up Data/Dynamic into Data/Typeable and Data/Dynamic.
(This makes clear what part is about TypeReps and cast vs.
dynamics. The latter is not needed by Data/Generics.)
- Renamed Data/include/Dynamic.h -> Typeable.h to end confusion.
- Split up Data/Generics.hs in a set of modules.
- Revised class Data:
- Got rid of gunfold but added fromConstr as more primtive one
- Revised representations of constructors
- Revised treatment of primitive types
- Revised type of gmapQ; preserved old gmapQ as gmapL
- Added a module Data/Types.hs for treatment of types as values.
This is going somewhere.
import System.IO.Unsafe (unsafePerformIO)
import Data.Dynamic
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
#endif
#ifndef __NHC__
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
#endif
#endif
import Data.Dynamic
-#include "Dynamic.h"
+#include "Typeable.h"
#include "MachDeps.h"
-- Instances of Complex
#ifndef __NHC__
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")
#endif
module Data.Dynamic
(
+
+ -- Module Data.Typeable re-exported for convenience
+ module Data.Typeable,
+
-- * The @Dynamic@ type
Dynamic, -- abstract, instance of: Show, Typeable
-- * Applying functions of dynamic type
dynApply,
- dynApp,
-
- -- * Concrete Type Representations
-
- -- | This section is useful if you need to define your own
- -- instances of 'Typeable'.
-
- Typeable( typeOf ), -- :: a -> TypeRep
- cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
-
- -- ** Building concrete type representations
- TypeRep, -- abstract, instance of: Eq, Show, Typeable
- TyCon, -- abstract, instance of: Eq, Show, Typeable
+ dynApp
- mkTyCon, -- :: String -> TyCon
- mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
- mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
- applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
+ ) where
- --
- -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
- -- [fTy,fTy,fTy])
- --
- -- returns "(Foo,Foo,Foo)"
- --
- -- The TypeRep Show instance promises to print tuple types
- -- correctly. Tuple type constructors are specified by a
- -- sequence of commas, e.g., (mkTyCon ",,,,") returns
- -- the 5-tuple tycon.
- ) where
-
-import qualified Data.HashTable as HT
+import Data.Typeable
import Data.Maybe
-import Data.Either
-import Data.Int
-import Data.Word
-import Data.List( foldl )
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Float
import GHC.Real( rem )
import GHC.IOBase
-import GHC.Ptr -- So we can give Typeable instance for Ptr
-import GHC.Stable -- So we can give Typeable instance for StablePtr
#endif
#ifdef __HUGS__
import NonStdUnsafeCoerce (unsafeCoerce)
import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
#else
-#include "Dynamic.h"
+#include "Typeable.h"
#endif
-------------------------------------------------------------
data Dynamic = Dynamic TypeRep Obj
#endif
+#ifndef __NHC__
+INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
+#endif
+
instance Show Dynamic where
-- the instance just prints the type representation.
showsPrec _ (Dynamic t _) =
Nothing -> error ("Type error in dynamic application.\n" ++
"Can't apply function " ++ show f ++
" to argument " ++ show x)
-
-#ifndef __HUGS__
--------------------------------------------------------------
---
--- Type representations
---
--------------------------------------------------------------
-
--- | A concrete representation of a (monomorphic) type. 'TypeRep'
--- supports reasonably efficient equality.
-data TypeRep = TypeRep !Key TyCon [TypeRep]
-
--- Compare keys for equality
-instance Eq TypeRep where
- (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
-
--- | An abstract representation of a type constructor. 'TyCon' objects can
--- be built using 'mkTyCon'.
-data TyCon = TyCon !Key String
-
-instance Eq TyCon where
- (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-#endif
-
------------------ Type-safe cast ------------------
-
--- | The type-safe cast operation
-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
-
------------------ Construction --------------------
-
--- | Applies a type constructor to a sequence of types
-mkAppTy :: TyCon -> [TypeRep] -> TypeRep
-mkAppTy tc@(TyCon tc_k _) args
- = TypeRep (appKeys tc_k arg_ks) tc args
- where
- arg_ks = [k | TypeRep k _ _ <- args]
-
-funTc :: TyCon
-funTc = mkTyCon "->"
-
--- | A special case of 'mkAppTy', which applies the function
--- type constructor to a pair of types.
-mkFunTy :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkAppTy funTc [f,a]
-
--- | Applies a type to a function type. Returns: @'Just' u@ if the
--- first argument represents a function of type @t -> u@ and the
--- second argument represents a function of type @t@. Otherwise,
--- returns 'Nothing'.
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-applyTy (TypeRep _ tc [t1,t2]) t3
- | tc == funTc && t1 == t3 = Just t2
-applyTy _ _ = Nothing
-
--- If we enforce the restriction that there is only one
--- @TyCon@ for a type & it is shared among all its uses,
--- we can map them onto Ints very simply. The benefit is,
--- of course, that @TyCon@s can then be compared efficiently.
-
--- Provided the implementor of other @Typeable@ instances
--- takes care of making all the @TyCon@s CAFs (toplevel constants),
--- this will work.
-
--- If this constraint does turn out to be a sore thumb, changing
--- the Eq instance for TyCons is trivial.
-
--- | Builds a 'TyCon' object representing a type constructor. An
--- implementation of "Data.Dynamic" should ensure that the following holds:
---
--- > mkTyCon "a" == mkTyCon "a"
---
-mkTyCon :: String -- ^ the name of the type constructor (should be unique
- -- in the program, so it might be wise to use the
- -- fully qualified name).
- -> TyCon -- ^ A unique 'TyCon' object
-mkTyCon str = TyCon (mkTyConKey str) str
-
-
------------------ Showing TypeReps --------------------
-
-instance Show TypeRep where
- showsPrec p (TypeRep _ tycon tys) =
- case tys of
- [] -> showsPrec p tycon
- [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
- [a,r] | tycon == funTc -> showParen (p > 8) $
- showsPrec 9 a . showString " -> " . showsPrec 8 r
- xs | isTupleTyCon tycon -> showTuple tycon xs
- | otherwise ->
- showParen (p > 9) $
- showsPrec p tycon .
- showChar ' ' .
- showArgs tys
-
-instance Show TyCon where
- showsPrec _ (TyCon _ s) = showString s
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ (',':_)) = True
-isTupleTyCon _ = False
-
--- Some (Show.TypeRep) helpers:
-
-showArgs :: Show a => [a] -> ShowS
-showArgs [] = id
-showArgs [a] = showsPrec 10 a
-showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
-
-showTuple :: TyCon -> [TypeRep] -> ShowS
-showTuple (TyCon _ str) args = showChar '(' . go str args
- where
- go [] [a] = showsPrec 10 a . showChar ')'
- go _ [] = showChar ')' -- a failure condition, really.
- go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
- go _ _ = showChar ')'
-
-
-
--------------------------------------------------------------
---
--- The Typeable class and some instances
---
--------------------------------------------------------------
-
--- | The class 'Typeable' allows a concrete representation of a type to
--- be calculated.
-class Typeable a where
- typeOf :: a -> TypeRep
- -- ^ Takes a value of type @a@ and returns a concrete representation
- -- of that type. The /value/ of the argument should be ignored by
- -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
- -- the argument.
-
--- Prelude types
-listTc :: TyCon
-listTc = mkTyCon "[]"
-
-instance Typeable a => Typeable [a] where
- typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
- -- In GHC we can say
- -- typeOf (undefined :: a)
- -- using scoped type variables, but we use the
- -- more verbose form here, for compatibility with Hugs
-
-unitTc :: TyCon
-unitTc = mkTyCon "()"
-
-instance Typeable () where
- typeOf _ = mkAppTy unitTc []
-
-tup2Tc :: TyCon
-tup2Tc = mkTyCon ","
-
-instance (Typeable a, Typeable b) => Typeable (a,b) where
- typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
- typeOf ((undefined :: (a,b) -> b) tu)]
-
-tup3Tc :: TyCon
-tup3Tc = mkTyCon ",,"
-
-instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
- typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
- typeOf ((undefined :: (a,b,c) -> b) tu),
- typeOf ((undefined :: (a,b,c) -> c) tu)]
-
-tup4Tc :: TyCon
-tup4Tc = mkTyCon ",,,"
-
-instance ( Typeable a
- , Typeable b
- , Typeable c
- , Typeable d) => Typeable (a,b,c,d) where
- typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
- typeOf ((undefined :: (a,b,c,d) -> b) tu),
- typeOf ((undefined :: (a,b,c,d) -> c) tu),
- typeOf ((undefined :: (a,b,c,d) -> d) tu)]
-tup5Tc :: TyCon
-tup5Tc = mkTyCon ",,,,"
-
-instance ( Typeable a
- , Typeable b
- , Typeable c
- , Typeable d
- , Typeable e) => Typeable (a,b,c,d,e) where
- typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
- typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
- typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
- typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
- typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
-
-instance (Typeable a, Typeable b) => Typeable (a -> b) where
- typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
- (typeOf ((undefined :: (a -> b) -> b) f))
-
-#ifndef __NHC__
-INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
-INSTANCE_TYPEABLE0(Char,charTc,"Char")
-INSTANCE_TYPEABLE0(Float,floatTc,"Float")
-INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
-INSTANCE_TYPEABLE0(Int,intTc,"Int")
-INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
-INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
-INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
-INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
-
-INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
-INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
-INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
-INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
-
-INSTANCE_TYPEABLE0(Word8,word8Tc, "Word8" )
-INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
-INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
-INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
-
-INSTANCE_TYPEABLE0(TyCon,tyconTc, "TyCon")
-INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
-
-#include "Dynamic.h"
-INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
-#endif
-
----------------------------------------------
---
--- Internals
---
----------------------------------------------
-
-#ifndef __HUGS__
-newtype Key = Key Int deriving( Eq )
-#endif
-
-data KeyPr = KeyPr !Key !Key deriving( Eq )
-
-hashKP :: KeyPr -> Int32
-hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
-
-data Cache = Cache { next_key :: !(IORef Key),
- tc_tbl :: !(HT.HashTable String Key),
- ap_tbl :: !(HT.HashTable KeyPr Key) }
-
-{-# NOINLINE cache #-}
-cache :: Cache
-cache = unsafePerformIO $ do
- empty_tc_tbl <- HT.new (==) HT.hashString
- empty_ap_tbl <- HT.new (==) hashKP
- key_loc <- newIORef (Key 1)
- return (Cache { next_key = key_loc,
- tc_tbl = empty_tc_tbl,
- ap_tbl = empty_ap_tbl })
-
-newKey :: IORef Key -> IO Key
-newKey kloc = do { k@(Key i) <- readIORef kloc ;
- writeIORef kloc (Key (i+1)) ;
- return k }
-
-mkTyConKey :: String -> Key
-mkTyConKey str
- = unsafePerformIO $ do
- let Cache {next_key = kloc, tc_tbl = tbl} = cache
- mb_k <- HT.lookup tbl str
- case mb_k of
- Just k -> return k
- Nothing -> do { k <- newKey kloc ;
- HT.insert tbl str k ;
- return k }
-
-appKey :: Key -> Key -> Key
-appKey k1 k2
- = unsafePerformIO $ do
- let Cache {next_key = kloc, ap_tbl = tbl} = cache
- mb_k <- HT.lookup tbl kpr
- case mb_k of
- Just k -> return k
- Nothing -> do { k <- newKey kloc ;
- HT.insert tbl kpr k ;
- return k }
- where
- kpr = KeyPr k1 k2
-
-appKeys :: Key -> [Key] -> Key
-appKeys k ks = foldl appKey k ks
-
-
-
-
-
-- Copyright : (c) The University of Glasgow, CWI 2001--2003
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--- Maintainer : libraries@haskell.org, ralf@cwi.nl
+-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
--- Generic programming in Haskell;
--- see <http://www.cs.vu.nl/boilerplate/>.
+-- "Scrap your boilerplate" --- Generic programming in Haskell
+-- See <http://www.cs.vu.nl/boilerplate/>.
--
-----------------------------------------------------------------------------
module Data.Generics (
- -- The Typeable class and the type-safe cast operation;
- -- re-exported for convenience
- Typeable(..), cast,
-
- -- * Prime types of generic functions
- GenericT, GenericQ, GenericM, GenericB,
-
- -- * Combinators to \"make\" generic functions
- mkT, mkQ, mkM, mkF, mkB,
- extT, extQ, extM, extF, extB,
-
- -- * The Data class for folding and unfolding constructor applications
- Data(
- gfoldl,
- gunfold,
- conOf,
- consOf
- ),
-
- -- * Typical generic maps defined in terms of gfoldl
-
- gmapT,
- gmapQ,
- gmapM,
- gmapF,
-
- -- * The Constr datatype for describing datatype constructors
- Constr(..),
-
- -- * Frequently used generic traversal schemes
- everywhere,
- everywhere',
- everywhereBut,
- everywhereM,
- somewhere,
- everything,
- listify,
- something,
- synthesize,
-
- -- * Generic operations such as show, equality, read
- glength,
- gcount,
- garity,
- gundefineds,
- gnodecount,
- gtypecount,
- gshow,
- geq,
- gzip,
- gread,
-
- -- * Miscellaneous further combinators
- sameType, orElse, recoverF, recoverQ, choiceF, choiceQ
+ -- * 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
#ifndef __HADDOCK__
,
#endif
#endif
-import Data.Maybe
-import Data.Dynamic
-import Control.Monad
-
-
-
-------------------------------------------------------------------------------
---
--- Prime types of generic functions
---
-------------------------------------------------------------------------------
-
--- | Generic transformations,
--- i.e., take an \"a\" and return an \"a\"
---
-type GenericT = forall a. Data a => a -> a
-
-
--- | Generic queries of type \"r\",
--- i.e., take any \"a\" and return an \"r\"
---
-type GenericQ r = forall a. Data a => a -> r
-
-
--- | Generic monadic transformations,
--- i.e., take an \"a\" and compute an \"a\"
---
-type GenericM m = forall a. Data a => a -> m a
-
-
--- | Generic builders with input i,
--- i.e., take an \"i\" and compute a pair of type (a,i)
---
-type GenericB m i = forall a. Data a => i -> m (a,i)
-
-
-
-------------------------------------------------------------------------------
---
--- Combinators to "make" generic functions
--- We use type-safe cast in a number of ways to make generic functions.
---
-------------------------------------------------------------------------------
-
--- | Make a generic transformation;
--- start from a type-specific case;
--- preserve the term otherwise
---
-mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
-mkT f = case cast f of
- Just g -> g
- Nothing -> id
-
-
--- | Make a generic query;
--- start from a type-specific case;
--- return a constant otherwise
---
-mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
-(r `mkQ` br) a = case cast a of
- Just b -> br b
- Nothing -> r
-
-
--- | Make a generic monadic transformation;
--- start from a type-specific case;
--- resort to return otherwise
---
-mkM :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), Monad m)
- => (b -> m b) -> a -> m a
-mkM f = case cast f of
- Just g -> g
- Nothing -> return
-
-
-{-
-
-For the remaining definitions, we stick to a more concise style, i.e.,
-we fold maybies with "maybe" instead of case ... of ..., and we also
-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.
---
-mkF :: (Typeable a, Typeable b, Typeable (m a), Typeable (m b), MonadPlus m)
- => (b -> m b) -> a -> m a
-mkF = maybe (const mzero) id . cast
-
-
--- | Make a generic builder;
--- start from a type-specific ase;
--- resort to no build (i.e., mzero) otherwise
---
-mkB :: (Typeable a, Typeable b,
- Typeable i,
- Typeable (m (a,i)), Typeable (m (b,i)),
- MonadPlus m)
- => (i -> m (b,i)) -> i -> m (a,i)
-mkB = maybe (const mzero) id . cast
-
-
--- | Extend a generic transformation by a type-specific case
-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 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)
- => (a -> m a) -> (b -> m b) -> a -> m a
-extM f = maybe f id . cast
-
-
--- | Extend a generic MonadPlus transformation by a type-specific case
-extF :: (Typeable a, Typeable b,
- Typeable (m a), Typeable (m b),
- MonadPlus m)
- => (a -> m a) -> (b -> m b) -> a -> m a
-extF = extM
-
-
--- | Extend a generic builder by a type-specific case
-extB :: (Typeable a, Typeable b,
- Typeable i,
- Typeable (m (a,i)), Typeable (m (b,i)),
- MonadPlus m)
- => (i -> m (a,i)) -> (i -> m (b,i)) -> i -> m (a,i)
-extB f = maybe f id . cast
-
-
-
-------------------------------------------------------------------------------
---
--- The Data class
---
-------------------------------------------------------------------------------
-
-{-
-
-The Data class comprehends two important primitives "gfoldl" and
-"gunfold" for folding and unfolding constructor applications, say
-terms. Besides, there are helpers "conOf" and "consOf" for retrieving
-constructors from terms and types. Finally, typical ways of mapping
-over immediate subterms are defined as "gmap" combinators in terms
-of gfoldl. A generic programmer does not necessarily need to use
-the ingenious gfoldl/gunfold couple but rather the "gmap" combinators.
-
--}
-
-class Typeable a => Data a where
-
-{-
-
-Folding constructor applications ("gfoldl")
-
-The combinator takes two arguments "f" and "z" to fold over a term
-"x". The result type is parametric via a type constructor "c" in the
-type of "gfoldl". The purpose of "z" is to define how the empty
-constructor application is folded. So "z" is like the neutral / start
-element for list folding. The purpose of "f" is to define how the
-nonempty constructor application is folded. That is, "f" takes the
-folded "tail" of the constructor application and its head, i.e., an
-immediate subterm, and combines them in some way. See the Data
-instances in this file which illustrate gfoldl. Conclusion: the type
-of gfoldl is a headache, but operationally it is simple generalisation
-of a list fold.
-
--}
-
- -- | Left-associative fold operation for constructor applications
- gfoldl :: (forall a b. Data a => c (a -> b) -> a -> c b)
- -> (forall g. g -> c g)
- -> a -> c a
-
-{-
-
-Unfolding constructor applications ("gunfold")
-
-The combinator takes alike "gfoldl" two arguments "f" and "z", but
-this time its about constructing (say, unfolding) constructor
-applications rather than folding. The input for unfolding is primarily
-an opaque representation of the desired constructor, which is
-essentially a string representation of the constructor. (It is in the
-responsibility of the programmer not to attempt unfolding invalid
-constructors. This is like the side condition that a programmer must
-not apply the "head" function to the empty list.) Besides the
-constructor, we also have to provide the "input" for constructing
-immediate subterms. This is anticipated via the type constructor "c"
-in the type of "gunfold". For example, in the case of a generic read
-function, "c" models string-processing functions. So "z" defines how
-to construct the empty constructor application, and "f" takes an
-incomplete constructor application to add more immediate subterm.
-Conclusion: the type of gunfoldl and what it does is a headache, but
-operationally it is a simple generalisation of the underappreciated
-list unfold.
-
--}
-
- -- | Unfold operation to build terms from constructors and others
- gunfold :: (forall a b. Data a => c (a -> b) -> c b)
- -> (forall g. g -> c g)
- -> Constr
- -> c a
-
- -- Default definition for gfoldl
- -- which copes immediately with basic datatypes
- --
- gfoldl _ z = z
-
- -- | Obtain the constructor from a given term
- conOf :: a -> Constr
-
- -- | List all constructors for a given type
- consOf :: a -> [Constr]
-
-
-
-------------------------------------------------------------------------------
---
--- Typical generic maps defined in terms of gfoldl
---
-------------------------------------------------------------------------------
-
-{-
-
-The combinators gmapT, gmapQ, gmapM, gmapF can all be defined in terms
-of gfoldl. We provide corresponding default definitions leaving open
-the opportunity to provide datatype-specific definitions if needed.
-
-(Also, the inclusion of the gmap combinators as members of class Data
-allows the programmer or the compiler to derive specialised, and maybe
-more efficient code per datatype. Note: gfoldl is more higher-order
-than the gmap combinators. This is subject to ongoing benchmarking
-experiments.)
-
-Conceptually, the definition of the gmap combinators in terms of the
-primitive gfoldl requires the identification of the gfoldl function
-arguments. Technically, we also need to identify the type constructor
-c used all over the type of gfoldl.
-
--}
-
- -- | A generic transformation that maps over the immediate subterms
- gmapT :: (forall b. Data b => b -> b) -> a -> a
-
- -- Use an identity datatype constructor ID (see below)
- -- to instantiate the type constructor c in the type of gfoldl,
- -- and perform injections ID and projections unID accordingly.
- --
- gmapT f x = unID (gfoldl k ID x)
- where
- k (ID c) x = ID (c (f x))
-
-
- -- | A generic query that processes the immediate subterms and returns a list
- gmapQ :: (forall a. Data a => a -> u) -> a -> [u]
-
- -- Use a phantom + function datatype constructor Q (see below),
- -- to instantiate the type constructor c in the type of gfoldl,
- -- and perform injections Q and projections unQ accordingly.
- --
- gmapQ f x = unQ (gfoldl k (const (Q id)) x) []
- where
- k (Q c) x = Q (\rs -> c (f x : rs))
-
-
- -- | A generic monadic transformation that maps over the immediate subterms
- gmapM :: Monad m => (forall a. Data a => a -> m a) -> a -> m a
-
- -- Use immediately the monad datatype constructor
- -- to instantiate the type constructor c in the type of gfoldl,
- -- so injection and projection is done by return and >>=.
- --
- gmapM f = gfoldl k return
- where
- k c x = do c' <- c
- x' <- f x
- return (c' x')
-
-
- -- | Transformation of at least one immediate subterm does not fail
- gmapF :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
-
- -- Use a datatype constructor F (see below)
- -- to instantiate the type constructor c in the type of gfoldl.
- --
- gmapF f x = unF (gfoldl k z x) >>= \(x',b) ->
- if b then return x' else mzero
- where
- z g = F (return (g,False))
- k (F c) x
- = F ( c >>= \(h,b) ->
- (f x >>= \x' -> return (h x',True))
- `mplus` return (h x, b)
- )
-
-
--- | The identity type constructor needed for the definition of gmapT
-newtype ID x = ID { unID :: x }
-
-
--- | A phantom datatype constructor used in definition of gmapQ;
--- the function-typed component is needed to mediate between
--- left-associative constructor application vs. right-associative lists.
---
-newtype Q r a = Q { unQ :: [r] -> [r] }
-
-
--- | A pairing type constructor needed for the definition of gmapF;
--- we keep track of the fact if a subterm was ever transformed successfully.
-newtype F m x = F { unF :: m (x, Bool) }
-
-
-
-------------------------------------------------------------------------------
---
--- The Constr datatype for describing datatype constructors
--- To be extended by fixity, associativity, and maybe others.
---
-------------------------------------------------------------------------------
-
--- | Description of datatype constructors
-data Constr = Constr { conString :: String } deriving (Eq, Typeable)
-
-
-{-
-
-It is interesting to observe that we can determine the arity of a
-constructor without further meta-information. To this end, we use
-gunfold to construct a term from a given constructor while leaving the
-subterms undefined; see "gundefineds" below. Here we instantiate the
-type constructor c of the gunfold type by the identity type
-constructor ID. In a subsequent step we determine the number of
-subterms by folding as captured in the generic operation "glength"
-elsewhere in this module. Note that we need a type argument to specify
-the intended type of the constructor.
-
--}
-
-
--- | Compute arity of a constructor against a type argument
-garity :: Data a => (a -> ()) -> Constr -> Int
-garity ta = glength . gundefineds ta
-
-
--- | Construct a term from a constructor with undefined subterms
-gundefineds :: Data a => (a -> ()) -> Constr -> a
-gundefineds (_::a -> ()) = (unID :: ID a -> a)
- . gunfold ((\f -> ID (f undefined)) . unID) ID
-
-
-
-------------------------------------------------------------------------------
---
--- Frequently used generic traversal schemes
---
-------------------------------------------------------------------------------
-
--- | Apply a transformation everywhere in bottom-up manner
-everywhere :: (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-
--- Use gmapT to recurse into immediate subterms;
--- recall: gmapT preserves the outermost constructor;
--- post-process recursively transformed result via f
---
-everywhere f = f . gmapT (everywhere f)
-
-
--- | Apply a transformation everywhere in top-down manner
-everywhere' :: (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-
--- Arguments of (.) are flipped compared to everywhere
-everywhere' f = gmapT (everywhere' f) . f
-
-
--- | Variation on everywhere with an extra stop condition
-everywhereBut :: GenericQ Bool -> GenericT -> GenericT
-
--- Guarded to let traversal cease if predicate q holds for x
-everywhereBut q f x
- | q x = x
- | otherwise = f (gmapT (everywhereBut q f) x)
-
-
--- | Monadic variation on everywhere
-everywhereM :: Monad m => GenericM m -> GenericM m
-
--- Bottom-up order is also reflected in order of do-actions
-everywhereM f x = do x' <- gmapM (everywhereM f) x
- f x'
-
-
--- | Apply a monadic transformation at least somewhere
-somewhere :: MonadPlus m => GenericM m -> GenericM m
-
--- We try "f" in top-down manner, but descent into "x" when we fail
--- at the root of the term. The transformation fails if "f" fails
--- everywhere, say succeeds nowhere.
---
-somewhere f x = f x `mplus` gmapF (somewhere f) x
-
-
--- | Summarise all nodes in top-down, left-to-right order
-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
-
--- Apply f to x to summarise top-level node;
--- use gmapQ to recurse into immediate subterms;
--- use ordinary foldl to reduce list of intermediate results
---
-everything k f x
- = foldl k (f x) (gmapQ (everything k f) x)
-
-
--- | Get a list of all entities that meet a predicate
-listify :: Typeable r => (r -> Bool) -> GenericQ [r]
-listify p
- = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))
-
-
--- | Look up a subterm by means of a maybe-typed filter
-something :: GenericQ (Maybe u) -> GenericQ (Maybe u)
-
--- "something" can be defined in terms of "everything"
--- when a suitable "choice" operator is used for reduction
---
-something = everything orElse
-
-
--- | Bottom-up synthesis of a data structure;
--- 1st argument z is the initial element for the synthesis;
--- 2nd argument o is for reduction of results from subterms;
--- 3rd argument f updates the sythesised data according to the given term
---
-synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
-synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
-
-
-
------------------------------------------------------------------------------
---
--- "Twin" variations on gmapT, gmapQ. gmapM,
--- i.e., these combinators take two terms at the same time.
--- They are needed for multi-parameter traversal as generic equality.
--- They are not exported.
---
------------------------------------------------------------------------------
-
-{-
-
-We need type constructors for twin traversal as we needed type
-constructor for the ordinary gmap combinators. These type constructors
-again serve for the instantiation of the type constructor c used in
-the definition of gfoldl. The type constructors for twin traversal are
-elaborations of the type constructors ID, Q and monads that were used
-for the ordinary gmap combinators. More precisely, we use a pairing
-technique to always attach an additional component to the results of
-folding. This additional component carries the list of generic
-functions to be used for the intermediate subterms encountered during
-folding.
-
--}
-
-newtype TT r a = TT { unTT :: (a,[GenericT']) }
-newtype TQ r a = TQ { unTQ :: ([r]->[r],[GenericQ' r]) }
-newtype TM m a = TM { unTM :: (m a,[GenericM' m]) }
-
-
--- First-class polymorphic versions of GenericT/GenericQ/GenericM;
--- they are referenced in TQ amd TM above
---
-data GenericT' = T' { unT' :: forall a. Data a => a -> a }
-data GenericQ' u = Q' { unQ' :: forall a. Data a => a -> u }
-data Monad m => GenericM' m = M' { unM' :: forall a. Data a => a -> m a }
-
-
-{-
-
-A twin variation on gmapT, where the pattern "GenericQ GenericT"
-expresses that the argument terms x and y are processed rather
-independently. So firstly, x is "queried" with a generic
-transformation as intermediate result, and secondly, this generic
-transformation is applied to y.
-
--}
-
-tmapT :: GenericQ GenericT -> GenericQ GenericT
-tmapT g x y = fst (unTT (gfoldl k z y))
- where
- k (TT (f,l)) x = TT (f (unT' (head l) x),tail l)
- z f = TT (f,gmapQ (\x -> T' (g x)) x)
-
-
-
--- A twin variation on gmapQ
-
-tmapQ :: forall r.
- (forall a b. (Data a, Data b) => a -> b -> r)
- -> (forall a b. (Data a, Data b) => a -> b -> [r])
-
-tmapQ g x y = fst (unTQ (gfoldl k z y)) []
- where
- k (TQ (c,l)) x = TQ (\rs -> c (unQ' (head l) x:rs), tail l)
- z _ = TQ (id,gmapQ (\x -> Q' (g x)) x)
-
-
--- A twin variation on gmapM
-
-tmapM :: forall m. Monad m
- => (forall a b. (Data a, Data b) => a -> b -> m b)
- -> (forall a b. (Data a, Data b) => a -> b -> m b)
-tmapM g x y = fst (unTM (gfoldl k z y))
- where
- k (TM (f,l)) x = TM (f >>= \f' -> unM' (head l) x >>= return . f',tail l)
- z f = TM (return f,gmapQ (\x -> M' (g x)) x)
-
-
-
-------------------------------------------------------------------------------
---
--- Generic operations such as show, equality, read
---
-------------------------------------------------------------------------------
-
--- | 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 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 (conOf t)
- ++ concat (gmapQ ((++) " " . gshow) t)
- ++ ")"
- ) `extQ` (show :: String -> String)
-
-
--- | Generic equality: an alternative to \"deriving Eq\"
-geq :: Data a => a -> a -> Bool
-
-{-
-
-Testing for equality of two terms goes like this. Firstly, we
-establish the equality of the two top-level datatype
-constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
-to compare the two lists of immediate subterms.
-
-(Note for the experts: the type of the worker geq' is rather general
-but precision is recovered via the restrictive type of the top-level
-operation geq. The imprecision of geq' is caused by the type system's
-unability to express the type equivalence for the corresponding
-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 ( (conString (conOf x) == conString (conOf y))
- : tmapQ 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 conString (conOf x) == conString (conOf y)
- then tmapM (gzip f) x y
- else Nothing
-
-
--- | The type constructor for gunfold a la ReadS from the Haskell 98 Prelude;
--- we don't use lists here for simplicity but only maybes.
-newtype GRead i a = GRead (i -> Maybe (a, i))
-unGRead (GRead x) = x
-
-
--- | Generic read: an alternative to \"deriving Read\"
-gread :: GenericB Maybe String
-
-{-
-
-This is a read operation which insists on prefix notation. (The
-Haskell 98 read deals with infix operators as well. We will be able to
-deal with such special cases as well as sonn as we include fixity
-information into the definition of "Constr".) We use gunfold to
-"parse" the input. To be precise, gunfold is used for all result types
-except String. The type-specific case for String uses basic String
-read. Another source of customisation would be to properly deal with
-infix operators subject to the capture of that information in the
-definition of Constr. The "gread" combinator properly checks the
-validity of constructors before invoking gunfold in order to rule
-out run-time errors.
-
--}
-
-gread = gdefault `extB` scase
-
- where
-
- -- a specific case for strings
- scase s = case reads s of
- [x::(String,String)] -> Just x
- _ -> Nothing
-
- -- the generic default of gread
- gdefault s =
- do s' <- return $ dropWhile ((==) ' ') s
- guard (not (s' == ""))
- guard (head s' == '(')
- (c,s'') <- prefixConstr (dropWhile ((==) ' ') (tail s'))
- u <- return undefined
- guard (or [consOf u == [], c `elem` consOf u])
- (a,s''') <- unGRead (gunfold f z c) s''
- _ <- return $ constrainTypes a u
- guard (not (s''' == ""))
- guard (head s''' == ')')
- return (a, tail s''')
-
- -- To force two types to be the same
- constrainTypes :: a -> a -> ()
- constrainTypes _ _ = ()
-
- -- Argument f for unfolding
- f :: Data a => GRead String (a -> b) -> GRead String b
- f x = GRead (\s -> do (r,s') <- unGRead x s
- (t,s'') <- gread s'
- return (r t,s''))
-
- -- Argument z for unfolding
- z :: forall g. g -> GRead String g
- z g = GRead (\s -> return (g,s))
-
- -- Get Constr at front of string
- prefixConstr :: String -> Maybe (Constr, String)
-
- -- Assume an infix operators in parantheses
- prefixConstr ('(':s)
- = case break ((==) ')') s of
- (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
- _ -> Nothing
-
- -- Special treatment of multiple token constructors
- prefixConstr ('[':']':s) = Just (Constr "[]",s)
-
- -- Try lex for ordinary constructor and basic datatypes
- prefixConstr s
- = case lex s of
- [(s'@(_:_),s'')] -> Just (Constr s',s'')
- _ -> Nothing
-
-
-
-------------------------------------------------------------------------------
---
--- Instances of the Data class
---
-------------------------------------------------------------------------------
-
--- Basic datatype Int; folding and unfolding is trivial
-instance Data Int where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
--- Another basic datatype instance
-instance Data Integer where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
--- Another basic datatype instance
-instance Data Float where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
--- Another basic datatype instance
-instance Data Char where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
-{-
-
-Commented out;
-subject to inclusion of a missing Typeable instance
-
--- Another basic datatype instance
-instance Data Rational where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
--}
-
--- Bool as a kind of enumeration type
-instance Data Bool where
- conOf False = Constr "False"
- conOf True = Constr "True"
- consOf _ = [Constr "False",Constr "True"]
- gunfold f z (Constr "False") = z False
- gunfold f z (Constr "True") = z True
-
-{-
-
-We should better not fold over characters in a string for efficiency.
-However, the following instance would clearly overlap with the
-instance for polymorphic lists. Given the current scheme of allowing
-overlapping instances, this would imply that ANY module that imports
-Data.Generics would need to explicitly and generally allow overlapping
-instances. This is prohibitive and calls for a more constrained model
-of allowing overlapping instances. The present instance would also be
-more sensible for UNFOLDING. In the definition of gread, we still
-obtained the favoured behaviour by using a type-specific case for
-String.
-
--- instance Data String where
- conOf x = Constr (show x)
- consOf _ = []
- gunfold f z c = z (read (conString c))
-
--}
-
--- Cons-lists are terms with two immediate subterms. Hence, the gmap
--- combinators do NOT coincide with the list fold/map combinators.
---
-instance Data a => Data [a] where
- gmapT f [] = []
- gmapT 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')
- gfoldl f z [] = z []
- gfoldl f z (x:xs) = z (:) `f` x `f` xs
- conOf [] = Constr "[]"
- conOf (_:_) = Constr "(:)"
- consOf _ = [Constr "[]",Constr "(:)"]
- gunfold f z (Constr "[]") = z []
- gunfold f z (Constr "(:)") = f (f (z (:)))
-
--- Yet enother polymorphic datatype constructor
-instance Data a => Data (Maybe a) where
- gfoldl f z Nothing = z Nothing
- gfoldl f z (Just x) = z Just `f` x
- conOf Nothing = Constr "Nothing"
- conOf (Just _) = Constr "Just"
- consOf _ = [Constr "Nothing", Constr "Just"]
- gunfold f z c | conString c == "Nothing" = z Nothing
- gunfold f z c | conString c == "Just" = f (z Just)
-
--- Yet enother polymorphic datatype constructor
-instance (Data a, Data b) => Data (a,b) where
- gfoldl f z (a,b) = z (,) `f` a `f` b
- conOf _ = Constr "(,)"
- consOf _ = [Constr "(,)"]
- gunfold f z c | conString c == "(,)" = f (f (z (,)))
-
--- Functions are treated as "non-compound" data regarding folding while
--- unfolding is out of reach, maybe not anymore with Template Haskell.
---
-instance (Typeable a, Typeable b) => Data (a -> b) where
- conOf _ = Constr "->"
- consOf _ = [Constr "->"]
- gunfold _ _ _ = undefined
-
-
-
-------------------------------------------------------------------------------
---
--- Miscellaneous
---
-------------------------------------------------------------------------------
-
--- | Test for two objects to agree on the type
-sameType :: (Typeable a, Typeable b) => a -> b -> Bool
-sameType (_::a) = maybe False (\(_::a) -> True) . cast
-
-
--- | Left-biased choice on maybes (non-strict in right argument)
-orElse :: Maybe a -> Maybe a -> Maybe a
-x `orElse` y = maybe y Just x
-
-
--- Another definition of orElse
--- where the folding over maybies as defined by maybe is inlined
--- to ease readability
---
-x `orElse'` y = case x of
- Just _ -> x
- Nothing -> y
-
-
-{-
-
-The following variations take "orElse" to the function
-level. Furthermore, we generalise from "Maybe" to any
-"MonadPlus". This makes sense for monadic transformations and
-queries. We say that the resulting combinators modell choice. We also
-provide a prime example of choice, that is, recovery from failure. In
-the case of transformations, we recover via return whereas for
-queries a given constant is returned.
-
--}
-
--- | Choice for monadic transformations
-choiceF :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
-choiceF f g x = f x `mplus` g x
-
-
--- | Choice for monadic queries
-choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)
-choiceQ f g x = f x `mplus` g x
-
-
--- | Recover from the failure of monadic transformation by identity
-recoverF :: MonadPlus m => GenericM m -> GenericM m
-recoverF f = f `choiceF` 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)
+import Data.Generics.Basics
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Data.Generics.Twins
+import Data.Generics.Strings
+import Data.Generics.Counts
+import Data.Generics.Types
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Generics.Aliases
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Aliases (
+
+ -- * Combinators to \"make\" generic functions via cast
+ mkT, mkQ, mkM, mkF, mkB,
+ extT, extQ, extM, extF, extB,
+
+ -- * Type synonyms for generic function types
+ GenericT,
+ GenericQ,
+ GenericM,
+ GenericB,
+ Generic,
+ Generic'(..),
+
+ -- * Inredients of generic functions
+ orElse,
+
+ -- * Function combinators on generic functions
+ recoverF,
+ recoverQ,
+ choiceF,
+ choiceQ
+
+ ) where
+
+
+import Control.Monad
+import Data.Generics.Basics
+
+
+
+------------------------------------------------------------------------------
+--
+-- Combinators to "make" generic functions
+-- We use type-safe cast in a number of ways to make generic functions.
+--
+------------------------------------------------------------------------------
+
+-- | Make a generic transformation;
+-- start from a type-specific case;
+-- preserve the term otherwise
+--
+mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
+mkT f = case cast f of
+ Just g -> g
+ Nothing -> id
+
+
+-- | Make a generic query;
+-- start from a type-specific case;
+-- return a constant otherwise
+--
+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+(r `mkQ` br) a = case cast a of
+ Just b -> br b
+ Nothing -> r
+
+
+-- | Make a generic monadic transformation;
+-- start from a type-specific case;
+-- resort to return otherwise
+--
+mkM :: ( Monad m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
+ => (b -> m b) -> a -> m a
+mkM f = case cast f of
+ Just g -> g
+ Nothing -> return
+
+
+{-
+
+For the remaining definitions, we stick to a more concise style, i.e.,
+we fold maybies with "maybe" instead of case ... of ..., and we also
+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.
+--
+mkF :: ( MonadPlus m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
+ => (b -> m b) -> a -> m a
+mkF = maybe (const mzero) id . cast
+
+
+-- | Make a generic builder;
+-- start from a type-specific ase;
+-- resort to no build (i.e., mzero) otherwise
+--
+mkB :: ( MonadPlus m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
+ => m b -> m a
+mkB = maybe mzero id . cast
+
+
+-- | Extend a generic transformation by a type-specific case
+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 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)
+ => (a -> m a) -> (b -> m b) -> a -> m a
+extM f = maybe f id . cast
+
+
+-- | Extend a generic MonadPlus transformation by a type-specific case
+extF :: ( MonadPlus m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
+ => (a -> m a) -> (b -> m b) -> a -> m a
+extF = extM
+
+
+
+-- | Extend a generic builder by a type-specific case
+extB :: ( Monad m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
+ => m a -> m b -> m a
+extB f = maybe f id . cast
+
+
+------------------------------------------------------------------------------
+--
+-- Type synonyms for generic function types
+--
+------------------------------------------------------------------------------
+
+
+-- | Generic transformations,
+-- i.e., take an \"a\" and return an \"a\"
+--
+type GenericT = forall a. Data a => a -> a
+
+
+-- | Generic queries of type \"r\",
+-- i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Generic monadic transformations,
+-- i.e., take an \"a\" and compute an \"a\"
+--
+type GenericM m = forall a. Data a => a -> m a
+
+
+-- | Generic monadic builders with input i,
+-- i.e., produce an \"a\" with the help of a monad \"m\".
+--
+type GenericB m = forall a. Data a => m a
+
+
+-- | The general scheme underlying generic functions
+-- assumed by gfoldl; there are isomorphisms such as
+-- GenericT = Generic ID.
+--
+type Generic c = forall a. Data a => a -> c a
+
+
+-- | Wrapped generic functions;
+-- recall: [Generic c] would be legal but [Generic' c] not.
+--
+data Generic' c = Generic' { unGeneric' :: Generic c }
+
+
+
+-- | Left-biased choice on maybies
+orElse :: Maybe a -> Maybe a -> Maybe a
+x `orElse` y = case x of
+ Just _ -> x
+ Nothing -> y
+
+
+{-
+
+The following variations take "orElse" to the function
+level. Furthermore, we generalise from "Maybe" to any
+"MonadPlus". This makes sense for monadic transformations and
+queries. We say that the resulting combinators modell choice. We also
+provide a prime example of choice, that is, recovery from failure. In
+the case of transformations, we recover via return whereas for
+queries a given constant is returned.
+
+-}
+
+-- | Choice for monadic transformations
+choiceF :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
+choiceF f g x = f x `mplus` g x
+
+
+-- | Choice for monadic queries
+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)
+choiceQ f g x = f x `mplus` g x
+
+
+-- | Recover from the failure of monadic transformation by identity
+recoverF :: MonadPlus m => GenericM m -> GenericM m
+recoverF f = f `choiceF` 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)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Generics.Basics
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Basics (
+
+ -- Module Data.Typeable re-exported for convenience
+ module Data.Typeable,
+
+ -- * The Data class for processing constructor applications
+ Data(
+ gfoldl, -- :: ... -> a -> c a
+ toConstr, -- :: a -> Constr
+ fromConstr, -- :: Constr -> a
+ dataTypeOf -- :: a -> DataType
+
+ ),
+
+ -- * Constructor representations
+ Constr, -- abstract, instance of: Eq, Show
+ ConIndex, -- alias for Int, start at 1
+ Fixity, -- instance of: Eq, Show
+ DataType, -- abstract, instance of: Show
+
+ -- * Constructing constructor representations
+ mkConstr, -- :: ConIndex -> String -> Fixity -> Constr
+ mkDataType, -- :: [Constr] -> DataType
+
+ -- * Observing constructor representations
+ conString, -- :: Constr -> String
+ conFixity, -- :: Constr -> Fixity
+ conIndex, -- :: Constr -> ConIndex
+ stringCon, -- :: DataType -> String -> Maybe Constr
+ indexCon, -- :: DataType -> ConIndex -> Constr
+ maxConIndex, -- :: DataType -> ConIndex
+ dataTypeCons, -- :: DataType -> [Constr]
+
+ -- * Generic maps defined in terms of gfoldl
+ gmapT,
+ gmapQ,
+ gmapL,
+ gmapM,
+ gmapF,
+
+ -- * Generic unfolding defined in terms of gfoldl and fromConstr
+ gunfoldM -- :: Monad m => ... -> m a
+
+ ) where
+
+
+------------------------------------------------------------------------------
+
+
+import Data.Typeable
+import Data.Maybe
+import Control.Monad
+
+
+------------------------------------------------------------------------------
+--
+-- The Data class
+--
+------------------------------------------------------------------------------
+
+{-
+
+The Data class comprehends a fundamental primitive "gfoldl" for
+folding over constructor applications, say terms. This primitive can
+be instantiated in several ways to map over the immediate subterms of
+a term; see the "gmap" combinators later in this module. Indeed, a
+generic programmer does not necessarily need to use the ingenious
+gfoldl primitive but rather the intuitive "gmap" combinators. The
+"gfoldl" primitive is completed by means to query top-level
+constructors, to turn constructor representations into proper terms,
+and to list all possible datatype constructors. This completion
+allows us to serve generic programming scenarios like read, show,
+equality, term generation.
+
+-}
+
+class Typeable a => Data a where
+
+{-
+
+Folding constructor applications ("gfoldl")
+
+The combinator takes two arguments "f" and "z" to fold over a term
+"x". The result type is defined in terms of "x" but variability is
+achieved by means of type constructor "c" for the construction of the
+actual result type. The purpose of the argument "z" is to define how
+the empty constructor application is folded. So "z" is like the
+neutral / start element for list folding. The purpose of the argument
+"f" is to define how the nonempty constructor application is
+folded. That is, "f" takes the folded "tail" of the constructor
+application and its head, i.e., an immediate subterm, and combines
+them in some way. See the Data instances in this file for an
+illustration of "gfoldl". Conclusion: the type of gfoldl is a
+headache, but operationally it is simple generalisation of a list
+fold.
+
+-}
+
+ -- | Left-associative fold operation for constructor applications
+ gfoldl :: (forall a b. Data a => c (a -> b) -> a -> c b)
+ -> (forall g. g -> c g)
+ -> a -> c a
+
+ -- Default definition for gfoldl
+ -- which copes immediately with basic datatypes
+ --
+ 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
+ -- values (i.e., constructors).
+ --
+ toConstr :: a -> Constr
+
+
+ -- | Building a term from a constructor
+ fromConstr :: Constr -> a
+
+
+ -- | Provide access to list of all constructors
+ dataTypeOf :: a -> DataType
+
+
+------------------------------------------------------------------------------
+--
+-- Typical generic maps defined in terms of gfoldl
+--
+------------------------------------------------------------------------------
+
+{-
+
+The combinators gmapT, gmapQ, gmapL, gmapM, gmapF can all be defined
+in terms of gfoldl. We provide corresponding default definitions
+leaving open the opportunity to provide datatype-specific definitions.
+
+(The inclusion of the gmap combinators as members of class Data allows
+the programmer or the compiler to derive specialised, and maybe more
+efficient code per datatype. Note: gfoldl is more higher-order than
+the gmap combinators. This is subject to ongoing benchmarking
+experiments. It might turn out that the gmap combinators will be moved
+out of the class Data.)
+
+Conceptually, the definition of the gmap combinators in terms of the
+primitive gfoldl requires the identification of the gfoldl function
+arguments. Technically, we also need to identify the type constructor
+"c" for the construction of the result type from the folded term type.
+
+-}
+
+
+ -- | A generic transformation that maps over the immediate subterms
+ gmapT :: (forall b. Data b => b -> b) -> a -> a
+
+ -- Use an identity datatype constructor ID (see below)
+ -- to instantiate the type constructor c in the type of gfoldl,
+ -- and perform injections ID and projections unID accordingly.
+ --
+ gmapT f x = unID (gfoldl k ID x)
+ where
+ k (ID c) x = ID (c (f x))
+
+
+ -- | A generic query with monoid-like operators
+ gmapQ :: (r -> r -> r) -> r -> (forall a. Data a => a -> r) -> a -> r
+ gmapQ o r f = unCONST . gfoldl k z
+ where
+ k c x = CONST $ (unCONST c) `o` f x
+ z _ = CONST r
+
+
+ -- | A generic query that processes the immediate subterms and returns a list
+ gmapL :: (forall a. Data a => a -> u) -> a -> [u]
+
+ -- Use a phantom + function datatype constructor QL (see below),
+ -- to instantiate the type constructor c in the type of gfoldl,
+ -- and perform injections QL and projections unQL accordingly.
+ --
+ gmapL f x = unQL (gfoldl k (const (QL id)) x) []
+ where
+ k (QL c) x = QL (\rs -> c (f x : rs))
+
+
+ -- | A generic monadic transformation that maps over the immediate subterms
+ gmapM :: Monad m => (forall a. Data a => a -> m a) -> a -> m a
+
+ -- Use immediately the monad datatype constructor
+ -- to instantiate the type constructor c in the type of gfoldl,
+ -- so injection and projection is done by return and >>=.
+ --
+ gmapM f = gfoldl k return
+ where
+ k c x = do c' <- c
+ x' <- f x
+ return (c' x')
+
+
+ -- | Transformation of at least one immediate subterm does not fail
+ gmapF :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
+
+ -- Use a datatype constructor F (see below)
+ -- to instantiate the type constructor c in the type of gfoldl.
+ --
+ gmapF f x = unFAIL (gfoldl k z x) >>= \(x',b) ->
+ if b then return x' else mzero
+ where
+ z g = FAIL (return (g,False))
+ k (FAIL c) x
+ = FAIL ( c >>= \(h,b) ->
+ (f x >>= \x' -> return (h x',True))
+ `mplus` return (h x, b)
+ )
+
+
+-- | The identity type constructor needed for the definition of gmapT
+newtype ID x = ID { unID :: x }
+
+
+-- | The constant type constructor needed for the definition of gmapQ
+newtype CONST c a = CONST { unCONST :: c }
+
+
+-- | A phantom datatype constructor used in definition of gmapL;
+-- the function-typed component is needed to mediate between
+-- left-associative constructor application vs. right-associative lists.
+--
+newtype QL r a = QL { unQL :: [r] -> [r] }
+
+
+-- | A pairing type constructor needed for the definition of gmapF;
+-- we keep track of the fact if a subterm was ever transformed successfully.
+newtype FAIL m x = FAIL { unFAIL :: m (x, Bool) }
+
+
+
+------------------------------------------------------------------------------
+--
+-- Constructor representations
+--
+------------------------------------------------------------------------------
+
+
+-- | Representation of constructors
+data Constr =
+ -- The prime case for proper datatype constructors
+ DataConstr ConIndex String Fixity
+
+ -- Provision for built-in types
+ | IntConstr Int
+ | IntegerConstr Integer
+ | FloatConstr Float
+ | CharConstr Char
+
+ -- Provision for any type that can be read/shown as string
+ | StringConstr String
+
+ -- Provision for function types
+ | FunConstr
+
+ deriving (Show, Typeable)
+
+--
+-- Equality of datatype constructors via index.
+-- Use designated equalities for primitive types.
+--
+instance Eq Constr where
+ (DataConstr i1 _ _) == (DataConstr i2 _ _) = i1 == i2
+ (IntConstr i1) == (IntConstr i2) = i1 == i2
+ (IntegerConstr i1) == (IntegerConstr i2) = i1 == i2
+ (FloatConstr i1) == (FloatConstr i2) = i1 == i2
+ (CharConstr i1) == (CharConstr i2) = i1 == i2
+ (StringConstr i1) == (StringConstr i2) = i1 == i2
+ _ == _ = False
+
+
+-- | Unique index for datatype constructors.
+-- Textual order is respected. Starts at 1.
+--
+type ConIndex = Int
+
+
+-- | Fixity of constructors
+data Fixity = NoFixity
+ | PreFixity
+ | InFixity
+ deriving (Eq,Show)
+
+-- | A package of constructor representations;
+-- could be a list, an array, a balanced tree, or others.
+--
+data DataType =
+ -- The prime case for algebraic datatypes
+ DataType [Constr]
+
+ -- Provision for built-in types
+ | IntType
+ | IntegerType
+ | FloatType
+ | CharType
+
+ -- Provision for any type that can be read/shown as string
+ | StringType
+
+ -- Provision for function types
+ | FunType
+
+ deriving Show
+
+
+------------------------------------------------------------------------------
+--
+-- Constructing constructor representations
+--
+------------------------------------------------------------------------------
+
+
+-- | Make a representation for a datatype constructor
+mkConstr :: ConIndex -> String -> Fixity -> Constr
+mkConstr = DataConstr
+
+-- | Make a package of constructor representations
+mkDataType :: [Constr] -> DataType
+mkDataType = DataType
+
+
+------------------------------------------------------------------------------
+--
+-- Observing constructor representations
+--
+------------------------------------------------------------------------------
+
+
+-- | Turn a constructor into a string
+conString :: Constr -> String
+conString (DataConstr _ str _) = str
+conString (IntConstr int) = show int
+conString (IntegerConstr int) = show int
+conString (FloatConstr real) = show real
+conString (CharConstr char) = show char
+conString (StringConstr str) = show str
+conString FunConstr = "->"
+
+
+-- | Determine fixity of a constructor;
+-- undefined for primitive types.
+conFixity :: Constr -> Fixity
+conFixity (DataConstr _ _ fix) = fix
+conFixity _ = undefined
+
+
+-- | Determine index of a constructor.
+-- Undefined for primitive types.
+conIndex :: Constr -> ConIndex
+conIndex (DataConstr idx _ _) = idx
+conIndex _ = undefined
+
+
+-- | Lookup a constructor via a string
+stringCon :: DataType -> String -> Maybe Constr
+stringCon (DataType cs) str = worker cs
+ where
+ worker (c:cs) =
+ case c of
+ (DataConstr _ str' _) -> if str == str'
+ then Just c
+ else worker cs
+ _ -> undefined -- other forms of Constr not valid here
+
+stringCon IntType str = Just . IntConstr $ read str
+stringCon IntegerType str = Just . IntegerConstr $ read str
+stringCon FloatType str = Just . FloatConstr $ read str
+stringCon CharType str = Just . CharConstr $ read str
+stringCon StringType str = Just . StringConstr $ read str
+stringCon FunType str = Just FunConstr
+
+
+-- | Lookup a constructor by its index;
+--- not defined for primitive types.
+indexCon :: DataType -> ConIndex -> Constr
+indexCon (DataType cs) idx = cs !! (idx-1)
+indexCon _ _ = undefined -- otherwise
+
+
+-- | Return maximum index;
+-- 0 for primitive types
+maxConIndex :: DataType -> ConIndex
+maxConIndex (DataType cs) = length cs
+maxConIndex _ = 0 -- otherwise
+
+
+-- | Return all constructors in increasing order of indicies;
+-- empty list for primitive types
+dataTypeCons :: DataType -> [Constr]
+dataTypeCons (DataType cs) = cs
+dataTypeCons _ = [] -- otherwise
+
+
+------------------------------------------------------------------------------
+--
+-- Instances of the Data class for Prelude types
+--
+------------------------------------------------------------------------------
+
+-- Basic datatype Int; folding and unfolding is trivial
+instance Data Int where
+ toConstr x = IntConstr x
+ fromConstr (IntConstr x) = x
+ dataTypeOf _ = IntType
+
+-- Another basic datatype instance
+instance Data Integer where
+ toConstr x = IntegerConstr x
+ fromConstr (IntegerConstr x) = x
+ dataTypeOf _ = IntegerType
+
+-- Another basic datatype instance
+instance Data Float where
+ toConstr x = FloatConstr x
+ fromConstr (FloatConstr x) = x
+ dataTypeOf _ = FloatType
+
+-- Another basic datatype instance
+instance Data Char where
+ toConstr x = CharConstr x
+ fromConstr (CharConstr x) = x
+ dataTypeOf _ = CharType
+
+-- A basic datatype without a specific branch in Constr
+instance Data Rational where
+ toConstr x = StringConstr (show x)
+ fromConstr (StringConstr x) = read x
+ dataTypeOf _ = StringType
+
+--
+-- Bool as the most trivial algebraic datatype;
+-- define top-level definitions for representations.
+--
+
+falseConstr = mkConstr 1 "False" NoFixity
+trueConstr = mkConstr 2 "True" NoFixity
+boolDataType = mkDataType [falseConstr,trueConstr]
+
+instance Data Bool where
+ toConstr False = falseConstr
+ toConstr True = trueConstr
+ fromConstr c = case conIndex c of
+ 1 -> False
+ 2 -> True
+ dataTypeOf _ = boolDataType
+
+
+--
+-- Lists as an example of a polymorphic algebraic datatype.
+-- Cons-lists are terms with two immediate subterms.
+--
+
+nilConstr = mkConstr 1 "[]" NoFixity
+consConstr = mkConstr 2 "(:)" InFixity
+listDataType = mkDataType [nilConstr,consConstr]
+
+instance Data a => Data [a] where
+ gfoldl f z [] = z []
+ gfoldl f z (x:xs) = z (:) `f` x `f` xs
+ toConstr [] = nilConstr
+ toConstr (_:_) = consConstr
+ fromConstr c = case conIndex c of
+ 1 -> []
+ 2 -> undefined:undefined
+ dataTypeOf _ = listDataType
+
+--
+-- The gmaps are given as an illustration.
+-- This shows that the gmaps for lists are different from list maps.
+--
+ gmapT f [] = []
+ gmapT f (x:xs) = (f x:f xs)
+ gmapL f [] = []
+ gmapL f (x:xs) = [f x,f xs]
+ gmapM f [] = return []
+ gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
+
+
+--
+-- Yet another polymorphic datatype constructor
+-- No surprises.
+--
+
+nothingConstr = mkConstr 1 "Nothing" NoFixity
+justConstr = mkConstr 2 "Just" NoFixity
+maybeDataType = mkDataType [nothingConstr,justConstr]
+
+instance Data a => Data (Maybe a) where
+ gfoldl f z Nothing = z Nothing
+ gfoldl f z (Just x) = z Just `f` x
+ toConstr Nothing = nothingConstr
+ toConstr (Just _) = justConstr
+ fromConstr c = case conIndex c of
+ 1 -> Nothing
+ 2 -> Just undefined
+ dataTypeOf _ = maybeDataType
+
+--
+-- Yet another polymorphic datatype constructor.
+-- No surprises.
+--
+
+pairConstr = mkConstr 1 "(,)" InFixity
+productDataType = mkDataType [pairConstr]
+
+instance (Data a, Data b) => Data (a,b) where
+ gfoldl f z (a,b) = z (,) `f` a `f` b
+ toConstr _ = pairConstr
+ fromConstr c = case conIndex c of
+ 1 -> (undefined,undefined)
+ dataTypeOf _ = productDataType
+
+
+{-
+
+We should better not FOLD over characters in a string for efficiency.
+However, the following instance would clearly overlap with the
+instance for polymorphic lists. Given the current scheme of allowing
+overlapping instances, this would imply that ANY module that imports
+Data.Generics would need to explicitly and generally allow overlapping
+instances. This is prohibitive and calls for a more constrained model
+of allowing overlapping instances. The present instance would be
+sensible even more for UNFOLDING. In the definition of "gread"
+(generic read --- based on unfolding), we succeed handling strings in a
+special way by using a type-specific case for String.
+
+instance Data String where
+ toConstr x = StringConstr x
+ fromConstr (StringConstr x) = x
+ dataTypeOf _ = StringType
+
+-}
+
+-- A last resort for functions
+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
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+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 . gmapL (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))
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Generics.Schemes
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Schemes (
+
+ -- * Frequently used generic traversal schemes
+ everywhere,
+ everywhere',
+ everywhereBut,
+ everywhereM,
+ somewhere,
+ everything,
+ listify,
+ something,
+ synthesize,
+
+ ) where
+
+------------------------------------------------------------------------------
+
+import Data.Generics.Basics
+import Data.Generics.Aliases
+import Control.Monad
+
+
+
+-- | Apply a transformation everywhere in bottom-up manner
+everywhere :: (forall a. Data a => a -> a)
+ -> (forall a. Data a => a -> a)
+
+-- Use gmapT to recurse into immediate subterms;
+-- recall: gmapT preserves the outermost constructor;
+-- post-process recursively transformed result via f
+--
+everywhere f = f . gmapT (everywhere f)
+
+
+-- | Apply a transformation everywhere in top-down manner
+everywhere' :: (forall a. Data a => a -> a)
+ -> (forall a. Data a => a -> a)
+
+-- Arguments of (.) are flipped compared to everywhere
+everywhere' f = gmapT (everywhere' f) . f
+
+
+-- | Variation on everywhere with an extra stop condition
+everywhereBut :: GenericQ Bool -> GenericT -> GenericT
+
+-- Guarded to let traversal cease if predicate q holds for x
+everywhereBut q f x
+ | q x = x
+ | otherwise = f (gmapT (everywhereBut q f) x)
+
+
+-- | Monadic variation on everywhere
+everywhereM :: Monad m => GenericM m -> GenericM m
+
+-- Bottom-up order is also reflected in order of do-actions
+everywhereM f x = do x' <- gmapM (everywhereM f) x
+ f x'
+
+
+-- | Apply a monadic transformation at least somewhere
+somewhere :: MonadPlus m => GenericM m -> GenericM m
+
+-- We try "f" in top-down manner, but descent into "x" when we fail
+-- at the root of the term. The transformation fails if "f" fails
+-- everywhere, say succeeds nowhere.
+--
+somewhere f x = f x `mplus` gmapF (somewhere f) x
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapL to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+--
+everything k f x
+ = foldl k (f x) (gmapL (everything k f) x)
+
+
+-- | Get a list of all entities that meet a predicate
+listify :: Typeable r => (r -> Bool) -> GenericQ [r]
+listify p
+ = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))
+
+
+-- | Look up a subterm by means of a maybe-typed filter
+something :: GenericQ (Maybe u) -> GenericQ (Maybe u)
+
+-- "something" can be defined in terms of "everything"
+-- when a suitable "choice" operator is used for reduction
+--
+something = everything orElse
+
+
+-- | Bottom-up synthesis of a data structure;
+-- 1st argument z is the initial element for the synthesis;
+-- 2nd argument o is for reduction of results from subterms;
+-- 3rd argument f updates the sythesised data according to the given term
+--
+synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
+synthesize z o f x = f x (foldr o z (gmapL (synthesize z o f) x))
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Shortcuts (
+
+ -- * Cut-off traversal
+ everywhere1RT'
+
+ ) where
+
+-----------------------------------------------------------------------------
+
+
+import Data.Generics.Basics
+import Data.Generics.Aliases
+import Data.Generics.Types
+import Data.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)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+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 (gmapL ((++) " " . 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))
+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
+ )
+-}
+
+-- | Generic read: an alternative to \"deriving Read\"
+gread :: GenericB Maybe
+
+{-
+
+This is a read operation which insists on prefix notation. (The
+Haskell 98 read deals with infix operators as well. We will be able to
+deal with such special cases as well as sonn as we include fixity
+information into the definition of "Constr".) We use gunfold to
+"parse" the input. To be precise, gunfold is used for all result types
+except String. The type-specific case for String uses basic String
+read. Another source of customisation would be to properly deal with
+infix operators subject to the capture of that information in the
+definition of Constr. The "gread" combinator properly checks the
+validity of constructors before invoking gunfold in order to rule
+out run-time errors.
+
+-}
+
+gread = undefined
+
+{-
+gdefault `extB` scase
+
+ where
+
+ -- a specific case for strings
+ scase s = case reads s of
+ [x::(String,String)] -> Just x
+ _ -> Nothing
+
+ -- the generic default of gread
+ gdefault s = undefined
+
+-}
+
+{-
+ do s' <- return $ dropWhile ((==) ' ') s
+ guard (not (s' == ""))
+ guard (head s' == '(')
+ (c,s'') <- prefixConstr (dropWhile ((==) ' ') (tail s'))
+ u <- return undefined
+ dt <- return $ dataTypeOf u
+ case stringCon dt c of
+ Nothing -> error "Generics: 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''')
+
+
+ -- To force two types to be the same
+ constrainTypes :: a -> a -> ()
+ constrainTypes _ _ = ()
+
+ -- Argument f for unfolding
+ f :: Data a => GRead (a -> b) -> GRead b
+ f x = GRead (\s -> do (r,s') <- unGRead x s
+ (t,s'') <- gread s'
+ return (r t,s''))
+
+ -- Argument z for unfolding
+ z :: forall g. g -> GRead g
+ z g = GRead (\s -> return (g,s))
+
+
+ -- Get Constr at front of string
+ prefixConstr :: String -> Maybe (Constr, String)
+
+ -- Assume an infix operators in parantheses
+ prefixConstr ('(':s)
+ = case break ((==) ')') s of
+ (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
+ _ -> Nothing
+
+ -- Special treatment of multiple token constructors
+ prefixConstr ('[':']':s) = Just (Constr "[]",s)
+
+ -- Try lex for ordinary constructor and basic datatypes
+ prefixConstr s
+ = case lex s of
+ [(s'@(_:_),s'')] -> Just (Constr s',s'')
+ _ -> Nothing
+
+-}
\ No newline at end of file
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Generics.Twins
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Twins (
+
+ -- * The idiom of multi-parameter traversal
+ tfoldl,
+
+ -- * Twin mapping combinators
+ tmapT,
+ tmapQ,
+ tmapM,
+
+ -- * Prime examples of twin traversal
+ geq,
+ gzip
+
+ ) where
+
+
+------------------------------------------------------------------------------
+
+
+import Data.Generics.Basics
+import Data.Generics.Aliases
+
+
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+--
+-- The idiom of 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.
+
+-}
+
+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 }
+ where
+ l = gmapL (\x -> Generic' (t x)) xs
+ k' (TWIN (r:rs) c) y = TWIN rs (k c (unGeneric' r y))
+ z' f = TWIN l (z f)
+
+
+-- Pairing ID, CONST, m or others with lists of generic functions
+data TWIN c a = TWIN [Generic' c] (c a)
+
+
+
+------------------------------------------------------------------------------
+--
+-- Twin mapping combinators
+--
+------------------------------------------------------------------------------
+
+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
+
+
+tmapQ :: (r -> r -> r)
+ -> r
+ -> GenericQ (GenericQ r)
+ -> GenericQ (GenericQ r)
+tmapQ 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
+
+
+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
+
+
+-- The identity type constructor needed for the definition of tmapT
+newtype ID x = ID { unID :: x }
+
+
+-- The constant type constructor needed for the definition of tmapQ
+newtype CONST c a = CONST { unCONST :: c }
+
+
+
+------------------------------------------------------------------------------
+--
+-- Prime examples of twin traversal
+--
+------------------------------------------------------------------------------
+
+-- | Generic equality: an alternative to \"deriving Eq\"
+geq :: Data a => a -> a -> Bool
+
+{-
+
+Testing for equality of two terms goes like this. Firstly, we
+establish the equality of the two top-level datatype
+constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
+to compare the two lists of immediate subterms.
+
+(Note for the experts: the type of the worker geq' is rather general
+but precision is recovered via the restrictive type of the top-level
+operation geq. The imprecision of geq' is caused by the type system's
+unability to express the type equivalence for the corresponding
+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)
+ , tmapQ (\b1 b2 -> and [b1,b2]) True 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
+ else Nothing
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- 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 <http://www.cs.vu.nl/boilerplate/>.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Types (
+
+ -- * Generic operations to reify types
+ constrArity,
+ typeReachableFrom,
+
+ ) where
+
+
+------------------------------------------------------------------------------
+
+
+import Data.Types
+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 . (\c -> withType (fromConstr c) b))
+ (dataTypeCons $ dataTypeOf b)
+ )
+ where
+
+ -- See if a is reachable from immediate subterms of a kind of b
+ recurse :: b -> Bool
+ recurse = or
+ . gmapL ( typeReachableFrom a
+ . typeValOf
+ )
instance Show PackedString where
showsPrec p ps r = showsPrec p (unpackPS ps) r
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString")
-- -----------------------------------------------------------------------------
import Data.Dynamic
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
-- |Mutate the contents of an 'STRef'
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Typeable
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- The Typeable class reifies types to some extent by associating type
+-- representations to types. These type representations can be compared,
+-- and one can in turn define a type-safe cast operation. To this end,
+-- an unsafe cast is guarded by a test for type (representation)
+-- equivalence. The module Data.Dynamic uses Typeable for an
+-- implementation of dynamics. The module Data.Generics uses Typeable
+-- and type-safe cast (but not dynamics) to support the "Scrap your
+-- boilerplate" style of generic programming.
+--
+-----------------------------------------------------------------------------
+
+module Data.Typeable
+ (
+
+ -- * The Typeable class
+ Typeable( typeOf ), -- :: a -> TypeRep
+
+ -- * Type-safe cast and other clients
+ cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
+ sameType, -- two type values are the same
+
+ -- * Type representations
+ TypeRep, -- abstract, instance of: Eq, Show, Typeable
+ TyCon, -- abstract, instance of: Eq, Show, Typeable
+
+ -- * Construction of type representations
+ mkTyCon, -- :: String -> TyCon
+ mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
+ mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
+ applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
+
+ --
+ -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
+ -- [fTy,fTy,fTy])
+ --
+ -- returns "(Foo,Foo,Foo)"
+ --
+ -- The TypeRep Show instance promises to print tuple types
+ -- correctly. Tuple type constructors are specified by a
+ -- sequence of commas, e.g., (mkTyCon ",,,,") returns
+ -- the 5-tuple tycon.
+
+ ) where
+
+
+import qualified Data.HashTable as HT
+import Data.Types
+import Data.Maybe
+import Data.Either
+import Data.Int
+import Data.Word
+import Data.List( foldl )
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Show
+import GHC.Err
+import GHC.Num
+import GHC.Float
+import GHC.Real( rem, Ratio )
+import GHC.IOBase
+import GHC.Ptr -- So we can give Typeable instance for Ptr
+import GHC.Stable -- So we can give Typeable instance for StablePtr
+#endif
+
+#ifdef __HUGS__
+import Hugs.Prelude
+import Hugs.IO
+import Hugs.IORef
+import Hugs.IOExts
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+unsafeCoerce :: a -> b
+unsafeCoerce = unsafeCoerce#
+#endif
+
+#ifdef __NHC__
+import NonStdUnsafeCoerce (unsafeCoerce)
+import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+#else
+#include "Typeable.h"
+#endif
+
+
+#ifndef __HUGS__
+-------------------------------------------------------------
+--
+-- Type representations
+--
+-------------------------------------------------------------
+
+-- | A concrete representation of a (monomorphic) type. 'TypeRep'
+-- supports reasonably efficient equality.
+data TypeRep = TypeRep !Key TyCon [TypeRep]
+
+-- Compare keys for equality
+instance Eq TypeRep where
+ (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
+
+-- | An abstract representation of a type constructor. 'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon !Key String
+
+instance Eq TyCon where
+ (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+
+#endif
+
+
+----------------- Construction --------------------
+
+-- | Applies a type constructor to a sequence of types
+mkAppTy :: TyCon -> [TypeRep] -> TypeRep
+mkAppTy tc@(TyCon tc_k _) args
+ = TypeRep (appKeys tc_k arg_ks) tc args
+ where
+ arg_ks = [k | TypeRep k _ _ <- args]
+
+funTc :: TyCon
+funTc = mkTyCon "->"
+
+-- | A special case of 'mkAppTy', which applies the function
+-- type constructor to a pair of types.
+mkFunTy :: TypeRep -> TypeRep -> TypeRep
+mkFunTy f a = mkAppTy funTc [f,a]
+
+-- | Applies a type to a function type. Returns: @'Just' u@ if the
+-- first argument represents a function of type @t -> u@ and the
+-- second argument represents a function of type @t@. Otherwise,
+-- returns 'Nothing'.
+applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
+applyTy (TypeRep _ tc [t1,t2]) t3
+ | tc == funTc && t1 == t3 = Just t2
+applyTy _ _ = Nothing
+
+-- If we enforce the restriction that there is only one
+-- @TyCon@ for a type & it is shared among all its uses,
+-- we can map them onto Ints very simply. The benefit is,
+-- of course, that @TyCon@s can then be compared efficiently.
+
+-- Provided the implementor of other @Typeable@ instances
+-- takes care of making all the @TyCon@s CAFs (toplevel constants),
+-- this will work.
+
+-- If this constraint does turn out to be a sore thumb, changing
+-- the Eq instance for TyCons is trivial.
+
+-- | Builds a 'TyCon' object representing a type constructor. An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- > mkTyCon "a" == mkTyCon "a"
+--
+
+mkTyCon :: String -- ^ the name of the type constructor (should be unique
+ -- in the program, so it might be wise to use the
+ -- fully qualified name).
+ -> TyCon -- ^ A unique 'TyCon' object
+mkTyCon str = TyCon (mkTyConKey str) str
+
+
+
+----------------- Showing TypeReps --------------------
+
+instance Show TypeRep where
+ showsPrec p (TypeRep _ tycon tys) =
+ case tys of
+ [] -> showsPrec p tycon
+ [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
+ [a,r] | tycon == funTc -> showParen (p > 8) $
+ showsPrec 9 a . showString " -> " . showsPrec 8 r
+ xs | isTupleTyCon tycon -> showTuple tycon xs
+ | otherwise ->
+ showParen (p > 9) $
+ showsPrec p tycon .
+ showChar ' ' .
+ showArgs tys
+
+instance Show TyCon where
+ showsPrec _ (TyCon _ s) = showString s
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ (',':_)) = True
+isTupleTyCon _ = False
+
+-- Some (Show.TypeRep) helpers:
+
+showArgs :: Show a => [a] -> ShowS
+showArgs [] = id
+showArgs [a] = showsPrec 10 a
+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
+
+showTuple :: TyCon -> [TypeRep] -> ShowS
+showTuple (TyCon _ str) args = showChar '(' . go str args
+ where
+ go [] [a] = showsPrec 10 a . showChar ')'
+ go _ [] = showChar ')' -- a failure condition, really.
+ go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
+ go _ _ = showChar ')'
+
+
+-------------------------------------------------------------
+--
+-- The Typeable class
+--
+-------------------------------------------------------------
+
+-- | The class 'Typeable' allows a concrete representation of a type to
+-- be calculated.
+class Typeable a where
+ typeOf :: a -> TypeRep
+ -- ^ Takes a value of type @a@ and returns a concrete representation
+ -- of that type. The /value/ of the argument should be ignored by
+ -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
+ -- the argument.
+
+
+-------------------------------------------------------------
+--
+-- Type-safe cast and other clients
+--
+-------------------------------------------------------------
+
+-- | The type-safe cast operation
+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
+
+
+-- | Test for type equivalence
+sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
+sameType (_::a->()) (_::b->()) = typeOf (undefined::a) ==
+ typeOf (undefined::b)
+
+
+-------------------------------------------------------------
+--
+-- Instances of the Typeable class for Prelude types
+--
+-------------------------------------------------------------
+
+listTc :: TyCon
+listTc = mkTyCon "[]"
+
+instance Typeable a => Typeable [a] where
+ typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
+ -- In GHC we can say
+ -- typeOf (undefined :: a)
+ -- using scoped type variables, but we use the
+ -- more verbose form here, for compatibility with Hugs
+
+unitTc :: TyCon
+unitTc = mkTyCon "()"
+
+instance Typeable () where
+ typeOf _ = mkAppTy unitTc []
+
+tup2Tc :: TyCon
+tup2Tc = mkTyCon ","
+
+instance (Typeable a, Typeable b) => Typeable (a,b) where
+ typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
+ typeOf ((undefined :: (a,b) -> b) tu)]
+
+tup3Tc :: TyCon
+tup3Tc = mkTyCon ",,"
+
+instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
+ typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
+ typeOf ((undefined :: (a,b,c) -> b) tu),
+ typeOf ((undefined :: (a,b,c) -> c) tu)]
+
+tup4Tc :: TyCon
+tup4Tc = mkTyCon ",,,"
+
+instance ( Typeable a
+ , Typeable b
+ , Typeable c
+ , Typeable d) => Typeable (a,b,c,d) where
+ typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
+ typeOf ((undefined :: (a,b,c,d) -> b) tu),
+ typeOf ((undefined :: (a,b,c,d) -> c) tu),
+ typeOf ((undefined :: (a,b,c,d) -> d) tu)]
+tup5Tc :: TyCon
+tup5Tc = mkTyCon ",,,,"
+
+instance ( Typeable a
+ , Typeable b
+ , Typeable c
+ , Typeable d
+ , Typeable e) => Typeable (a,b,c,d,e) where
+ typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
+
+instance (Typeable a, Typeable b) => Typeable (a -> b) where
+ typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
+ (typeOf ((undefined :: (a -> b) -> b) f))
+
+
+-------------------------------------------------------
+--
+-- Generate Typeable instances for standard datatypes
+--
+-------------------------------------------------------
+
+#ifndef __NHC__
+INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
+INSTANCE_TYPEABLE0(Char,charTc,"Char")
+INSTANCE_TYPEABLE0(Float,floatTc,"Float")
+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
+INSTANCE_TYPEABLE0(Int,intTc,"Int")
+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
+INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+
+INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
+
+INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
+
+INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
+#endif
+
+
+---------------------------------------------
+--
+-- Internals
+--
+---------------------------------------------
+
+#ifndef __HUGS__
+newtype Key = Key Int deriving( Eq )
+#endif
+
+data KeyPr = KeyPr !Key !Key deriving( Eq )
+
+hashKP :: KeyPr -> Int32
+hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
+
+data Cache = Cache { next_key :: !(IORef Key),
+ tc_tbl :: !(HT.HashTable String Key),
+ ap_tbl :: !(HT.HashTable KeyPr Key) }
+
+{-# NOINLINE cache #-}
+cache :: Cache
+cache = unsafePerformIO $ do
+ empty_tc_tbl <- HT.new (==) HT.hashString
+ empty_ap_tbl <- HT.new (==) hashKP
+ key_loc <- newIORef (Key 1)
+ return (Cache { next_key = key_loc,
+ tc_tbl = empty_tc_tbl,
+ ap_tbl = empty_ap_tbl })
+
+newKey :: IORef Key -> IO Key
+newKey kloc = do { k@(Key i) <- readIORef kloc ;
+ writeIORef kloc (Key (i+1)) ;
+ return k }
+
+mkTyConKey :: String -> Key
+mkTyConKey str
+ = unsafePerformIO $ do
+ let Cache {next_key = kloc, tc_tbl = tbl} = cache
+ mb_k <- HT.lookup tbl str
+ case mb_k of
+ Just k -> return k
+ Nothing -> do { k <- newKey kloc ;
+ HT.insert tbl str k ;
+ return k }
+
+appKey :: Key -> Key -> Key
+appKey k1 k2
+ = unsafePerformIO $ do
+ let Cache {next_key = kloc, ap_tbl = tbl} = cache
+ mb_k <- HT.lookup tbl kpr
+ case mb_k of
+ Just k -> return k
+ Nothing -> do { k <- newKey kloc ;
+ HT.insert tbl kpr k ;
+ return k }
+ where
+ kpr = KeyPr k1 k2
+
+appKeys :: Key -> [Key] -> Key
+appKeys k ks = foldl appKey k ks
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Types
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- This module provides a style of encoding types as values and using
+-- them. This style is seens as an alternative to the pragmatic style
+-- used in Data.Typeable and elsewhere, i.e., simply use an undefined
+-- to denote a type argument. This pragmatic style suffers from lack
+-- of robustness: one fells tempted to pattern match on undefineds.
+--
+-----------------------------------------------------------------------------
+
+module Data.Types
+ (
+
+ -- * 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
+ TypeFun -- functions on types
+
+ ) where
+
+
+-------------------------------------------------------------
+--
+-- Types as values
+--
+-------------------------------------------------------------
+
+
+-- 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
+
+
+-- Type functions,
+-- i.e., functions mapping types to values
+--
+type TypeFun a r = TypeVal a -> r
import Foreign.Ptr
#endif
-#include "Dynamic.h"
+#include "Typeable.h"
#include "CTypes.h"
INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR)
import Foreign.Ptr
#endif
-#include "Dynamic.h"
+#include "Typeable.h"
#include "CTypes.h"
INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T)
import Foreign.Marshal.Alloc ( malloc, mallocBytes, finalizerFree )
import Data.Dynamic
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
instance Eq (ForeignPtr a) where
instance Show (ForeignPtr a) where
showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
-- |A Finaliser is represented as a pointer to a foreign function that, at
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.44 2003/07/23 15:39:54 simonmar Exp $
+# $Id: Makefile,v 1.45 2003/07/24 12:19:57 ralf Exp $
TOP=..
include $(TOP)/mk/boilerplate.mk
Control/Monad \
Control/Monad/ST \
Data \
+ Data/Generics \
Data/Array \
Data/Array/IO \
Data/STRef \
#endif /* __GLASGOW_HASKELL__ */
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE1(StableName,stableNameTc,"StableName")
mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
-#include "Dynamic.h"
+#include "Typeable.h"
INSTANCE_TYPEABLE1(Weak,weakTc,"Weak")
{- $precise
import Control.Monad
#endif
-#include "Dynamic.h"
+#include "Typeable.h"
#include "CTypes.h"
NUMERIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T)
-/* -----------------------------------------------------------------------------
- * $Id: Dynamic.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
- *
+/* ----------------------------------------------------------------------------
* Macros to help make Typeable instances.
* -------------------------------------------------------------------------- */
projects / haskell-directory.git / commitdiff