-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Typeable
--- Copyright : (c) The University of Glasgow 2001
+-- 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
+-- 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.
+-- 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.
+--
+-- Note, only relevant if you use dynamic linking. If you have a program
+-- that is statically linked with Data.Typeable, and then dynamically link
+-- a program that also uses Data.Typeable, you'll get two copies of the module.
+-- That's fine, but behind the scenes, the module uses a mutable variable to
+-- allocate unique Ids to type constructors. So in the situation described,
+-- there'll be two separate Id allocators, which aren't comparable to each other.
+-- This can lead to chaos. (It's a bug that we will fix.) None of
+-- this matters if you aren't using dynamic linking.
--
-----------------------------------------------------------------------------
-- * The Typeable class
Typeable( typeOf ), -- :: a -> TypeRep
- -- * Type-safe cast and other clients
+ -- * Type-safe cast
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
- sameType, -- two type values are the same
+ gcast, -- a generalisation of cast
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
-- * Construction of type representations
mkTyCon, -- :: String -> TyCon
- mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
+ mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep
+ mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
- applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
-
- -- * Types as values
- TypeVal, -- view type "a" as "a -> ()"
- typeVal, -- :: TypeVal a
- typeValOf, -- :: a -> TypeVal a
- undefinedType, -- :: TypeVal a -> a
- withType, -- :: a -> TypeVal a -> a
- argType, -- :: (a -> b) -> TypeVal a
- resType, -- :: (a -> b) -> TypeVal b
- paraType, -- :: t a -> TypeVal a
- TypeFun -- functions on types
- ) where
+ -- * 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 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
+import GHC.Real ( rem, Ratio )
+import GHC.IOBase (IORef,newIORef,unsafePerformIO)
+
+-- These imports are so we can define Typeable instances
+-- It'd be better to give Typeable instances in the modules themselves
+-- but they all have to be compiled before Typeable
+import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException,
+ ArrayException, AsyncException, Handle )
+import GHC.ST ( ST )
+import GHC.STRef ( STRef )
+import GHC.Ptr ( Ptr, FunPtr )
+import GHC.ForeignPtr ( ForeignPtr )
+import GHC.Stable ( StablePtr )
+import GHC.Arr ( Array, STArray )
+
#endif
#ifdef __HUGS__
import Hugs.IO
import Hugs.IORef
import Hugs.IOExts
+ -- For the Typeable instance
+import Hugs.Array ( Array )
+import Hugs.ConcBase ( MVar )
#endif
#ifdef __GLASGOW_HASKELL__
#ifdef __NHC__
import NonStdUnsafeCoerce (unsafeCoerce)
import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
-#else
-#include "Typeable.h"
+import IO (Handle)
+import Ratio (Ratio)
+ -- For the Typeable instance
+import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr )
+import Array ( Array )
#endif
+#include "Typeable.h"
#ifndef __HUGS__
+
-------------------------------------------------------------
--
-- Type representations
--
-------------------------------------------------------------
-
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
data TypeRep = TypeRep !Key TyCon [TypeRep]
#endif
--
- -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
+ -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
-- [fTy,fTy,fTy])
--
-- returns "(Foo,Foo,Foo)"
----------------- Construction --------------------
-- | Applies a type constructor to a sequence of types
-mkAppTy :: TyCon -> [TypeRep] -> TypeRep
-mkAppTy tc@(TyCon tc_k _) args
+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]
-funTc :: TyCon
-funTc = mkTyCon "->"
-
--- | A special case of 'mkAppTy', which applies the function
+-- | A special case of 'mkTyConApp', which applies the function
-- type constructor to a pair of types.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkAppTy funTc [f,a]
+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'.
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-applyTy (TypeRep _ tc [t1,t2]) t3
- | tc == funTc && t1 == t3 = Just t2
-applyTy _ _ = 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,
-> 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 --------------------
[] -> showsPrec p tycon
[x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
[a,r] | tycon == funTc -> showParen (p > 8) $
- showsPrec 9 a . showString " -> " . showsPrec 8 r
+ showsPrec 9 a .
+ showString " -> " .
+ showsPrec 8 r
xs | isTupleTyCon tycon -> showTuple tycon xs
| otherwise ->
showParen (p > 9) $
go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
go _ _ = showChar ')'
-
-------------------------------------------------------------
--
--- The Typeable class
+-- The Typeable class and friends
--
-------------------------------------------------------------
-- 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
--------------------------------------------------------------
---
--- 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 tva tvb = typeOf (undefinedType tva) ==
- typeOf (undefinedType tvb)
-
+-- | 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
--------------------------------------------------------------
---
--- Instances of the Typeable class for Prelude types
---
--------------------------------------------------------------
+-- | Variant for binary type constructors
+class Typeable2 t where
+ typeOf2 :: t a b -> TypeRep
-listTc :: TyCon
-listTc = mkTyCon "[]"
+-- | 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
-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
+-- | Variant for 3-ary type constructors
+class Typeable3 t where
+ typeOf3 :: t a b c -> TypeRep
-unitTc :: TyCon
-unitTc = mkTyCon "()"
+-- | 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
-instance Typeable () where
- typeOf _ = mkAppTy unitTc []
+-- | Variant for 4-ary type constructors
+class Typeable4 t where
+ typeOf4 :: t a b c d -> TypeRep
-tup2Tc :: TyCon
-tup2Tc = mkTyCon ","
+-- | 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
-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)]
+-- | Variant for 5-ary type constructors
+class Typeable5 t where
+ typeOf5 :: t a b c d e -> TypeRep
-tup3Tc :: TyCon
-tup3Tc = mkTyCon ",,"
+-- | 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
-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)]
+-- | Variant for 6-ary type constructors
+class Typeable6 t where
+ typeOf6 :: t a b c d e f -> TypeRep
-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 ",,,,"
+-- | 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
-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)]
+-- | Variant for 7-ary type constructors
+class Typeable7 t where
+ typeOf7 :: t a b c d e f g -> TypeRep
-instance (Typeable a, Typeable b) => Typeable (a -> b) where
- typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
- (typeOf ((undefined :: (a -> b) -> b) f))
+-- | 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
+#ifdef __GLASGOW_HASKELL__
+-- 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
+
+#endif /* __GLASGOW_HASKELL__ */
-------------------------------------------------------------
--
--- Types as values
+-- Type-safe cast
--
-------------------------------------------------------------
-{-
-
-This group provides a style of encoding types as values and using
-them. This style is seen as an alternative to the pragmatic style used
-in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"
-to denote a type argument. This pragmatic style suffers from lack
-of robustness: one feels tempted to pattern match on undefineds.
-Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.
-
--}
-
-
--- | Type as values to stipulate use of undefineds
-type TypeVal a = a -> ()
-
-
--- | The value that denotes a type
-typeVal :: TypeVal a
-typeVal = const ()
+-- | 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
--- | Map a value to its type
-typeValOf :: a -> TypeVal a
-typeValOf _ = typeVal
+-------------------------------------------------------------
+--
+-- Instances of the Typeable classes for Prelude types
+--
+-------------------------------------------------------------
+INSTANCE_TYPEABLE0((),unitTc,"()")
+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")
--- | Stipulate this idiom!
-undefinedType :: TypeVal a -> a
-undefinedType _ = undefined
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+-- Types defined in GHC.IOBase
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
+INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
+INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
+INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
+INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
+#endif
+-- Types defined in GHC.Arr
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
--- | Constrain a type
-withType :: a -> TypeVal a -> a
-withType x _ = x
+#ifdef __GLASGOW_HASKELL__
+-- Hugs has these too, but their Typeable<n> instances are defined
+-- elsewhere to keep this module within Haskell 98.
+-- This is important because every invocation of runhugs or ffihugs
+-- uses this module via Data.Dynamic.
+INSTANCE_TYPEABLE2(ST,stTc,"ST")
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
+#endif
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,",")
+INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
--- | The argument type of a function
-argType :: (a -> b) -> TypeVal a
-argType _ = typeVal
+tup4Tc :: TyCon
+tup4Tc = mkTyCon ",,,"
+instance Typeable4 (,,,) where
+ typeOf4 tu = mkTyConApp tup4Tc []
--- | The result type of a function
-resType :: (a -> b) -> TypeVal b
-resType _ = typeVal
+tup5Tc :: TyCon
+tup5Tc = mkTyCon ",,,,"
+instance Typeable5 (,,,,) where
+ typeOf5 tu = mkTyConApp tup5Tc []
--- | The parameter type of type constructor
-paraType :: t a -> TypeVal a
-paraType _ = typeVal
+tup6Tc :: TyCon
+tup6Tc = mkTyCon ",,,,,"
+instance Typeable6 (,,,,,) where
+ typeOf6 tu = mkTyConApp tup6Tc []
--- Type functions,
--- i.e., functions mapping types to values
---
-type TypeFun a r = TypeVal a -> r
+tup7Tc :: TyCon
+tup7Tc = mkTyCon ",,,,,,"
+instance Typeable7 (,,,,,,) where
+ typeOf7 tu = mkTyConApp tup7Tc []
+#endif /* __NHC__ */
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-------------------------------------------------------
--
--
-------------------------------------------------------
-#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")
+#ifndef __NHC__
+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+#endif
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(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
+#ifdef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
#endif
-
---------------------------------------------
--
-- Internals
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),
+data Cache = Cache { next_key :: !(IORef Key), -- Not used by GHC (calls genSym instead)
tc_tbl :: !(HT.HashTable String Key),
ap_tbl :: !(HT.HashTable KeyPr Key) }
ap_tbl = empty_ap_tbl })
newKey :: IORef Key -> IO Key
+#ifdef __GLASGOW_HASKELL__
+newKey kloc = do i <- genSym; return (Key i)
+#else
newKey kloc = do { k@(Key i) <- readIORef kloc ;
writeIORef kloc (Key (i+1)) ;
return k }
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+-- 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.
+foreign import ccall unsafe "genSymZh"
+ genSym :: IO Int
+#endif
mkTyConKey :: String -> Key
mkTyConKey str
projects / ghc-base.git / blobdiff