X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=159137c96bba9c119d156d6f5ec73a16793d59b1;hb=7659d3c9c7c6dc87d3d2be1391f123c15553a1a4;hp=42d1b293dc5d5ec90fa116257ffa9fae893bb658;hpb=06638f8c2dc14da8cf4f999028a92aa50a27fab9;p=ghc-base.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index 42d1b29..159137c 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Typeable
@@ -9,15 +9,24 @@
 -- 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.
 --
+-- 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
@@ -36,17 +45,19 @@ 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
 
 	-- * 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
@@ -55,11 +66,21 @@ module Data.Typeable
 	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))
+	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
@@ -73,10 +94,21 @@ 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 )
+import GHC.Arr		( Array, STArray )
+
 #endif
 
 #ifdef __HUGS__
@@ -84,6 +116,9 @@ import Hugs.Prelude
 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__
@@ -94,10 +129,14 @@ 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__
 
@@ -107,7 +146,6 @@ import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
 --
 -------------------------------------------------------------
 
-
 -- | A concrete representation of a (monomorphic) type.  'TypeRep'
 -- supports reasonably efficient equality.
 data TypeRep = TypeRep !Key TyCon [TypeRep] 
@@ -126,7 +164,7 @@ instance Eq TyCon where
 #endif
 
 	-- 
-	-- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
+	-- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
 	--                                 [fTy,fTy,fTy])
 	-- 
 	-- returns "(Foo,Foo,Foo)"
@@ -136,45 +174,40 @@ instance Eq TyCon where
 	-- 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 
+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]
 
-
--- The function type constructor
-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.
-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])
 
-
 -- 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,
@@ -199,25 +232,19 @@ mkTyCon :: String	-- ^ the name of the type constructor (should be unique
 	-> 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 --------------------
 
@@ -244,7 +271,6 @@ isTupleTyCon :: TyCon -> Bool
 isTupleTyCon (TyCon _ (',':_)) = True
 isTupleTyCon _		       = False
 
-
 -- Some (Show.TypeRep) helpers:
 
 showArgs :: Show a => [a] -> ShowS
@@ -260,14 +286,12 @@ showTuple (TyCon _ str) args = showChar '(' . go str args
   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
@@ -277,105 +301,126 @@ class Typeable a where
   -- 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
 
-
--- | One Typeable instance for all Typeable1 instances
-instance (Typeable1 s, Typeable a)
-       => Typeable (s a) where
-  typeOf x = typeOf1 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x -> x
-     argType =  undefined
-
+-- | 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
 
-
--- | One Typeable1 instance for all Typeable2 instances
-instance (Typeable2 s, Typeable a)
-       => Typeable1 (s a) where
-  typeOf1 x = typeOf2 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y -> x
-     argType =  undefined
-
+-- | 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
 
-
--- | One Typeable2 instance for all Typeable3 instances
-instance (Typeable3 s, Typeable a)
-       => Typeable2 (s a) where
-  typeOf2 x = typeOf3 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y z -> x
-     argType =  undefined
-
+-- | 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
 
-
--- | One Typeable3 instance for all Typeable4 instances
-instance (Typeable4 s, Typeable a)
-       => Typeable3 (s a) where
-  typeOf3 x = typeOf4 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y z z' -> x
-     argType =  undefined
-
+-- | 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
 
-
--- | One Typeable4 instance for all Typeable5 instances
-instance (Typeable5 s, Typeable a)
-       => Typeable4 (s a) where
-  typeOf4 x = typeOf5 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y z z' z'' -> x
-     argType =  undefined
-
+-- | 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
 
-
--- | One Typeable5 instance for all Typeable6 instances
-instance (Typeable6 s, Typeable a)
-       => Typeable5 (s a) where
-  typeOf5 x = typeOf6 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y z z' z'' z''' -> x
-     argType =  undefined
-
+-- | 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
+
+#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 x = typeOf7 x `popStarTy` typeOf (argType x)
-   where
-     argType :: t x y z z' z'' z''' z'''' -> x
-     argType =  undefined
-
+  typeOf6 = typeOf6Default
 
+#endif /* __GLASGOW_HASKELL__ */
 
 -------------------------------------------------------------
 --
@@ -391,7 +436,6 @@ cast x = 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
@@ -402,8 +446,6 @@ gcast x = r
   getArg :: c x -> x 
   getArg = undefined
 
-
-
 -- | Cast for * -> *
 gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) 
 gcast1 x = r
@@ -414,7 +456,6 @@ gcast1 x = r
   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
@@ -425,133 +466,77 @@ gcast2 x = r
   getArg :: c x -> x 
   getArg = undefined
 
-
-
 -------------------------------------------------------------
 --
 --	Instances of the Typeable classes for Prelude types
 --
 -------------------------------------------------------------
 
-unitTc :: TyCon
-unitTc = mkTyCon "()"
-
-instance Typeable () where
-  typeOf _ = mkAppTy unitTc []
-
+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")
+
+#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
 
-tup3Tc :: TyCon
-tup3Tc = mkTyCon ",,"
+-- Types defined in GHC.Arr
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
 
-instance Typeable3 (,,) where
-  typeOf3 tu = mkAppTy tup3Tc []
+#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 []
-
-
-listTc :: TyCon
-listTc = mkTyCon "[]"
-
--- | Instance for lists
-instance Typeable1 [] where
-  typeOf1 _ = mkAppTy listTc []
-
-
-maybeTc :: TyCon
-maybeTc = mkTyCon "Maybe"
-
--- | Instance for maybes
-instance Typeable1 Maybe where
-  typeOf1 _ = mkAppTy maybeTc []
-
-
-ratioTc :: TyCon
-ratioTc = mkTyCon "Ratio"
-
--- | Instance for ratios
-instance Typeable1 Ratio where
-  typeOf1 _ = mkAppTy ratioTc []
-
-
-pairTc :: TyCon
-pairTc = mkTyCon "(,)"
-
--- | Instance for products
-instance Typeable2 (,) where
-  typeOf2 _ = mkAppTy pairTc []
-
-
-eitherTc :: TyCon
-eitherTc = mkTyCon "Either"
-
--- | Instance for sums
-instance Typeable2 Either where
-  typeOf2 _ = mkAppTy eitherTc []
-
-
--- | Instance for functions
-instance Typeable2 (->) where
-  typeOf2 _ = mkAppTy funTc []
-
-
-#ifdef __GLASGOW_HASKELL__
-
-ioTc :: TyCon
-ioTc = mkTyCon "GHC.IOBase.IO"
-
-instance Typeable1 IO where
-  typeOf1 _ = mkAppTy ioTc []
-
-
-ptrTc :: TyCon
-ptrTc = mkTyCon "GHC.Ptr.Ptr"
-
-instance Typeable1 Ptr where
-  typeOf1 _ = mkAppTy ptrTc []
-
-
-stableptrTc :: TyCon
-stableptrTc = mkTyCon "GHC.Stable.StablePtr"
-
-instance Typeable1 StablePtr where
-  typeOf1 _ = mkAppTy stableptrTc []
-
-
-iorefTc :: TyCon
-iorefTc = mkTyCon "GHC.IOBase.IORef"
-
-instance Typeable1 IORef where
-  typeOf1 _ = mkAppTy iorefTc []
-
-#endif
-
+  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")
 
 -------------------------------------------------------
 --
@@ -559,12 +544,14 @@ instance Typeable1 IORef where
 --
 -------------------------------------------------------
 
-#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")
@@ -581,14 +568,11 @@ INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
 
 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-#endif
 
 #ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
 #endif
 
-
-
 ---------------------------------------------
 --
 --		Internals 
@@ -604,7 +588,7 @@ 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) }