diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index 8452b8bac24bcb47a77f39927030a0a29a0f5627..0b0782d6e8a559def9b44d74be3b0ef5691f1c11 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -305,11 +305,20 @@ toIfaceAppArgsX fr kind ty_args go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps = IA_Vis (toIfaceTypeX fr t) (go env res ts) - go env ty ts = ASSERT2( not (isEmptyTCvSubst env) - , ppr kind $$ ppr ty_args ) - go (zapTCvSubst env) (substTy env ty) ts + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapTCvSubst env) (substTy env ty) ts -- See Note [Care with kind instantiation] in Type.hs + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473) + WARN( True, ppr kind $$ ppr ty_args ) + IA_Vis (toIfaceTypeX fr t1) (go env ty ts1) + tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 4f0bcf83722265ae5e2c6f0f429ab6f7ca57fe84..9b4aec670db2198368f7cc61a9a39a279da3d7e2 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -1048,13 +1048,19 @@ piResultTys ty orig_args@(arg:args) | ForAllTy (TvBndr tv _) res <- ty = go (extendVarEnv tv_env tv arg) res args - | otherwise -- See Note [Care with kind instantiation] - = ASSERT2( not (isEmptyVarEnv tv_env) - , ppr ty $$ ppr orig_args $$ ppr all_args ) - go emptyTvSubstEnv + | not (isEmptyVarEnv tv_env) -- See Note [Care with kind instantiation] + = go emptyTvSubstEnv (substTy (mkTvSubst in_scope tv_env) ty) all_args + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without hte explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infniite loop, which is very unhelpful + -- c.f. Trac #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + applyTysX :: [TyVar] -> Type -> [Type] -> Type -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed