Commit bb5afd3c authored by barrucadu's avatar barrucadu Committed by Herbert Valerio Riedel

Print which warning-flag controls an emitted warning

Both gcc and clang tell which warning flag a reported warning can be
controlled with, this patch makes ghc do the same. More generally, this
allows for annotated compiler output, where an optional annotation is
displayed in brackets after the severity.

This also adds a new flag `-f(no-)show-warning-groups` to control
whether to show which warning-group (such as `-Wall` or `-Wcompat`)
a warning belongs to. This flag is on by default.

This implements #10752

Reviewed By: quchen, bgamari, hvr

Differential Revision: https://phabricator.haskell.org/D1943
parent 1badf157
......@@ -284,7 +284,7 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***"
, pprCoreBindings binds
......@@ -294,7 +294,7 @@ displayLintResults dflags pass warns errs binds
| not (isEmptyBag warns)
, not opt_NoDebugOutput
, showLintWarnings pass
= log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
= log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
| otherwise = return ()
......@@ -324,7 +324,8 @@ lintInteractiveExpr what hsc_env expr
dflags = hsc_dflags hsc_env
display_lint_err err
= do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
= do { log_action dflags dflags NoReason Err.SevDump
noSrcSpan defaultDumpStyle
(vcat [ lint_banner "errors" (text what)
, err
, text "*** Offending Program ***"
......
......@@ -111,7 +111,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
......
......@@ -170,7 +170,7 @@ showTerm term = do
-- XXX: this tries to disable logging of errors
-- does this still do what it is intended to do
-- with the changed error handling and logging?
let noop_log _ _ _ _ _ = return ()
let noop_log _ _ _ _ _ _ = return ()
expr = "show " ++ showPpr dflags bname
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
......
......@@ -235,7 +235,7 @@ withExtendedLinkEnv new_env action
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
......@@ -374,7 +374,7 @@ classifyLdInput dflags f
| isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
where platform = targetPlatform dflags
......@@ -1397,7 +1397,12 @@ maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s
= when (verbosity dflags > 1) $
do let act = log_action dflags
act dflags SevInteractive noSrcSpan defaultUserStyle (text s)
act dflags
NoReason
SevInteractive
noSrcSpan
defaultUserStyle
(text s)
maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
......
......@@ -80,7 +80,14 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> log_action dflags dflags SevOutput noSrcSpan defaultDumpStyle sd
TraceBinIFaceReading -> \sd ->
log_action dflags
dflags
NoReason
SevOutput
noSrcSpan
defaultDumpStyle
sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO ()
wantedGot what wanted got =
......
......@@ -861,7 +861,7 @@ showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
pprModIface :: ModIface -> SDoc
-- Show a ModIface
......
......@@ -67,7 +67,13 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
do_lint cmm = do
{ showPass dflags "CmmLint"
; case cmmLint dflags cmm of
Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
Just err -> do { log_action dflags
dflags
NoReason
SevDump
noSrcSpan
defaultDumpStyle
err
; ghcExit dflags 1
}
Nothing -> return ()
......
......@@ -1594,7 +1594,7 @@ mkExtraObj dflags extn xs
mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary dflags = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
......@@ -1969,7 +1969,7 @@ linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
......
......@@ -21,7 +21,7 @@ module DynFlags (
-- * Dynamic flags and associated configuration types
DumpFlag(..),
GeneralFlag(..),
WarningFlag(..),
WarningFlag(..), WarnReason(..),
Language(..),
PlatformConstants(..),
FatalMessager, LogAction, FlushOut(..), FlushErr(..),
......@@ -173,7 +173,7 @@ import FastString
import Outputable
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
......@@ -382,6 +382,7 @@ data GeneralFlag
| Opt_NoLlvmMangler -- hidden flag
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_ShowWarnGroups -- Show the group a warning belongs to
| Opt_PrintExplicitForalls
| Opt_PrintExplicitKinds
......@@ -533,6 +534,11 @@ data GeneralFlag
| Opt_PackageTrust
deriving (Eq, Show, Enum)
-- | Used when outputting warnings: if a reason is given, it is
-- displayed. If a warning isn't controlled by a flag, this is made
-- explicit at the point of use.
data WarnReason = NoReason | Reason !WarningFlag
data WarningFlag =
-- See Note [Updating flag description in the User's Guide]
Opt_WarnDuplicateExports
......@@ -1616,13 +1622,20 @@ interpreterDynamic dflags
--------------------------------------------------------------------------
type FatalMessager = String -> IO ()
type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
type LogAction = DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> PprStyle
-> MsgDoc
-> IO ()
defaultFatalMessager :: FatalMessager
defaultFatalMessager = hPutStrLn stderr
defaultLogAction :: LogAction
defaultLogAction dflags severity srcSpan style msg
defaultLogAction dflags reason severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> printSDoc (msg $$ blankLine) style
......@@ -1630,7 +1643,7 @@ defaultLogAction dflags severity srcSpan style msg
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
printErrs (mkLocMessage severity srcSpan msg) style
printErrs message style
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
......@@ -1638,6 +1651,19 @@ defaultLogAction dflags severity srcSpan style msg
where printSDoc = defaultLogActionHPrintDoc dflags stdout
printErrs = defaultLogActionHPrintDoc dflags stderr
putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
-- Pretty print the warning flag, if any (#10752)
message = mkLocMessageAnn flagMsg severity srcSpan msg
flagMsg = case reason of
NoReason -> Nothing
Reason flag -> (\spec -> "-W" ++ flagSpecName spec ++ flagGrp flag) <$>
flagSpecOf flag
flagGrp flag
| gopt Opt_ShowWarnGroups dflags =
case smallestGroups flag of
[] -> ""
groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
| otherwise = ""
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc dflags h d sty
......@@ -3145,6 +3171,12 @@ useInstead flag turn_on
nop :: TurnOnFlag -> DynP ()
nop _ = return ()
-- | Find the 'FlagSpec' for a 'WarningFlag'.
flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)
flagSpecOf flag = listToMaybe $ filter check wWarningFlags
where
check fs = flagSpecFlag fs == flag
-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@
wWarningFlags :: [FlagSpec WarningFlag]
wWarningFlags = map snd wWarningFlagsDeps
......@@ -3344,7 +3376,8 @@ fFlagsDeps = [
flagSpec "unbox-strict-fields" Opt_UnboxStrictFields,
flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance,
flagSpec "vectorise" Opt_Vectorise,
flagSpec "worker-wrapper" Opt_WorkerWrapper
flagSpec "worker-wrapper" Opt_WorkerWrapper,
flagSpec "show-warning-groups" Opt_ShowWarnGroups
]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
......@@ -3584,7 +3617,8 @@ defaultFlags settings
Opt_ProfCountEntries,
Opt_RPath,
Opt_SharedImplib,
Opt_SimplPreInlining
Opt_SimplPreInlining,
Opt_ShowWarnGroups
]
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
......@@ -3757,6 +3791,51 @@ removes an assertion failure. -}
-- * utils/mkUserGuidePart/
-- * docs/users_guide/using-warnings.rst
-- | Warning groups.
--
-- As all warnings are in the Weverything set, it is ignored when
-- displaying to the user which group a warning is in.
warningGroups :: [(String, [WarningFlag])]
warningGroups =
[ ("compat", minusWcompatOpts)
, ("unused-binds", unusedBindsFlags)
, ("default", standardWarnings)
, ("extra", minusWOpts)
, ("all", minusWallOpts)
, ("everything", minusWeverythingOpts)
]
-- | Warning group hierarchies, where there is an explicit inclusion
-- relation.
--
-- Each inner list is a hierarchy of warning groups, ordered from
-- smallest to largest, where each group is a superset of the one
-- before it.
--
-- Separating this from 'warningGroups' allows for multiple
-- hierarchies with no inherent relation to be defined.
--
-- The special-case Weverything group is not included.
warningHierarchies :: [[String]]
warningHierarchies = hierarchies ++ map (:[]) rest
where
hierarchies = [["default", "extra", "all"]]
rest = filter (`notElem` "everything" : concat hierarchies) $
map fst warningGroups
-- | Find the smallest group in every hierarchy which a warning
-- belongs to, excluding Weverything.
smallestGroups :: WarningFlag -> [String]
smallestGroups flag = mapMaybe go warningHierarchies where
-- Because each hierarchy is arranged from smallest to largest,
-- the first group we find in a hierarchy which contains the flag
-- is the smallest.
go (group:rest) = fromMaybe (go rest) $ do
flags <- lookup group warningGroups
guard (flag `elem` flags)
pure (Just group)
go [] = Nothing
-- | Warnings enabled unless specified otherwise
standardWarnings :: [WarningFlag]
standardWarnings -- see Note [Documenting warning flags]
......
......@@ -23,7 +23,7 @@ module ErrUtils (
pprLocErrMsg, printBagOfErrors,
-- ** Construction
emptyMessages, mkLocMessage, makeIntoWarning,
emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
warnIsErrorMsg, mkLongWarnMsg,
......@@ -110,7 +110,8 @@ data ErrMsg = ErrMsg {
errMsgDoc :: ErrDoc,
-- | This has the same text as errDocImportant . errMsgDoc.
errMsgShortString :: String,
errMsgSeverity :: Severity
errMsgSeverity :: Severity,
errMsgReason :: WarnReason
}
-- The SrcSpan is used for sorting errors into line-number order
......@@ -160,15 +161,18 @@ pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessage = mkLocMessageAnn Nothing
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
-- Always print the location, even if it is unhelpful. Error messages
-- are supposed to be in a standard format, and one without a location
-- would look strange. Better to say explicitly "<no location info>".
mkLocMessage severity locn msg
mkLocMessageAnn ann severity locn msg
= sdocWithDynFlags $ \dflags ->
let locn' = if gopt Opt_ErrorSpans dflags
then ppr locn
else ppr (srcSpanStart locn)
in hang (locn' <> colon <+> sev_info) 4 msg
in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg
where
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
......@@ -178,8 +182,13 @@ mkLocMessage severity locn msg
SevFatal -> text "fatal:"
_ -> empty
makeIntoWarning :: ErrMsg -> ErrMsg
makeIntoWarning err = err { errMsgSeverity = SevWarning }
-- Add optional information
opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
{ errMsgSeverity = SevWarning
, errMsgReason = reason }
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.
......@@ -190,7 +199,8 @@ mk_err_msg dflags sev locn print_unqual doc
, errMsgContext = print_unqual
, errMsgDoc = doc
, errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
, errMsgSeverity = sev }
, errMsgSeverity = sev
, errMsgReason = NoReason }
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError
......@@ -226,10 +236,11 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
in log_action dflags dflags sev s style (formatErrDoc dflags doc)
in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
errMsgReason = reason,
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
......@@ -283,7 +294,13 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
| otherwise = log_action dflags
dflags
NoReason
SevDump
noSrcSpan
defaultDumpStyle
(mkDumpDoc hdr doc)
-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
......@@ -359,7 +376,7 @@ dumpSDoc dflags print_unqual flag hdr doc
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
log_action dflags dflags severity noSrcSpan dump_style doc'
log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
-- | Choose where to put a dump file based on DynFlags
......@@ -416,18 +433,18 @@ ifVerbose dflags val act
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
= log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
= log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
= log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg
= log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg =
la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
......@@ -458,11 +475,13 @@ printOutputForUser dflags print_unqual msg
= logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
logInfo dflags sty msg
= log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
logOutput dflags sty msg
= log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
......
......@@ -16,3 +16,4 @@ data Severity
type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
......@@ -678,7 +678,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
data LogQueue = LogQueue !(IORef [Maybe (Severity, SrcSpan, PprStyle, MsgDoc)])
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
!(MVar ())
-- | The graph of modules to compile and their corresponding result 'MVar' and
......@@ -879,7 +879,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
return (success_flag,ok_results)
where
writeLogQueue :: LogQueue -> Maybe (Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue (LogQueue ref sem) msg = do
atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
_ <- tryPutMVar sem ()
......@@ -888,8 +888,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
-- The log_action callback that is used to synchronize messages from a
-- worker thread.
parLogAction :: LogQueue -> LogAction
parLogAction log_queue _dflags !severity !srcSpan !style !msg = do
writeLogQueue log_queue (Just (severity,srcSpan,style,msg))
parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
-- Print each message from the log_queue using the log_action from the
-- session's DynFlags.
......@@ -902,8 +902,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
print_loop [] = read_msgs
print_loop (x:xs) = case x of
Just (severity,srcSpan,style,msg) -> do
log_action dflags dflags severity srcSpan style msg
Just (reason,severity,srcSpan,style,msg) -> do
log_action dflags dflags reason severity srcSpan style msg
print_loop xs
-- Exit the loop once we encounter the end marker.
Nothing -> return ()
......
......@@ -1367,10 +1367,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
msg <- readChan chan
case msg of
BuildMsg msg -> do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle msg
loop chan hProcess t p exitcode
BuildError loc msg -> do
log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
log_action dflags dflags NoReason SevError (mkSrcSpan loc loc) defaultUserStyle msg
loop chan hProcess t p exitcode
EOF ->
loop chan hProcess (t-1) p exitcode
......
......@@ -390,7 +390,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
(log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
......
......@@ -462,7 +462,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat
-- or an occurrence of, a variable on the RHS
; whenWOptM Opt_WarnUnusedPatternBinds $
when (null bndrs && not is_wild_pat) $
addWarn $ unusedPatBindWarn bind'
addWarn (Reason Opt_WarnUnusedPatternBinds) $ unusedPatBindWarn bind'
; fvs' `seq` -- See Note [Free-variable space leak]
return (bind', bndrs, all_fvs) }
......@@ -1104,7 +1104,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
rnBody rhs
; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn (nonStdGuardErr guards'))
(addWarn NoReason (nonStdGuardErr guards'))
; return (GRHS guards' rhs', fvs) }
where
......
......@@ -743,7 +743,8 @@ lookup_demoted rdr_name dflags
Just demoted_name
| data_kinds ->
do { whenWOptM Opt_WarnUntickedPromotedConstructors $
addWarn (untickedPromConstrWarn demoted_name)
addWarn (Reason Opt_WarnUntickedPromotedConstructors)
(untickedPromConstrWarn demoted_name)
; return demoted_name }
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }
......@@ -1068,7 +1069,8 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
-- See Note [Handling of deprecations]
do { iface <- loadInterfaceForName doc name
; case lookupImpDeprec iface gre of
Just txt -> addWarn (mk_msg imp_spec txt)
Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
(mk_msg imp_spec txt)
Nothing -> return () } }
| otherwise
= return ()
......@@ -1738,7 +1740,9 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
-- we don't find any GREs that are in scope qualified-only
complain [] = return ()
complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs)
complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
loc
(shadowedNameWarn occ pp_locs)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
-- Returns False for record selectors that are shadowed, when
......@@ -2118,7 +2122,8 @@ warnUnusedLocals names = do
warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM ()
warnUnusedLocal fld_env name
= when (reportable name) $
addUnusedWarning occ (nameSrcSpan name)
addUnusedWarning Opt_WarnUnusedLocalBinds
occ (nameSrcSpan name)
(text "Defined but not used")
where
occ = case lookupNameEnv fld_env name of
......@@ -2132,7 +2137,7 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
| otherwise = when (reportable name) (mapM_ warn is)
where
occ = greOccName gre
warn spec = addUnusedWarning occ span msg
warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
......@@ -2154,9 +2159,9 @@ reportable name
-- from Data.Tuple
| otherwise = not (startsWithUnderscore (nameOccName name))
addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning occ span msg
= addWarnAt span $
addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning flag occ span msg
= addWarnAt (Reason flag) span $
sep [msg <> colon,
nest 2 $ pprNonVarNameSpace (occNameSpace occ)
<+> quotes (ppr occ)]
......
......@@ -236,7 +236,8 @@ rnImportDecl this_mod
_ | implicit -> return () -- Do not bleat for implicit imports
| qual_only -> return ()
| otherwise -> whenWOptM Opt_WarnMissingImportList $
addWarn (missingImportListWarn imp_mod_name)
addWarn (Reason Opt_WarnMissingImportList)
(missingImportListWarn imp_mod_name)
iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
......@@ -253,7 +254,8 @@ rnImportDecl this_mod
-- the non-boot module depends on the compilation order, which
-- is not deterministic. The hs-boot test can show this up.
dflags <- getDynFlags
warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
warnIf NoReason
(want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErr (text "safe import can't be used as Safe Haskell isn't on!"
......@@ -297,7 +299,8 @@ rnImportDecl this_mod
-- Complain if we import a deprecated module
whenWOptM Opt_WarnWarningsDeprecations (
case (mi_warns iface) of
WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt
WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
(moduleWarn imp_mod_name txt)
_ -> return ()
)
......@@ -814,11 +817,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
where
-- Warn when importing T(..) if T was exported abstractly
emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
addWarn (dodgyImportWarn n)
addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
addWarn (missingImportListItem ieRdr)
addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $