X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=d7fd0084c503bd350658a1c9175035e34b964ffc;hb=f77ec15be0f622df81980b757244d3401833c926;hp=1151d08ab438d62b267383fc00dc6c68a19f72f0;hpb=d4213f24ad9ab7d3615aede1cc496be08626c6c1;p=ghc-base.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index 1151d08..d7fd008 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -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
@@ -58,17 +69,18 @@ module Data.Typeable
 	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,	-- :: (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
 
-
 import qualified Data.HashTable as HT
 import Data.Maybe
 import Data.Either
@@ -103,10 +115,13 @@ unsafeCoerce = unsafeCoerce#
 #ifdef __NHC__
 import NonStdUnsafeCoerce (unsafeCoerce)
 import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+import IO (Handle)
+import Ratio (Ratio)
+import NHC.FFI (Ptr,StablePtr)
 #else
-#include "Typeable.h"
 #endif
 
+#include "Typeable.h"
 
 #ifndef __HUGS__
 
@@ -116,7 +131,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] 
@@ -135,7 +149,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)"
@@ -145,40 +159,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]
 
-
--- | 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,
@@ -203,25 +217,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 --------------------
 
@@ -248,7 +256,6 @@ isTupleTyCon :: TyCon -> Bool
 isTupleTyCon (TyCon _ (',':_)) = True
 isTupleTyCon _		       = False
 
-
 -- Some (Show.TypeRep) helpers:
 
 showArgs :: Show a => [a] -> ShowS
@@ -264,14 +271,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
@@ -287,139 +292,120 @@ 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
 
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable instance for all Typeable1 instances
-instance (Typeable1 s, Typeable a)
-       => Typeable (s a) where
-  typeOf = typeOfDefault
-#endif
-
-
 -- | Variant for binary type constructors
 class Typeable2 t where
   typeOf2 :: t a b -> TypeRep
 
 -- | 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
 
-
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable1 instance for all Typeable2 instances
-instance (Typeable2 s, Typeable a)
-       => Typeable1 (s a) where
-  typeOf1 = typeOf1Default
-#endif
-
-
 -- | Variant for 3-ary type constructors
 class Typeable3 t where
   typeOf3 :: t a b c -> TypeRep
 
 -- | 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
 
-
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable2 instance for all Typeable3 instances
-instance (Typeable3 s, Typeable a)
-       => Typeable2 (s a) where
-  typeOf2 = typeOf2Default
-#endif
-
-
 -- | Variant for 4-ary type constructors
 class Typeable4 t where
   typeOf4 :: t a b c d -> TypeRep
 
 -- | 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
 
-
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable3 instance for all Typeable4 instances
-instance (Typeable4 s, Typeable a)
-       => Typeable3 (s a) where
-  typeOf3 = typeOf3Default
-#endif
-
-
 -- | Variant for 5-ary type constructors
 class Typeable5 t where
   typeOf5 :: t a b c d e -> TypeRep
 
 -- | 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
 
-
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable4 instance for all Typeable5 instances
-instance (Typeable5 s, Typeable a)
-       => Typeable4 (s a) where
-  typeOf4 = typeOf4Default
-#endif
-
-
 -- | Variant for 6-ary type constructors
 class Typeable6 t where
   typeOf6 :: t a b c d e f -> TypeRep
 
 -- | 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
 
-
-#ifdef __GLASGOW_HASKELL__
--- | One Typeable5 instance for all Typeable6 instances
-instance (Typeable6 s, Typeable a)
-       => Typeable5 (s a) where
-  typeOf5 = typeOf5Default
-#endif
-
-
 -- | 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 `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
 
-
 #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 = typeOf6Default
-#endif
-
 
+#endif /* __GLASGOW_HASKELL__ */
 
 -------------------------------------------------------------
 --
@@ -435,7 +421,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
@@ -446,8 +431,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
@@ -458,7 +441,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
@@ -469,56 +451,51 @@ gcast2 x = r
   getArg :: c x -> x 
   getArg = undefined
 
-
-
 -------------------------------------------------------------
 --
 --	Instances of the Typeable classes for Prelude types
 --
 -------------------------------------------------------------
 
-#ifndef __NHC__
 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")
 INSTANCE_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+#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 []
 
-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__ */
+#endif /* __NHC__ */
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iorefTc,"IORef")
 
 -------------------------------------------------------
 --
@@ -526,7 +503,6 @@ INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
 --
 -------------------------------------------------------
 
-#ifndef __NHC__
 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
 INSTANCE_TYPEABLE0(Char,charTc,"Char")
 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
@@ -548,10 +524,10 @@ 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_TYPEABLE1(MVar,mvarTc,"MVar" )
 #endif
 
 ---------------------------------------------