Turn infinite loop into a panic

In these two functions
  * TcIface.toIfaceAppTyArgsX
  * Type.piResultTys
we take a type application (f t1 .. tn) and try to find
its kind. It turned out that, if (f t1 .. tn) was ill-kinded
the function would go into an infinite loop.

That's not good: it caused the loop in Trac #15473.

This patch doesn't fix the bug in #15473, but it does turn the
loop into a decent panic, which is a step forward.

2 files changed, 22 insertions, 7 deletions

diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index 8452b8bac2..0b0782d6e8 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 4f0bcf8372..9b4aec670d 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