Fix #11811.

Previously, I had forgotten to omit variables already in scope
from the TypeInType CUSK check. Simple enough to fix.

Test case: typecheck/should_compile/T11811

2 files changed, 35 insertions, 31 deletions

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 89880422ea..ea7d036601 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -52,6 +52,7 @@ import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
+import Control.Arrow ( first )
 import Data.List ( sortBy )
 import Maybes( orElse, mapMaybe )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
@@ -801,7 +802,7 @@ rnTyFamDefltEqn :: Name
 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
                               , tfe_pats  = tyvars
                               , tfe_rhs   = rhs })
-  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' ->
+  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
     do { tycon'      <- lookupFamInstName (Just cls) tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
        ; return (TyFamEqn { tfe_tycon = tycon'
@@ -1251,7 +1252,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
        ; let doc = TySynCtx tycon
        ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
        ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
-                                    \ tyvars' ->
+                                    \ tyvars' _ ->
                                     do { (rhs', fvs) <- rnTySyn doc rhs
                                        ; return ((tyvars', rhs'), fvs) }
        ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
@@ -1265,9 +1266,11 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
        ; let doc = TyDataCtx tycon
        ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
        ; ((tyvars', defn', no_kvs), fvs)
-           <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' ->
-              do { ((defn', no_kvs), fvs) <- rnDataDefn doc defn
-                 ; return ((tyvars', defn', no_kvs), fvs) }
+           <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
+              do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
+                 ; let sig_tvs         = filterNameSet isTyVarName kind_sig_fvs
+                       unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
+                 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
           -- See Note [Complete user-supplied kind signatures] in HsDecls
        ; typeintype <- xoptM LangExt.TypeInType
        ; let cusk = hsTvbAllKinded tyvars' &&
@@ -1287,7 +1290,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
 
         -- Tyvars scope over superclass context and method signatures
         ; ((tyvars', context', fds', ats'), stuff_fvs)
-            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' -> do
+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
                   -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds fds
@@ -1398,22 +1401,18 @@ orphanRoleAnnotErr (L loc decl)
             text "is declared.")
 
 rnDataDefn :: HsDocContext -> HsDataDefn RdrName
-           -> RnM ((HsDataDefn Name, Bool), FreeVars)
-                -- the Bool is True if the DataDefn is consistent with
-                -- having a CUSK. See Note [Complete user-supplied kind signatures]
-                -- in HsDecls
+           -> RnM ((HsDataDefn Name, NameSet), FreeVars)
+                -- the NameSet includes all Names free in the kind signature
+                -- See Note [Complete user-supplied kind signatures]
 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                            , dd_ctxt = context, dd_cons = condecls
                            , dd_kindSig = m_sig, dd_derivs = derivs })
   = do  { checkTc (h98_style || null (unLoc context))
                   (badGadtStupidTheta doc)
 
-        ; (m_sig', cusk, sig_fvs) <- case m_sig of
-             Just sig -> do { fkvs <- freeKiTyVarsAllVars <$>
-                                      extractHsTyRdrTyVars sig
-                            ; (sig', fvs) <- rnLHsKind doc sig
-                            ; return (Just sig', null fkvs, fvs) }
-             Nothing  -> return (Nothing, True, emptyFVs)
+        ; (m_sig', sig_fvs) <- case m_sig of
+             Just sig -> first Just <$> rnLHsKind doc sig
+             Nothing  -> return (Nothing, emptyFVs)
         ; (context', fvs1) <- rnContext doc context
         ; (derivs',  fvs3) <- rn_derivs derivs
 
@@ -1433,7 +1432,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                                , dd_ctxt = context', dd_kindSig = m_sig'
                                , dd_cons = condecls'
                                , dd_derivs = derivs' }
-                  , cusk )
+                  , sig_fvs )
                  , all_fvs )
         }
   where
@@ -1464,7 +1463,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
        ; kvs <- extractRdrKindSigVars res_sig
        ; ((tyvars', res_sig', injectivity'), fv1) <-
             bindHsQTyVars doc Nothing mb_cls kvs tyvars $
-            \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) ->
+            \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
             do { let rn_sig = rnFamResultSig doc rn_kvs
                ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
@@ -1728,7 +1727,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
         ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
 
         ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
-          \new_tyvars -> do
+          \new_tyvars _ -> do
         { (new_context, fvs1) <- case mcxt of
                              Nothing   -> return (Nothing,emptyFVs)
                              Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index fc8dfa6724..08c157163f 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -25,6 +25,7 @@ module RnTypes (
         -- Binding related stuff
         bindLHsTyVarBndr,
         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        extractFilteredRdrTyVars,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
         extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
@@ -104,7 +105,7 @@ rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
 rn_hs_sig_wc_type no_implicit_if_forall ctxt
                   (HsIB { hsib_body = wc_ty }) thing_inside
   = do { let hs_ty = hswc_body wc_ty
-       ; free_vars <- extract_filtered_rdr_ty_vars hs_ty
+       ; free_vars <- extractFilteredRdrTyVars hs_ty
        ; (free_vars', nwc_rdrs) <- partition_nwcs free_vars
        ; rnImplicitBndrs no_implicit_if_forall free_vars' hs_ty $ \ vars ->
     do { rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
@@ -113,7 +114,7 @@ rn_hs_sig_wc_type no_implicit_if_forall ctxt
 
 rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
 rnHsWcType ctxt wc_ty@(HsWC { hswc_body = hs_ty })
-  = do { free_vars <- extract_filtered_rdr_ty_vars hs_ty
+  = do { free_vars <- extractFilteredRdrTyVars hs_ty
        ; (_, nwc_rdrs) <- partition_nwcs free_vars
        ; rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
          return (wc_ty', emptyFVs) }
@@ -148,7 +149,7 @@ rnWcSigTy :: RnTyKiEnv -> LHsType RdrName
 -- wildcard.  Some code duplication, but no big deal.
 rnWcSigTy env (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
   = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
-                      Nothing [] tvs $ \ _ tvs' _ ->
+                      Nothing [] tvs $ \ _ tvs' _ _ ->
     do { (hs_tau', fvs) <- rnWcSigTy env hs_tau
        ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
              awcs_bndrs = collectAnonWildCardsBndrs tvs'
@@ -197,13 +198,13 @@ rnWcSigContext env (L loc hs_ctxt)
     rn_top_constraint = rnLHsTyKi (env { rtke_what = RnTopConstraint })
 
 
--- | extract_filtered finds free type and kind variables in a type,
+-- | Finds free type and kind variables in a type,
 --     without duplicates, and
 --     without variables that are already in scope in LocalRdrEnv
 --   NB: this includes named wildcards, which look like perfectly
 --       ordinary type variables at this point
-extract_filtered_rdr_ty_vars :: LHsType RdrName -> RnM FreeKiTyVars
-extract_filtered_rdr_ty_vars hs_ty
+extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
+extractFilteredRdrTyVars hs_ty
   = do { rdr_env <- getLocalRdrEnv
        ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
 
@@ -248,7 +249,7 @@ rnHsSigType :: HsDocContext -> LHsSigType RdrName
 -- Used for source-language type signatures
 -- that cannot have wildcards
 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
-  = do { vars <- extract_filtered_rdr_ty_vars hs_ty
+  = do { vars <- extractFilteredRdrTyVars hs_ty
        ; rnImplicitBndrs True vars hs_ty $ \ vars ->
     do { (body', fvs) <- rnLHsType ctx hs_ty
        ; return (HsIB { hsib_vars = vars
@@ -454,7 +455,7 @@ rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
   = do { checkTypeInType env ty
        ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
-                           Nothing [] tyvars $ \ _ tyvars' _ ->
+                           Nothing [] tyvars $ \ _ tyvars' _ _ ->
     do { (tau',  fvs) <- rnLHsTyKi env tau
        ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
                 , fvs) } }
@@ -840,7 +841,10 @@ bindHsQTyVars :: forall a b.
               -> [Located RdrName]       -- Kind variables from scope, in l-to-r
                                          -- order, but not from ...
               -> (LHsQTyVars RdrName)     -- ... these user-written tyvars
-              -> (LHsQTyVars Name -> RnM (b, FreeVars))
+              -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars))
+                  -- also returns all names used in kind signatures, for the
+                  -- TypeInType clause of Note [Complete user-supplied kind
+                  -- signatures] in HsDecls
               -> RnM (b, FreeVars)
 -- (a) Bring kind variables into scope
 --     both (i)  passed in (kv_bndrs)
@@ -849,10 +853,10 @@ bindHsQTyVars :: forall a b.
 bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
   = do { bindLHsTyVarBndrs doc mb_in_doc
                            mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
-         \ rn_kvs rn_bndrs dep_var_set ->
+         \ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
          thing_inside (HsQTvs { hsq_implicit = rn_kvs
                               , hsq_explicit = rn_bndrs
-                              , hsq_dependent = dep_var_set }) }
+                              , hsq_dependent = dep_var_set }) all_dep_vars }
 
 bindLHsTyVarBndrs :: forall a b.
                      HsDocContext
@@ -867,6 +871,7 @@ bindLHsTyVarBndrs :: forall a b.
                       -> NameSet -- which names, from the preceding list,
                                  -- are used dependently within that list
                                  -- See Note [Dependent LHsQTyVars] in TcHsType
+                      -> NameSet -- all names used in kind signatures
                       -> RnM (b, FreeVars))
                   -> RnM (b, FreeVars)
 bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
@@ -910,7 +915,7 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
                                                ppr all_rn_kvs $$
                                                ppr all_rn_tvs $$
                                                ppr exp_dep_vars))
-           ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars }
+           ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
 
     warn_unused tv_bndr fvs = case mb_in_doc of
       Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs