Simplify bindLHsTyVarBndrs and bindHsQTyVarswip/simply-bind-tyvars

Both `bindLHsTyVarBndrs` and `bindHsQTyVars` take two separate
`Maybe` arguments, which I find terribly confusing. Thankfully, it's
possible to remove one `Maybe` argument from each of these functions,
which this patch accomplishes:

* `bindHsQTyVars` takes a `Maybe SDoc` argument, which is `Just` if
  GHC should warn about any of the quantified type variables going
  unused. However, every call site uses `Nothing` in practice. This
  makes sense, since it doesn't really make sense to warn about
  unused type variables bound by an `LHsQTyVars`. For instance, you
  wouldn't warn about the `a` in `data Proxy a = Proxy` going unused.

  As a result, I simply remove this `Maybe SDoc` argument altogether.
* `bindLHsTyVarBndrs` also takes a `Maybe SDoc` argument for the same
  reasons that `bindHsQTyVars` took one. To make things more
  confusing, however, `bindLHsTyVarBndrs` also takes a separate
  `HsDocContext` argument, which is pretty-printed (to an `SDoc`) in
  warnings and error messages.

  In practice, the `Maybe SDoc` and the `HsDocContext` often contain
  the same text. See the call sites for `bindLHsTyVarBndrs` in
  `rnFamInstEqn` and `rnConDecl`, for instance. There are only a
  handful of call sites where the text differs between the
  `Maybe SDoc` and `HsDocContext` arguments:

  * In `rnHsRuleDecl`, where the `Maybe SDoc` says "`In the rule`"
    and the `HsDocContext` says "`In the transformation rule`".
  * In `rnHsTyKi`/`rn_ty`, where the `Maybe SDoc` says
    "`In the type`" but the `HsDocContext` is inhereted from the
    surrounding context (e.g., if `rnHsTyKi` were called on a
    top-level type signature, the `HsDocContext` would be
    "`In the type signature`" instead)

  In both cases, warnings/error messages arguably _improve_ by
  unifying making the `Maybe SDoc`'s text match that of the
  `HsDocContext`. As a result, I decided to remove the `Maybe SDoc`
  argument to `bindLHsTyVarBndrs` entirely and simply reuse the text
  from the `HsDocContext`. (I decided to change the phrase
  "transformation rule" to "rewrite rule" while I was in the area.)

  The `Maybe SDoc` argument has one other purpose: signaling when to
  emit "`Unused quantified type variable`" warnings. To recover this
  functionality, I replaced the `Maybe SDoc` argument with a
  boolean-like `WarnUnusedForalls` argument. The only
  `bindLHsTyVarBndrs` call site that chooses _not_ to emit these
  warnings in `bindHsQTyVars`.

3 files changed, 77 insertions, 44 deletions

diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 5f82f6935a..18f2c9071e 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -23,8 +23,8 @@ module GHC.Rename.HsType (
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
-        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
+        rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
         extractHsTysRdrTyVarsDups,
         extractRdrKindSigVars, extractDataDefnKindVars,
@@ -41,9 +41,10 @@ import GHC.Driver.Session
 import GHC.Hs
 import GHC.Rename.Doc    ( rnLHsDoc, rnMbLHsDoc )
 import GHC.Rename.Env
-import GHC.Rename.Utils  ( HsDocContext(..), withHsDocContext, mapFvRn
-                         , pprHsDocContext, bindLocalNamesFV, typeAppErr
-                         , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
+import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext
+                         , mapFvRn, pprHsDocContext, bindLocalNamesFV
+                         , typeAppErr, newLocalBndrRn, checkDupRdrNames
+                         , checkShadowedRdrNames )
 import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
                          , lookupTyFixityRn )
 import GHC.Tc.Utils.Monad
@@ -203,9 +204,10 @@ rnWcBody ctxt nwc_rdrs hs_ty
 
     rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
     -- A lot of faff just to allow the extra-constraints wildcard to appear
-    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs
-                                , hst_body = hs_body })
-      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
+    rn_ty env (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs
+                          , hst_body = hs_body })
+      = bindLHsTyVarBndrs (rtke_ctxt env) WarnUnusedForalls
+                          Nothing tvs $ \ tvs' ->
         do { (hs_body', fvs) <- rn_lty env hs_body
            ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
                                 , hst_bndrs = tvs', hst_body = hs_body' }
@@ -534,7 +536,7 @@ rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
 rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars
                             , hst_body = tau })
   = do { checkPolyKinds env ty
-       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
+       ; bindLHsTyVarBndrs (rtke_ctxt env) WarnUnusedForalls
                            Nothing tyvars $ \ tyvars' ->
     do { (tau',  fvs) <- rnLHsTyKi env tau
        ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
@@ -845,11 +847,9 @@ bindLRdrNames rdrs thing_inside
 ---------------
 bindHsQTyVars :: forall a b.
                  HsDocContext
-              -> Maybe SDoc         -- Just d => check for unused tvs
-                                    --   d is a phrase like "in the type ..."
               -> Maybe a            -- Just _  => an associated type decl
               -> [Located RdrName]  -- Kind variables from scope, no dups
-              -> (LHsQTyVars GhcPs)
+              -> LHsQTyVars GhcPs
               -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
                   -- The Bool is True <=> all kind variables used in the
                   -- kind signature are bound on the left.  Reason:
@@ -863,7 +863,7 @@ bindHsQTyVars :: forall a b.
 --     and  (ii) mentioned in the kinds of hsq_bndrs
 -- (b) Bring type variables into scope
 --
-bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
+bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
   = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
              bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
 
@@ -888,7 +888,10 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
        ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
 
        ; bindLocalNamesFV implicit_kv_nms                     $
-         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+         bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+           -- This is the only call site for bindLHsTyVarBndrs where we pass
+           -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings.
+           -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars].
     do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
        ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
                               , hsq_explicit  = rn_bndrs })
@@ -990,17 +993,50 @@ variable in (a :: k), later in the binding. (This mistake lead to #14710.)
 So tvs is {k,a} and kvs is {k}.
 
 NB: we do this only at the binding site of 'tvs'.
+
+Note [Suppress -Wunused-foralls when binding LHsQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about
+explicit type variable binders that go unused (e.g., the `a` in
+`forall a. Int`). We almost always want to warn about these, since unused type
+variables can usually be deleted without any repercussions. There is one
+exception to this rule, however: binding LHsQTyVars. Consider this example:
+
+  data Proxy a = Proxy
+
+The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it
+into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it
+has a choice to make about whether to emit -Wunused-foralls warnings or not.
+If it /did/ emit warnings, then the `a` would be flagged as unused. However,
+this is not what we want! Removing the `a` in `Proxy a` would change its kind
+entirely, which is a huge price to pay for fixing a warning.
+
+Unlike other forms of type variable binders, dropping "unused" variables in
+an LHsQTyVars can be semantically significant. As a result, we suppress
+-Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
 -}
 
+-- | Should GHC warn if a quantified type variable goes unused? Usually, the
+-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we
+-- avoid emitting warnings.
+-- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@.
+data WarnUnusedForalls
+  = WarnUnusedForalls
+  | NoWarnUnusedForalls
+
+instance Outputable WarnUnusedForalls where
+  ppr wuf = text $ case wuf of
+    WarnUnusedForalls   -> "WarnUnusedForalls"
+    NoWarnUnusedForalls -> "NoWarnUnusedForalls"
+
 bindLHsTyVarBndrs :: (OutputableBndrFlag flag)
                   => HsDocContext
-                  -> Maybe SDoc            -- Just d => check for unused tvs
-                                           --   d is a phrase like "in the type ..."
+                  -> WarnUnusedForalls
                   -> Maybe a               -- Just _  => an associated type decl
                   -> [LHsTyVarBndr flag GhcPs]  -- User-written tyvars
                   -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
                   -> RnM (b, FreeVars)
-bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
+bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside
   = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
        ; checkDupRdrNames tv_names_w_loc
        ; go tv_bndrs thing_inside }
@@ -1014,9 +1050,9 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
                                 ; warn_unused b' fvs
                                 ; return (res, fvs) }
 
-    warn_unused tv_bndr fvs = case mb_in_doc of
-      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
-      Nothing     -> return ()
+    warn_unused tv_bndr fvs = case wuf of
+      WarnUnusedForalls   -> warnUnusedForAll doc tv_bndr fvs
+      NoWarnUnusedForalls -> return ()
 
 bindLHsTyVarBndr :: HsDocContext
                  -> Maybe a   -- associated class
@@ -1456,16 +1492,14 @@ dataKindsErr env thing
     pp_what | isRnKindLevel env = text "kind"
             | otherwise          = text "type"
 
-inTypeDoc :: HsType GhcPs -> SDoc
-inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
-
-warnUnusedForAll :: (OutputableBndrFlag flag) => SDoc -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
-warnUnusedForAll in_doc (L loc tv) used_names
+warnUnusedForAll :: OutputableBndrFlag flag
+                 => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
+warnUnusedForAll doc (L loc tv) used_names
   = whenWOptM Opt_WarnUnusedForalls $
     unless (hsTyVarName tv `elemNameSet` used_names) $
     addWarnAt (Reason Opt_WarnUnusedForalls) loc $
     vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
-         , in_doc ]
+         , inHsDocContext doc ]
 
 opTyErr :: Outputable a => RdrName -> a -> SDoc
 opTyErr op overall_ty
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 6c071217f8..5e9d4dec64 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -31,7 +31,7 @@ import GHC.Rename.HsType
 import GHC.Rename.Bind
 import GHC.Rename.Env
 import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
-                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
+                        , checkDupRdrNames, bindLocalNamesFV
                         , checkShadowedRdrNames, warnUnusedTypePatterns
                         , extendTyVarEnvFVRn, newLocalBndrsRn
                         , withHsDocContext )
@@ -720,7 +720,7 @@ rnFamInstEqn doc atfi rhs_kvars
              -- with a sensible binding location
        ; ((bndrs', pats', payload'), fvs)
               <- bindLocalNamesFV all_imp_var_names $
-                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                 bindLHsTyVarBndrs doc WarnUnusedForalls
                                    Nothing bndrs $ \bndrs' ->
                  -- Note: If we pass mb_cls instead of Nothing here,
                  --  bindLHsTyVarBndrs will use class variables for any names
@@ -1017,7 +1017,7 @@ rnHsRuleDecl (HsRule { rd_name = rule_name
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
        ; let doc = RuleCtx (snd $ unLoc rule_name)
-       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+       ; bindRuleTyVars doc tyvs $ \ tyvs' ->
          bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
@@ -1033,7 +1033,6 @@ rnHsRuleDecl (HsRule { rd_name = rule_name
     get_var :: RuleBndr GhcPs -> Located RdrName
     get_var (RuleBndrSig _ v _) = v
     get_var (RuleBndr _ v)      = v
-    in_rule = text "in the rule" <+> pprFullRuleName rule_name
 
 bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
                -> [LRuleBndr GhcPs] -> [Name]
@@ -1059,17 +1058,17 @@ bindRuleTmVars doc tyvs vars names thing_inside
     bind_free_tvs = case tyvs of Nothing -> AlwaysBind
                                  Just _  -> NeverBind
 
-bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr () GhcPs]
+bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
                -> (Maybe [LHsTyVarBndr () GhcRn]  -> RnM (b, FreeVars))
                -> RnM (b, FreeVars)
-bindRuleTyVars doc in_doc (Just bndrs) thing_inside
-  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
-bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+bindRuleTyVars doc (Just bndrs) thing_inside
+  = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ thing_inside = thing_inside Nothing
 
 {-
 Note [Rule LHS validity checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Check the shape of a transformation rule LHS.  Currently we only allow
+Check the shape of a rewrite rule LHS.  Currently we only allow
 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 @forall@'d variables.
 
@@ -1581,7 +1580,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
        ; let kvs = extractHsTyRdrTyVarsKindVars rhs
              doc = TySynCtx tycon
        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
-       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
+       ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ ->
     do { (rhs', fvs) <- rnTySyn doc rhs
        ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
                          , tcdFixity = fixity
@@ -1597,7 +1596,7 @@ rnTyClDecl (DataDecl
        ; let kvs = extractDataDefnKindVars defn
              doc = TyDataCtx tycon
        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
-       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
+       ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
     do { (defn', fvs) <- rnDataDefn doc defn
        ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig
        ; let rn_info = DataDeclRn { tcdDataCusk = cusk
@@ -1621,7 +1620,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 kvs tyvars $ \ tyvars' _ -> do
                   -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds fds
@@ -1878,7 +1877,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
                              , fdInjectivityAnn = injectivity })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; ((tyvars', res_sig', injectivity'), fv1) <-
-            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
+            bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->
             do { let rn_sig = rnFamResultSig doc
                ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
@@ -2080,7 +2079,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
         -- scoping we get.  So no implicit binders at the existential forall
 
         ; let ctxt = ConDeclCtx [new_name]
-        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+        ; bindLHsTyVarBndrs ctxt WarnUnusedForalls
                             Nothing ex_tvs $ \ new_ex_tvs ->
     do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
         ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
@@ -2118,11 +2117,11 @@ rnConDecl decl@(ConDeclGADT { con_names   = names
             $ extractHsTvBndrs explicit_tkvs
             $ extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
 
-        ; let ctxt    = ConDeclCtx new_names
-              mb_ctxt = Just (inHsDocContext ctxt)
+        ; let ctxt = ConDeclCtx new_names
 
         ; rnImplicitBndrs implicit_bndrs $ \ implicit_tkvs ->
-          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+          bindLHsTyVarBndrs ctxt WarnUnusedForalls
+                            Nothing explicit_tkvs $ \ explicit_tkvs ->
     do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
         ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
         ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 19a7c57cfb..f7ab9496f5 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -495,7 +495,7 @@ pprHsDocContext PatCtx                = text "a pattern type-signature"
 pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"
 pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
 pprHsDocContext DerivDeclCtx          = text "a deriving declaration"
-pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name
+pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)
 pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)
 pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)
 pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)