X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=ff2b304a685c7e9150ef6dcbbbf702646b4b8da7;hb=d4039901986f6991c23f0469a40148e8150b0f1e;hp=4c8050aebe044f43c252c604b4d59e1e35aeb529;hpb=db57e8fc131e5f1507474bb1b38fa7179e494aa0;p=ghc-base.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index 4c8050a..ff2b304 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -2,7 +2,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Typeable
--- Copyright   :  (c) The University of Glasgow 2001
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
@@ -28,8 +28,7 @@ module Data.Typeable
 
 	-- * Type-safe cast
 	cast,			-- :: (Typeable a, Typeable b) => a -> Maybe b
-	castss,			-- a cast for kind "* -> *"
-	castarr,		-- another convenient variation
+	gcast,			-- a generalisation of cast
 
 	-- * Type representations
 	TypeRep,	-- abstract, instance of: Eq, Show, Typeable
@@ -37,19 +36,42 @@ 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
+	splitTyConApp,	-- :: TypeRep -> (TyCon, [TypeRep])
+	funResultTy,	-- :: TypeRep -> TypeRep   -> Maybe TypeRep
 
 	-- * Observation of type representations
 	typerepTyCon,	-- :: TypeRep -> TyCon
 	typerepArgs,	-- :: TypeRep -> [TypeRep]
-	tyconString	-- :: TyCon   -> String
-
+	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
 
   ) where
 
-
 import qualified Data.HashTable as HT
 import Data.Maybe
 import Data.Either
@@ -65,8 +87,8 @@ 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.Ptr          -- So we can give Typeable instance for Ptr
+import GHC.Stable       -- So we can give Typeable instance for StablePtr
 #endif
 
 #ifdef __HUGS__
@@ -84,19 +106,22 @@ 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__
+
 -------------------------------------------------------------
 --
 --		Type representations
 --
 -------------------------------------------------------------
 
-
 -- | A concrete representation of a (monomorphic) type.  'TypeRep'
 -- supports reasonably efficient equality.
 data TypeRep = TypeRep !Key TyCon [TypeRep] 
@@ -115,7 +140,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)"
@@ -128,28 +153,36 @@ 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]
 
-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.
+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,
@@ -175,26 +208,20 @@ 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
 
-
 -- | Observe the argument types of a type representation
 typerepArgs :: TypeRep -> [TypeRep]
 typerepArgs (TypeRep _ _ args) = args
 
-
 -- | Observe string encoding of a type representation
 tyconString :: TyCon   -> String
 tyconString  (TyCon _ str) = str
 
-
 ----------------- Showing TypeReps --------------------
 
 instance Show TypeRep where
@@ -203,7 +230,9 @@ instance Show TypeRep where
       [] -> showsPrec p tycon
       [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
       [a,r] | tycon == funTc  -> showParen (p > 8) $
-			         showsPrec 9 a . showString " -> " . showsPrec 8 r
+			         showsPrec 9 a .
+                                 showString " -> " .
+                                 showsPrec 8 r
       xs | isTupleTyCon tycon -> showTuple tycon xs
 	 | otherwise	     ->
 	    showParen (p > 9) $
@@ -233,10 +262,9 @@ showTuple (TyCon _ str) args = showChar '(' . go str args
   go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
   go _ _   = showChar ')'
 
-
 -------------------------------------------------------------
 --
---	The Typeable class
+--	The Typeable class and friends
 --
 -------------------------------------------------------------
 
@@ -249,6 +277,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
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+-- | 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 = typeOf6Default
+
+#endif /* __GLASGOW_HASKELL__ */
 
 -------------------------------------------------------------
 --
@@ -264,109 +412,81 @@ cast x = r
                then Just $ unsafeCoerce x
 	       else Nothing
 
-
--- | A convenient variation for kind \"* -> *\"
-castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
-castss x = r
-       where
-	 r = if typeOf (get x) == typeOf (get (fromJust r))
-               then Just $ unsafeCoerce x
-	       else Nothing
-         get :: t c -> c
-	 get = undefined
-
-
--- | Another variation
-castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
-        => (a -> t b) -> Maybe (c -> t d)
-castarr x = r
-       where
-	 r = if typeOf (get x) == typeOf (get (fromJust r))
-               then Just $ unsafeCoerce x
-	       else Nothing
-         get :: (e -> t f) -> (e, f)
-	 get = undefined
-
-{-
-
-The variations castss and castarr are arguably not really needed.
-Let's discuss castss in some detail. To get rid of castss, we can
-require "Typeable (t a)" and "Typeable (t b)" rather than just
-"Typeable a" and "Typeable b". In that case, the ordinary cast would
-work. Eventually, all kinds of library instances should become
-Typeable. (There is another potential use of variations as those given
-above. It allows quantification on type constructors.
-
--}
-
+-- | A flexible variation parameterised in a type constructor
+gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
+gcast x = r
+ where
+  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
+        then Just $ unsafeCoerce x
+        else Nothing
+  getArg :: c x -> x 
+  getArg = undefined
+
+-- | Cast for * -> *
+gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) 
+gcast1 x = r
+ where
+  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
+       then Just $ unsafeCoerce x
+       else Nothing
+  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
+ where
+  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
+       then Just $ unsafeCoerce x
+       else Nothing
+  getArg :: c x -> x 
+  getArg = undefined
 
 -------------------------------------------------------------
 --
---	Instances of the Typeable class for Prelude types
+--	Instances of the Typeable classes for Prelude types
 --
 -------------------------------------------------------------
 
-listTc :: TyCon
-listTc = mkTyCon "[]"
-
-instance Typeable a => Typeable [a] where
-  typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
-	-- In GHC we can say
-	--	typeOf (undefined :: a)
-	-- using scoped type variables, but we use the 
-	-- more verbose form here, for compatibility with Hugs
-
-unitTc :: TyCon
-unitTc = mkTyCon "()"
-
-instance Typeable () where
-  typeOf _ = mkAppTy unitTc []
-
-tup2Tc :: TyCon
-tup2Tc = mkTyCon ","
-
-instance (Typeable a, Typeable b) => Typeable (a,b) where
-  typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
-			      typeOf ((undefined :: (a,b) -> b) tu)]
-
-tup3Tc :: TyCon
-tup3Tc = mkTyCon ",,"
-
-instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
-  typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
-			      typeOf ((undefined :: (a,b,c) -> b) tu),
-			      typeOf ((undefined :: (a,b,c) -> c) tu)]
+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,"()")
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,",")
+INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
 
 tup4Tc :: TyCon
 tup4Tc = mkTyCon ",,,"
 
-instance ( Typeable a
-	 , Typeable b
-	 , Typeable c
-	 , Typeable d) => Typeable (a,b,c,d) where
-  typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
-			      typeOf ((undefined :: (a,b,c,d) -> b) tu),
-			      typeOf ((undefined :: (a,b,c,d) -> c) tu),
-			      typeOf ((undefined :: (a,b,c,d) -> d) tu)]
+instance Typeable4 (,,,) where
+  typeOf4 tu = mkTyConApp tup4Tc []
+
 tup5Tc :: TyCon
 tup5Tc = mkTyCon ",,,,"
 
-instance ( Typeable a
-	 , Typeable b
-	 , Typeable c
-	 , Typeable d
-	 , Typeable e) => Typeable (a,b,c,d,e) where
-  typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
-			      typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
-			      typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
-			      typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
-			      typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
+instance Typeable5 (,,,,) where
+  typeOf5 tu = mkTyConApp tup5Tc []
+
+tup6Tc :: TyCon
+tup6Tc = mkTyCon ",,,,,"
 
-instance (Typeable a, Typeable b) => Typeable (a -> b) where
-  typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
-		     (typeOf ((undefined :: (a -> b) -> b) f))
+instance Typeable6 (,,,,,) where
+  typeOf6 tu = mkTyConApp tup6Tc []
 
+tup7Tc :: TyCon
+tup7Tc = mkTyCon ",,,,,"
 
+instance Typeable7 (,,,,,,) where
+  typeOf7 tu = mkTyConApp tup7Tc []
+
+#endif /* __NHC__ */
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
+INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
+INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
 
 -------------------------------------------------------
 --
@@ -374,21 +494,14 @@ instance (Typeable a, Typeable b) => Typeable (a -> b) 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")
 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
-INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
-INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
 
 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
@@ -403,11 +516,10 @@ INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 
-INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
+#ifdef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
 #endif
 
-
-
 ---------------------------------------------
 --
 --		Internals