diff options
| -rw-r--r-- | compiler/GHC/Rename/Utils.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 31 |
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 |