-- * 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
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
#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__
--
-------------------------------------------------------------
-
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
data TypeRep = TypeRep !Key TyCon [TypeRep]
#endif
--
- -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
+ -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
-- [fTy,fTy,fTy])
--
-- returns "(Foo,Foo,Foo)"
-- 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,
-> 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 --------------------
isTupleTyCon (TyCon _ (',':_)) = True
isTupleTyCon _ = False
-
-- Some (Show.TypeRep) helpers:
showArgs :: Show a => [a] -> ShowS
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
-- any instance of 'Typeable', so that it is safe to pass 'undefined' as
-- the argument.
--- HACK HACK HACK
-#ifdef __HUGS__
-#define INSTANCE_TYPEABLE1x(tycon,tcname,str) \
-instance Typeable a => Typeable (tycon a) where { \
- typeOf x = mkAppTy tcname [typeOf ((undefined :: tycon a -> a) x) ] }
-#define INSTANCE_TYPEABLE2x(tycon,tcname,str) \
-instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
- typeOf x = mkAppTy tcname [typeOf ((undefined :: tycon a b -> a) x), \
- typeOf ((undefined :: tycon a b -> b) x)] }
-
-INSTANCE_TYPEABLE1x(Ratio,ratioTc,"Ratio")
-INSTANCE_TYPEABLE2x(Either,eitherTc,"Either")
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-INSTANCE_TYPEABLE1x(Maybe,maybeTc,"Maybe")
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
-#endif
-
-- | Variant for unary type constructors
class Typeable1 t where
typeOf1 :: t a -> TypeRep
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-
-#ifndef __HUGS__
--- | 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
-#endif
-
+-- | 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
-#ifndef __HUGS__
-- | 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
-#endif
-
+ typeOf6 = typeOf6Default
+#endif /* __GLASGOW_HASKELL__ */
-------------------------------------------------------------
--
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
getArg :: c x -> x
getArg = undefined
-
-
-- | Cast for * -> *
gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
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
getArg :: c x -> x
getArg = undefined
-
-
-------------------------------------------------------------
--
-- Instances of the Typeable classes for Prelude types
--
-------------------------------------------------------------
-unitTc :: TyCon
-unitTc = mkTyCon "()"
-
-instance Typeable () where
- typeOf _ = mkAppTy unitTc []
-
-
-tup3Tc :: TyCon
-tup3Tc = mkTyCon ",,"
-
-instance Typeable3 (,,) where
- typeOf3 tu = mkAppTy tup3Tc []
-
+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 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 ",,,,,"
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(StablePtr,stableptrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iorefTc,"IORef")
-------------------------------------------------------
--
--
-------------------------------------------------------
-#ifndef __NHC__
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
INSTANCE_TYPEABLE0(Char,charTc,"Char")
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-#endif
#ifdef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
#endif
-
-
---------------------------------------------
--
-- Internals