X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FDynamic.hs;h=761f55f150679140c66eed315cb9330d4483c5c8;hb=6b1a36a595eddf1e124529646afdb75c76a9966d;hp=1c13873b8b5f85193d0f7077543f58ee32b30330;hpb=674a63cc5d56510d79ca46dce381af01f64cb2b9;p=haskell-directory.git diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index 1c13873..761f55f 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS_GHC -fno-implicit-prelude #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic @@ -20,6 +20,10 @@ module Data.Dynamic ( + + -- Module Data.Typeable re-exported for convenience + module Data.Typeable, + -- * The @Dynamic@ type Dynamic, -- abstract, instance of: Show, Typeable @@ -31,51 +35,19 @@ module Data.Dynamic -- * Applying functions of dynamic type dynApply, dynApp, + dynTypeRep - -- * Concrete Type Representations - - -- | This section is useful if you need to define your own - -- instances of 'Typeable'. - - Typeable( typeOf ), -- :: a -> TypeRep - - -- ** Building concrete type representations - TypeRep, -- abstract, instance of: Eq, Show, Typeable - TyCon, -- abstract, instance of: Eq, Show, Typeable - - 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 + ) where +import Data.Typeable import Data.Maybe -import Data.Either -import Data.Int -import Data.Word -import Foreign.Ptr -import Foreign.StablePtr #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Show import GHC.Err import GHC.Num -import GHC.Float -import GHC.IOBase -import GHC.List( lookup, foldl ) #endif #ifdef __HUGS__ @@ -93,10 +65,10 @@ unsafeCoerce = unsafeCoerce# #ifdef __NHC__ import NonStdUnsafeCoerce (unsafeCoerce) import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO) -#else -#include "Dynamic.h" #endif +#include "Typeable.h" + ------------------------------------------------------------- -- -- The type Dynamic @@ -117,6 +89,8 @@ import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO) data Dynamic = Dynamic TypeRep Obj #endif +INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic") + instance Show Dynamic where -- the instance just prints the type representation. showsPrec _ (Dynamic t _) = @@ -125,16 +99,14 @@ instance Show Dynamic where showString ">>" #ifdef __GLASGOW_HASKELL__ -type Obj = forall a . a - -- Dummy type to hold the dynamically typed value. +type Obj = Any + -- Use GHC's primitive 'Any' type to hold the dynamically typed value. -- - -- In GHC's new eval/apply execution model this type must - -- be polymorphic. It can't be a constructor, because then - -- GHC will use the constructor convention when evaluating it, - -- and this will go wrong if the object is really a function. On - -- the other hand, if we use a polymorphic type, GHC will use + -- In GHC's new eval/apply execution model this type must not look + -- like a data type. If it did, GHC would use the constructor convention + -- when evaluating it, and this will go wrong if the object is really a + -- function. Using Any forces GHC to use -- a fallback convention for evaluating it that works for all types. - -- (using a function type here would also work). #elif !defined(__HUGS__) data Obj = Obj #endif @@ -168,7 +140,7 @@ fromDyn (Dynamic t v) def fromDynamic :: Typeable a => Dynamic -- ^ the dynamically-typed object - -> Maybe a -- ^ returns: @'Just' a@, if the dyanmically-typed + -> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed -- object has the correct type (and @a@ is its value), -- or 'Nothing' otherwise. fromDynamic (Dynamic t v) = @@ -179,7 +151,7 @@ fromDynamic (Dynamic t v) = -- (f::(a->b)) `dynApply` (x::a) = (f a)::b dynApply :: Dynamic -> Dynamic -> Maybe Dynamic dynApply (Dynamic t1 f) (Dynamic t2 x) = - case applyTy t1 t2 of + case funResultTy t1 t2 of Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) Nothing -> Nothing @@ -190,260 +162,5 @@ dynApp f x = case dynApply f x of "Can't apply function " ++ show f ++ " to argument " ++ show x) -------------------------------------------------------------- --- --- Type representations --- -------------------------------------------------------------- - --- | A concrete representation of a (monomorphic) type. 'TypeRep' --- supports reasonably efficient equality. -#ifndef __HUGS__ -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 - -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 - --- 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" --- --- NOTE: GHC\'s implementation is quite hacky, and the above equation --- does not necessarily hold. For defining your own instances of --- 'Typeable', try to ensure that only one call to 'mkTyCon' exists --- for each type constructor (put it at the top level, and annotate the --- corresponding definition with a @NOINLINE@ pragma). -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 - --- 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 ')' - - --- | 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] - --- Auxillary functions - --- | 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 - - -------------------------------------------------------------- --- --- 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 --- ---------------------------------------------- - -newtype Key = Key Int deriving( Eq ) - -appKeys :: Key -> [Key] -> Key -appKeys k ks = foldl appKey k ks - -appKey :: Key -> Key -> Key -appKey (Key k1) (Key k2) - = unsafePerformIO $ do - (v, cache) <- readIORef memo - case lookup (k1,k2) cache of - Just k -> return (Key k) - Nothing -> do writeIORef memo (v+1, ((k1,k2),v) : cache) - return (Key v) - -memo :: IORef (Int, [((Int,Int),Int)]) -memo = unsafePerformIO (newIORef (1000, [])) - -- 1000, yuk! - -mkTyConKey :: String -> Key -mkTyConKey str = unsafePerformIO $ do - v <- readIORef uni - writeIORef uni (v+1) - return (str `seq` Key v) - -{-# NOINLINE uni #-} -uni :: IORef Int -uni = unsafePerformIO ( newIORef 0 ) +dynTypeRep :: Dynamic -> TypeRep +dynTypeRep (Dynamic tr _) = tr