small refactor

2 files changed, 18 insertions, 14 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 714ec4095b..ab8accbd20 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -968,6 +968,10 @@ renameSigs ctxt sigs
 -- We'll just rename the INLINE prag to refer to whatever other 'op'
 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 -- Doesn't seem worth much trouble to sort this.
+--
+-- When ImplicitForAll has been disabled, we attach a hint about it if no forall
+-- is present, since the error messages about undeclared tyvars might be confusing
+-- otherwise to an observer who's not aware of the extension.
 
 renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
 renameSig _ (IdSig _ x)
@@ -981,7 +985,7 @@ renameSig ctxt sig@(TypeSig _ vs ty)
         ; return (TypeSig noAnn new_vs new_ty, fvs) }
   where
     -- Since this information is lost from here on, the existence of an outer forall in
-    -- conjunction with a manually disabled 'ImplicitForAll' is is observed as an
+    -- conjunction with a manually disabled 'ImplicitForAll' is observed as an
     -- 'OutOfScopeHint' here, so an error message about a missing type variable may alert
     -- the user of this fact.
     outOfScopeHint :: Bool -> LHsSigType GhcPs -> OutOfScopeHint
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 6a5e340f40..80ed3359dd 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -51,7 +51,7 @@ import GHC.Rename.Env
 import GHC.Rename.Doc
 import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV
                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN
-                         , checkShadowedRdrNames, warnForallIdentifier )
+                         , checkShadowedRdrNames, warnForallIdentifier, newLocalBndrsRn )
 import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
                          , lookupTyFixityRn )
 import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
@@ -235,19 +235,22 @@ rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of
       (res, fvs') <- thing_inside sig_ty
       return (res, fvs `plusFV` fvs')
 
-unboundWildcards :: FreeKiTyVars -> RnM [Name]
-unboundWildcards tyvars = do
-  new <- filterInScopeM tyvars
-  mapM newLocalBndrRn (nubL (wcs new))
-  where
-    wcs =
-      filter (startsWithUnderscore . rdrNameOcc . unLoc)
+is_wildcard :: LocatedN RdrName -> Bool
+is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
+
+rnNamedWildCards :: FreeKiTyVars -> RnM [Name]
+rnNamedWildCards tyvars =
+  xoptM LangExt.NamedWildCards >>= \case
+    True -> do
+      new <- filterInScopeM tyvars
+      newLocalBndrsRn (nubL (filter is_wildcard new))
+    False ->
+      pure []
 
 rnWcBody :: HsDocContext -> OutOfScopeHint -> [LocatedN RdrName] -> LHsType GhcPs
          -> RnM ([Name], LHsType GhcRn, FreeVars)
 rnWcBody ctxt hint tyvars hs_ty
-  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards
-       ; nwcs <- if wildcards_enabled then unboundWildcards tyvars else pure []
+  = do { nwcs <- rnNamedWildCards tyvars
        ; let env = RTKE { rtke_level = TypeLevel
                         , rtke_what  = RnTypeBody
                         , rtke_nwcs  = mkNameSet nwcs
@@ -354,9 +357,6 @@ partition_nwcs ctx free_vars
            if namedWildCardsAllowed ctx && wildcards_enabled
            then partition is_wildcard free_vars
            else ([], free_vars) }
-  where
-     is_wildcard :: LocatedN RdrName -> Bool
-     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
 
 {- Note [Renaming named wild cards]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~