(original) (raw)

{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}

module Data.Typeable.Internal (

[Fingerprint](GHC.Fingerprint.Type.html#Fingerprint)(..),


[Typeable](Data.Typeable.Internal.html#Typeable)(..),
[withTypeable](Data.Typeable.Internal.html#withTypeable),


Module,  
[moduleName](Data.Typeable.Internal.html#moduleName), [modulePackage](Data.Typeable.Internal.html#modulePackage), [rnfModule](Data.Typeable.Internal.html#rnfModule),


TyCon,   
[tyConPackage](Data.Typeable.Internal.html#tyConPackage), [tyConModule](Data.Typeable.Internal.html#tyConModule), [tyConName](Data.Typeable.Internal.html#tyConName), [tyConKindArgs](Data.Typeable.Internal.html#tyConKindArgs), [tyConKindRep](Data.Typeable.Internal.html#tyConKindRep),
[tyConFingerprint](Data.Typeable.Internal.html#tyConFingerprint),
KindRep(.., [KindRepTypeLit](Data.Typeable.Internal.html#KindRepTypeLit)), TypeLitSort(..),
[rnfTyCon](Data.Typeable.Internal.html#rnfTyCon),


[TypeRep](Data.Typeable.Internal.html#TypeRep),
pattern [App](Data.Typeable.Internal.html#App), pattern [Con](Data.Typeable.Internal.html#Con), pattern [Con'](Data.Typeable.Internal.html#Con%27), pattern [Fun](Data.Typeable.Internal.html#Fun),
[typeRep](Data.Typeable.Internal.html#typeRep),
[typeOf](Data.Typeable.Internal.html#typeOf),
[typeRepTyCon](Data.Typeable.Internal.html#typeRepTyCon),
[typeRepFingerprint](Data.Typeable.Internal.html#typeRepFingerprint),
[rnfTypeRep](Data.Typeable.Internal.html#rnfTypeRep),
[eqTypeRep](Data.Typeable.Internal.html#eqTypeRep),
[typeRepKind](Data.Typeable.Internal.html#typeRepKind),
[splitApps](Data.Typeable.Internal.html#splitApps),


[SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep)(..),
[someTypeRep](Data.Typeable.Internal.html#someTypeRep),
[someTypeRepTyCon](Data.Typeable.Internal.html#someTypeRepTyCon),
[someTypeRepFingerprint](Data.Typeable.Internal.html#someTypeRepFingerprint),
[rnfSomeTypeRep](Data.Typeable.Internal.html#rnfSomeTypeRep),


[mkTrType](Data.Typeable.Internal.html#mkTrType), [mkTrCon](Data.Typeable.Internal.html#mkTrCon), [mkTrApp](Data.Typeable.Internal.html#mkTrApp), [mkTrAppChecked](Data.Typeable.Internal.html#mkTrAppChecked), [mkTrFun](Data.Typeable.Internal.html#mkTrFun),
[mkTyCon](Data.Typeable.Internal.html#mkTyCon), [mkTyCon#](Data.Typeable.Internal.html#mkTyCon%23),
[typeSymbolTypeRep](Data.Typeable.Internal.html#typeSymbolTypeRep), [typeNatTypeRep](Data.Typeable.Internal.html#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 {-# SOURCE #-} 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

data TypeRep (a :: k) where

[TrType](Data.Typeable.Internal.html#TrType) :: [TypeRep](Data.Typeable.Internal.html#TypeRep) Type
[TrTyCon](Data.Typeable.Internal.html#TrTyCon) :: { 
             [trTyConFingerprint](Data.Typeable.Internal.html#trTyConFingerprint) :: {-# UNPACK #-} ![Fingerprint](GHC.Fingerprint.Type.html#Fingerprint)
             
             
           , [trTyCon](Data.Typeable.Internal.html#trTyCon) :: !TyCon
           , [trKindVars](Data.Typeable.Internal.html#trKindVars) :: [[SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep)]
           , [trTyConKind](Data.Typeable.Internal.html#trTyConKind) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) [k](#local-6989586621679248348)) }  
        -> [TypeRep](Data.Typeable.Internal.html#TypeRep) ([a](#local-6989586621679248349) :: [k](#local-6989586621679248348))


[TrApp](Data.Typeable.Internal.html#TrApp)   :: forall [k1](#local-6989586621679248350) [k2](#local-6989586621679248351) ([a](#local-6989586621679248352) :: [k1](#local-6989586621679248350) -> [k2](#local-6989586621679248351)) ([b](#local-6989586621679248353) :: [k1](#local-6989586621679248350)).
           { 
             [trAppFingerprint](Data.Typeable.Internal.html#trAppFingerprint) :: {-# UNPACK #-} ![Fingerprint](GHC.Fingerprint.Type.html#Fingerprint)
             
             
           , [trAppFun](Data.Typeable.Internal.html#trAppFun) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) ([a](#local-6989586621679248352) :: [k1](#local-6989586621679248350) -> [k2](#local-6989586621679248351)))
           , [trAppArg](Data.Typeable.Internal.html#trAppArg) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) ([b](#local-6989586621679248353) :: [k1](#local-6989586621679248350)))
           , [trAppKind](Data.Typeable.Internal.html#trAppKind) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) [k2](#local-6989586621679248351)) }   
        -> [TypeRep](Data.Typeable.Internal.html#TypeRep) ([a](#local-6989586621679248352) [b](#local-6989586621679248353))


[TrFun](Data.Typeable.Internal.html#TrFun)   :: forall ([r1](#local-6989586621679248354) :: RuntimeRep) ([r2](#local-6989586621679248355) :: RuntimeRep)
                  ([a](#local-6989586621679248356) :: TYPE [r1](#local-6989586621679248354)) ([b](#local-6989586621679248357) :: TYPE [r2](#local-6989586621679248355)).
           { 
             [trFunFingerprint](Data.Typeable.Internal.html#trFunFingerprint) :: {-# UNPACK #-} ![Fingerprint](GHC.Fingerprint.Type.html#Fingerprint)
             
             
           , [trFunArg](Data.Typeable.Internal.html#trFunArg) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) [a](#local-6989586621679248356))
           , [trFunRes](Data.Typeable.Internal.html#trFunRes) :: !([TypeRep](Data.Typeable.Internal.html#TypeRep) [b](#local-6989586621679248357)) }
        -> [TypeRep](Data.Typeable.Internal.html#TypeRep) ([a](#local-6989586621679248356) -> [b](#local-6989586621679248357))

instance Eq (TypeRep a) where _ == _ = True {-# INLINABLE (==) #-}

instance TestEquality TypeRep where a [testEquality](Data.Type.Equality.html#testEquality) b | Just HRefl <- eqTypeRep a b = Just Refl | otherwise = Nothing {-# INLINEABLE testEquality #-}

instance Ord (TypeRep a) where compare _ _ = EQ {-# INLINABLE compare #-}

data SomeTypeRep where SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep

instance Eq SomeTypeRep where SomeTypeRep a == SomeTypeRep b = case a [eqTypeRep](Data.Typeable.Internal.html#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]

{-# NOINLINE fpTYPELiftedRep #-}

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](Data.Typeable.Internal.html#eqTypeRep) trTYPE , Just HRefl <- b [eqTypeRep](Data.Typeable.Internal.html#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](Data.Typeable.Internal.html#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](Data.Typeable.Internal.html#IsCon) :: [IsApplication](Data.Type.Equality.html#~) [a](#local-6989586621679248343) ~ "" => TyCon -> [[SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep)] -> [AppOrCon](Data.Typeable.Internal.html#AppOrCon) [a](#local-6989586621679248343)

type family IsApplication (x :: k) :: Symbol where IsApplication (_ _) = "An error message about this unifying with "" " [AppendSymbol](GHC.TypeLits.html#AppendSymbol) "means that you tried to match a TypeRep with Con or " [AppendSymbol](GHC.TypeLits.html#AppendSymbol) "Con' when the represented type was known to be an " [AppendSymbol](GHC.TypeLits.html#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)

{-# COMPLETE Fun, App, Con #-} {-# COMPLETE Fun, App, Con' #-}

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

{-# INLINABLE eqTypeRep #-}

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](#local-6989586621679248543) = [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [$](GHC.Base.html#%24) [mkTrCon](Data.Typeable.Internal.html#mkTrCon) [tc](#local-6989586621679248538) ([map](GHC.Base.html#map) [go](#local-6989586621679248536) [kind_args](#local-6989586621679248541))
        
        applyTy :: [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) -> KindRep -> [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep)
        [applyTy](#local-6989586621679248544) ([SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [acc](#local-6989586621679248545)) [ty](#local-6989586621679248546)
          | [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [ty'](#local-6989586621679248547) <- [go](#local-6989586621679248536) [ty](#local-6989586621679248546)
          = [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [$](GHC.Base.html#%24) [mkTrApp](Data.Typeable.Internal.html#mkTrApp) ([unsafeCoerce](Unsafe.Coerce.html#unsafeCoerce) [acc](#local-6989586621679248545)) [ty'](#local-6989586621679248547)
    in [foldl'](GHC.List.html#foldl%27) [applyTy](#local-6989586621679248544) [tycon_app](#local-6989586621679248543) [ty_args](#local-6989586621679248542)
go (KindRepVar [var](#local-6989586621679248548))
  = [vars](#local-6989586621679248535) [A.!](GHC.Arr.html#%21) [var](#local-6989586621679248548)
go (KindRepApp [f](#local-6989586621679248549) [a](#local-6989586621679248550))
  = [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [$](GHC.Base.html#%24) [mkTrApp](Data.Typeable.Internal.html#mkTrApp) ([unsafeCoerceRep](Data.Typeable.Internal.html#unsafeCoerceRep) [$](GHC.Base.html#%24) [go](#local-6989586621679248536) [f](#local-6989586621679248549)) ([unsafeCoerceRep](Data.Typeable.Internal.html#unsafeCoerceRep) [$](GHC.Base.html#%24) [go](#local-6989586621679248536) [a](#local-6989586621679248550))
go (KindRepFun [a](#local-6989586621679248551) [b](#local-6989586621679248552))
  = [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [$](GHC.Base.html#%24) [mkTrFun](Data.Typeable.Internal.html#mkTrFun) ([unsafeCoerceRep](Data.Typeable.Internal.html#unsafeCoerceRep) [$](GHC.Base.html#%24) [go](#local-6989586621679248536) [a](#local-6989586621679248551)) ([unsafeCoerceRep](Data.Typeable.Internal.html#unsafeCoerceRep) [$](GHC.Base.html#%24) [go](#local-6989586621679248536) [b](#local-6989586621679248552))
go (KindRepTYPE LiftedRep) = [SomeTypeRep](Data.Typeable.Internal.html#SomeTypeRep) [TrType](Data.Typeable.Internal.html#TrType)
go (KindRepTYPE [r](#local-6989586621679248553)) = [unkindedTypeRep](Data.Typeable.Internal.html#unkindedTypeRep) [$](GHC.Base.html#%24) [tYPE](#local-6989586621679248537) `[kApp](Data.Typeable.Internal.html#kApp)` [runtimeRepTypeRep](Data.Typeable.Internal.html#runtimeRepTypeRep) [r](#local-6989586621679248553)
go (KindRepTypeLitS [sort](#local-6989586621679248554) [s](#local-6989586621679248555))
  = [mkTypeLitFromString](Data.Typeable.Internal.html#mkTypeLitFromString) [sort](#local-6989586621679248554) (unpackCStringUtf8# [s](#local-6989586621679248555))
go (KindRepTypeLitD [sort](#local-6989586621679248556) [s](#local-6989586621679248557))
  = [mkTypeLitFromString](Data.Typeable.Internal.html#mkTypeLitFromString) [sort](#local-6989586621679248556) [s](#local-6989586621679248557)

[tYPE](#local-6989586621679248537) = [kindedTypeRep](Data.Typeable.Internal.html#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](Data.Typeable.Internal.html#kApp) x [kApp](Data.Typeable.Internal.html#kApp) rest

runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep runtimeRepTypeRep r = case r of LiftedRep -> rep @'LiftedRep UnliftedRep -> rep @'UnliftedRep VecRep c e -> kindedTypeRep @_ @'VecRep [kApp](Data.Typeable.Internal.html#kApp) vecCountTypeRep c [kApp](Data.Typeable.Internal.html#kApp) vecElemTypeRep e TupleRep rs -> kindedTypeRep @_ @'TupleRep [kApp](Data.Typeable.Internal.html#kApp) buildList (map runtimeRepTypeRep rs) SumRep rs -> kindedTypeRep @_ @'SumRep [kApp](Data.Typeable.Internal.html#kApp) buildList (map runtimeRepTypeRep rs) IntRep -> rep @'IntRep WordRep -> rep @'WordRep Int64Rep -> rep @'Int64Rep 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](Data.Typeable.Internal.html#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) {-# INLINE typeRep #-}

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 = 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](GHC.List.html#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

{-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun, KindRepTYPE, KindRepTypeLit #-}

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]