summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsBinds.hs17
-rw-r--r--compiler/prelude/PrelNames.hs25
-rw-r--r--compiler/typecheck/TcTypeable.hs16
-rw-r--r--libraries/base/Data/Typeable/Internal.hs200
-rw-r--r--libraries/base/GHC/Show.hs38
-rw-r--r--libraries/base/Type/Reflection/Unsafe.hs11
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break006.stderr4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print019.stderr2
-rw-r--r--testsuite/tests/indexed-types/should_fail/T12522a.stderr2
-rw-r--r--testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr2
-rw-r--r--testsuite/tests/typecheck/should_compile/holes2.stderr2
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail133.stderr2
12 files changed, 251 insertions, 70 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index e11f580842..3048871d7f 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1239,10 +1239,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
-- Note that we use the kind of the type, not the TyCon from which it
-- is constructed since the latter may be kind polymorphic whereas the
-- former we know is not (we checked in the solver).
- ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty)
- , Type ty
- , tc_rep
- , kind_args ]
+ ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+ , Type ty
+ , tc_rep
+ , kind_args ]
+ -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+ ; return expr
}
ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
@@ -1253,8 +1255,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
-- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
-- TypeRep a -> TypeRep b -> TypeRep (a b)
; let (k1, k2) = splitFunTy (typeKind t1)
- ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
- [ e1, e2 ] }
+ ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+ [ e1, e2 ]
+ -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+ ; return expr
+ }
ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
| Just (t1,t2) <- splitFunTy_maybe ty
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index f418348fcd..47b146559f 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -240,6 +240,7 @@ basicKnownKeyNames
typeLitSymbolDataConName,
typeLitNatDataConName,
typeRepIdName,
+ mkTrTypeName,
mkTrConName,
mkTrAppName,
mkTrFunName,
@@ -1256,6 +1257,7 @@ typeableClassName
, typeRepTyConName
, someTypeRepTyConName
, someTypeRepDataConName
+ , mkTrTypeName
, mkTrConName
, mkTrAppName
, mkTrFunName
@@ -1269,6 +1271,7 @@ typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeR
someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey
someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey
typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey
+mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey
mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey
mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey
mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey
@@ -2329,6 +2332,7 @@ proxyHashKey = mkPreludeMiscIdUnique 502
-- Used to make `Typeable` dictionaries
mkTyConKey
+ , mkTrTypeKey
, mkTrConKey
, mkTrAppKey
, mkTrFunKey
@@ -2337,12 +2341,13 @@ mkTyConKey
, typeRepIdKey
:: Unique
mkTyConKey = mkPreludeMiscIdUnique 503
-mkTrConKey = mkPreludeMiscIdUnique 504
-mkTrAppKey = mkPreludeMiscIdUnique 505
-typeNatTypeRepKey = mkPreludeMiscIdUnique 506
-typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507
-typeRepIdKey = mkPreludeMiscIdUnique 508
-mkTrFunKey = mkPreludeMiscIdUnique 509
+mkTrTypeKey = mkPreludeMiscIdUnique 504
+mkTrConKey = mkPreludeMiscIdUnique 505
+mkTrAppKey = mkPreludeMiscIdUnique 506
+typeNatTypeRepKey = mkPreludeMiscIdUnique 507
+typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508
+typeRepIdKey = mkPreludeMiscIdUnique 509
+mkTrFunKey = mkPreludeMiscIdUnique 510
-- Representations for primitive types
trTYPEKey
@@ -2350,10 +2355,10 @@ trTYPEKey
, trRuntimeRepKey
, tr'PtrRepLiftedKey
:: Unique
-trTYPEKey = mkPreludeMiscIdUnique 510
-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511
-trRuntimeRepKey = mkPreludeMiscIdUnique 512
-tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 513
+trTYPEKey = mkPreludeMiscIdUnique 511
+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512
+trRuntimeRepKey = mkPreludeMiscIdUnique 513
+tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514
-- KindReps for common cases
starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index ed4b5483ef..6fa875b8d3 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -655,17 +655,20 @@ The TypeRep encoding of `Proxy Type Int` looks like this:
$tcProxy :: GHC.Types.TyCon
$trInt :: TypeRep Int
- $trType :: TypeRep Type
+ TrType :: TypeRep Type
$trProxyType :: TypeRep (Proxy Type :: Type -> Type)
$trProxyType = TrTyCon $tcProxy
- [$trType] -- kind variable instantiation
+ [TrType] -- kind variable instantiation
+ (tyConKind $tcProxy [TrType]) -- The TypeRep of
+ -- Type -> Type
$trProxy :: TypeRep (Proxy Type Int)
- $trProxy = TrApp $trProxyType $trInt
+ $trProxy = TrApp $trProxyType $trInt TrType
$tkProxy :: GHC.Types.KindRep
- $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
+ $tkProxy = KindRepFun (KindRepVar 0)
+ (KindRepTyConApp (KindRepTYPE LiftedRep) [])
Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
polymorphic types. So instead
@@ -679,9 +682,10 @@ polymorphic types. So instead
Proxy :: forall k. k->Type
* A KindRep is just a recipe that we can instantiate with the
- argument kinds, using Data.Typeable.Internal.instantiateKindRep.
+ argument kinds, using Data.Typeable.Internal.tyConKind and
+ store in the relevant 'TypeRep' constructor.
- Data.Typeable.Internal.typeRepKind uses instantiateKindRep
+ Data.Typeable.Internal.typeRepKind looks up the stored kinds.
* In a KindRep, the kind variables are represented by 0-indexed
de Bruijn numbers:
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 221dfb58b4..d2ed9d1500 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -75,7 +75,7 @@ module Data.Typeable.Internal (
-- * Construction
-- | These are for internal use only
- mkTrCon, mkTrApp, mkTrFun,
+ mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,
mkTyCon, mkTyCon#,
typeSymbolTypeRep, typeNatTypeRep,
) where
@@ -97,6 +97,7 @@ import {-# SOURCE #-} GHC.Fingerprint
-- Better to break the loop here, because we want non-SOURCE imports
-- of Data.Typeable as much as possible so we can optimise the derived
-- instances.
+-- import {-# SOURCE #-} Debug.Trace (trace)
#include "MachDeps.h"
@@ -178,6 +179,8 @@ rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k
-- | A concrete representation of a (monomorphic) type.
-- 'TypeRep' supports reasonably efficient equality.
data TypeRep (a :: k) where
+ -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2
+ TrType :: TypeRep Type
TrTyCon :: { -- See Note [TypeRep fingerprints]
trTyConFingerprint :: {-# UNPACK #-} !Fingerprint
@@ -186,7 +189,8 @@ data TypeRep (a :: k) where
-- 'Just :: Bool -> Maybe Bool, the trTyCon will be
-- 'Just and the trKindVars will be [Bool].
, trTyCon :: !TyCon
- , trKindVars :: [SomeTypeRep] }
+ , trKindVars :: [SomeTypeRep]
+ , trTyConKind :: !(TypeRep k) } -- See Note [Kind caching]
-> TypeRep (a :: k)
-- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)
@@ -198,8 +202,9 @@ data TypeRep (a :: k) where
-- The TypeRep represents the application of trAppFun
-- to trAppArg. For Maybe Int, the trAppFun will be Maybe
-- and the trAppArg will be Int.
- , trAppFun :: TypeRep (a :: k1 -> k2)
- , trAppArg :: TypeRep (b :: k1) }
+ , trAppFun :: !(TypeRep (a :: k1 -> k2))
+ , trAppArg :: !(TypeRep (b :: k1))
+ , trAppKind :: !(TypeRep k2) } -- See Note [Kind caching]
-> TypeRep (a b)
-- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for
@@ -211,8 +216,8 @@ data TypeRep (a :: k) where
-- The TypeRep represents a function from trFunArg to
-- trFunRes.
- , trFunArg :: TypeRep a
- , trFunRes :: TypeRep b }
+ , trFunArg :: !(TypeRep a)
+ , trFunRes :: !(TypeRep b) }
-> TypeRep (a -> b)
{- Note [TypeRep fingerprints]
@@ -222,6 +227,63 @@ us to test whether two TypeReps are equal in constant time, rather than
having to walk their full structures.
-}
+{- Note [Kind caching]
+ ~~~~~~~~~~~~~~~~~~~
+
+We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.
+This is necessary to ensure that typeRepKind (which is used, at least, in
+deserialization and dynApply) is cheap. There are two reasons for this:
+
+1. Calculating the kind of a nest of type applications, such as
+
+ F X Y Z W (App (App (App (App F X) Y) Z) W)
+
+is linear in the depth, which is already a bit pricy. In deserialization,
+we build up such a nest from the inside out, so without caching, that ends
+up taking quadratic time, and calculating the KindRep of the constructor,
+F, a linear number of times. See #14254.
+
+2. Calculating the kind of a type constructor, in instantiateTypeRep,
+requires building (allocating) a TypeRep for the kind "from scratch".
+This can get pricy. When combined with point (1), we can end up with
+a large amount of extra allocation deserializing very deep nests.
+See #14337.
+
+It is quite possible to speed up deserialization by structuring that process
+very carefully. Unfortunately, that doesn't help dynApply or anything else
+that may use typeRepKind. Since caching the kind isn't terribly expensive, it
+seems better to just do that and solve all the potential problems at once.
+
+There are two things we need to be careful about when caching kinds.
+
+Wrinkle 1:
+
+We want to do it eagerly. Suppose we have
+
+ tf :: TypeRep (f :: j -> k)
+ ta :: TypeRep (a :: j)
+
+Then the cached kind of App tf ta should be eagerly evaluated to k, rather
+than being stored as a thunk that will strip the (j ->) off of j -> k if
+and when it is forced.
+
+Wrinkle 2:
+
+We need to be able to represent TypeRep Type. This is a bit tricky because
+typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the
+typerep of the kind of Type, we will have a loop. One simple way to do this
+is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.
+
+But we *do not* want TypeReps to have cyclical structure! Most importantly,
+a cyclical structure cannot be stored in a compact region. Secondarily,
+using :force in GHCi on a cyclical structure will lead to non-termination.
+
+To avoid this trouble, we use a separate constructor for TypeRep Type.
+mkTrApp is responsible for recognizing that TYPE is being applied to
+'LiftedRep and produce trType; other functions must recognize that TrType
+represents an application.
+-}
+
-- Compare keys for equality
-- | @since 2.01
@@ -278,10 +340,15 @@ pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}
--
-- @since 4.8.0.0
typeRepFingerprint :: TypeRep a -> Fingerprint
+typeRepFingerprint TrType = fpTYPELiftedRep
typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr
typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr
typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr
+-- For compiler use
+mkTrType :: TypeRep Type
+mkTrType = TrType
+
-- | Construct a representation for a type constructor
-- applied at a monomorphic kind.
--
@@ -292,39 +359,74 @@ 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
+
+-- The fingerprint of Type. We don't store this in the TrType
+-- constructor, so we need to build it here.
+fpTYPELiftedRep :: Fingerprint
+fpTYPELiftedRep = fingerprintFingerprints
+ [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep]
+-- There is absolutely nothing to gain and everything to lose
+-- by inlining the worker. The wrapper should inline anyway.
+{-# NOINLINE fpTYPELiftedRep #-}
+
+trTYPE :: TypeRep TYPE
+trTYPE = typeRep
--- | Construct a representation for a type application.
+trLiftedRep :: TypeRep 'LiftedRep
+trLiftedRep = typeRep
+
+-- | Construct a representation for a type application that is
+-- NOT a saturated arrow type. This is not checked!
-- Note that this is known-key to the compiler, which uses it in desugar
--- 'Typeable' evidence. See Note [Kind caching]
+-- 'Typeable' evidence.
mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep (a :: k1 -> k2)
-> TypeRep (b :: k1)
-> TypeRep (a b)
-mkTrApp rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x}) (y :: TypeRep y)
- | TrTyCon {trTyCon=con} <- p
- , con == funTyCon -- cheap check first
- , 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
-mkTrApp a b = TrApp
+mkTrApp a b -- See Note [Kind caching], Wrinkle 2
+ | 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]
+-- | Construct a representation for a type application that
+-- may be a saturated arrow type. This is renamed to mkTrApp in
+-- Type.Reflection.Unsafe
+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 -- cheap check first
+ , 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
+
-- | A type application.
--
-- For instance,
@@ -347,7 +449,7 @@ 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 -> Just (IsApp f x))
- where App f x = mkTrApp f x
+ where App f x = mkTrAppChecked f x
data IsApp (a :: k) where
IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
@@ -356,6 +458,7 @@ data IsApp (a :: k) where
splitApp :: forall k (a :: k). ()
=> TypeRep a
-> Maybe (IsApp a)
+splitApp TrType = Just (IsApp trTYPE trLiftedRep)
splitApp (TrApp {trAppFun = f, trAppArg = x}) = Just (IsApp f x)
splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = Just (IsApp (mkTrApp arr a) b)
where arr = bareArrow rep
@@ -407,6 +510,7 @@ someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t
-- | Observe the type constructor of a type representation
typeRepTyCon :: TypeRep a -> TyCon
+typeRepTyCon TrType = tyConTYPE
typeRepTyCon (TrTyCon {trTyCon = tc}) = tc
typeRepTyCon (TrApp {trAppFun = a}) = typeRepTyCon a
typeRepTyCon (TrFun {}) = typeRepTyCon $ typeRep @(->)
@@ -429,15 +533,10 @@ eqTypeRep a b
-- | Observe the kind of a type.
typeRepKind :: TypeRep (a :: k) -> TypeRep k
-typeRepKind (TrTyCon {trTyCon = tc, trKindVars = args})
- = unsafeCoerceRep $ tyConKind tc args
-typeRepKind (TrApp {trAppFun = f})
- | TrFun {trFunRes = res} <- typeRepKind f
- = res
- | otherwise
- = error ("Ill-kinded type application: " ++ show (typeRepKind f))
-typeRepKind (TrFun {})
- = typeRep @Type
+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 =
@@ -458,7 +557,7 @@ instantiateKindRep vars = go
applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
applyTy (SomeTypeRep acc) ty
| SomeTypeRep ty' <- go ty
- = SomeTypeRep $ mkTrApp (unsafeCoerce acc) (unsafeCoerce ty')
+ = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'
in foldl' applyTy tycon_app ty_args
go (KindRepVar var)
= vars A.! var
@@ -466,6 +565,7 @@ instantiateKindRep vars = go
= 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)
@@ -570,12 +670,14 @@ data IsTYPE (a :: Type) where
-- | Is a type of the form @TYPE rep@?
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"
@@ -617,9 +719,8 @@ instance Show (TypeRep (a :: k)) where
showTypeable :: Int -> TypeRep (a :: k) -> ShowS
+showTypeable _ TrType = showChar '*'
showTypeable _ rep
- | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) =
- showChar '*'
| isListTyCon tc, [ty] <- tys =
showChar '[' . shows ty . showChar ']'
| isTupleTyCon tc =
@@ -656,13 +757,33 @@ splitApps = go []
go [] (TrFun {trFunArg = a, trFunRes = b})
= (funTyCon, [SomeTypeRep a, SomeTypeRep b])
go _ (TrFun {})
- = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible"
+ = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
+ go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
+ go _ TrType
+ = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"
+
+-- This is incredibly shady! We don't really want to do this here; we
+-- should really have the compiler reveal the TYPE TyCon directly
+-- somehow. We need to construct this by hand because otherwise
+-- we end up with horrible and somewhat mysterious loops trying to calculate
+-- typeRep @TYPE. For the moment, we use the fact that we can get the proper
+-- name of the ghc-prim package from the TyCon of LiftedRep (which we can
+-- produce a TypeRep for without difficulty), and then just substitute in the
+-- appropriate module and constructor names.
+--
+-- The ticket to find a better way to deal with this is
+-- Trac #14480.
+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 [Int])
+isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])
isTupleTyCon :: TyCon -> Bool
isTupleTyCon tc
@@ -678,12 +799,11 @@ showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
--
-- @since 4.8.0.0
rnfTypeRep :: TypeRep a -> ()
-rnfTypeRep (TrTyCon {trTyCon = tyc})
- = rnfTyCon tyc
-rnfTypeRep (TrApp {trAppFun = f, trAppArg = x})
- = rnfTypeRep f `seq` rnfTypeRep x
-rnfTypeRep (TrFun {trFunArg = x, trFunRes = y})
- = rnfTypeRep x `seq` rnfTypeRep y
+-- The TypeRep structure is almost entirely strict by definition. The
+-- fingerprinting and strict kind caching ensure that everything
+-- else is forced anyway. So we don't need to do anything special
+-- to reduce to normal form.
+rnfTypeRep !_ = ()
-- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@
-- implementation
diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs
index 980b4a7d85..d1c607556e 100644
--- a/libraries/base/GHC/Show.hs
+++ b/libraries/base/GHC/Show.hs
@@ -53,6 +53,8 @@ import GHC.Base
import GHC.List ((!!), foldr1, break)
import GHC.Num
import GHC.Stack.Types
+import GHC.Types (TypeLitSort (..))
+
-- | The @shows@ functions return a function that prepends the
-- output 'String' to an existing 'String'. This allows constant-time
@@ -547,3 +549,39 @@ integerToString n0 cs0
c@(C# _) -> jblock' (d - 1) q (c : cs)
where
(q, r) = n `quotRemInt` 10
+
+instance Show KindRep where
+ showsPrec d (KindRepVar v) = showParen (d > 10) $
+ showString "KindRepVar " . showsPrec 11 v
+ showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $
+ showString "KindRepTyConApp "
+ . showsPrec 11 p
+ . showString " "
+ . showsPrec 11 q
+ showsPrec d (KindRepApp p q) = showParen (d > 10) $
+ showString "KindRepApp "
+ . showsPrec 11 p
+ . showString " "
+ . showsPrec 11 q
+ showsPrec d (KindRepFun p q) = showParen (d > 10) $
+ showString "KindRepFun "
+ . showsPrec 11 p
+ . showString " "
+ . showsPrec 11 q
+ showsPrec d (KindRepTYPE rep) = showParen (d > 10) $
+ showString "KindRepTYPE " . showsPrec 11 rep
+ showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $
+ showString "KindRepTypeLitS "
+ . showsPrec 11 p
+ . showString " "
+ . showsPrec 11 (unpackCString# q)
+ showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $
+ showString "KindRepTypeLitD "
+ . showsPrec 11 p
+ . showString " "
+ . showsPrec 11 q
+
+deriving instance Show RuntimeRep
+deriving instance Show VecCount
+deriving instance Show VecElem
+deriving instance Show TypeLitSort
diff --git a/libraries/base/Type/Reflection/Unsafe.hs b/libraries/base/Type/Reflection/Unsafe.hs
index c0f2327706..9a8af16f36 100644
--- a/libraries/base/Type/Reflection/Unsafe.hs
+++ b/libraries/base/Type/Reflection/Unsafe.hs
@@ -12,6 +12,7 @@
-- type representations.
--
-----------------------------------------------------------------------------
+{-# LANGUAGE TypeInType, ScopedTypeVariables #-}
module Type.Reflection.Unsafe (
-- * Type representations
@@ -22,4 +23,12 @@ module Type.Reflection.Unsafe (
, TyCon, mkTrCon, tyConKindRep, tyConKindArgs, tyConFingerprint
) where
-import Data.Typeable.Internal
+import Data.Typeable.Internal hiding (mkTrApp)
+import qualified Data.Typeable.Internal as TI
+
+-- | Construct a representation for a type application.
+mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+ TypeRep (a :: k1 -> k2)
+ -> TypeRep (b :: k1)
+ -> TypeRep (a b)
+mkTrApp = TI.mkTrAppChecked
diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr
index 8bd838dffe..a9429d92a7 100644
--- a/testsuite/tests/ghci.debugger/scripts/break006.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr
@@ -9,7 +9,7 @@
instance Show Integer -- Defined in ‘GHC.Show’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
...plus 22 others
- ...plus 12 instances involving out-of-scope types
+ ...plus 17 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
@@ -23,6 +23,6 @@
instance Show Integer -- Defined in ‘GHC.Show’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
...plus 22 others
- ...plus 12 instances involving out-of-scope types
+ ...plus 17 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr
index 29d5317b97..70432f5558 100644
--- a/testsuite/tests/ghci.debugger/scripts/print019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr
@@ -9,6 +9,6 @@
instance Show TyCon -- Defined in ‘GHC.Show’
instance Show Integer -- Defined in ‘GHC.Show’
...plus 29 others
- ...plus 13 instances involving out-of-scope types
+ ...plus 18 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/indexed-types/should_fail/T12522a.stderr b/testsuite/tests/indexed-types/should_fail/T12522a.stderr
index 94ef226601..d7a4f06b8c 100644
--- a/testsuite/tests/indexed-types/should_fail/T12522a.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T12522a.stderr
@@ -11,7 +11,7 @@ T12522a.hs:20:26: error:
instance Show Integer -- Defined in ‘GHC.Show’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
...plus 22 others
- ...plus six instances involving out-of-scope types
+ ...plus 11 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the first argument of ‘(++)’, namely ‘show n’
In the second argument of ‘($)’, namely ‘show n ++ s’
diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
index 1c5ab2ee61..5ece21fca5 100644
--- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
+++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
@@ -8,7 +8,7 @@ overloadedlistsfail01.hs:5:8: error:
instance Show Integer -- Defined in ‘GHC.Show’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
...plus 22 others
- ...plus 7 instances involving out-of-scope types
+ ...plus 12 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the expression: print [1]
In an equation for ‘main’: main = print [1]
diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr
index 9cca0e214d..37c206cf8d 100644
--- a/testsuite/tests/typecheck/should_compile/holes2.stderr
+++ b/testsuite/tests/typecheck/should_compile/holes2.stderr
@@ -9,7 +9,7 @@ holes2.hs:3:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
instance Show Ordering -- Defined in ‘GHC.Show’
instance Show Integer -- Defined in ‘GHC.Show’
...plus 23 others
- ...plus 62 instances involving out-of-scope types
+ ...plus 67 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the expression: show _
In an equation for ‘f’: f = show _
diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr
index bf37f16141..80e5ea7e28 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr
@@ -12,7 +12,7 @@ tcfail133.hs:68:7: error:
instance (Number a, Digit b, Show a, Show b) => Show (a :@ b)
-- Defined at tcfail133.hs:11:54
...plus 25 others
- ...plus six instances involving out-of-scope types
+ ...plus 11 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the expression: show $ add (One :@ Zero) (One :@ One)
In an equation for ‘foo’:
View Lorry Controller Status