module Data.Typeable.Internal (
Proxy (..),
TypeRep(..),
KindRep,
Fingerprint(..),
typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
TyCon(..),
typeRep,
mkTyCon,
mkTyCon3,
mkTyConApp,
mkPolyTyConApp,
mkAppTy,
typeRepTyCon,
Typeable(..),
mkFunTy,
splitTyConApp,
splitPolyTyConApp,
funResultTy,
typeRepArgs,
typeRepFingerprint,
rnfTypeRep,
showsTypeRep,
tyConString,
rnfTyCon,
listTc, funTc,
typeRepKinds,
typeLitTypeRep
) where
import GHC.Base
import GHC.Word
import GHC.Show
import Data.Proxy
import GHC.Fingerprint.Type
import GHC.Fingerprint
data TypeRep = TypeRep !Fingerprint TyCon [KindRep] [TypeRep]
type KindRep = TypeRep
instance Eq TypeRep where
TypeRep x _ _ _ == TypeRep y _ _ _ = x == y
instance Ord TypeRep where
TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y
data TyCon = TyCon {
tyConFingerprint :: !Fingerprint,
tyConPackage :: String,
tyConModule :: String,
tyConName :: String
}
instance Eq TyCon where
(TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
instance Ord TyCon where
(TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
#include "MachDeps.h"
#if WORD_SIZE_IN_BITS < 64
mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
#else
mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
#endif
mkTyCon high# low# pkg modl name
= TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] []
mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types =
TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types
where
arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ]
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc = mkPolyTyConApp tc []
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp funTc [f,a]
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
splitTyConApp (TypeRep _ tc _ trs) = (tc,trs)
splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep])
splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,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 _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
mkTyCon3 :: String
-> String
-> String
-> TyCon
mkTyCon3 pkg modl name =
TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _ _) = tc
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ _ tys) = tys
typeRepKinds :: TypeRep -> [KindRep]
typeRepKinds (TypeRep _ _ ks _) = ks
tyConString :: TyCon -> String
tyConString = tyConName
typeRepFingerprint :: TypeRep -> Fingerprint
typeRepFingerprint (TypeRep fpr _ _ _) = fpr
class Typeable a where
typeRep# :: Proxy# a -> TypeRep
typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
typeRep _ = typeRep# (proxy# :: Proxy# a)
typeOf :: forall a. Typeable a => a -> TypeRep
typeOf _ = typeRep (Proxy :: Proxy a)
typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
typeOf1 _ = typeRep (Proxy :: Proxy t)
typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
typeOf2 _ = typeRep (Proxy :: Proxy t)
typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
=> t a b c -> TypeRep
typeOf3 _ = typeRep (Proxy :: Proxy t)
typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
=> t a b c d -> TypeRep
typeOf4 _ = typeRep (Proxy :: Proxy t)
typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
=> t a b c d e -> TypeRep
typeOf5 _ = typeRep (Proxy :: Proxy t)
typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
Typeable t => t a b c d e f -> TypeRep
typeOf6 _ = typeRep (Proxy :: Proxy t)
typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
(g :: *). Typeable t => t a b c d e f g -> TypeRep
typeOf7 _ = typeRep (Proxy :: Proxy t)
type Typeable1 (a :: * -> *) = Typeable a
type Typeable2 (a :: * -> * -> *) = Typeable a
type Typeable3 (a :: * -> * -> * -> *) = Typeable a
type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a
type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a
type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a
type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
instance Show TypeRep where
showsPrec p (TypeRep _ tycon kinds 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 (showChar ' ') (kinds ++ tys)
showsTypeRep :: TypeRep -> ShowS
showsTypeRep = shows
instance Show TyCon where
showsPrec _ t = showString (tyConName t)
isTupleTyCon :: TyCon -> Bool
isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
isTupleTyCon _ = False
rnfTypeRep :: TypeRep -> ()
rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
where
go [] = ()
go (x:xs) = rnfTypeRep x `seq` go xs
rnfTyCon :: TyCon -> ()
rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn
where
go [] = ()
go (x:xs) = x `seq` go xs
showArgs :: Show a => ShowS -> [a] -> ShowS
showArgs _ [] = id
showArgs _ [a] = showsPrec 10 a
showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
showTuple :: [TypeRep] -> ShowS
showTuple args = showChar '('
. showArgs (showChar ',') args
. showChar ')'
listTc :: TyCon
listTc = typeRepTyCon (typeOf [()])
funTc :: TyCon
funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
typeLitTypeRep :: String -> TypeRep
typeLitTypeRep nm = rep
where
rep = mkTyConApp tc []
tc = TyCon
{ tyConFingerprint = fingerprintString (mk pack modu nm)
, tyConPackage = pack
, tyConModule = modu
, tyConName = nm
}
pack = "base"
modu = "GHC.TypeLits"
mk a b c = a ++ " " ++ b ++ " " ++ c