module Data.Typeable.Internal (
Fingerprint(..),
Typeable(..),
withTypeable,
Module,
moduleName, modulePackage, rnfModule,
TyCon,
tyConPackage, tyConModule, tyConName, tyConKindArgs, tyConKindRep,
tyConFingerprint,
KindRep(.., KindRepTypeLit), TypeLitSort(..),
rnfTyCon,
TypeRep,
pattern App, pattern Con, pattern Con', pattern Fun,
typeRep,
typeOf,
typeRepTyCon,
typeRepFingerprint,
rnfTypeRep,
eqTypeRep,
typeRepKind,
splitApps,
SomeTypeRep(..),
someTypeRep,
someTypeRepTyCon,
someTypeRepFingerprint,
rnfSomeTypeRep,
mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,
mkTyCon, mkTyCon#,
typeSymbolTypeRep, typeNatTypeRep,
) where
import GHC.Base
import qualified GHC.Arr as A
import GHC.Types ( TYPE )
import Data.Type.Equality
import GHC.List ( splitAt, foldl', elem )
import GHC.Word
import GHC.Show
import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol )
import GHC.TypeNats ( KnownNat, natVal' )
import Unsafe.Coerce ( unsafeCoerce )
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) = unpackCStringUtf8# s
trNameString (TrNameD s) = s
tyConFingerprint :: TyCon -> Fingerprint
tyConFingerprint (TyCon hi lo _ _ _ _)
= Fingerprint (W64# hi) (W64# lo)
tyConKindArgs :: TyCon -> Int
tyConKindArgs (TyCon _ _ _ _ n _) = I# n
tyConKindRep :: TyCon -> KindRep
tyConKindRep (TyCon _ _ _ _ _ k) = k
rnfModule :: Module -> ()
rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
rnfTrName :: TrName -> ()
rnfTrName (TrNameS _) = ()
rnfTrName (TrNameD n) = rnfString n
rnfKindRep :: KindRep -> ()
rnfKindRep (KindRepTyConApp tc args) = rnfTyCon tc `seq` rnfList rnfKindRep args
rnfKindRep (KindRepVar _) = ()
rnfKindRep (KindRepApp a b) = rnfKindRep a `seq` rnfKindRep b
rnfKindRep (KindRepFun a b) = rnfKindRep a `seq` rnfKindRep b
rnfKindRep (KindRepTYPE rr) = rnfRuntimeRep rr
rnfKindRep (KindRepTypeLitS _ _) = ()
rnfKindRep (KindRepTypeLitD _ t) = rnfString t
rnfRuntimeRep :: RuntimeRep -> ()
rnfRuntimeRep (VecRep !_ !_) = ()
rnfRuntimeRep !_ = ()
rnfList :: (a -> ()) -> [a] -> ()
rnfList _ [] = ()
rnfList force (x:xs) = force x `seq` rnfList force xs
rnfString :: [Char] -> ()
rnfString = rnfList (`seq` ())
rnfTyCon :: TyCon -> ()
rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k
type TypeRep :: k -> Type
data TypeRep a where
TrType :: TypeRep Type
TrTyCon :: {
trTyConFingerprint :: !Fingerprint
, trTyCon :: !TyCon
, trKindVars :: [SomeTypeRep]
, trTyConKind :: !(TypeRep k) }
-> TypeRep (a :: k)
TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
{
trAppFingerprint :: !Fingerprint
, trAppFun :: !(TypeRep (a :: k1 -> k2))
, trAppArg :: !(TypeRep (b :: k1))
, trAppKind :: !(TypeRep k2) }
-> TypeRep (a b)
TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
{
trFunFingerprint :: !Fingerprint
, trFunArg :: !(TypeRep a)
, trFunRes :: !(TypeRep b) }
-> TypeRep (a -> b)
instance Eq (TypeRep a) where
_ == _ = True
instance TestEquality TypeRep where
a `testEquality` b
| Just HRefl <- eqTypeRep a b
= Just Refl
| otherwise
= Nothing
instance Ord (TypeRep a) where
compare _ _ = EQ
data SomeTypeRep where
SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep
instance Eq SomeTypeRep where
SomeTypeRep a == SomeTypeRep b =
case a `eqTypeRep` b of
Just _ -> True
Nothing -> False
instance Ord SomeTypeRep where
SomeTypeRep a `compare` SomeTypeRep b =
typeRepFingerprint a `compare` typeRepFingerprint b
pattern Fun :: forall k (fun :: k). ()
=> forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(arg :: TYPE r1) (res :: TYPE r2).
(k ~ Type, fun ~~ (arg -> res))
=> TypeRep arg
-> TypeRep res
-> TypeRep fun
pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}
where Fun arg res = mkTrFun arg res
typeRepFingerprint :: TypeRep a -> Fingerprint
typeRepFingerprint TrType = fpTYPELiftedRep
typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr
typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr
typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr
mkTrType :: TypeRep Type
mkTrType = TrType
mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon tc kind_vars = TrTyCon
{ trTyConFingerprint = fpr
, trTyCon = tc
, trKindVars = kind_vars
, trTyConKind = kind }
where
fpr_tc = tyConFingerprint tc
fpr_kvs = map someTypeRepFingerprint kind_vars
fpr = fingerprintFingerprints (fpr_tc:fpr_kvs)
kind = unsafeCoerceRep $ tyConKind tc kind_vars
fpTYPELiftedRep :: Fingerprint
fpTYPELiftedRep = fingerprintFingerprints
[tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep]
trTYPE :: TypeRep TYPE
trTYPE = typeRep
trLiftedRep :: TypeRep 'LiftedRep
trLiftedRep = typeRep
mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep (a :: k1 -> k2)
-> TypeRep (b :: k1)
-> TypeRep (a b)
mkTrApp a b
| Just HRefl <- a `eqTypeRep` trTYPE
, Just HRefl <- b `eqTypeRep` trLiftedRep
= TrType
| TrFun {trFunRes = res_kind} <- typeRepKind a
= TrApp
{ trAppFingerprint = fpr
, trAppFun = a
, trAppArg = b
, trAppKind = res_kind }
| otherwise = error ("Ill-kinded type application: "
++ show (typeRepKind a))
where
fpr_a = typeRepFingerprint a
fpr_b = typeRepFingerprint b
fpr = fingerprintFingerprints [fpr_a, fpr_b]
mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep (a :: k1 -> k2)
-> TypeRep (b :: k1)
-> TypeRep (a b)
mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})
(y :: TypeRep y)
| TrTyCon {trTyCon=con} <- p
, con == funTyCon
, Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
, Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
, Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
$ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
= mkTrFun x y
mkTrAppChecked a b = mkTrApp a b
pattern App :: forall k2 (t :: k2). ()
=> forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
=> TypeRep a -> TypeRep b -> TypeRep t
pattern App f x <- (splitApp -> IsApp f x)
where App f x = mkTrAppChecked f x
data AppOrCon (a :: k) where
IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
=> TypeRep f -> TypeRep x -> AppOrCon (f x)
IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a
type family IsApplication (x :: k) :: Symbol where
IsApplication (_ _) = "An error message about this unifying with \"\" "
`AppendSymbol` "means that you tried to match a TypeRep with Con or "
`AppendSymbol` "Con' when the represented type was known to be an "
`AppendSymbol` "application."
IsApplication _ = ""
splitApp :: forall k (a :: k). ()
=> TypeRep a
-> AppOrCon a
splitApp TrType = IsApp trTYPE trLiftedRep
splitApp (TrApp {trAppFun = f, trAppArg = x}) = IsApp f x
splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = IsApp (mkTrApp arr a) b
where arr = bareArrow rep
splitApp (TrTyCon{trTyCon = con, trKindVars = kinds})
= case unsafeCoerce Refl :: IsApplication a :~: "" of
Refl -> IsCon con kinds
withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()
=> TypeRep a -> (Typeable a => r) -> r
withTypeable rep k = unsafeCoerce k' rep
where k' :: Gift a r
k' = Gift k
newtype Gift a (r :: TYPE rep) = Gift (Typeable a => r)
pattern Con :: forall k (a :: k). ()
=> IsApplication a ~ ""
=> TyCon -> TypeRep a
pattern Con con <- (splitApp -> IsCon con _)
pattern Con' :: forall k (a :: k). ()
=> IsApplication a ~ ""
=> TyCon -> [SomeTypeRep] -> TypeRep a
pattern Con' con ks <- (splitApp -> IsCon con ks)
someTypeRepTyCon :: SomeTypeRep -> TyCon
someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t
typeRepTyCon :: TypeRep a -> TyCon
typeRepTyCon TrType = tyConTYPE
typeRepTyCon (TrTyCon {trTyCon = tc}) = tc
typeRepTyCon (TrApp {trAppFun = a}) = typeRepTyCon a
typeRepTyCon (TrFun {}) = typeRepTyCon $ typeRep @(->)
eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep a b
| sameTypeRep a b = Just (unsafeCoerce# HRefl)
| otherwise = Nothing
sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Bool
sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b
typeRepKind :: TypeRep (a :: k) -> TypeRep k
typeRepKind TrType = TrType
typeRepKind (TrTyCon {trTyConKind = kind}) = kind
typeRepKind (TrApp {trAppKind = kind}) = kind
typeRepKind (TrFun {}) = typeRep @Type
tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep
tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars =
let kindVarsArr :: A.Array KindBndr SomeTypeRep
kindVarsArr = A.listArray (0, I# (nKindVars# -# 1#)) kindVars
in instantiateKindRep kindVarsArr kindRep
instantiateKindRep :: A.Array KindBndr SomeTypeRep -> KindRep -> SomeTypeRep
instantiateKindRep vars = go
where
go :: KindRep -> SomeTypeRep
go (KindRepTyConApp tc args)
= let n_kind_args = tyConKindArgs tc
(kind_args, ty_args) = splitAt n_kind_args args
tycon_app = SomeTypeRep $ mkTrCon tc (map go kind_args)
applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
applyTy (SomeTypeRep acc) ty
| SomeTypeRep ty' <- go ty
= SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'
in foldl' applyTy tycon_app ty_args
go (KindRepVar var)
= vars A.! var
go (KindRepApp f a)
= SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
go (KindRepFun a b)
= SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
go (KindRepTYPE LiftedRep) = SomeTypeRep TrType
go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
go (KindRepTypeLitS sort s)
= mkTypeLitFromString sort (unpackCStringUtf8# s)
go (KindRepTypeLitD sort s)
= mkTypeLitFromString sort s
tYPE = kindedTypeRep @(RuntimeRep -> Type) @TYPE
unsafeCoerceRep :: SomeTypeRep -> TypeRep a
unsafeCoerceRep (SomeTypeRep r) = unsafeCoerce r
unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep
unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x
data SomeKindedTypeRep k where
SomeKindedTypeRep :: forall k (a :: k). TypeRep a
-> SomeKindedTypeRep k
kApp :: SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k
-> SomeKindedTypeRep k'
kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =
SomeKindedTypeRep (mkTrApp f a)
kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep = SomeKindedTypeRep (typeRep @a)
buildList :: forall k. Typeable k
=> [SomeKindedTypeRep k]
-> SomeKindedTypeRep [k]
buildList = foldr cons nil
where
nil = kindedTypeRep @[k] @'[]
cons x rest = SomeKindedTypeRep (typeRep @'(:)) `kApp` x `kApp` rest
runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep
runtimeRepTypeRep r =
case r of
LiftedRep -> rep @'LiftedRep
UnliftedRep -> rep @'UnliftedRep
VecRep c e -> kindedTypeRep @_ @'VecRep
`kApp` vecCountTypeRep c
`kApp` vecElemTypeRep e
TupleRep rs -> kindedTypeRep @_ @'TupleRep
`kApp` buildList (map runtimeRepTypeRep rs)
SumRep rs -> kindedTypeRep @_ @'SumRep
`kApp` buildList (map runtimeRepTypeRep rs)
IntRep -> rep @'IntRep
Int8Rep -> rep @'Int8Rep
Int16Rep -> rep @'Int16Rep
Int32Rep -> rep @'Int32Rep
Int64Rep -> rep @'Int64Rep
WordRep -> rep @'WordRep
Word8Rep -> rep @'Word8Rep
Word16Rep -> rep @'Word16Rep
Word32Rep -> rep @'Word32Rep
Word64Rep -> rep @'Word64Rep
AddrRep -> rep @'AddrRep
FloatRep -> rep @'FloatRep
DoubleRep -> rep @'DoubleRep
where
rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep
rep = kindedTypeRep @RuntimeRep @a
vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount
vecCountTypeRep c =
case c of
Vec2 -> rep @'Vec2
Vec4 -> rep @'Vec4
Vec8 -> rep @'Vec8
Vec16 -> rep @'Vec16
Vec32 -> rep @'Vec32
Vec64 -> rep @'Vec64
where
rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
rep = kindedTypeRep @VecCount @a
vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem
vecElemTypeRep e =
case e of
Int8ElemRep -> rep @'Int8ElemRep
Int16ElemRep -> rep @'Int16ElemRep
Int32ElemRep -> rep @'Int32ElemRep
Int64ElemRep -> rep @'Int64ElemRep
Word8ElemRep -> rep @'Word8ElemRep
Word16ElemRep -> rep @'Word16ElemRep
Word32ElemRep -> rep @'Word32ElemRep
Word64ElemRep -> rep @'Word64ElemRep
FloatElemRep -> rep @'FloatElemRep
DoubleElemRep -> rep @'DoubleElemRep
where
rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep = kindedTypeRep @VecElem @a
bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2). ()
=> TypeRep (a -> b)
-> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
bareArrow (TrFun _ a b) =
mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]
where
rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1
rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2
bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"
data IsTYPE (a :: Type) where
IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)
isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
isTYPE TrType = Just (IsTYPE trLiftedRep)
isTYPE (TrApp {trAppFun=f, trAppArg=r})
| Just HRefl <- f `eqTypeRep` typeRep @TYPE
= Just (IsTYPE r)
isTYPE _ = Nothing
getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
getRuntimeRep TrType = trLiftedRep
getRuntimeRep (TrApp {trAppArg=r}) = r
getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"
class Typeable (a :: k) where
typeRep# :: TypeRep a
typeRep :: Typeable a => TypeRep a
typeRep = typeRep#
typeOf :: Typeable a => a -> TypeRep a
typeOf _ = typeRep
someTypeRep :: forall proxy a. Typeable a => proxy a -> SomeTypeRep
someTypeRep _ = SomeTypeRep (typeRep :: TypeRep a)
someTypeRepFingerprint :: SomeTypeRep -> Fingerprint
someTypeRepFingerprint (SomeTypeRep t) = typeRepFingerprint t
instance Show (TypeRep (a :: k)) where
showsPrec = showTypeable
showTypeable :: Int -> TypeRep (a :: k) -> ShowS
showTypeable _ TrType = showChar '*'
showTypeable _ rep
| isListTyCon tc, [ty] <- tys =
showChar '[' . shows ty . showChar ']'
| isTupleTyCon tc,
Just _ <- TrType `eqTypeRep` typeRepKind rep =
showChar '(' . showArgs (showChar ',') tys . showChar ')'
where (tc, tys) = splitApps rep
showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []})
= showTyCon tycon
showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})
= showParen (p > 9) $
showTyCon tycon .
showChar ' ' .
showArgs (showChar ' ') args
showTypeable p (TrFun {trFunArg = x, trFunRes = r})
= showParen (p > 8) $
showsPrec 9 x . showString " -> " . showsPrec 8 r
showTypeable p (TrApp {trAppFun = f, trAppArg = x})
= showParen (p > 9) $
showsPrec 8 f .
showChar ' ' .
showsPrec 10 x
instance Show SomeTypeRep where
showsPrec p (SomeTypeRep ty) = showsPrec p ty
splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
splitApps = go []
where
go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
go xs (TrTyCon {trTyCon = tc})
= (tc, xs)
go xs (TrApp {trAppFun = f, trAppArg = x})
= go (SomeTypeRep x : xs) f
go [] (TrFun {trFunArg = a, trFunRes = b})
= (funTyCon, [SomeTypeRep a, SomeTypeRep b])
go _ (TrFun {})
= errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
go _ TrType
= errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"
tyConTYPE :: TyCon
tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0
(KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep))
where
liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep)
funTyCon :: TyCon
funTyCon = typeRepTyCon (typeRep @(->))
isListTyCon :: TyCon -> Bool
isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])
isTupleTyCon :: TyCon -> Bool
isTupleTyCon tc
| ('(':',':_) <- tyConName tc = True
| otherwise = False
isOperatorTyCon :: TyCon -> Bool
isOperatorTyCon tc
| symb : _ <- tyConName tc
, symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True
| otherwise = False
showTyCon :: TyCon -> ShowS
showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon)
showArgs :: Show a => ShowS -> [a] -> ShowS
showArgs _ [] = id
showArgs _ [a] = showsPrec 10 a
showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
rnfTypeRep :: TypeRep a -> ()
rnfTypeRep !_ = ()
rnfSomeTypeRep :: SomeTypeRep -> ()
rnfSomeTypeRep (SomeTypeRep r) = rnfTypeRep r
pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep
pattern KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t))
where
KindRepTypeLit sort t = KindRepTypeLitD sort t
getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)
getKindRepTypeLit (KindRepTypeLitS sort t) = Just (sort, unpackCStringUtf8# t)
getKindRepTypeLit (KindRepTypeLitD sort t) = Just (sort, t)
getKindRepTypeLit _ = Nothing
mkTyCon# :: Addr#
-> Addr#
-> Addr#
-> Int#
-> KindRep
-> TyCon
mkTyCon# pkg modl name n_kinds kind_rep
| Fingerprint (W64# hi) (W64# lo) <- fingerprint
= TyCon hi lo mod (TrNameS name) n_kinds kind_rep
where
mod = Module (TrNameS pkg) (TrNameS modl)
fingerprint :: Fingerprint
fingerprint = mkTyConFingerprint (unpackCStringUtf8# pkg)
(unpackCStringUtf8# modl)
(unpackCStringUtf8# name)
mkTyCon :: String
-> String
-> String
-> Int
-> KindRep
-> TyCon
mkTyCon pkg modl name (I# n_kinds) kind_rep
| Fingerprint (W64# hi) (W64# lo) <- fingerprint
= TyCon hi lo mod (TrNameD name) n_kinds kind_rep
where
mod = Module (TrNameD pkg) (TrNameD modl)
fingerprint :: Fingerprint
fingerprint = mkTyConFingerprint pkg modl name
mkTyConFingerprint :: String
-> String
-> String
-> Fingerprint
mkTyConFingerprint pkg_name mod_name tycon_name =
fingerprintFingerprints
[ fingerprintString pkg_name
, fingerprintString mod_name
, fingerprintString tycon_name
]
mkTypeLitTyCon :: String -> TyCon -> TyCon
mkTypeLitTyCon name kind_tycon
= mkTyCon "base" "GHC.TypeLits" name 0 kind
where kind = KindRepTyConApp kind_tycon []
typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a
typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) tcNat
typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) tcSymbol
mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
mkTypeLitFromString TypeLitSymbol s =
SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol)
mkTypeLitFromString TypeLitNat s =
SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat)
tcSymbol :: TyCon
tcSymbol = typeRepTyCon (typeRep @Symbol)
tcNat :: TyCon
tcNat = typeRepTyCon (typeRep @Nat)
typeLitTypeRep :: forall k (a :: k). (Typeable k) =>
String -> TyCon -> TypeRep a
typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) []
mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type)
mkTrFun arg res = TrFun
{ trFunFingerprint = fpr
, trFunArg = arg
, trFunRes = res }
where fpr = fingerprintFingerprints [ typeRepFingerprint arg
, typeRepFingerprint res]