Add the TcRnShadowedName constructor to TcRnMessage

This commit adds the TcRnShadowedName to the TcRnMessage type and it
uses it in GHC.Rename.Utils.

3 files changed, 46 insertions, 16 deletions

diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index bd5c9240e0..ed1cf40ea4 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -163,9 +163,9 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
     check_shadow n
         | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"
                                                 -- See #3262
-        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
+        | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n))
         | otherwise = do { gres' <- filterM is_shadowed_gre gres
-                         ; complain (map pprNameProvenance gres') }
+                         ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') }
         where
           (loc,occ) = get_loc_occ n
           mb_local  = lookupLocalRdrOcc local_env occ
@@ -173,12 +173,7 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
                 -- Make an Unqualified RdrName and look that up, so that
                 -- we don't find any GREs that are in scope qualified-only
 
-          complain []      = return ()
-          complain pp_locs = do
-             let msg = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnNameShadowing)
-                                                              noHints
-                                                              (shadowedNameWarn occ pp_locs)
-             addDiagnosticAt loc msg
+          complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance)
 
     is_shadowed_gre :: GlobalRdrElt -> RnM Bool
         -- Returns False for record selectors that are shadowed, when
@@ -591,13 +586,6 @@ addNameClashErrRn rdr_name gres
     num_non_flds = length non_flds
 
 
-shadowedNameWarn :: OccName -> [SDoc] -> SDoc
-shadowedNameWarn occ shadowed_locs
-  = sep [text "This binding for" <+> quotes (ppr occ)
-            <+> text "shadows the existing binding" <> plural shadowed_locs,
-         nest 2 (vcat shadowed_locs)]
-
-
 unknownSubordinateErr :: SDoc -> RdrName -> SDoc
 unknownSubordinateErr doc op    -- Doc is "method of class" or
                                 -- "field of constructor"
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 837672c4d1..727edc78cd 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -13,6 +13,7 @@ import GHC.Core.TyCo.Ppr (pprWithTYPE)
 import GHC.Core.Type
 import GHC.Tc.Errors.Types
 import GHC.Types.Error
+import GHC.Types.Name.Reader (pprNameProvenance)
 import GHC.Types.Var.Env (emptyTidyEnv)
 import GHC.Driver.Flags
 import GHC.Hs
@@ -49,6 +50,14 @@ instance Diagnostic TcRnMessage where
       -> mkDecorated [text "Use of plugins makes the module unsafe"]
     TcRnModMissingRealSrcSpan mod
       -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]
+    TcRnShadowedName occ provenance
+      -> let shadowed_locs = case provenance of
+               ShadowedNameProvenanceLocal n     -> [text "bound at" <+> ppr n]
+               ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres
+         in mkSimpleDecorated $
+            sep [text "This binding for" <+> quotes (ppr occ)
+             <+> text "shadows the existing binding" <> plural shadowed_locs,
+                   nest 2 (vcat shadowed_locs)]
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -72,6 +81,8 @@ instance Diagnostic TcRnMessage where
       -> WarningWithoutFlag
     TcRnModMissingRealSrcSpan{}
       -> ErrorWithoutFlag
+    TcRnShadowedName{}
+      -> WarningWithFlag Opt_WarnNameShadowing
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -95,6 +106,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnModMissingRealSrcSpan{}
       -> noHints
+    TcRnShadowedName{}
+      -> noHints
 
 messageWithInfoDiagnosticMessage :: UnitState
                                  -> ErrInfo
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index dfaf43df5b..26e4308768 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -6,12 +6,14 @@ module GHC.Tc.Errors.Types (
   , TcRnMessageDetailed(..)
   , ErrInfo(..)
   , LevityCheckProvenance(..)
+  , ShadowedNameProvenance(..)
   ) where
 
 import GHC.Hs
 import GHC.Types.Error
-import GHC.Types.Name (Name)
+import GHC.Types.Name (Name, OccName)
 import GHC.Types.Name.Reader
+import GHC.Types.SrcLoc
 import GHC.Unit.Types (Module)
 import GHC.Utils.Outputable
 import Data.Typeable
@@ -164,6 +166,33 @@ data TcRnMessage where
   TcRnModMissingRealSrcSpan :: Module -> TcRnMessage
 
 
+  {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever
+      an inner-scope value has the same name as an outer-scope value, i.e. the inner
+      value shadows the outer one. This can catch typographical errors that turn into
+      hard-to-find bugs. The warning is suppressed for names beginning with an underscore.
+
+      Examples(s):
+        f = ... let f = id in ... f ...  -- NOT OK, 'f' is shadowed
+        f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore
+
+     Test cases: typecheck/should_compile/T10971a
+                 rename/should_compile/rn039
+                 rename/should_compile/rn064
+                 rename/should_compile/T1972
+                 rename/should_fail/T2723
+                 rename/should_compile/T3262
+                 driver/werror
+  -}
+  TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage
+
+
+-- | Where a shadowed name comes from
+data ShadowedNameProvenance
+  = ShadowedNameProvenanceLocal !SrcLoc
+    -- ^ The shadowed name is local to the module
+  | ShadowedNameProvenanceGlobal [GlobalRdrElt]
+    -- ^ The shadowed name is global, typically imported from elsewhere.
+
 -- | Where the levity checking for the input type originated
 data LevityCheckProvenance
   = LevityCheckInVarType