-{-# OPTIONS -fno-implicit-prelude #-}
+{-# LANGUAGE CPP
+ , NoImplicitPrelude
+ , OverlappingInstances
+ , ScopedTypeVariables
+ , ForeignFunctionInterface
+ , FlexibleInstances
+ #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
+-- The -XOverlappingInstances flag allows the user to over-ride
+-- the instances for Typeable given here. In particular, we provide an instance
+-- instance ... => Typeable (s a)
+-- But a user might want to say
+-- instance ... => Typeable (MyType a b)
+
-----------------------------------------------------------------------------
-- |
-- Module : Data.Typeable
-- 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
+-- equivalence. The module "Data.Dynamic" uses Typeable for an
+-- implementation of dynamics. The module "Data.Data" 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
- 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
- splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep])
- funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
-
- -- * Observation of type representations
- 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
+ -- * 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
+ showsTypeRep,
+
+ -- * 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
+ typeRepKey, -- :: TypeRep -> IO Int
+
+ -- * 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 Data.List( foldl, intersperse )
+import Unsafe.Coerce
#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
+import GHC.Show (Show(..), ShowS,
+ shows, showString, showChar, showParen)
+import GHC.Err (undefined)
+import GHC.Num (Integer, (+))
+import GHC.Real ( rem, Ratio )
+import GHC.IORef (IORef,newIORef)
+import GHC.IO (unsafePerformIO,mask_)
+
+-- 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.IOArray
+import GHC.MVar
+import GHC.ST ( ST )
+import GHC.STRef ( STRef )
+import GHC.Ptr ( Ptr, FunPtr )
+import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr,
+ deRefStablePtr, castStablePtrToPtr,
+ castPtrToStablePtr )
+import GHC.Arr ( Array, STArray )
+
#endif
#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.IO
-import Hugs.IORef
-import Hugs.IOExts
+import Hugs.Prelude ( Key(..), TypeRep(..), TyCon(..), Ratio,
+ Handle, Ptr, FunPtr, ForeignPtr, StablePtr )
+import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Hugs.IOExts ( unsafePerformIO )
+ -- For the Typeable instance
+import Hugs.Array ( Array )
+import Hugs.IOArray
+import Hugs.ConcBase ( MVar )
#endif
-#ifdef __GLASGOW_HASKELL__
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
+#ifdef __NHC__
+import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+import IO (Handle)
+import Ratio (Ratio)
+ -- For the Typeable instance
+import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr )
+import Array ( Array )
#endif
-#ifdef __NHC__
-import NonStdUnsafeCoerce (unsafeCoerce)
-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
-#else
#include "Typeable.h"
-#endif
#ifndef __HUGS__
-------------------------------------------------------------
--
--- Type representations
+-- Type representations
--
-------------------------------------------------------------
instance Eq TyCon where
(TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
#endif
- --
- -- 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.
+-- | Returns a unique integer associated with a 'TypeRep'. This can
+-- be used for making a mapping with TypeReps
+-- as the keys, for example. It is guaranteed that @t1 == t2@ if and only if
+-- @typeRepKey t1 == typeRepKey t2@.
+--
+-- It is in the 'IO' monad because the actual value of the key may
+-- vary from run to run of the program. You should only rely on
+-- the equality property, not any actual key value. The relative ordering
+-- of keys has no meaning either.
+--
+typeRepKey :: TypeRep -> IO Int
+typeRepKey (TypeRep (Key i) _ _) = return i
+
+ --
+ -- 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 --------------------
-- > 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 :: 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
+typeRepTyCon :: TypeRep -> TyCon
+typeRepTyCon (TypeRep _ tc _) = tc
-- | Observe the argument types of a type representation
-typerepArgs :: TypeRep -> [TypeRep]
-typerepArgs (TypeRep _ _ args) = args
+typeRepArgs :: TypeRep -> [TypeRep]
+typeRepArgs (TypeRep _ _ args) = args
-- | Observe string encoding of a type representation
-tyconString :: TyCon -> String
-tyconString (TyCon _ str) = str
+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 .
+ showsPrec 9 a .
showString " -> " .
showsPrec 8 r
- xs | isTupleTyCon tycon -> showTuple tycon xs
- | otherwise ->
- showParen (p > 9) $
- showsPrec p tycon .
- showChar ' ' .
- showArgs tys
+ xs | isTupleTyCon tycon -> showTuple xs
+ | otherwise ->
+ showParen (p > 9) $
+ showsPrec p tycon .
+ showChar ' ' .
+ showArgs tys
+
+showsTypeRep :: TypeRep -> ShowS
+showsTypeRep = shows
instance Show TyCon where
showsPrec _ (TyCon _ s) = showString s
isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ (',':_)) = True
-isTupleTyCon _ = False
+isTupleTyCon (TyCon _ ('(':',':_)) = True
+isTupleTyCon _ = False
-- Some (Show.TypeRep) helpers:
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 ')'
+showTuple :: [TypeRep] -> ShowS
+showTuple args = showChar '('
+ . (foldr (.) id $ intersperse (showChar ',')
+ $ map (showsPrec 10) args)
+ . showChar ')'
-------------------------------------------------------------
--
--- The Typeable class and friends
+-- The Typeable class and friends
--
-------------------------------------------------------------
+{- Note [Memoising typeOf]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+IMPORTANT: we don't want to recalculate the type-rep once per
+call to the dummy argument. This is what went wrong in Trac #3245
+So we help GHC by manually keeping the 'rep' *outside* the value
+lambda, thus
+
+ typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+ typeOfDefault = \_ -> rep
+ where
+ rep = typeOf1 (undefined :: t a) `mkAppTy`
+ typeOf (undefined :: a)
+
+Notice the crucial use of scoped type variables here!
+-}
+
-- | The class 'Typeable' allows a concrete representation of a type to
-- be calculated.
class Typeable a where
class Typeable1 t where
typeOf1 :: t a -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault = \_ -> rep
+ where
+ rep = typeOf1 (undefined :: t a) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for binary type constructors
class Typeable2 t where
typeOf2 :: t a b -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default = \_ -> rep
+ where
+ rep = typeOf2 (undefined :: t a b) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 3-ary type constructors
class Typeable3 t where
typeOf3 :: t a b c -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default = \_ -> rep
+ where
+ rep = typeOf3 (undefined :: t a b c) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 4-ary type constructors
class Typeable4 t where
typeOf4 :: t a b c d -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default = \_ -> rep
+ where
+ rep = typeOf4 (undefined :: t a b c d) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
-
+ argType = undefined
+#endif
+
-- | Variant for 5-ary type constructors
class Typeable5 t where
typeOf5 :: t a b c d e -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default = \_ -> rep
+ where
+ rep = typeOf5 (undefined :: t a b c d e) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 6-ary type constructors
class Typeable6 t where
typeOf6 :: t a b c d e f -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default = \_ -> rep
+ where
+ rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 7-ary type constructors
class Typeable7 t where
typeOf7 :: t a b c d e f g -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default = \_ -> rep
+ where
+ rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
#ifdef __GLASGOW_HASKELL__
-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
-------------------------------------------------------------
--
--- Type-safe cast
+-- Type-safe cast
--
-------------------------------------------------------------
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r
where
- r = if typeOf x == typeOf (fromJust r)
+ r = if typeOf x == typeOf (fromJust r)
then Just $ unsafeCoerce x
- else Nothing
+ else Nothing
-- | A flexible variation parameterised in a type constructor
gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
-------------------------------------------------------------
--
--- Instances of the Typeable classes for Prelude types
+-- Instances of the Typeable classes for Prelude types
--
-------------------------------------------------------------
-#ifndef __NHC__
+INSTANCE_TYPEABLE0((),unitTc,"()")
INSTANCE_TYPEABLE1([],listTc,"[]")
+#if defined(__GLASGOW_HASKELL__)
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
+#endif
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
-INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
+#if defined(__GLASGOW_HASKELL__)
+{-
+TODO: Deriving this instance fails with:
+libraries/base/Data/Typeable.hs:589:1:
+ Can't make a derived instance of `Typeable2 (->)':
+ The last argument of the instance must be a data or newtype application
+ In the stand-alone deriving instance for `Typeable2 (->)'
+-}
+instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
+funTc :: TyCon
+funTc = mkTyCon "->"
+#else
INSTANCE_TYPEABLE2((->),funTc,"->")
+#endif
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-INSTANCE_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE2((,),pairTc,",")
-INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
-
-tup4Tc :: TyCon
-tup4Tc = mkTyCon ",,,"
-
-instance Typeable4 (,,,) where
- typeOf4 tu = mkTyConApp tup4Tc []
-
-tup5Tc :: TyCon
-tup5Tc = mkTyCon ",,,,"
-
-instance Typeable5 (,,,,) where
- typeOf5 tu = mkTyConApp tup5Tc []
-tup6Tc :: TyCon
-tup6Tc = mkTyCon ",,,,,"
-
-instance Typeable6 (,,,,,) where
- typeOf6 tu = mkTyConApp tup6Tc []
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+-- Types defined in GHC.MVar
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+#endif
-tup7Tc :: TyCon
-tup7Tc = mkTyCon ",,,,,"
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
-instance Typeable7 (,,,,,,) where
- typeOf7 tu = mkTyConApp tup7Tc []
+#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
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
-INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
-#endif /* ! __NHC__ */
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
+#endif /* __NHC__ */
+
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
+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_TYPEABLE0(Ordering,orderingTc,"Ordering")
+#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+#endif
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-#endif /* !__NHC__ */
#ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+{-
+TODO: This can't be derived currently:
+libraries/base/Data/Typeable.hs:674:1:
+ Can't make a derived instance of `Typeable RealWorld':
+ The last argument of the instance must be a data or newtype application
+ In the stand-alone deriving instance for `Typeable RealWorld'
+-}
+realWorldTc :: TyCon; \
+realWorldTc = mkTyCon "GHC.Base.RealWorld"; \
+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+
#endif
---------------------------------------------
--
--- Internals
+-- 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),
- tc_tbl :: !(HT.HashTable String Key),
- ap_tbl :: !(HT.HashTable KeyPr 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) }
{-# NOINLINE cache #-}
+#ifdef __GLASGOW_HASKELL__
+foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"
+ getOrSetTypeableStore :: Ptr a -> IO (Ptr a)
+#endif
+
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 })
+ empty_tc_tbl <- HT.new (==) HT.hashString
+ empty_ap_tbl <- HT.new (==) hashKP
+ key_loc <- newIORef (Key 1)
+ let ret = Cache { next_key = key_loc,
+ tc_tbl = empty_tc_tbl,
+ ap_tbl = empty_ap_tbl }
+#ifdef __GLASGOW_HASKELL__
+ mask_ $ do
+ stable_ref <- newStablePtr ret
+ let ref = castStablePtrToPtr stable_ref
+ ref2 <- getOrSetTypeableStore ref
+ if ref==ref2
+ then deRefStablePtr stable_ref
+ else do
+ freeStablePtr stable_ref
+ deRefStablePtr
+ (castPtrToStablePtr ref2)
+#else
+ return ret
+#endif
newKey :: IORef Key -> IO Key
#ifdef __GLASGOW_HASKELL__
-newKey kloc = do i <- genSym; return (Key i)
+newKey _ = do i <- genSym; return (Key i)
#else
newKey kloc = do { k@(Key i) <- readIORef kloc ;
- writeIORef kloc (Key (i+1)) ;
- return k }
+ 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
= 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 }
+ 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 }
+ 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
projects / ghc-base.git / blobdiff