summaryrefslogtreecommitdiff
path: root/compiler/GHC/Utils
diff options
context:
space:
mode:
authorAlfredo Di Napoli <alfredo@well-typed.com>2021-03-09 09:11:47 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-05 20:39:54 -0400
commit495281215ae0fdcb296b2b30c1efd3a683006f42 (patch)
tree721e48d12c7bd79f05eb03f4a4d3c7114a71f9b8 /compiler/GHC/Utils
parent77772bb122410ef58ff006a1d18c6f2212216fda (diff)
downloadhaskell-495281215ae0fdcb296b2b30c1efd3a683006f42.tar.gz
Introduce SevIgnore Severity to suppress warnings
This commit introduces a new `Severity` type constructor called `SevIgnore`, which can be used to classify diagnostic messages which are not meant to be displayed to the user, for example suppressed warnings. This extra constructor allows us to get rid of a bunch of redundant checks when emitting diagnostics, typically in the form of the pattern: ``` when (optM Opt_XXX) $ addDiagnosticTc (WarningWithFlag Opt_XXX) ... ``` Fair warning! Not all checks should be omitted/skipped, as evaluating some data structures used to produce a diagnostic might still be expensive (e.g. zonking, etc). Therefore, a case-by-case analysis must be conducted when deciding if a check can be removed or not. Last but not least, we remove the unnecessary `CmdLine.WarnReason` type, which is now redundant with `DiagnosticReason`.
Diffstat (limited to 'compiler/GHC/Utils')
-rw-r--r--compiler/GHC/Utils/Error.hs3
-rw-r--r--compiler/GHC/Utils/Logger.hs15
2 files changed, 11 insertions, 7 deletions
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 2ee1763ebb..d18791d0c6 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -87,7 +87,8 @@ import System.CPUTime
-- particular diagnostic message is built, otherwise the computed 'Severity' might
-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity
-diagReasonSeverity dflags (WarningWithFlag wflag) | wopt_fatal wflag dflags = SevError
+diagReasonSeverity dflags (WarningWithFlag wflag) | not (wopt wflag dflags) = SevIgnore
+ | wopt_fatal wflag dflags = SevError
| otherwise = SevWarning
diagReasonSeverity dflags WarningWithoutFlag | gopt Opt_WarnIsError dflags = SevError
| otherwise = SevWarning
diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs
index fbbacb2b48..2e5a9b06a7 100644
--- a/compiler/GHC/Utils/Logger.hs
+++ b/compiler/GHC/Utils/Logger.hs
@@ -198,6 +198,7 @@ makeThreadSafe logger = do
-- See Note [JSON Error Messages]
--
jsonLogAction :: LogAction
+jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message
jsonLogAction dflags msg_class srcSpan msg
=
defaultLogActionHPutStrDoc dflags True stdout
@@ -214,12 +215,13 @@ defaultLogAction :: LogAction
defaultLogAction dflags msg_class srcSpan msg
| dopt Opt_D_dump_json dflags = jsonLogAction dflags msg_class srcSpan msg
| otherwise = case msg_class of
- MCOutput -> printOut msg
- MCDump -> printOut (msg $$ blankLine)
- MCInteractive -> putStrSDoc msg
- MCInfo -> printErrs msg
- MCFatal -> printErrs msg
- MCDiagnostic sev rea -> printDiagnostics sev rea
+ MCOutput -> printOut msg
+ MCDump -> printOut (msg $$ blankLine)
+ MCInteractive -> putStrSDoc msg
+ MCInfo -> printErrs msg
+ MCFatal -> printErrs msg
+ MCDiagnostic SevIgnore _ -> pure () -- suppress the message
+ MCDiagnostic sev rea -> printDiagnostics sev rea
where
printOut = defaultLogActionHPrintDoc dflags False stdout
printErrs = defaultLogActionHPrintDoc dflags False stderr
@@ -242,6 +244,7 @@ defaultLogAction dflags msg_class srcSpan msg
-- each unicode char.
flagMsg :: Severity -> DiagnosticReason -> Maybe String
+ flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore"
flagMsg SevError WarningWithoutFlag = Just "-Werror"
flagMsg SevError (WarningWithFlag wflag) = do
spec <- flagSpecOf wflag