module Data.Typeable ( Typeable(..), TypeRep, typeOf, cast, eqT, gcast, TyCon, tyConModule, tyConName, mkTyCon, mkTyConApp, mkAppTy, mkFunTy, splitTyConApp, funResultTy, typeRepTyCon, typeRepArgs, ) 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.Word import System.IO.MD5 import Unsafe.Coerce type Typeable :: forall k . k -> Constraint class Typeable a where typeRep :: forall proxy . 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 []) = showsPrec 11 c showsPrec p (TypeRep _ c [a,b]) | c == funTc = showParen (p > 5) $ showsPrec 6 a . showString " -> " . showsPrec 5 b showsPrec p (TypeRep _ c [a]) | tyConName c == "[]" = showString "[" . showsPrec 0 a . showString "]" showsPrec p (TypeRep _ c ts) | head (tyConName c) == ',' = showParen True $ comma (map (showsPrec 0) ts) | otherwise = showParen (p > 11) $ showsPrec 11 c . foldr (\ t s -> showChar ' ' . showsPrec 12 t . s) id ts where comma [] = undefined comma [s] = s comma (s:ss) = s . showString "," . comma ss 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 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 . (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) [] prim :: forall a . String -> a -> TypeRep prim n = nullary "Primitives" n instance Typeable () where typeRep = nullary "Data.Tuple" "()" instance Typeable AnyType where typeRep = prim "AnyType" instance Typeable Bool where typeRep = nullary "Data.Bool_Type" "Bool" 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 Typeable IO where typeRep = prim "IO" instance Typeable Ptr where typeRep = prim "Ptr" instance Typeable IOArray where typeRep = prim "IOArray" instance Typeable IORef where typeRep = nullary "Data.IORef" "IORef" instance Typeable IntMap where typeRep = nullary "Data.IntMap" "IntMap" instance Typeable [] where typeRep = nullary "Data.List_Type" "[]" instance Typeable Complex where typeRep = nullary "Data.Complex" "Complex" instance Typeable Maybe where typeRep = nullary "Data.Maybe_Type" "Maybe" instance Typeable Proxy where typeRep = nullary "Data.Proxy" "Proxy" instance Typeable Ratio where typeRep = nullary "Data.Ratio" "Ratio" instance Typeable Functor where typeRep = nullary "Data.Functor" "Functor" instance Typeable Applicative where typeRep = nullary "Control.Applicative" "Applicative" instance Typeable Monad where typeRep = nullary "Control.Monad" "Monad" instance Typeable (,) where typeRep = nullary "Data.Tuple" "," instance Typeable (->) where typeRep = prim "->" instance Typeable Either where typeRep = nullary "Data.Either" "Either" instance Typeable Map where typeRep = nullary "Data.Map" "Map" instance Typeable ST where typeRep = nullary "Control.Monad.ST" "ST" instance Typeable STRef where typeRep = nullary "Data.STRef" "STRef" instance Typeable (,,) where typeRep = nullary "Data.Tuple" ",," instance Typeable (,,,) where typeRep = nullary "Data.Tuple" ",,," instance forall f a . (Typeable f, Typeable a) => Typeable (f a) where typeRep _ = mkAppTy (typeRep (Proxy :: Proxy f)) (typeRep (Proxy :: Proxy a))