Added a new warning about compatibility with RequiredTypeArguments

This commit introduces a new warning
that indicates code incompatible with
future extension: RequiredTypeArguments.

Enabling this extension may break some code and the warning
will help to make it compatible in advance.

11 files changed, 88 insertions, 4 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index ed77b81ebd..4f656041df 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -628,6 +628,7 @@ data WarningFlag =
    | Opt_WarnGADTMonoLocalBinds                      -- Since 9.4
    | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4
    | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4
+   | Opt_WarnTermVariableCapture
    deriving (Eq, Ord, Show, Enum)
 
 -- | Return the names of a WarningFlag
@@ -639,6 +640,7 @@ warnFlagNames wflag = case wflag of
   Opt_WarnAlternativeLayoutRuleTransitional       -> "alternative-layout-rule-transitional" :| []
   Opt_WarnAmbiguousFields                         -> "ambiguous-fields" :| []
   Opt_WarnAutoOrphans                             -> "auto-orphans" :| []
+  Opt_WarnTermVariableCapture                     -> "term-variable-capture" :| []
   Opt_WarnCPPUndef                                -> "cpp-undef" :| []
   Opt_WarnUnbangedStrictPatterns                  -> "unbanged-strict-patterns" :| []
   Opt_WarnDeferredTypeErrors                      -> "deferred-type-errors" :| []
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index ad71ee27a0..29dff3650f 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3323,7 +3323,8 @@ wWarningFlagsDeps = mconcat [
   warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,
   warnSpec    Opt_WarnGADTMonoLocalBinds,
   warnSpec    Opt_WarnTypeEqualityOutOfScope,
-  warnSpec    Opt_WarnTypeEqualityRequiresOperators
+  warnSpec    Opt_WarnTypeEqualityRequiresOperators,
+  warnSpec    Opt_WarnTermVariableCapture
  ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 90c9f38faf..e9733a8bfc 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1152,6 +1152,14 @@ its namespace to DataName and do a second lookup.
 The final result (after the renamer) will be:
   HsTyVar ("Zero", DataName)
 
+Another case of demotion happens when the compiler needs to check
+if a name of a type variable has already been used for a term that is in scope.
+We need to do it to check if a user should change the name
+to make his code compatible with the RequiredTypeArguments extension.
+
+This type of demotion is made via demoteTvNameSpace.
+
+
 Note [Promotion]
 ~~~~~~~~~~~~~~~
 When the user mentions a type constructor or a type variable in a
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 989a8bf3d8..cb246d1c77 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -395,6 +395,7 @@ rnImplicitTvOccs :: Maybe assoc
                  -> RnM (a, FreeVars)
 rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside
   = do { let implicit_vs = nubN implicit_vs_with_dups
+       ; mapM_ warn_term_var_capture implicit_vs
 
        ; traceRn "rnImplicitTvOccs" $
          vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
@@ -1151,6 +1152,20 @@ bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
         thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
                                        , hso_bndrs     = exp_bndrs' }
 
+warn_term_var_capture :: LocatedN RdrName -> RnM ()
+warn_term_var_capture lVar = do
+    gbl_env <- getGlobalRdrEnv
+    local_env <- getLocalRdrEnv
+    case demoteRdrNameTv $ unLoc lVar of
+      Nothing           -> return ()
+      Just demoted_name -> do
+        let global_vars = lookupGRE_RdrName demoted_name gbl_env
+        let mlocal_var  = lookupLocalRdrEnv local_env demoted_name
+        case mlocal_var of
+          Just name -> warnCapturedTerm lVar (Right name)
+          Nothing   -> unless (null global_vars) $
+                         warnCapturedTerm lVar (Left global_vars)
+
 bindHsForAllTelescope :: HsDocContext
                       -> HsForAllTelescope GhcPs
                       -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
@@ -1654,6 +1669,11 @@ warnUnusedForAll doc (L loc tv) used_names
                    , inHsDocContext doc ]
       addDiagnosticAt (locA loc) msg
 
+warnCapturedTerm :: LocatedN RdrName -> Either [GlobalRdrElt] Name -> TcM ()
+warnCapturedTerm (L loc tv) shadowed_term_names
+  = let msg = TcRnCapturedTermName tv shadowed_term_names
+    in addDiagnosticAt (locA loc) msg
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index f135826147..8d18cad2a2 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -62,7 +62,7 @@ import GHC.Types.Error.Codes ( constructorCode )
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance
-                             , RdrName, rdrNameOcc, greMangledName )
+                             , RdrName, rdrNameOcc, greMangledName, grePrintableName )
 import GHC.Types.Name.Set
 import GHC.Types.SrcLoc
 import GHC.Types.TyThing
@@ -1221,6 +1221,18 @@ instance Diagnostic TcRnMessage where
       hang (text "A section must be enclosed in parentheses")
          2 (text "thus:" <+> (parens (ppr expr)))
 
+    TcRnCapturedTermName tv_name shadowed_term_names
+      -> mkSimpleDecorated $
+        text "The type variable" <+> quotes (ppr tv_name) <+>
+          text "is implicitly quantified," $+$
+          text "even though another variable of the same name is in scope:" $+$
+          nest 2 var_names $+$
+          text "This is not forward-compatible with a planned GHC extension, RequiredTypeArguments."
+        where
+          var_names = case shadowed_term_names of
+              Left gbl_names -> vcat (map (\name -> quotes (ppr $ grePrintableName name) <+> pprNameProvenance name) gbl_names)
+              Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at"
+                <+> ppr (nameSrcLoc lcl_name)
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1625,6 +1637,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnIllegalTupleSection{}
       -> ErrorWithoutFlag
+    TcRnCapturedTermName{}
+      -> WarningWithFlag Opt_WarnTermVariableCapture
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -2034,7 +2048,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnIllegalTupleSection{}
       -> [suggestExtension LangExt.TupleSections]
-
+    TcRnCapturedTermName{}
+      -> [SuggestRenameTypeVariable]
 
   diagnosticCode = constructorCode
 
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 990c97970c..13bef7b699 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1642,6 +1642,16 @@ data TcRnMessage where
   -}
   TcRnForallIdentifier :: RdrName -> TcRnMessage
 
+  {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs
+    when an implicitly quantified type variable's name is already used for a term.
+    Example:
+      a = 10
+      f :: a -> a
+
+    Test cases: T22513a T22513b T22513c T22513d T22513e T22513f T22513g T22513h T22513i
+ -}
+  TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage
+
   {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)
       that occurs when the type equality (a ~ b) is not in scope.
 
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index ad8028ef38..3b7220f703 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -500,6 +500,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnMissingClassAssoc"                         = 06205
   GhcDiagnosticCode "TcRnBadFamInstDecl"                            = 06206
   GhcDiagnosticCode "TcRnNotOpenFamily"                             = 06207
+  GhcDiagnosticCode "TcRnCapturedTermName"                          = 54201
 
   -- IllegalNewtypeReason
   GhcDiagnosticCode "DoesNotHaveSingleField"                        = 23517
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 0a175347b0..7e194ed194 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -418,6 +418,11 @@ data GhcHint
     -}
   | SuggestSpecialiseVisibilityHints Name
 
+    {-| Suggest renaming implicitly quantified type variable in case it
+        captures a term's name.
+    -}
+  | SuggestRenameTypeVariable
+
 -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
 -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
 -- to instantiate a particular signature, where the first argument is
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 53890e8daf..e6c42539e3 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -206,6 +206,8 @@ instance Outputable GhcHint where
            <+> quotes (ppr name) <+> text "has an INLINABLE pragma"
          where
            mod = nameModule name
+    SuggestRenameTypeVariable
+      -> text "Consider renaming the type variable."
 
 perhapsAsPat :: SDoc
 perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index bfc3b8aa95..36add1cfea 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/compiler/GHC/Types/Name/Occurrence.hs
@@ -49,6 +49,7 @@ module GHC.Types.Name.Occurrence (
         mkDFunOcc,
         setOccNameSpace,
         demoteOccName,
+        demoteOccTvName,
         promoteOccName,
         HasOccName(..),
 
@@ -215,6 +216,14 @@ demoteNameSpace DataName = Nothing
 demoteNameSpace TvName = Nothing
 demoteNameSpace TcClsName = Just DataName
 
+-- demoteTvNameSpace lowers the NameSpace of a type variable.
+-- See Note [Demotion] in GHC.Rename.Env.
+demoteTvNameSpace :: NameSpace -> Maybe NameSpace
+demoteTvNameSpace TvName = Just VarName
+demoteTvNameSpace VarName = Nothing
+demoteTvNameSpace DataName = Nothing
+demoteTvNameSpace TcClsName = Nothing
+
 -- promoteNameSpace promotes the NameSpace as follows.
 -- See Note [Promotion] in GHC.Rename.Env.
 promoteNameSpace :: NameSpace -> Maybe NameSpace
@@ -334,6 +343,11 @@ demoteOccName (OccName space name) = do
   space' <- demoteNameSpace space
   return $ OccName space' name
 
+demoteOccTvName :: OccName -> Maybe OccName
+demoteOccTvName (OccName space name) = do
+  space' <- demoteTvNameSpace space
+  return $ OccName space' name
+
 -- promoteOccName promotes the NameSpace of OccName.
 -- See Note [Promotion] in GHC.Rename.Env.
 promoteOccName :: OccName -> Maybe OccName
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index feecb3bfc3..7c52a94584 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -33,7 +33,7 @@ module GHC.Types.Name.Reader (
         nameRdrName, getRdrName,
 
         -- ** Destruction
-        rdrNameOcc, rdrNameSpace, demoteRdrName, promoteRdrName,
+        rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTv, promoteRdrName,
         isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
         isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
 
@@ -195,6 +195,12 @@ demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
 demoteRdrName (Orig _ _) = Nothing
 demoteRdrName (Exact _) = Nothing
 
+demoteRdrNameTv :: RdrName -> Maybe RdrName
+demoteRdrNameTv (Unqual occ) = fmap Unqual (demoteOccTvName occ)
+demoteRdrNameTv (Qual m occ) = fmap (Qual m) (demoteOccTvName occ)
+demoteRdrNameTv (Orig _ _) = Nothing
+demoteRdrNameTv (Exact _) = Nothing
+
 -- promoteRdrName promotes the NameSpace of RdrName.
 -- See Note [Promotion] in GHC.Rename.Env.
 promoteRdrName :: RdrName -> Maybe RdrName