From 7fd3cd95f2b99edc02db0f56c8952a342801876f Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 19 Nov 2019 16:52:35 +0000
Subject: Remove an unnecessary zonk from tcInferApps

Removing zonking is good!

To do this it turned out to be convenient to make
matchExpectedFunKind return the result kind as well as
the coercion
---
 compiler/typecheck/TcHsType.hs | 11 +++++------
 compiler/typecheck/TcUnify.hs  | 18 +++++++++++-------
 2 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 008eb2b896..6ae7a4c444 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -1154,19 +1154,18 @@ tcInferApps_nosat mode orig_hs_ty fun orig_hs_args
       (HsValArg _ : _, Nothing)
         -> try_again_after_substing_or $
            do { let arrows_needed = n_initial_val_args all_args
-              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki
+              ; (co, co_res_kind) <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki
 
-              ; fun' <- zonkTcType (fun `mkTcCastTy` co)
-                     -- This zonk is essential, to expose the fruits
-                     -- of matchExpectedFunKind to the 'go' loop
+              ; let fun' = fun `mkTcCastTy` co
+                    -- NB:  typeKind fun' = co_res_kind
 
               ; traceTc "tcInferApps (no binder)" $
                    vcat [ ppr fun <+> dcolon <+> ppr fun_ki
                         , ppr arrows_needed
                         , ppr co
                         , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]
-              ; go_init n fun' all_args }
-                -- Use go_init to establish go's INVARIANT
+              ; go n fun' subst co_res_kind all_args }
+                -- NB: subst is empty but we need its in-scope set
       where
         instantiate ki_binder inner_ki
           = do { traceTc "tcInferApps (need to instantiate)"
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 9f9e69850d..d5842806d4 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -1685,7 +1685,7 @@ uUnfilledVar2 :: CtOrigin
               -> SwapFlag
               -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar
                                 --    definitely not a /filled/ meta-tyvar
-              -> TcTauType      -- Type 2, zonked
+              -> TcTauType      -- Type 2, zonked, to make occurs check easy
               -> TcM Coercion
 uUnfilledVar2 origin t_or_k swapped tv1 ty2
   = do { dflags  <- getDynFlags
@@ -2082,11 +2082,13 @@ matchExpectedFunKind
   => fun             -- ^ type, only for errors
   -> Arity           -- ^ n: number of desired arrows
   -> TcKind          -- ^ fun_ kind
-  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)
+  -> TcM (Coercion, TcKind)
+                     -- ^ co :: fun_kind ~ fun_kind'
+                     -- ^ fun_kind' = arg1 -> ... -> argn -> res
 
 matchExpectedFunKind hs_ty n k = go n k
   where
-    go 0 k = return (mkNomReflCo k)
+    go 0 k = return (mkNomReflCo k, k)
 
     go n k | Just k' <- tcView k = go n k'
 
@@ -2097,9 +2099,10 @@ matchExpectedFunKind hs_ty n k = go n k
                 Indirect fun_kind -> go n fun_kind
                 Flexi ->             defer n k }
 
-    go n (FunTy _ arg res)
-      = do { co <- go (n-1) res
-           ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }
+    go n (FunTy af arg res)
+      = do { (co, k') <- go (n-1) res
+           ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co
+                    , mkFunTy af arg  k') }
 
     go n other
      = defer n other
@@ -2113,7 +2116,8 @@ matchExpectedFunKind hs_ty n k = go n k
                                         , uo_thing    = Just (ppr hs_ty)
                                         , uo_visible  = True
                                         }
-           ; uType KindLevel origin k new_fun }
+           ; co <- uType KindLevel origin k new_fun
+           ; return (co, new_fun) }
 
 {- *********************************************************************
 *                                                                      *
-- 
cgit v1.2.1