diff options
Diffstat (limited to 'libraries/base/Data/Typeable/Internal.hs')
| -rw-r--r-- | libraries/base/Data/Typeable/Internal.hs | 66 |
1 files changed, 56 insertions, 10 deletions
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 008ac1b81b..39974b4052 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns #-} @@ -79,7 +80,10 @@ module Data.Typeable.Internal ( -- | These are for internal use only mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, - typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep + typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep, + + -- * For internal use + trLiftedRep ) where import GHC.Prim ( FUN ) @@ -375,7 +379,12 @@ mkTrCon tc kind_vars = TrTyCon -- constructor, so we need to build it here. fpTYPELiftedRep :: Fingerprint fpTYPELiftedRep = fingerprintFingerprints - [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep] + [ tyConFingerprint tyConTYPE + , fingerprintFingerprints + [ tyConFingerprint tyCon'BoxedRep + , tyConFingerprint tyCon'Lifted + ] + ] -- There is absolutely nothing to gain and everything to lose -- by inlining the worker. The wrapper should inline anyway. {-# NOINLINE fpTYPELiftedRep #-} @@ -383,7 +392,7 @@ fpTYPELiftedRep = fingerprintFingerprints trTYPE :: TypeRep TYPE trTYPE = typeRep -trLiftedRep :: TypeRep 'LiftedRep +trLiftedRep :: TypeRep ('BoxedRep 'Lifted) trLiftedRep = typeRep trMany :: TypeRep 'Many @@ -623,7 +632,7 @@ instantiateKindRep vars = go = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) go (KindRepFun a b) = SomeTypeRep $ mkTrFun trMany (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) - go (KindRepTYPE LiftedRep) = SomeTypeRep TrType + go (KindRepTYPE (BoxedRep Lifted)) = SomeTypeRep TrType go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r go (KindRepTypeLitS sort s) = mkTypeLitFromString sort (unpackCStringUtf8# s) @@ -662,8 +671,9 @@ buildList = foldr cons nil runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep runtimeRepTypeRep r = case r of - LiftedRep -> rep @'LiftedRep - UnliftedRep -> rep @'UnliftedRep + BoxedRep Lifted -> SomeKindedTypeRep trLiftedRep + BoxedRep v -> kindedTypeRep @_ @'BoxedRep + `kApp` levityTypeRep v VecRep c e -> kindedTypeRep @_ @'VecRep `kApp` vecCountTypeRep c `kApp` vecElemTypeRep e @@ -688,6 +698,15 @@ runtimeRepTypeRep r = rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep rep = kindedTypeRep @RuntimeRep @a +levityTypeRep :: Levity -> SomeKindedTypeRep Levity +levityTypeRep c = + case c of + Lifted -> rep @'Lifted + Unlifted -> rep @'Unlifted + where + rep :: forall (a :: Levity). Typeable a => SomeKindedTypeRep Levity + rep = kindedTypeRep @Levity @a + vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount vecCountTypeRep c = case c of @@ -840,13 +859,40 @@ splitApps = go [] -- produce a TypeRep for without difficulty), and then just substitute in the -- appropriate module and constructor names. -- +-- Prior to the introduction of BoxedRep, this was bad, but now it is +-- even worse! We have to construct several different TyCons by hand +-- so that we can build the fingerprint for TYPE ('BoxedRep 'LiftedRep). +-- If we call `typeRep @('BoxedRep 'LiftedRep)` while trying to compute +-- the fingerprint of `TYPE ('BoxedRep 'LiftedRep)`, we get a loop. +-- -- The ticket to find a better way to deal with this is -- #14480. + +tyConRuntimeRep :: TyCon +tyConRuntimeRep = mkTyCon ghcPrimPackage "GHC.Types" "RuntimeRep" 0 + (KindRepTYPE (BoxedRep Lifted)) + tyConTYPE :: TyCon -tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0 - (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep)) - where - liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep) +tyConTYPE = mkTyCon ghcPrimPackage "GHC.Prim" "TYPE" 0 + (KindRepFun + (KindRepTyConApp tyConRuntimeRep []) + (KindRepTYPE (BoxedRep Lifted)) + ) + +tyConLevity :: TyCon +tyConLevity = mkTyCon ghcPrimPackage "GHC.Types" "Levity" 0 + (KindRepTYPE (BoxedRep Lifted)) + +tyCon'Lifted :: TyCon +tyCon'Lifted = mkTyCon ghcPrimPackage "GHC.Types" "'Lifted" 0 + (KindRepTyConApp tyConLevity []) + +tyCon'BoxedRep :: TyCon +tyCon'BoxedRep = mkTyCon ghcPrimPackage "GHC.Types" "'BoxedRep" 0 + (KindRepFun (KindRepTyConApp tyConLevity []) (KindRepTyConApp tyConRuntimeRep [])) + +ghcPrimPackage :: String +ghcPrimPackage = tyConPackage (typeRepTyCon (typeRep @Bool)) funTyCon :: TyCon funTyCon = typeRepTyCon (typeRep @(->)) |