ref: 29c4cb296e5a41beeb2e093bb0a74db79fd679a0
dir: /lib/Data/Typeable.hs/
module Data.Typeable (
Typeable(..),
TypeRep,
typeOf,
cast,
eqT,
gcast,
TyCon,
tyConModule,
tyConName,
mkTyCon,
mkTyConApp,
mkAppTy,
mkFunTy,
splitTyConApp,
funResultTy,
typeRepTyCon,
typeRepArgs,
{-
typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
-}
) where
import Primitives
import Prelude
import Control.Monad.ST
import Data.Complex
import Data.IntMap
import Data.IORef
import Data.Map
import Data.Proxy
import Data.Ratio
import Data.STRef
import Data.Type.Equality
import Data.Void
import Data.Word8
import System.IO.MD5
import Unsafe.Coerce
class Typeable a where
typeRep :: forall (proxy :: Type -> Type) . proxy a -> TypeRep
typeOf :: forall a . Typeable a => a -> TypeRep
typeOf _ = typeRep (Proxy :: Proxy a)
-----------------
data TypeRep = TypeRep MD5CheckSum TyCon [TypeRep]
-- Compare keys for equality
instance Eq TypeRep where
TypeRep k1 _ _ == TypeRep k2 _ _ = k1 == k2
instance Ord TypeRep where
TypeRep k1 _ _ <= TypeRep k2 _ _ = k1 <= k2
instance Show TypeRep where
showsPrec p (TypeRep _ c ts) = showParen (p > 11) $ showsPrec 11 c . foldr (\ t s -> showChar ' ' . showsPrec 11 t . s) id ts
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _) = tc
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ args) = args
trMd5 :: TypeRep -> MD5CheckSum
trMd5 (TypeRep md5 _ _) = md5
mkAppTy :: TypeRep -> TypeRep -> TypeRep
mkAppTy (TypeRep _ tc trs) tr = mkTyConApp tc (trs ++ [tr])
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc@(TyCon cmd5 _ _) trs = TypeRep md5 tc trs
where md5 = md5Combine $ cmd5 : map trMd5 trs
-----------------
data TyCon = TyCon MD5CheckSum String String
instance Eq TyCon where
TyCon k1 _ _ == TyCon k2 _ _ = k1 == k2
instance Ord TyCon where
TyCon k1 _ _ <= TyCon k2 _ _ = k1 <= k2
instance Show TyCon where
showsPrec _ (TyCon _ m n) = showString m . showChar '.' . showString n
tyConModule :: TyCon -> String
tyConModule (TyCon _ m _) = m
tyConName :: TyCon -> String
tyConName (TyCon _ _ n) = n
mkTyCon :: String -> String -> TyCon
mkTyCon m n = TyCon md5 m n
where md5 = md5String $ show $ m ++ "." ++ n
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp funTc [f,a]
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
splitTyConApp (TypeRep _ tc trs) = (tc,trs)
funTc :: TyCon
funTc = mkTyCon "Primitives" "->"
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy trFun trArg
= case splitTyConApp trFun of
(tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
_ -> Nothing
-----------------
cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast x = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b)
then Just $ unsafeCoerce x
else Nothing
eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b)
then Just $ unsafeCoerce (Refl :: () :~: ())
else Nothing
gcast :: forall a b (c :: Type -> Type) .
(Typeable a, Typeable b) => c a -> Maybe (c b)
gcast x =
case eqT :: Maybe (a :~: b) of
Just Refl -> Just x
Nothing -> Nothing
-----------------
-- I really need to implement deriving...
nullary :: forall a . String -> String -> a -> TypeRep
nullary m n _ = mkTyConApp (mkTyCon m n) []
unary :: forall (proxy :: Type -> Type) (t :: Type -> Type) a .
Typeable a => String -> String -> proxy (t a) -> TypeRep
unary m n _ = mkTyConApp (mkTyCon m n) [typeRep (Proxy :: Proxy a)]
binary :: forall (proxy :: Type -> Type) (t :: Type -> Type -> Type) a b .
(Typeable a, Typeable b) => String -> String -> proxy (t a b) -> TypeRep
binary m n _ = mkTyConApp (mkTyCon m n) [typeRep (Proxy :: Proxy a), typeRep (Proxy :: Proxy b)]
prim :: forall a . String -> a -> TypeRep
prim n = nullary "Primitives" n
instance Typeable () where typeRep = nullary "Data.Tuple" "()"
instance Typeable Any where typeRep = prim "Any"
instance Typeable Bool where typeRep = nullary "Data.Bool_Type" "Char"
instance Typeable Char where typeRep = prim "Char"
instance Typeable Int where typeRep = prim "Int"
instance Typeable Integer where typeRep = nullary "Data.Integer_Type" "Integer"
instance Typeable Double where typeRep = prim "Double"
instance Typeable Void where typeRep = nullary "Data.Void" "Void"
instance Typeable Word where typeRep = prim "Word"
instance Typeable Word8 where typeRep = nullary "Data.Word8" "Word8"
instance Typeable TypeRep where typeRep = nullary "Data.Typeable" "TypeRep"
instance Typeable TyCon where typeRep = nullary "Data.Typeable" "TyCon"
instance forall a . Typeable a => Typeable (IO a) where typerep = unary "Primitives" "IO"
instance forall a . Typeable a => Typeable (Ptr a) where typeRep = unary "Primitives" "Ptr"
instance forall a . Typeable a => Typeable (IOArray a) where typeRep = unary "Primitives" "IOArray"
instance forall a . Typeable a => Typeable (IORef a) where typeRep = unary "Data.IORef" "IORef"
instance forall a . Typeable a => Typeable (IntMap a) where typeRep = unary "Data.IntMap" "IntMap"
instance forall a . Typeable a => Typeable [a] where typeRep = unary "Data.List_Type" "[]"
instance forall a . Typeable a => Typeable (Complex a) where typeRep = unary "Data.Complex" "Complex"
instance forall a . Typeable a => Typeable (Maybe a) where typeRep = unary "Data.Maybe_Type" "Maybe"
instance forall a . Typeable a => Typeable (Proxy a) where typeRep = unary "Data.Proxy" "Proxy"
instance forall a . Typeable a => Typeable (Ratio a) where typeRep = unary "Data.Ratio" "Ratio"
instance forall a b . (Typeable a, Typeable b) => Typeable (a, b) where typeRep = binary "Data.Tuple" ","
instance forall a b . (Typeable a, Typeable b) => Typeable (a -> b) where typeRep = binary "Primitives" "->"
instance forall a b . (Typeable a, Typeable b) => Typeable (Either a b) where typeRep = binary "Data.Either" "Either"
instance forall a b . (Typeable a, Typeable b) => Typeable (Map a b) where typeRep = binary "Data.Map" "Map"
instance forall a b . (Typeable a, Typeable b) => Typeable (ST a b) where typeRep = binary "Control.Monad.ST" "ST"
instance forall a b . (Typeable a, Typeable b) => Typeable (STRef a b) where typeRep = binary "Data.STRef" "STRef"