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

1 files changed, 31 insertions, 15 deletions

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