[commit: ghc] ghc-8.6: Fix a nasty bug in piResultTys (a107cce)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.6
Link       : http://ghc.haskell.org/trac/ghc/changeset/a107cced37cb95c661b7c7cca1171b33eedf18a9/ghc

>---------------------------------------------------------------

commit a107cced37cb95c661b7c7cca1171b33eedf18a9
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jul 24 08:57:34 2018 +0100

    Fix a nasty bug in piResultTys
    
    I was failing to instantiate vigorously enough in Type.piResultTys
    and in the very similar function ToIface.toIfaceAppArgsX
    
    This caused Trac #15428.  The fix is easy.
    
    See Note [Care with kind instantiation] in Type.hs
    
    (cherry picked from commit e1b5a1174e42e390855b153015ce5227b3251d89)


>---------------------------------------------------------------

a107cced37cb95c661b7c7cca1171b33eedf18a9
 compiler/iface/ToIface.hs                          |  8 ++--
 compiler/types/Type.hs                             | 43 ++++++++++++++++++----
 testsuite/tests/typecheck/should_compile/T15428.hs |  9 +++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 4 files changed, 49 insertions(+), 12 deletions(-)

diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index d148e9a..dc9ea71 100644
--- a/compiler/iface/ToIface.hs
+++ b/compiler/iface/ToIface.hs
@@ -291,10 +291,10 @@ toIfaceTcArgsX fr tc ty_args
     go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
       = ITC_Vis (toIfaceTypeX fr t) (go env res ts)
 
-    go env (TyVarTy tv) ts
-      | Just ki <- lookupTyVar env tv = go env ki ts
-    go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
-                         ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded
+    go env ty ts = ASSERT2( not (isEmptyTCvSubst env)
+                          , ppr (tyConKind tc) $$ ppr ty_args )
+                   go (zapTCvSubst env) (substTy env ty) ts
+        -- See Note [Care with kind instantiation] in Type.hs
 
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 601eadb..ab0a449 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -1032,13 +1032,12 @@ piResultTys ty orig_args@(arg:args)
       | ForAllTy (TvBndr tv _) res <- ty
       = go (extendVarEnv tv_env tv arg) res args
 
-      | TyVarTy tv <- ty
-      , Just ty' <- lookupVarEnv tv_env tv
-        -- Deals with piResultTys (forall a. a) [forall b.b, Int]
-      = piResultTys ty' all_args
-
-      | otherwise
-      = pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
+      | otherwise  -- See Note [Care with kind instantiation]
+      = ASSERT2( not (isEmptyVarEnv tv_env)
+               , ppr ty $$ ppr orig_args $$ ppr all_args )
+        go emptyTvSubstEnv
+          (substTy (mkTvSubst in_scope tv_env) ty)
+          all_args
 
 applyTysX :: [TyVar] -> Type -> [Type] -> Type
 -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
@@ -1052,7 +1051,35 @@ applyTysX tvs body_ty arg_tys
     pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]
     n_tvs = length tvs
 
-{-
+
+
+{- Note [Care with kind instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  T :: forall k. k
+and we are finding the kind of
+  T (forall b. b -> b) * Int
+Then
+  T (forall b. b->b) :: k[ k :-> forall b. b->b]
+                     :: forall b. b -> b
+So
+  T (forall b. b->b) * :: (b -> b)[ b :-> *]
+                       :: * -> *
+
+In other words wwe must intantiate the forall!
+
+Similarly (Trac #154218)
+   S :: forall k f. k -> f k
+and we are finding the kind of
+   S * (* ->) Int Bool
+We have
+   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]
+              :: * -> * -> *
+So again we must instantiate.
+
+The same thing happens in ToIface.toIfaceAppArgsX.
+
+
 ---------------------------------------------------------------------
                                 TyConApp
                                 ~~~~~~~~
diff --git a/testsuite/tests/typecheck/should_compile/T15428.hs b/testsuite/tests/typecheck/should_compile/T15428.hs
new file mode 100644
index 0000000..a9d1cdd
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15428.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+module T15428 where
+
+data Flurmp
+type family Pure (x :: a) :: f a
+
+type T = Pure Flurmp Flurmp
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 1cc8cd8..1124247 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -641,3 +641,4 @@ def onlyHsParLocs(x):
                         and not "<no location info>" in loc)
     return '\n'.join(filteredLines)
 test('T15242', normalise_errmsg_fun(onlyHsParLocs), compile, [''])
+test('T15428', normal, compile, [''])