-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -fallow-overlapping-instances #-}
+
+-- The -fallow-overlapping-instances 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
-- 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.
---
-----------------------------------------------------------------------------
module Data.Typeable
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.
ArrayException, AsyncException, Handle )
import GHC.ST ( ST )
import GHC.STRef ( STRef )
-import GHC.Ptr ( Ptr )
+import GHC.Ptr ( Ptr, FunPtr )
import GHC.ForeignPtr ( ForeignPtr )
-import GHC.Stable ( StablePtr )
+import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr,
+ deRefStablePtr, castStablePtrToPtr,
+ castPtrToStablePtr )
+import GHC.Exception ( block )
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,
+ Exception, ArithException, IOException,
+ ArrayException, AsyncException, Handle,
+ Ptr, FunPtr, ForeignPtr, StablePtr )
+import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Hugs.IOExts ( unsafePerformIO, unsafeCoerce )
-- For the Typeable instance
-import Hugs.Array ( Array )
-import Hugs.ST ( ST, STRef, STArray )
-import Hugs.ForeignPtr ( ForeignPtr )
-imprt
+import Hugs.Array ( Array )
+import Hugs.ConcBase ( MVar )
#endif
#ifdef __GLASGOW_HASKELL__
import IO (Handle)
import Ratio (Ratio)
-- For the Typeable instance
-import NHC.FFI ( Ptr,StablePtr )
+import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr )
import Array ( Array )
#endif
instance Eq TyCon where
(TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
#endif
+-- | Returns a unique integer associated with a 'TypeRep'. This can
+-- be used for making a mapping ('Data.IntMap.IntMap') 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])
INSTANCE_TYPEABLE2((->),funTc,"->")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-#ifdef __GLASGOW_HASKELL__
-
-
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-- Types defined in GHC.IOBase
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
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")
-#endif
-
-
-#ifndef __NHC__
-INSTANCE_TYPEABLE2((,),pairTc,",")
-INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
--- I don't think NHC has ST, STRef, STArray, ForeignPtr
--- but GHC and Hugs do
+#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_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
+#endif
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,",")
+INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
tup4Tc :: TyCon
tup4Tc = mkTyCon ",,,"
instance Typeable7 (,,,,,,) where
typeOf7 tu = mkTyConApp tup7Tc []
-
#endif /* __NHC__ */
+
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,iorefTc,"IORef")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-------------------------------------------------------
--
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 })
+ let ret = Cache { next_key = key_loc,
+ tc_tbl = empty_tc_tbl,
+ ap_tbl = empty_ap_tbl }
+#ifdef __GLASGOW_HASKELL__
+ block $ 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__
#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
projects / haskell-directory.git / blobdiff