Print which warning-flag controls an emitted warning.wip/D1934

Summary:
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.

Fixes T10752.

Reviewers: austin, hvr, goldfire, bgamari

Subscribers: goldfire, thomie

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

8 files changed, 54 insertions, 31 deletions

diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 00a0801c47..083133c70f 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -67,7 +67,7 @@ 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 Nothing SevDump noSrcSpan defaultDumpStyle err
                                        ; ghcExit dflags 1
                                        }
                         Nothing  -> return ()
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 3de94fd403..bbc190812e 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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 Nothing 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 Nothing 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.")
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 52da3005bf..df95312edc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
@@ -1616,13 +1616,13 @@ interpreterDynamic dflags
 --------------------------------------------------------------------------
 
 type FatalMessager = String -> IO ()
-type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+type LogAction = DynFlags -> Maybe WarningFlag -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
 
 defaultFatalMessager :: FatalMessager
 defaultFatalMessager = hPutStrLn stderr
 
 defaultLogAction :: LogAction
-defaultLogAction dflags severity srcSpan style msg
+defaultLogAction dflags flag severity srcSpan style msg
     = case severity of
       SevOutput      -> printSDoc msg style
       SevDump        -> printSDoc (msg $$ blankLine) style
@@ -1630,7 +1630,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 (mkLocMessageAnn flagMsg severity srcSpan msg) 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 +1638,9 @@ 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)
+          flagMsg = (\wf -> '-':'W':flagSpecName wf) <$> (flag >>= \f ->
+            listToMaybe $ filter (\fs -> flagSpecFlag fs == f) wWarningFlags)
 
 defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
 defaultLogActionHPrintDoc dflags h d sty
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index eafe4e802f..585cab5f22 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -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,
+        errMsgFlag        :: Maybe WarningFlag
         }
         -- 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 :: Maybe WarningFlag -> ErrMsg -> ErrMsg
+makeIntoWarning flag err
+= err { errMsgSeverity = SevWarning
+      , errMsgFlag = flag }
 
 -- -----------------------------------------------------------------------------
 -- 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
+          , errMsgFlag = Nothing }
 
 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 flag sev s style (formatErrDoc dflags doc)
               | ErrMsg { errMsgSpan      = s,
                          errMsgDoc       = doc,
                          errMsgSeverity  = sev,
+                         errMsgFlag      = flag,
                          errMsgContext   = unqual } <- sortMsgBag (Just dflags)
                                                                   bag_of_errors ]
 
@@ -283,7 +294,8 @@ 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 Nothing SevDump
+                            noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
 
 -- | a wrapper around 'dumpSDoc'.
 -- First check whether the dump flag is set
@@ -359,7 +371,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 Nothing severity noSrcSpan dump_style doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -416,18 +428,20 @@ ifVerbose dflags val act
 
 errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg
-   = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
+   = log_action dflags dflags Nothing 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 Nothing 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 Nothing SevFatal noSrcSpan (defaultErrStyle dflags) msg
 
 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
 fatalErrorMsg'' fm msg = fm msg
@@ -458,11 +472,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 Nothing 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 Nothing SevOutput noSrcSpan sty msg
 
 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
 prettyPrintGhcErrors dflags
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index 31edcc05ee..b991ec4958 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -16,3 +16,4 @@ data Severity
 type MsgDoc = SDoc
 
 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
+mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 7bbe4be495..3e62d8dea4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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 (Maybe WarningFlag, 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 (Maybe WarningFlag,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 !flag !severity !srcSpan !style !msg = do
+        writeLogQueue log_queue (Just (flag,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 (flag,severity,srcSpan,style,msg) -> do
+                    log_action dflags dflags flag severity srcSpan style msg
                     print_loop xs
                 -- Exit the loop once we encounter the end marker.
                 Nothing -> return ()
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index c3436edd9e..d7de69ae8d 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -1367,10 +1367,12 @@ 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 Nothing 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 Nothing SevError (mkSrcSpan loc loc)
+                             defaultUserStyle msg
                   loop chan hProcess t p exitcode
                 EOF ->
                   loop chan hProcess (t-1) p exitcode
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index df31fda16c..072fb840a4 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -390,7 +390,8 @@ 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 Nothing SevDump noSrcSpan
+                          defaultDumpStyle
                           (text "Tidy size (terms,types,coercions)"
                            <+> ppr (moduleName mod) <> colon
                            <+> int (cs_tm cs)