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

8 files changed, 101 insertions, 67 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dac3136579..2be121e133 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -585,7 +585,12 @@ data GeneralFlag
 -- | 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 WarnReason
+  = NoReason
+  -- | Warning was enabled with the flag
+  | Reason !WarningFlag
+  -- | Warning was made an error because of -Werror or -Werror=WarningFlag
+  | ErrReason !(Maybe WarningFlag)
   deriving Show
 
 instance Outputable WarnReason where
@@ -594,6 +599,8 @@ instance Outputable WarnReason where
 instance ToJson WarnReason where
   json NoReason = JSNull
   json (Reason wf) = JSString (show wf)
+  json (ErrReason Nothing) = JSString "Opt_WarnIsError"
+  json (ErrReason (Just wf)) = JSString (show wf)
 
 data WarningFlag =
 -- See Note [Updating flag description in the User's Guide]
@@ -1827,34 +1834,48 @@ defaultLogAction dflags reason severity srcSpan style msg
       SevInteractive -> putStrSDoc msg style
       SevInfo        -> printErrs msg style
       SevFatal       -> printErrs msg style
-      _              -> do -- otherwise (i.e. SevError or SevWarning)
-                           hPutChar stderr '\n'
-                           caretDiagnostic <-
-                               if gopt Opt_DiagnosticsShowCaret dflags
-                               then getCaretDiagnostic severity srcSpan
-                               else pure empty
-                           printErrs (message $+$ caretDiagnostic)
-                               (setStyleColoured True style)
-                           -- careful (#2302): printErrs prints in UTF-8,
-                           -- whereas converting to string first and using
-                           -- hPutStr would just emit the low 8 bits of
-                           -- each unicode char.
-    where printOut   = 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 = ""
+      SevWarning     -> printWarns
+      SevError       -> printWarns
+    where
+      printOut   = 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
+
+      printWarns = do
+        hPutChar stderr '\n'
+        caretDiagnostic <-
+            if gopt Opt_DiagnosticsShowCaret dflags
+            then getCaretDiagnostic severity srcSpan
+            else pure empty
+        printErrs (message $+$ caretDiagnostic)
+            (setStyleColoured True style)
+        -- careful (#2302): printErrs prints in UTF-8,
+        -- whereas converting to string first and using
+        -- hPutStr would just emit the low 8 bits of
+        -- each unicode char.
+
+      flagMsg =
+        case reason of
+          NoReason -> Nothing
+          Reason wflag -> do
+            spec <- flagSpecOf wflag
+            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)
+          ErrReason Nothing ->
+            return "-Werror"
+          ErrReason (Just wflag) -> do
+            spec <- flagSpecOf wflag
+            return $
+              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++
+              ", -Werror=" ++ flagSpecName spec
+
+      warnFlagGrp flag
+          | gopt Opt_ShowWarnGroups dflags =
+                case smallestGroups flag of
+                    [] -> ""
+                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
+          | otherwise = ""
 
 -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
 defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
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)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 9f1da3fcdd..f7a8140583 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -179,7 +179,7 @@ import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule
 import TysWiredIn
 import Packages hiding  ( Version(..) )
 import CmdLineParser
-import DynFlags hiding  ( WarnReason(..) )
+import DynFlags
 import DriverPhases     ( Phase, HscSource(..), isHsBootOrSig, hscSourceString )
 import BasicTypes
 import IfaceSyn
@@ -322,11 +322,21 @@ instance Exception GhcApiError
 -- | Given a bag of warnings, turn them into an exception if
 -- -Werror is enabled, or print them out otherwise.
 printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings dflags warns
-  | anyBag (isWarnMsgFatal dflags) warns
-  = throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
-  | otherwise
-  = printBagOfErrors dflags warns
+printOrThrowWarnings dflags warns = do
+  let (make_error, warns') =
+        mapAccumBagL
+          (\make_err warn ->
+            case isWarnMsgFatal dflags warn of
+              Nothing ->
+                (make_err, warn)
+              Just err_reason ->
+                (True, warn{ errMsgSeverity = SevError
+                           , errMsgReason = ErrReason err_reason
+                           }))
+          False warns
+  if make_error
+    then throwIO (mkSrcErr warns')
+    else printBagOfErrors dflags warns
 
 handleFlagWarnings :: DynFlags -> [Warn] -> IO ()
 handleFlagWarnings dflags warns = do
@@ -340,7 +350,7 @@ handleFlagWarnings dflags warns = do
   printOrThrowWarnings dflags bag
 
 -- Given a warn reason, check to see if it's associated -W opt is enabled
-shouldPrintWarning :: DynFlags -> WarnReason -> Bool
+shouldPrintWarning :: DynFlags -> CmdLineParser.WarnReason -> Bool
 shouldPrintWarning dflags ReasonDeprecatedFlag
   = wopt Opt_WarnDeprecatedFlags dflags
 shouldPrintWarning dflags ReasonUnrecognisedFlag
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 3c1473402c..6dc9f1d0d2 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -266,8 +266,7 @@ 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 NoReason
-           (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
+    warnIf (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!"
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index a565959c9a..20c3d5cbb9 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -676,9 +676,9 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
 
        ; oflag <- getOverlapFlag overlap_mode
        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
-       ; warnIf (Reason Opt_WarnOrphans)
-                (isOrphan (is_orphan inst))
-                (instOrphWarn inst)
+       ; warnIfFlag Opt_WarnOrphans
+                    (isOrphan (is_orphan inst))
+                    (instOrphWarn inst)
        ; return inst }
 
 instOrphWarn :: ClsInst -> SDoc
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 3965675b77..ec099582a1 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -220,8 +220,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
         | let earlier_mods = [ mod
                              | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
         , mod `elem` earlier_mods    -- Duplicate export of M
-        = do { warnIf (Reason Opt_WarnDuplicateExports) True
-                      (dupModuleExport mod) ;
+        = do { warnIfFlag Opt_WarnDuplicateExports True
+                          (dupModuleExport mod) ;
                return acc }
 
         | otherwise
@@ -234,9 +234,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                }
 
              ; checkErr exportValid (moduleNotImported mod)
-             ; warnIf (Reason Opt_WarnDodgyExports)
-                      (exportValid && null gre_prs)
-                      (nullModuleExport mod)
+             ; warnIfFlag Opt_WarnDodgyExports
+                          (exportValid && null gre_prs)
+                          (nullModuleExport mod)
 
              ; traceRn "efa" (ppr mod $$ ppr all_gres)
              ; addUsedGREs all_gres
@@ -594,9 +594,9 @@ check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
             | name == name'   -- Duplicate export
             -- But we don't want to warn if the same thing is exported
             -- by two different module exports. See ticket #4478.
-            -> do { warnIf (Reason Opt_WarnDuplicateExports)
-                           (not (dupExport_ok name ie ie'))
-                           (dupExportWarn name_occ ie ie')
+            -> do { warnIfFlag Opt_WarnDuplicateExports
+                               (not (dupExport_ok name ie ie'))
+                               (dupExportWarn name_occ ie ie')
                   ; return occs }
 
             | otherwise    -- Same occ name but different names: an error
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 812ed0a266..a6a995de1a 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -82,7 +82,7 @@ module TcRnMonad(
   failWithTc, failWithTcM,
   checkTc, checkTcM,
   failIfTc, failIfTcM,
-  warnIf, warnTc, warnTcM,
+  warnIfFlag, warnIf, warnTc, warnTcM,
   addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
   tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
 
@@ -1231,15 +1231,18 @@ failIfTcM True  err = failWithTcM err
 
 --         Warnings have no 'M' variant, nor failure
 
--- | Display a warning if a condition is met.
+-- | Display a warning if a condition is met,
 --   and the warning is enabled
-warnIf :: WarnReason -> Bool -> MsgDoc -> TcRn ()
-warnIf reason is_bad msg
-  = do { warn_on <- case reason of
-                       NoReason         -> return True
-                       Reason warn_flag -> woptM warn_flag
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+  = do { warn_on <- woptM warn_flag
        ; when (warn_on && is_bad) $
-         addWarn reason msg }
+         addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+  = when is_bad (addWarn NoReason msg)
 
 -- | Display a warning if a condition is met.
 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index 803761b903..c898fd96bd 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -695,7 +695,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
 -- However we want to use fun_name in the error message, since that is
 -- what the user wrote (Trac #8537)
   = addErrCtxt (spec_ctxt prag) $
-    do  { warnIf NoReason (not (isOverloadedTy poly_ty || isInlinePragma inl))
+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
                  (text "SPECIALISE pragma for non-overloaded function"
                   <+> quotes (ppr fun_name))
                   -- Note [SPECIALISE pragmas]