Mention which -Werror promoted a warning to an error

Previously -Werror or -Werror=flag printed warnings as usual and then
printed
these two lines:

    <no location info>: error:
    Failing due to -Werror.

This is not ideal: first, it's not clear which flag made one of the
warnings an
error. Second, warning messages are not modified in any way, so there's
no way
to know which warnings caused this error.

With this patch we (1) promote warning messages to error messages if a
relevant
-Werror is enabled (2) mention which -Werror is used during this
promotion.

Previously:

    [1 of 1] Compiling Main             ( test.hs, test.o )

    test.hs:9:10: warning: [-Wincomplete-patterns]
        Pattern match(es) are non-exhaustive
        In a case alternative: Patterns not matched: (C2 _)
      |
    9 | sInt s = case s of
      |          ^^^^^^^^^...

    test.hs:12:14: warning: [-Wmissing-fields]
        • Fields of ‘Rec’ not initialised: f2
        • In the first argument of ‘print’, namely ‘Rec {f1 =
1}’
          In the expression: print Rec {f1 = 1}
          In an equation for ‘main’: main = print Rec {f1 = 1}
       |
    12 | main = print Rec{ f1 = 1 }
       |              ^^^^^^^^^^^^^

    <no location info>: error:
    Failing due to -Werror.

Now:

    [1 of 1] Compiling Main             ( test.hs, test.o )

    test.hs:9:10: error: [-Wincomplete-patterns,
-Werror=incomplete-patterns]
        Pattern match(es) are non-exhaustive
        In a case alternative: Patterns not matched: (C2 _)
      |
    9 | sInt s = case s of
      |          ^^^^^^^^^...

    test.hs:12:14: error: [-Wmissing-fields, -Werror=missing-fields]
        • Fields of ‘Rec’ not initialised: f2
        • In the first argument of ‘print’, namely ‘Rec {f1 =
1}’
          In the expression: print Rec {f1 = 1}
          In an equation for ‘main’: main = print Rec {f1 = 1}
       |
    12 | main = print Rec{ f1 = 1 }
       |              ^^^^^^^^^^^^^

Test Plan: - Update old tests, add new tests if there aren't any
relevant tests

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3709

1 files changed, 10 insertions, 9 deletions

diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index c0127b2a27..5883fe14da 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -14,7 +14,7 @@ module ErrUtils (
         Severity(..),
 
         -- * Messages
-        ErrMsg, errMsgDoc,
+        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
         ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
         WarnMsg, MsgDoc,
         Messages, ErrorMessages, WarningMessages,
@@ -32,7 +32,7 @@ module ErrUtils (
         emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
         mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
         mkPlainWarnMsg,
-        warnIsErrorMsg, mkLongWarnMsg,
+        mkLongWarnMsg,
 
         -- * Utilities
         doIfSet, doIfSet_dyn,
@@ -349,10 +349,6 @@ emptyMessages = (emptyBag, emptyBag)
 isEmptyMessages :: Messages -> Bool
 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
 
-warnIsErrorMsg :: DynFlags -> ErrMsg
-warnIsErrorMsg dflags
-    = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
-
 errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
@@ -670,10 +666,15 @@ prettyPrintGhcErrors dflags
                           liftIO $ throwIO e
 
 -- | Checks if given 'WarnMsg' is a fatal warning.
-isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
+isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
-  = wopt_fatal wflag dflags
-isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
+  = if wopt_fatal wflag dflags
+      then Just (Just wflag)
+      else Nothing
+isWarnMsgFatal dflags _
+  = if gopt Opt_WarnIsError dflags
+      then Just Nothing
+      else Nothing
 
 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
 -- trace the command (at two levels of verbosity)