X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=d187296faca25b2f75762d32521ef6844e5beb46;hb=a0d7892da0d00fee781a550ef353df8734be5884;hp=4eef6818739678fef63e2e94d7358d279b5970d8;hpb=2aa1070a9a6095e80e82d66f20e4c6f3b5155b82;p=haskell-directory.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index 4eef681..d187296 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -1,4 +1,11 @@
-{-# OPTIONS -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
@@ -9,12 +16,12 @@
 -- 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.Generics" uses Typeable
 -- and type-safe cast (but not dynamics) to support the \"Scrap your
 -- boilerplate\" style of generic programming.
 --
@@ -36,18 +43,20 @@ module Data.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
-	popStarTy,	-- :: TypeRep -> TypeRep   -> TypeRep
 
 	-- * Observation of type representations
-	typerepTyCon,	-- :: TypeRep -> TyCon
-	typerepArgs,	-- :: TypeRep -> [TypeRep]
-	tyconString,	-- :: TyCon   -> String
+	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
-	-- | The general instances are provided for GHC only.
+	-- | /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
@@ -59,15 +68,15 @@ module Data.Typeable
 	gcast2,			-- :: ... => c (t a b) -> Maybe (c (t' a b))
 
 	-- * Default instances
-	-- | These are not needed by GHC, for which these instances are
-	-- generated by general instance declarations.
+	-- | /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,	-- :: (Typeable2 t, Typeable a) => t a b c -> TypeRep
-	typeOf3Default,	-- :: (Typeable2 t, Typeable a) => t a b c d -> TypeRep
-	typeOf4Default,	-- :: (Typeable2 t, Typeable a) => t a b c d e -> TypeRep
-	typeOf5Default,	-- :: (Typeable2 t, Typeable a) => t a b c d e f -> TypeRep
-	typeOf6Default	-- :: (Typeable2 t, Typeable a) => t a b c d e f g -> 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
 
@@ -84,17 +93,36 @@ 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.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, 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.ConcBase	( MVar )
 #endif
 
 #ifdef __GLASGOW_HASKELL__
@@ -105,10 +133,15 @@ unsafeCoerce = unsafeCoerce#
 #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__
 
 -------------------------------------------------------------
@@ -131,11 +164,23 @@ data TyCon = TyCon !Key String
 
 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 (mkAppTy (mkTyCon ",,")
+	-- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
 	--                                 [fTy,fTy,fTy])
 	-- 
 	-- returns "(Foo,Foo,Foo)"
@@ -148,29 +193,34 @@ instance Eq TyCon where
 ----------------- 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]
 
--- | 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.
-popStarTy :: TypeRep -> TypeRep -> TypeRep
-popStarTy (TypeRep tr_k tc trs) arg_tr
+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])
 
@@ -201,16 +251,16 @@ 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 --------------------
 
@@ -273,7 +323,7 @@ class Typeable1 t where
 
 -- | For defining a 'Typeable' instance from any 'Typeable1' instance.
 typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault x = typeOf1 x `popStarTy` typeOf (argType x)
+typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a -> a
    argType =  undefined
@@ -284,7 +334,7 @@ class Typeable2 t where
 
 -- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
 typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default x = typeOf2 x `popStarTy` typeOf (argType x)
+typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b -> a
    argType =  undefined
@@ -295,7 +345,7 @@ class Typeable3 t where
 
 -- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
 typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default x = typeOf3 x `popStarTy` typeOf (argType x)
+typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c -> a
    argType =  undefined
@@ -306,7 +356,7 @@ class Typeable4 t where
 
 -- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
 typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default x = typeOf4 x `popStarTy` typeOf (argType x)
+typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d -> a
    argType =  undefined
@@ -317,7 +367,7 @@ class Typeable5 t where
 
 -- | 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 `popStarTy` typeOf (argType x)
+typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d e -> a
    argType =  undefined
@@ -328,7 +378,7 @@ class Typeable6 t where
 
 -- | 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 `popStarTy` typeOf (argType x)
+typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d e f -> a
    argType =  undefined
@@ -339,7 +389,7 @@ class Typeable7 t where
 
 -- | 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 `popStarTy` typeOf (argType x)
+typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d e f g -> a
    argType =  undefined
@@ -438,45 +488,71 @@ gcast2 x = r
 --
 -------------------------------------------------------------
 
-#ifndef __NHC__
+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_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+
+#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")
+
+#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,",,")
 
 tup4Tc :: TyCon
 tup4Tc = mkTyCon ",,,"
 
 instance Typeable4 (,,,) where
-  typeOf4 tu = mkAppTy tup4Tc []
+  typeOf4 tu = mkTyConApp tup4Tc []
 
 tup5Tc :: TyCon
 tup5Tc = mkTyCon ",,,,"
 
 instance Typeable5 (,,,,) where
-  typeOf5 tu = mkAppTy tup5Tc []
+  typeOf5 tu = mkTyConApp tup5Tc []
 
 tup6Tc :: TyCon
 tup6Tc = mkTyCon ",,,,,"
 
 instance Typeable6 (,,,,,) where
-  typeOf6 tu = mkAppTy tup6Tc []
+  typeOf6 tu = mkTyConApp tup6Tc []
 
 tup7Tc :: TyCon
-tup7Tc = mkTyCon ",,,,,"
+tup7Tc = mkTyCon ",,,,,,"
 
 instance Typeable7 (,,,,,,) where
-  typeOf7 tu = mkAppTy tup7Tc []
+  typeOf7 tu = mkTyConApp tup7Tc []
+#endif /* __NHC__ */
 
-INSTANCE_TYPEABLE1(IO,ioTc,"System.IO.IO")
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
-INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
-#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")
 
 -------------------------------------------------------
 --
@@ -484,12 +560,14 @@ INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.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")
 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
@@ -506,10 +584,9 @@ INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
 
 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-#endif /* !__NHC__ */
 
 #ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
 #endif
 
 ---------------------------------------------
@@ -527,19 +604,38 @@ 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),
+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 })
+		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__
@@ -551,16 +647,6 @@ newKey kloc = do { k@(Key i) <- readIORef kloc ;
 #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