From 7856e250aa3e7afc027491b02b015789a90c7f28 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Mon, 29 Jan 2007 03:14:51 +0000 Subject: [PATCH] Remove AltData, yay. --- src/AltData/Dynamic.hs | 162 ------- src/AltData/Typeable.hs | 960 ------------------------------------- src/System/Eval/Haskell.hs | 2 +- 3 files changed, 1 insertion(+), 1123 deletions(-) delete mode 100644 src/AltData/Dynamic.hs delete mode 100644 src/AltData/Typeable.hs diff --git a/src/AltData/Dynamic.hs b/src/AltData/Dynamic.hs deleted file mode 100644 index 0c65aa4..0000000 --- a/src/AltData/Dynamic.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} --- --- | --- Module : Data.Dynamic --- 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 Dynamic interface provides basic support for dynamic types. --- --- Operations for injecting values of arbitrary type into --- a dynamically typed value, Dynamic, are provided, together --- with operations for converting dynamic values into a concrete --- (monomorphic) type. --- ------------------------------------------------------------------------------ - -module AltData.Dynamic ( - - -- Module Data.Typeable re-exported for convenience - module AltData.Typeable, - - -- * The @Dynamic@ type - Dynamic, -- abstract, instance of: Show, Typeable - - -- * Converting to and from @Dynamic@ - toDyn, -- :: Typeable a => a -> Dynamic - fromDyn, -- :: Typeable a => Dynamic -> a -> a - fromDynamic, -- :: Typeable a => Dynamic -> Maybe a - -#if __GLASGOW_HASKELL__ >= 603 - -- * Applying functions of dynamic type - dynApply, - dynApp, - dynTypeRep - -#endif - ) where - -import AltData.Typeable -import Data.Maybe - -import System.IO.Unsafe (unsafePerformIO) - -import GHC.Base -import GHC.Show -#if __GLASGOW_HASKELL__ >= 603 -import GHC.Err -#endif - -unsafeCoerce :: a -> b -unsafeCoerce = unsafeCoerce# - -------------------------------------------------------------- --- --- The type Dynamic --- -------------------------------------------------------------- - -{-| - A value of type 'Dynamic' is an object encapsulated together with its type. - - A 'Dynamic' may only represent a monomorphic value; an attempt to - create a value of type 'Dynamic' from a polymorphically-typed - expression will result in an ambiguity error (see 'toDyn'). - - 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation - of the object\'s type; useful for debugging. --} -data Dynamic = Dynamic TypeRep Obj - -instance Typeable Dynamic where -#if __GLASGOW_HASKELL__ >= 603 - typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") [] -#else - typeOf _ = mkAppTy (mkTyCon "AltData.Dynamic") [] -#endif - -instance Show Dynamic where - -- the instance just prints the type representation. - showsPrec _ (Dynamic t _) = - showString "<<" . - showsPrec 0 t . - showString ">>" - -type Obj = forall a . a - -- Dummy 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 - -- a fallback convention for evaluating it that works for all types. - -- (using a function type here would also work). - --- | Converts an arbitrary value into an object of type 'Dynamic'. --- --- The type of the object must be an instance of 'Typeable', which --- ensures that only monomorphically-typed objects may be converted to --- 'Dynamic'. To convert a polymorphic object into 'Dynamic', give it --- a monomorphic type signature. For example: --- --- > toDyn (id :: Int -> Int) --- -toDyn :: Typeable a => a -> Dynamic -toDyn v = Dynamic (typeOf v) (unsafeCoerce v) - --- | Converts a 'Dynamic' object back into an ordinary Haskell value of --- the correct type. See also 'fromDynamic'. -fromDyn :: Typeable a - => Dynamic -- ^ the dynamically-typed object - -> a -- ^ a default value - -> a -- ^ returns: the value of the first argument, if - -- it has the correct type, otherwise the value of - -- the second argument. -fromDyn (Dynamic t v) def - | typeOf def == t = unsafeCoerce v - | otherwise = def - --- | Converts a 'Dynamic' object back into an ordinary Haskell value of --- the correct type. See also 'fromDyn'. -fromDynamic - :: Typeable a - => Dynamic -- ^ the dynamically-typed object - -> 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) = - case unsafeCoerce v of - r | t == typeOf r -> Just r - | otherwise -> unsafePerformIO (putStrLn $ - "Couldn't match `" ++show(typeOf r) ++ - "' against `" ++show t ++"'"++ - "\n\tExpected type: " ++show(typeOf r) ++ - "\n\tInferred type: " ++show t - ) `seq` Nothing - -#if __GLASGOW_HASKELL__ >= 603 - --- (f::(a->b)) `dynApply` (x::a) = (f a)::b -dynApply :: Dynamic -> Dynamic -> Maybe Dynamic -dynApply (Dynamic t1 f) (Dynamic t2 x) = - case funResultTy t1 t2 of - Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) - Nothing -> Nothing - - -dynApp :: Dynamic -> Dynamic -> Dynamic -dynApp f x = case dynApply f x of - Just r -> r - Nothing -> error ("Type error in dynamic application.\n" ++ - "Can't apply function " ++ show f ++ - " to argument " ++ show x) - -dynTypeRep :: Dynamic -> TypeRep -dynTypeRep (Dynamic tr _) = tr - -#endif diff --git a/src/AltData/Typeable.hs b/src/AltData/Typeable.hs deleted file mode 100644 index d7e4a58..0000000 --- a/src/AltData/Typeable.hs +++ /dev/null @@ -1,960 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} --- --- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 --- USA --- - --- Based on: --- --- | --- Module : Data.Typeable --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : 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 AltData.Typeable - -#if __GLASGOW_HASKELL__ >= 603 - ( - - -- * The Typeable class - Typeable( typeOf ), -- :: a -> TypeRep - - -- * Type-safe cast - cast, -- :: (Typeable a, Typeable b) => a -> Maybe b - gcast, -- a generalisation of cast - - -- * Type representations - TypeRep, -- abstract, instance of: Eq, Show, Typeable - TyCon, -- abstract, instance of: Eq, Show, Typeable - - -- * Construction of type representations - mkTyCon, -- :: String -> TyCon - mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep - mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep - mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep - - -- * Observation of type representations - splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) - funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep - typeRepTyCon, -- :: TypeRep -> TyCon - typeRepArgs, -- :: TypeRep -> [TypeRep] - tyConString, -- :: TyCon -> String - - -- * The other Typeable classes - -- | /Note:/ The general instances are provided for GHC only. - Typeable1( typeOf1 ), -- :: t a -> TypeRep - Typeable2( typeOf2 ), -- :: t a b -> TypeRep - Typeable3( typeOf3 ), -- :: t a b c -> TypeRep - Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep - Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep - Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep - Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep - gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) - gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) - - -- * Default instances - -- | /Note:/ These are not needed by GHC, for which these instances - -- are generated by general instance declarations. - typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep - typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep - typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep - typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep - typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep - typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep - typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep - - ) where - -import qualified Data.HashTable as HT -import Data.Maybe -import Data.Either -import Data.Int -import Data.Word -import Data.List( foldl ) - -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 - -unsafeCoerce :: a -> b -unsafeCoerce = unsafeCoerce# - -#include "Typeable.h" - -------------------------------------------------------------- --- --- Type representations --- -------------------------------------------------------------- - --- | A concrete representation of a (monomorphic) type. 'TypeRep' --- supports reasonably efficient equality. --- --- equality of keys doesn't work for dynamically loaded code, so we --- revert back to canonical type names. --- --- could use packed strings here. --- -data TypeRep = TypeRep !Key TyCon [TypeRep] - --- Compare keys for equality -instance Eq TypeRep where - (TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 - --- | An abstract representation of a type constructor. 'TyCon' objects can --- be built using 'mkTyCon'. -data TyCon = TyCon !Key String - -instance Eq TyCon where - (TyCon _ s1) == (TyCon _ s2) = s1 == s2 - - -- - -- let fTy = mkTyCon "Foo" in show (mkTyConApp (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. - ------------------ Construction -------------------- - --- | Applies a type constructor to a sequence of types -mkTyConApp :: TyCon -> [TypeRep] -> TypeRep -mkTyConApp tc@(TyCon tc_k _) args - = TypeRep (appKeys tc_k arg_ks) tc args - where - arg_ks = [k | TypeRep k _ _ <- args] - --- | A special case of 'mkTyConApp', which applies the function --- type constructor to a pair of types. -mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkTyConApp funTc [f,a] - --- | Splits a type constructor application -splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) -splitTyConApp (TypeRep _ tc trs) = (tc,trs) - --- | 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'. -funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep -funResultTy trFun trArg - = case splitTyConApp trFun of - (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 - _ -> Nothing - --- | Adds a TypeRep argument to a TypeRep. -mkAppTy :: TypeRep -> TypeRep -> TypeRep -mkAppTy (TypeRep tr_k tc trs) arg_tr - = let (TypeRep arg_k _ _) = arg_tr - in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) - --- 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 - ------------------ Observation --------------------- - --- | Observe the type constructor of a type representation -typeRepTyCon :: TypeRep -> TyCon -typeRepTyCon (TypeRep _ tc _) = tc - --- | Observe the argument types of a type representation -typeRepArgs :: TypeRep -> [TypeRep] -typeRepArgs (TypeRep _ _ args) = args - --- | Observe string encoding of a type representation -tyConString :: TyCon -> String -tyConString (TyCon _ 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 friends --- -------------------------------------------------------------- - --- | 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. - --- | Variant for unary type constructors -class Typeable1 t where - typeOf1 :: t a -> TypeRep - --- | For defining a 'Typeable' instance from any 'Typeable1' instance. -typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep -typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) - where - argType :: t a -> a - argType = undefined - --- | Variant for binary type constructors -class Typeable2 t where - typeOf2 :: t a b -> TypeRep - --- | For defining a 'Typeable1' instance from any 'Typeable2' instance. -typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep -typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) - where - argType :: t a b -> a - argType = undefined - --- | Variant for 3-ary type constructors -class Typeable3 t where - typeOf3 :: t a b c -> TypeRep - --- | For defining a 'Typeable2' instance from any 'Typeable3' instance. -typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep -typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c -> a - argType = undefined - --- | Variant for 4-ary type constructors -class Typeable4 t where - typeOf4 :: t a b c d -> TypeRep - --- | For defining a 'Typeable3' instance from any 'Typeable4' instance. -typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep -typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d -> a - argType = undefined - --- | Variant for 5-ary type constructors -class Typeable5 t where - typeOf5 :: t a b c d e -> TypeRep - --- | For defining a 'Typeable4' instance from any 'Typeable5' instance. -typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep -typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e -> a - argType = undefined - --- | Variant for 6-ary type constructors -class Typeable6 t where - typeOf6 :: t a b c d e f -> TypeRep - --- | For defining a 'Typeable5' instance from any 'Typeable6' instance. -typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep -typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e f -> a - argType = undefined - --- | Variant for 7-ary type constructors -class Typeable7 t where - typeOf7 :: t a b c d e f g -> TypeRep - --- | For defining a 'Typeable6' instance from any 'Typeable7' instance. -typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep -typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e f g -> a - argType = undefined - --- Given a @Typeable@/n/ instance for an /n/-ary type constructor, --- define the instances for partial applications. --- Programmers using non-GHC implementations must do this manually --- for each type constructor. --- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.) - --- | One Typeable instance for all Typeable1 instances -instance (Typeable1 s, Typeable a) - => Typeable (s a) where - typeOf = typeOfDefault - --- | One Typeable1 instance for all Typeable2 instances -instance (Typeable2 s, Typeable a) - => Typeable1 (s a) where - typeOf1 = typeOf1Default - --- | One Typeable2 instance for all Typeable3 instances -instance (Typeable3 s, Typeable a) - => Typeable2 (s a) where - typeOf2 = typeOf2Default - --- | One Typeable3 instance for all Typeable4 instances -instance (Typeable4 s, Typeable a) - => Typeable3 (s a) where - typeOf3 = typeOf3Default - --- | One Typeable4 instance for all Typeable5 instances -instance (Typeable5 s, Typeable a) - => Typeable4 (s a) where - typeOf4 = typeOf4Default - --- | One Typeable5 instance for all Typeable6 instances -instance (Typeable6 s, Typeable a) - => Typeable5 (s a) where - typeOf5 = typeOf5Default - --- | One Typeable6 instance for all Typeable7 instances -instance (Typeable7 s, Typeable a) - => Typeable6 (s a) where - typeOf6 = typeOf6Default - -------------------------------------------------------------- --- --- 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 - --- | A flexible variation parameterised in a type constructor -gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) -gcast x = r - where - r = if typeOf (getArg x) == typeOf (getArg (fromJust r)) - then Just $ unsafeCoerce x - else Nothing - getArg :: c x -> x - getArg = undefined - --- | Cast for * -> * -gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) -gcast1 x = r - where - r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r)) - then Just $ unsafeCoerce x - else Nothing - getArg :: c x -> x - getArg = undefined - --- | Cast for * -> * -> * -gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) -gcast2 x = r - where - r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r)) - then Just $ unsafeCoerce x - else Nothing - getArg :: c x -> x - getArg = undefined - -------------------------------------------------------------- --- --- Instances of the Typeable classes for Prelude types --- -------------------------------------------------------------- - -INSTANCE_TYPEABLE1([],listTc,"[]") -INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") -INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") -INSTANCE_TYPEABLE2(Either,eitherTc,"Either") -INSTANCE_TYPEABLE2((->),funTc,"->") -INSTANCE_TYPEABLE1(IO,ioTc,"IO") -INSTANCE_TYPEABLE0((),unitTc,"()") - -INSTANCE_TYPEABLE2((,),pairTc,",") -INSTANCE_TYPEABLE3((,,),tup3Tc,",,") - -tup4Tc :: TyCon -tup4Tc = mkTyCon ",,," - -instance Typeable4 (,,,) where - typeOf4 _ = mkTyConApp tup4Tc [] - -tup5Tc :: TyCon -tup5Tc = mkTyCon ",,,," - -instance Typeable5 (,,,,) where - typeOf5 _ = mkTyConApp tup5Tc [] - -tup6Tc :: TyCon -tup6Tc = mkTyCon ",,,,," - -instance Typeable6 (,,,,,) where - typeOf6 _ = mkTyConApp tup6Tc [] - -tup7Tc :: TyCon -tup7Tc = mkTyCon ",,,,," - -instance Typeable7 (,,,,,,) where - typeOf7 _ = mkTyConApp tup7Tc [] - -INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr") -INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr") -INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef") - -------------------------------------------------------- --- --- Generate Typeable instances for standard datatypes --- -------------------------------------------------------- - -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_TYPEABLE0(Ordering,orderingTc,"Ordering") -INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") - -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(Word,wordTc,"Word" ) - -#else /* GHC < 6.3 */ - - ( - -- * The Typeable class - Typeable( typeOf ), -- :: a -> TypeRep - - -- * Type-safe cast - cast, -- :: (Typeable a, Typeable b) => a -> Maybe b - castss, -- a cast for kind "* -> *" - castarr, -- another convenient variation - - -- * 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 - - -- * Observation of type representations - typerepTyCon, -- :: TypeRep -> TyCon - typerepArgs, -- :: TypeRep -> [TypeRep] - tyconString -- :: TyCon -> String - - - ) where - -import qualified Data.HashTable as HT -import Data.Maybe -import Data.Either -import Data.Int -import Data.Word -import Data.List( foldl ) - -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 - -unsafeCoerce :: a -> b -unsafeCoerce = unsafeCoerce# - -#include "Typeable.h" - - -------------------------------------------------------------- --- --- 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 _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2 - --- | An abstract representation of a type constructor. 'TyCon' objects can --- be built using 'mkTyCon'. -data TyCon = TyCon !Key String - -instance Eq TyCon where - (TyCon _ s1) == (TyCon _ s2) = s1 == s2 - - -- - -- 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. - ------------------ 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 - - - ------------------ Observation --------------------- - - --- | Observe the type constructor of a type representation -typerepTyCon :: TypeRep -> TyCon -typerepTyCon (TypeRep _ tc _) = tc - - --- | Observe the argument types of a type representation -typerepArgs :: TypeRep -> [TypeRep] -typerepArgs (TypeRep _ _ args) = args - - --- | Observe string encoding of a type representation -tyconString :: TyCon -> String -tyconString (TyCon _ 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 --- -------------------------------------------------------------- - --- | 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 - - --- | A convenient variation for kind "* -> *" -castss :: (Typeable a, Typeable b) => t a -> Maybe (t b) -castss x = r - where - r = if typeOf (get x) == typeOf (get (fromJust r)) - then Just $ unsafeCoerce x - else Nothing - get :: t c -> c - get = undefined - - --- | Another variation -castarr :: (Typeable a, Typeable b, Typeable c, Typeable d) - => (a -> t b) -> Maybe (c -> t d) -castarr x = r - where - r = if typeOf (get x) == typeOf (get (fromJust r)) - then Just $ unsafeCoerce x - else Nothing - get :: (e -> t f) -> (e, f) - get = undefined - -{- - -The variations castss and castarr are arguably not really needed. -Let's discuss castss in some detail. To get rid of castss, we can -require "Typeable (t a)" and "Typeable (t b)" rather than just -"Typeable a" and "Typeable b". In that case, the ordinary cast would -work. Eventually, all kinds of library instances should become -Typeable. (There is another potential use of variations as those given -above. It allows quantification on type constructors. - --} - - -------------------------------------------------------------- --- --- 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 --- -------------------------------------------------------- - -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 /* GHC < 6.3 */ - - ---------------------------------------------- --- --- Internals --- ---------------------------------------------- - -newtype Key = Key Int deriving( Eq ) - -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 _ = do i <- genSym; return (Key i) - - --- In GHC we use the RTS's genSym function to get a new unique, --- because in GHCi we might have two copies of the Data.Typeable --- library running (one in the compiler and one in the running --- program), and we need to make sure they don't share any keys. --- --- This is really a hack. A better solution would be to centralise the --- whole mutable state used by this module, i.e. both hashtables. But --- the current solution solves the immediate problem, which is that --- dynamics generated in one world with one type were erroneously --- being recognised by the other world as having a different type. --- --- dons: SimonM says we need to unify the hashes by storing them in a --- variable in the rts. --- -foreign import ccall unsafe "genSymZh" - genSym :: IO Int - -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 diff --git a/src/System/Eval/Haskell.hs b/src/System/Eval/Haskell.hs index 55f9144..a6c3ec2 100644 --- a/src/System/Eval/Haskell.hs +++ b/src/System/Eval/Haskell.hs @@ -237,7 +237,7 @@ dynwrap :: String -> String -> [Import] -> String dynwrap expr nm mods = "module "++nm++ "( resource ) where\n" ++ concatMap (\m-> "import "++m++"\n") mods ++ - "import AltData.Dynamic\n" ++ + "import Data.Dynamic\n" ++ "resource = let { "++x++" = \n" ++ "{-# LINE 1 \"\" #-}\n" ++ expr ++ ";} in toDyn "++x where