module Data.Typeable.Internal (
Proxy (..),
Fingerprint(..),
typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
Module,
moduleName, modulePackage,
TyCon,
tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint,
mkTyCon3, mkTyCon3#,
rnfTyCon,
TypeRep(..), KindRep,
typeRep,
mkTyConApp,
mkPolyTyConApp,
mkAppTy,
typeRepTyCon,
Typeable(..),
mkFunTy,
splitTyConApp,
splitPolyTyConApp,
funResultTy,
typeRepArgs,
typeRepFingerprint,
rnfTypeRep,
showsTypeRep,
typeRepKinds,
typeSymbolTypeRep, typeNatTypeRep
) where
import GHC.Base
import GHC.Types (TYPE)
import GHC.Word
import GHC.Show
import Data.Proxy
import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' )
import GHC.Fingerprint.Type
import GHC.Fingerprint
#include "MachDeps.h"
modulePackage :: Module -> String
modulePackage (Module p _) = trNameString p
moduleName :: Module -> String
moduleName (Module _ m) = trNameString m
tyConPackage :: TyCon -> String
tyConPackage (TyCon _ _ m _) = modulePackage m
tyConModule :: TyCon -> String
tyConModule (TyCon _ _ m _) = moduleName m
tyConName :: TyCon -> String
tyConName (TyCon _ _ _ n) = trNameString n
trNameString :: TrName -> String
trNameString (TrNameS s) = unpackCString# s
trNameString (TrNameD s) = s
tyConString :: TyCon -> String
tyConString = tyConName
tyConFingerprint :: TyCon -> Fingerprint
tyConFingerprint (TyCon hi lo _ _)
= Fingerprint (W64# hi) (W64# lo)
mkTyCon3# :: Addr#
-> Addr#
-> Addr#
-> TyCon
mkTyCon3# pkg modl name
| Fingerprint (W64# hi) (W64# lo) <- fingerprint
= TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name)
where
fingerprint :: Fingerprint
fingerprint = fingerprintString (unpackCString# pkg
++ (' ': unpackCString# modl)
++ (' ' : unpackCString# name))
mkTyCon3 :: String
-> String
-> String
-> TyCon
mkTyCon3 pkg modl name
| Fingerprint (W64# hi) (W64# lo) <- fingerprint
= TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name)
where
fingerprint :: Fingerprint
fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name))
isTupleTyCon :: TyCon -> Bool
isTupleTyCon tc
| ('(':',':_) <- tyConName tc = True
| otherwise = False
rnfModule :: Module -> ()
rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
rnfTrName :: TrName -> ()
rnfTrName (TrNameS _) = ()
rnfTrName (TrNameD n) = rnfString n
rnfTyCon :: TyCon -> ()
rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n
rnfString :: [Char] -> ()
rnfString [] = ()
rnfString (c:cs) = c `seq` rnfString cs
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
typeRepFingerprint :: TypeRep -> Fingerprint
typeRepFingerprint (TypeRep fpr _ _ _) = fpr
mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
mkPolyTyConApp tc kinds types
= TypeRep (fingerprintFingerprints sub_fps) tc kinds types
where
!kt_fps = typeRepFingerprints kinds types
sub_fps = tyConFingerprint tc : kt_fps
typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint]
typeRepFingerprints kinds types
= go1 [] kinds
where
go1 acc [] = go2 acc types
go1 acc (k:ks) = let !fp = typeRepFingerprint k
in go1 (fp:acc) ks
go2 acc [] = acc
go2 acc (t:ts) = let !fp = typeRepFingerprint t
in go2 (fp:acc) ts
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc = mkPolyTyConApp tc []
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp tcFun [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 == tcFun && t1 == trArg -> Just t2
_ -> Nothing
tyConOf :: Typeable a => Proxy a -> TyCon
tyConOf = typeRepTyCon . typeRep
tcFun :: TyCon
tcFun = tyConOf (Proxy :: Proxy (Int -> Int))
mkAppTy :: TypeRep -> TypeRep -> TypeRep
mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _ _) = tc
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ _ tys) = tys
typeRepKinds :: TypeRep -> [KindRep]
typeRepKinds (TypeRep _ _ ks _) = ks
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 == tcList -> showChar '[' . shows x . showChar ']'
where
tcList = tyConOf @[] Proxy
[TypeRep _ ptrRepCon _ []]
| tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted
-> showChar '*'
| tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted
-> showChar '#'
where
tcTYPE = tyConOf @TYPE Proxy
tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy
tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy
[a,r] | tycon == tcFun -> 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
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
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 ')'
mkTypeLitTyCon :: String -> TyCon
mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name
typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
typeLitTypeRep :: String -> TypeRep
typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) []