[commit: ghc] ghc-8.2: Do zonking in tcLHsKindSig (3fedc0f)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/3fedc0fb5820243a1f47c883bb76b829a4a24c85/ghc

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

commit 3fedc0fb5820243a1f47c883bb76b829a4a24c85
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jun 28 12:34:41 2017 +0100

    Do zonking in tcLHsKindSig
    
    Trac #13879 showed that there was a missing zonk in tcLHsKind.
    
    I also renamed it to tcLHsKindSig, for consistency with type signatures
    There's a commment to explain why the zonk is needed.
    
    (cherry picked from commit c80920d26f4eef8e87c130412d007628cff7589d)


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

3fedc0fb5820243a1f47c883bb76b829a4a24c85
 compiler/typecheck/TcHsType.hs     | 20 ++++++++++++++------
 compiler/typecheck/TcTyClsDecls.hs | 10 +++++-----
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index f2369fe..7992174 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -37,7 +37,7 @@ module TcHsType (
         kindGeneralize,
 
         -- Sort-checking kinds
-        tcLHsKind,
+        tcLHsKindSig,
 
         -- Pattern type signatures
         tcHsPatSigType, tcPatSig, funAppCtxt
@@ -1427,7 +1427,7 @@ kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars
            ; return tv_pair }
 
     kc_hs_tv (KindedTyVar (L _ name) lhs_kind)
-      = do { kind <- tcLHsKind lhs_kind
+      = do { kind <- tcLHsKindSig lhs_kind
            ; tcHsTyVarName (Just kind) name }
 
     report_non_cusk_tvs all_tvs
@@ -1544,7 +1544,7 @@ tcHsTyVarBndr new_tv (UserTyVar (L _ name))
        ; new_tv name kind }
 
 tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)
-  = do { kind <- tcLHsKind kind
+  = do { kind <- tcLHsKindSig kind
        ; new_tv name kind }
 
 newWildTyVar :: Name -> TcM TcTyVar
@@ -2030,12 +2030,20 @@ unifyKinds act_kinds
 *                                                                      *
 ************************************************************************
 
-tcLHsKind converts a user-written kind to an internal, sort-checked kind.
+tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
 It does sort checking and desugaring at the same time, in one single pass.
 -}
 
-tcLHsKind :: LHsKind Name -> TcM Kind
-tcLHsKind = tc_lhs_kind kindLevelMode
+tcLHsKindSig :: LHsKind Name -> TcM Kind
+tcLHsKindSig hs_kind
+  = do { kind <- tc_lhs_kind kindLevelMode hs_kind
+       ; zonkTcType kind }
+         -- This zonk is very important in the case of higher rank kinds
+         -- E.g. Trac #13879    f :: forall (p :: forall z (y::z). <blah>).
+         --                          <more blah>
+         --      When instanting p's kind at occurrences of p in <more blah>
+         --      it's crucial that the kind we instantiate is fully zonked,
+         --      else we may fail to substitute properly
 
 tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind
 tc_lhs_kind mode k
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index b510db3..6c5c3aa 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -493,7 +493,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
   = do  { (tycon, _) <-
            kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $
            do { res_k <- case m_sig of
-                           Just ksig -> tcLHsKind ksig
+                           Just ksig -> tcLHsKindSig ksig
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
         ; return (mkTcTyConEnv tycon) }
@@ -508,7 +508,7 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name
                             False {- not open -} True ktvs $
             do  { res_k <- case kind_annotation rhs of
                             Nothing -> newMetaKindVar
-                            Just ksig -> tcLHsKind ksig
+                            Just ksig -> tcLHsKindSig ksig
                 ; return (res_k, ()) }
         ; return (mkTcTyConEnv tycon) }
   where
@@ -536,8 +536,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
   = do { (tycon, _) <-
            kcHsTyVarBndrs name unsat cusk open True ktvs $
            do { res_k <- case resultSig of
-                      KindSig ki                        -> tcLHsKind ki
-                      TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
+                      KindSig ki                        -> tcLHsKindSig ki
+                      TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki
                       _ -- open type families have * return kind by default
                         | open                     -> return liftedTypeKind
                         -- closed type families have their return kind inferred
@@ -1180,7 +1180,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats })
         ; discardResult $
           case mb_kind of
             Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind
-            Just k  -> do { k' <- tcLHsKind k
+            Just k  -> do { k' <- tcLHsKindSig k
                           ; unifyKind (Just hs_ty_pats) res_k k' } }
   where
     hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats