module Data.Typeable
(
Typeable( typeOf ),
cast,
gcast,
TypeRep,
TyCon,
showsTypeRep,
mkTyCon,
mkTyConApp,
mkAppTy,
mkFunTy,
splitTyConApp,
funResultTy,
typeRepTyCon,
typeRepArgs,
tyConString,
typeRepKey,
Typeable1( typeOf1 ),
Typeable2( typeOf2 ),
Typeable3( typeOf3 ),
Typeable4( typeOf4 ),
Typeable5( typeOf5 ),
Typeable6( typeOf6 ),
Typeable7( typeOf7 ),
gcast1,
gcast2,
typeOfDefault,
typeOf1Default,
typeOf2Default,
typeOf3Default,
typeOf4Default,
typeOf5Default,
typeOf6Default
) where
import qualified Data.HashTable as HT
import Data.Maybe
import Data.Int
import Data.Word
import Data.List( foldl, intersperse )
import Unsafe.Coerce
#ifdef __GLASGOW_HASKELL__
import GHC.Base
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_)
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 )
#endif
#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 )
import Hugs.Array ( Array )
import Hugs.IOArray
import Hugs.ConcBase ( MVar )
#endif
#ifdef __NHC__
import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
import IO (Handle)
import Ratio (Ratio)
import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr )
import Array ( Array )
#endif
#include "Typeable.h"
#ifndef __HUGS__
data TypeRep = TypeRep !Key TyCon [TypeRep]
instance Eq TypeRep where
(TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
data TyCon = TyCon !Key String
instance Eq TyCon where
(TyCon t1 _) == (TyCon t2 _) = t1 == t2
#endif
typeRepKey :: TypeRep -> IO Int
typeRepKey (TypeRep (Key i) _ _) = return i
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]
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp funTc [f,a]
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
splitTyConApp (TypeRep _ tc trs) = (tc,trs)
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy trFun trArg
= case splitTyConApp trFun of
(tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
_ -> Nothing
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])
mkTyCon :: String
-> TyCon
mkTyCon str = TyCon (mkTyConKey str) str
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _) = tc
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ args) = args
tyConString :: TyCon -> String
tyConString (TyCon _ str) = str
instance Show TypeRep where
showsPrec p (TypeRep _ tycon tys) =
case tys of
[] -> showsPrec p tycon
[x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
[a,r] | tycon == funTc -> showParen (p > 8) $
showsPrec 9 a .
showString " -> " .
showsPrec 8 r
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
showArgs :: Show a => [a] -> ShowS
showArgs [] = id
showArgs [a] = showsPrec 10 a
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
showTuple :: [TypeRep] -> ShowS
showTuple args = showChar '('
. (foldr (.) id $ intersperse (showChar ',')
$ map (showsPrec 10) args)
. showChar ')'
class Typeable a where
typeOf :: a -> TypeRep
class Typeable1 t where
typeOf1 :: t a -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault = \_ -> rep
where
rep = typeOf1 (undefined :: t a) `mkAppTy`
typeOf (undefined :: a)
#else
typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
where
argType :: t a -> a
argType = undefined
#endif
class Typeable2 t where
typeOf2 :: t a b -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
class Typeable3 t where
typeOf3 :: t a b c -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
class Typeable4 t where
typeOf4 :: t a b c d -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
class Typeable5 t where
typeOf5 :: t a b c d e -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
class Typeable6 t where
typeOf6 :: t a b c d e f -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
class Typeable7 t where
typeOf7 :: t a b c d e f g -> TypeRep
#ifdef __GLASGOW_HASKELL__
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)
#else
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
#endif
#ifdef __GLASGOW_HASKELL__
instance (Typeable1 s, Typeable a)
=> Typeable (s a) where
typeOf = typeOfDefault
instance (Typeable2 s, Typeable a)
=> Typeable1 (s a) where
typeOf1 = typeOf1Default
instance (Typeable3 s, Typeable a)
=> Typeable2 (s a) where
typeOf2 = typeOf2Default
instance (Typeable4 s, Typeable a)
=> Typeable3 (s a) where
typeOf3 = typeOf3Default
instance (Typeable5 s, Typeable a)
=> Typeable4 (s a) where
typeOf4 = typeOf4Default
instance (Typeable6 s, Typeable a)
=> Typeable5 (s a) where
typeOf5 = typeOf5Default
instance (Typeable7 s, Typeable a)
=> Typeable6 (s a) where
typeOf6 = typeOf6Default
#endif /* __GLASGOW_HASKELL__ */
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r
where
r = if typeOf x == typeOf (fromJust r)
then Just $ unsafeCoerce x
else Nothing
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
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
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
INSTANCE_TYPEABLE0((),unitTc,"()")
INSTANCE_TYPEABLE1([],listTc,"[]")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
INSTANCE_TYPEABLE2((->),funTc,"->")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
#endif
INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
#ifdef __GLASGOW_HASKELL__
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(FunPtr,funPtrTc,"FunPtr")
#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
#endif
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
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")
#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
#endif
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
#ifdef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
#endif
#ifndef __HUGS__
newtype Key = Key Int deriving( Eq )
#endif
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) }
#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)
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 _ = do i <- genSym; return (Key i)
#else
newKey kloc = do { k@(Key i) <- readIORef kloc ;
writeIORef kloc (Key (i+1)) ;
return k }
#endif
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "genSymZh"
genSym :: IO Int
#endif
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 }
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 }
where
kpr = KeyPr k1 k2
appKeys :: Key -> [Key] -> Key
appKeys k ks = foldl appKey k ks