First error codes are printing

11 files changed, 50 insertions, 44 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 0511a4004d..8e5a1dc655 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2989,7 +2989,7 @@ addMsg is_error env msgs msg
                []    -> noSrcSpan
                (s:_) -> s
    !diag_opts = initDiagOpts (le_dynflags env)
-   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span
+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span
                              (msg $$ context)
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 4182be9fb9..05c5704e76 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -43,7 +43,7 @@ module GHC.Core.Opt.Monad (
     getAnnotations, getFirstAnnotations,
 
     -- ** Screen output
-    putMsg, putMsgS, errorMsg, errorMsgS, msg,
+    putMsg, putMsgS, errorMsg, msg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
   ) where
@@ -807,9 +807,9 @@ msg msg_class doc = do
     loc    <- getSrcSpanM
     unqual <- getPrintUnqualified
     let sty = case msg_class of
-                MCDiagnostic _ _ -> err_sty
-                MCDump           -> dump_sty
-                _                -> user_sty
+                MCDiagnostic _ _ _ -> err_sty
+                MCDump             -> dump_sty
+                _                  -> user_sty
         err_sty  = mkErrStyle unqual
         user_sty = mkUserStyle unqual AllTheWay
         dump_sty = mkDumpStyle unqual
@@ -824,10 +824,6 @@ putMsg :: SDoc -> CoreM ()
 putMsg = msg MCInfo
 
 -- | Output an error to the screen. Does not cause the compiler to die.
-errorMsgS :: String -> CoreM ()
-errorMsgS = errorMsg . text
-
--- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
 errorMsg doc = msg errorDiagnostic doc
 
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 2e18049dd7..c0b058f4ea 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -814,7 +814,7 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
     allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
     diag_opts = initDiagOpts dflags
     doWarn reason =
-      msg (mkMCDiagnostic diag_opts reason)
+      msg (mkMCDiagnostic diag_opts reason Nothing)
         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)
                         | caller <- callers])
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index baaa551588..c737164899 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -20,7 +20,7 @@ printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
 printMessages logger opts msgs
   = sequence_ [ let style = mkErrStyle unqual
                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
-                in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $
+                in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $
                    withPprStyle style (messageWithHints ctx dia)
               | MsgEnvelope { errMsgSpan      = s,
                               errMsgDiagnostic = dia,
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index efaefd84f5..9fb5a92a87 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2159,9 +2159,9 @@ withDeferredDiagnostics f = do
     let deferDiagnostics _dflags !msgClass !srcSpan !msg = do
           let action = logMsg logger msgClass srcSpan msg
           case msgClass of
-            MCDiagnostic SevWarning _reason
+            MCDiagnostic SevWarning _reason _code
               -> atomicModifyIORef' warnings $ \i -> (action: i, ())
-            MCDiagnostic SevError _reason
+            MCDiagnostic SevError _reason _code
               -> atomicModifyIORef' errors   $ \i -> (action: i, ())
             MCFatal
               -> atomicModifyIORef' fatals   $ \i -> (action: i, ())
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index ed633fedb4..b9e2b268a2 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -1505,7 +1505,7 @@ load_dyn interp hsc_env crash_early dll = do
         else
           when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
             $ logMsg logger
-                (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
+                (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing)
                   noSrcSpan $ withPprStyle defaultUserStyle (note err)
   where
     diag_opts = initDiagOpts (hsc_dflags hsc_env)
@@ -1673,7 +1673,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
       , not loading_dynamic_hs_libs
       , interpreterProfiled interp
       = do
-          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag
+          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing
           logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
             text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
               text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index cd9f3dff03..482b378408 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -514,7 +514,7 @@ addErr diag_opts errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
-                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)
+                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing)
                                       l (hdr $$ msg)
     mk_msg []      = msg
 
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index f7e0de048b..3069102448 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -367,7 +367,7 @@ data MessageClass
     -- ^ Log messages intended for end users.
     -- No file\/line\/column stuff.
 
-  | MCDiagnostic Severity DiagnosticReason
+  | MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode)
     -- ^ Diagnostics from the compiler. This constructor is very powerful as
     -- it allows the construction of a 'MessageClass' with a completely
     -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
@@ -376,7 +376,11 @@ data MessageClass
     -- and manipulate diagnostic messages directly, for example inside
     -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
     -- emitting compiler diagnostics, use the smart constructor.
-  deriving (Eq, Show)
+    --
+    -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for
+    -- this diagnostic. If you are creating a message not tied to any
+    -- error-message type, then use Nothing. In the long run, this really
+    -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].
 
 {-
 Note [Suppressing Messages]
@@ -434,8 +438,8 @@ instance ToJson MessageClass where
   json MCInteractive = JSString "MCInteractive"
   json MCDump = JSString "MCDump"
   json MCInfo = JSString "MCInfo"
-  json (MCDiagnostic sev reason) =
-    JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason)
+  json (MCDiagnostic sev reason code) =
+    JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code)
 
 instance Show (MsgEnvelope DiagnosticMessage) where
     show = showMsgEnvelope
@@ -476,21 +480,26 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
 
           msg_title =
             case msg_class of
-              MCDiagnostic SevError _reason   -> text "error:"
-              MCDiagnostic SevWarning _reason -> text "warning:"
-              MCFatal                         -> text "fatal:"
-              _                               -> empty
+              MCDiagnostic SevError _reason _code   -> text "error:"
+              MCDiagnostic SevWarning _reason _code -> text "warning:"
+              MCFatal                               -> text "fatal:"
+              _                                     -> empty
 
           warning_flag_doc =
             case msg_class of
-              MCDiagnostic sev reason
+              MCDiagnostic sev reason _code
                 | Just str <- flag_msg sev reason -> brackets (coloured msg_colour (text str))
               _                                   -> empty
 
+          diag_code_doc =
+            case msg_class of
+              MCDiagnostic _ _ (Just code) -> ppr code
+              _                            -> empty
+
           -- Add prefixes, like    Foo.hs:34: warning:
           --                           <the warning message>
           header = locn' <> colon <+>
-                   coloured msg_colour msg_title <+> warning_flag_doc
+                   coloured msg_colour msg_title <+> warning_flag_doc <+> diag_code_doc
 
       in coloured (Col.sMessage col_scheme)
                   (hang (coloured (Col.sHeader col_scheme) header) 4
@@ -521,10 +530,10 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
 
 
 getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic SevError _reason)   = Col.sError
-getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning
-getMessageClassColour MCFatal                           = Col.sFatal
-getMessageClassColour _                                 = const mempty
+getMessageClassColour (MCDiagnostic SevError _reason _code)   = Col.sError
+getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning
+getMessageClassColour MCFatal                                 = Col.sFatal
+getMessageClassColour _                                       = const mempty
 
 getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
@@ -665,6 +674,7 @@ partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarnin
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 "RAE": Write note.
 Talk about difference between DiagnosticCode and GhcDiagnosticCode.
+Talk about aspirations to remove Maybe.
 -}
 
 -- | A diagnostic code (called an "error code" in its specification
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index f79bf7c149..4e276a83d4 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -124,13 +124,13 @@ diagReasonSeverity opts reason = case reason of
 
 -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
 -- 'DiagOpts.
-mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass
-mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason
+mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
+mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code
 
 -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
--- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
+-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code.
 errorDiagnostic :: MessageClass
-errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
+errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing
 
 --
 -- Creating MsgEnvelope(s)
@@ -241,7 +241,7 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s
                                , errMsgContext   = unqual })
   = sdocWithContext $ \ctx ->
     withErrStyle unqual $
-      mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e)
+      mkLocMessage (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) s (formatBulleted ctx $ diagnosticMessage e)
 
 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
 sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs
index 49d295e91a..40ec3e3838 100644
--- a/compiler/GHC/Utils/Logger.hs
+++ b/compiler/GHC/Utils/Logger.hs
@@ -327,7 +327,7 @@ makeThreadSafe logger = do
 -- See Note [JSON Error Messages]
 --
 jsonLogAction :: LogAction
-jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message
+jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
 jsonLogAction logflags msg_class srcSpan msg
   =
     defaultLogActionHPutStrDoc logflags True stdout
@@ -344,13 +344,13 @@ defaultLogAction :: LogAction
 defaultLogAction logflags msg_class srcSpan msg
   | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags 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 SevIgnore _ -> pure () -- suppress the message
-      MCDiagnostic _sev _rea   -> printDiagnostics
+      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 _code -> printDiagnostics
     where
       printOut   = defaultLogActionHPrintDoc  logflags False stdout
       printErrs  = defaultLogActionHPrintDoc  logflags False stderr
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index ff607d645c..d37aee1468 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -618,7 +618,7 @@ ghciLogAction lastErrLocations old_log_action
               dflags msg_class srcSpan msg = do
     old_log_action dflags msg_class srcSpan msg
     case msg_class of
-        MCDiagnostic SevError _reason -> case srcSpan of
+        MCDiagnostic SevError _reason _code -> case srcSpan of
             RealSrcSpan rsp _ -> modifyIORef lastErrLocations
                 (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
             _ -> return ()