X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=ce602e4999f8d4071f61f84645fcec891fb1ef89;hb=HEAD;hp=e56312934ffed22397abeecf7ae8b6a5356792b8;hpb=dcc348a1421cc0c5aa6c88eb0d32a1c6dbfa741e;p=ghc-base.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index e563129..ce602e4 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -1,4 +1,21 @@
-{-# 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
@@ -14,113 +31,116 @@
 -- 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
+-- 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.
 --
--- 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
   (
 
-	-- * 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
-
-	-- * 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
+        -- * 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.ST		-- So we can give Typeable instance for ST
-import GHC.Ptr          -- So we can give Typeable instance for Ptr
-import GHC.Stable       -- So we can give Typeable instance for StablePtr
-#endif
+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 )
 
-#ifdef __HUGS__
-import Hugs.Prelude
-import Hugs.IO
-import Hugs.IORef
-import Hugs.ST
-import Hugs.IOExts
 #endif
 
-#ifdef __GLASGOW_HASKELL__
-unsafeCoerce :: a -> b
-unsafeCoerce = unsafeCoerce#
+#ifdef __HUGS__
+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 __NHC__
-import NonStdUnsafeCoerce (unsafeCoerce)
-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
 import IO (Handle)
 import Ratio (Ratio)
-import NHC.FFI (Ptr,StablePtr)
-#else
+        -- For the Typeable instance
+import NHC.FFI  ( Ptr,FunPtr,StablePtr,ForeignPtr )
+import Array    ( Array )
 #endif
 
 #include "Typeable.h"
@@ -129,7 +149,7 @@ import NHC.FFI (Ptr,StablePtr)
 
 -------------------------------------------------------------
 --
---		Type representations
+--              Type representations
 --
 -------------------------------------------------------------
 
@@ -147,19 +167,31 @@ data TyCon = TyCon !Key String
 
 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 --------------------
 
@@ -213,10 +245,10 @@ mkAppTy (TypeRep tr_k tc trs) arg_tr
 -- >  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 ---------------------
@@ -241,22 +273,25 @@ instance Show TypeRep where
       [] -> 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:
 
@@ -265,20 +300,34 @@ showArgs [] = id
 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
@@ -292,78 +341,148 @@ 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,
@@ -411,7 +530,7 @@ instance (Typeable7 s, Typeable a)
 
 -------------------------------------------------------------
 --
---		Type-safe cast
+--              Type-safe cast
 --
 -------------------------------------------------------------
 
@@ -419,9 +538,9 @@ instance (Typeable7 s, Typeable a)
 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)
@@ -455,50 +574,68 @@ gcast2 x = r
 
 -------------------------------------------------------------
 --
---	Instances of the Typeable classes for Prelude types
+--      Instances of the Typeable classes for Prelude types
 --
 -------------------------------------------------------------
 
+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_TYPEABLE2(ST,stTc,"ST")
-INSTANCE_TYPEABLE0((),unitTc,"()")
-#ifndef __NHC__
-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
 
+#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(StablePtr,stableptrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,iorefTc,"IORef")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
 
 -------------------------------------------------------
 --
@@ -511,9 +648,14 @@ 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")
@@ -529,14 +671,22 @@ INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 
 #ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+{-
+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 
 --
 ---------------------------------------------
 
@@ -549,40 +699,49 @@ 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),
-		     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
@@ -590,24 +749,24 @@ foreign import ccall unsafe "genSymZh"
 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