GitLab

Simon Hengel pushed to branch wip/sol/lint-messages at Glasgow Haskell Compiler / GHC

Commits:

f99e4bae

by Simon Hengel at 2025-08-09T16:50:20+07:00

Refactoring: Don't misuse `MCDiagnostic` for lint messages

`MCDiagnostic` is meant to be used for compiler diagnostics.

Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json`
(see e.g. !14475, !14492 !14548).

To avoid this in the future I want to control more narrowly who creates
`MCDiagnostic` (see #24113).

Some parts of the compiler use `MCDiagnostic` purely for formatting
purposes, without creating any real compiler diagnostics.  This change
introduces a helper function, `formatDiagnostic`, that can be used in
such cases instead of constructing `MCDiagnostic`.

4 changed files:

compiler/GHC/Core/Lint.hs
compiler/GHC/Stg/Lint.hs
compiler/GHC/Types/Error.hs
compiler/GHC/Utils/Error.hs

Changes:

compiler/GHC/Core/Lint.hs

@@ -3418,7 +3418,7 @@ addMsg show_context env msgs msg
                 []    -> noSrcSpan
                 (s:_) -> s
     !diag_opts = le_diagOpts env
 -   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span
 +   mk_msg msg = mkLintWarning diag_opts msg_span
                               (msg $$ context)
  addLoc :: LintLocInfo -> LintM a -> LintM a

compiler/GHC/Stg/Lint.hs

@@ -107,7 +107,6 @@ import GHC.Core.Type
  import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
  import GHC.Types.CostCentre ( isCurrentCCS )
 -import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) )
  import GHC.Types.Id
  import GHC.Types.Var.Set
  import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
@@ -116,7 +115,7 @@ import GHC.Types.SrcLoc
  import GHC.Utils.Logger
  import GHC.Utils.Outputable
 -import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
 +import GHC.Utils.Error      ( DiagOpts )
  import qualified GHC.Utils.Error as Err
  import GHC.Unit.Module            ( Module )
@@ -540,7 +539,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 Nothing)
 +                     in  Err.mkLintWarning diag_opts
                                        l (hdr $$ msg)
      mk_msg []      = msg

compiler/GHC/Types/Error.hs

@@ -72,6 +72,7 @@ module GHC.Types.Error
     , pprMessageBag
     , mkLocMessage
     , mkLocMessageWarningGroups
 +   , formatDiagnostic
     , getCaretDiagnostic
     , jsonDiagnostic
@@ -495,11 +496,11 @@ data MessageClass
      -- ^ 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,
 -    -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
 +    -- users are encouraged to use higher level primitives
      -- instead. Use this constructor directly only if you need to construct
      -- 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.
 +    -- emitting compiler diagnostics, use higher level primitives.
      --
      -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for
      -- this diagnostic. If you are creating a message not tied to any
@@ -656,32 +657,51 @@ mkLocMessageWarningGroups
    -> SrcSpan                            -- ^ location
    -> SDoc                               -- ^ message
    -> SDoc
 -  -- 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>".
  mkLocMessageWarningGroups show_warn_groups msg_class locn msg
 -    = sdocOption sdocColScheme $ \col_scheme ->
 -      let locn' = sdocOption sdocErrorSpans $ \case
 -                     True  -> ppr locn
 -                     False -> ppr (srcSpanStart locn)
+-
 +  = case msg_class of
 +    MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg
 +    _ -> sdocOption sdocColScheme $ \col_scheme ->
 +      let
            msg_colour = getMessageClassColour msg_class col_scheme
 -          col = coloured msg_colour . text
            msg_title = coloured msg_colour $
              case msg_class of
 -              MCDiagnostic SevError   _ _ -> text "error"
 -              MCDiagnostic SevWarning _ _ -> text "warning"
                MCFatal                     -> text "fatal"
                _                           -> empty
 +      in formatLocMessageWarningGroups locn msg_title empty empty msg
++
 +formatDiagnostic
 +  :: Bool                               -- ^ Print warning groups?
 +  -> SrcSpan                            -- ^ location
 +  -> Severity
 +  -> ResolvedDiagnosticReason
 +  -> Maybe DiagnosticCode
 +  -> SDoc                               -- ^ message
 +  -> SDoc
 +formatDiagnostic show_warn_groups locn severity reason code msg
 +    = sdocOption sdocColScheme $ \col_scheme ->
 +      let
 +          msg_colour :: Col.PprColour
 +          msg_colour = getSeverityColour severity col_scheme
++
 +          col :: String -> SDoc
 +          col = coloured msg_colour . text
++
 +          msg_title :: SDoc
 +          msg_title = coloured msg_colour $
 +            case severity of
 +              SevError -> text "error"
 +              SevWarning -> text "warning"
 +              SevIgnore -> empty
++
 +          warning_flag_doc :: SDoc
            warning_flag_doc =
 -            case msg_class of
 -              MCDiagnostic sev reason _code
 -                | Just msg <- flag_msg sev (resolvedDiagnosticReason reason)
 -                  -> brackets msg
 -              _   -> empty
 +            case flag_msg severity (resolvedDiagnosticReason reason) of
 +              Nothing -> empty
 +              Just msg -> brackets msg
 +          ppr_with_hyperlink :: DiagnosticCode -> SDoc
            ppr_with_hyperlink code =
              -- this is a bit hacky, but we assume that if the terminal supports colors
              -- then it should also support links
@@ -691,10 +711,11 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
                   then ppr $ LinkedDiagCode code
                   else ppr code
 +          code_doc :: SDoc
            code_doc =
 -            case msg_class of
 -              MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)
 -              _                            -> empty
 +            case code of
 +              Just code -> brackets (ppr_with_hyperlink code)
 +              Nothing -> empty
            flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
            flag_msg SevIgnore _                 = Nothing
@@ -725,13 +746,35 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
                vcat [ text "locn:" <+> ppr locn
                     , text "msg:" <+> ppr msg ]
 +          warn_flag_grp :: [WarningGroup] -> SDoc
            warn_flag_grp groups
                | show_warn_groups, not (null groups)
                            = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")"
                | otherwise = empty
 +      in formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
++
 +formatLocMessageWarningGroups
 +  :: SrcSpan                            -- ^ location
 +  -> SDoc                               -- ^ title
 +  -> SDoc                               -- ^ diagnostic code
 +  -> SDoc                               -- ^ warning groups
 +  -> SDoc                               -- ^ message
 +  -> SDoc
 +formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
 +    = sdocOption sdocColScheme $ \col_scheme ->
 +      let
 +          -- 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>".
 +          locn' :: SDoc
 +          locn' = sdocOption sdocErrorSpans $ \case
 +                     True  -> ppr locn
 +                     False -> ppr (srcSpanStart locn)
++
            -- Add prefixes, like    Foo.hs:34: warning:
            --                           <the warning message>
 +          header :: SDoc
            header = locn' <> colon <+>
                     msg_title <> colon <+>
                     code_doc <+> warning_flag_doc
@@ -741,11 +784,16 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
                          msg)
  getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
 -getMessageClassColour (MCDiagnostic SevError _reason _code)   = Col.sError
 -getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning
 +getMessageClassColour (MCDiagnostic severity _reason _code)   = getSeverityColour severity
  getMessageClassColour MCFatal                                 = Col.sFatal
  getMessageClassColour _                                       = const mempty
 +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
 +getSeverityColour severity = case severity of
 +  SevError -> Col.sError
 +  SevWarning -> Col.sWarning
 +  SevIgnore -> const mempty
++
  getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
  getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
  getCaretDiagnostic msg_class (RealSrcSpan span _) =

compiler/GHC/Utils/Error.hs

@@ -32,7 +32,7 @@ module GHC.Utils.Error (
          emptyMessages, mkDecorated, mkLocMessage,
          mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
          mkErrorMsgEnvelope,
 -        mkMCDiagnostic, diagReasonSeverity,
 +        mkLintWarning, diagReasonSeverity,
          mkPlainError,
          mkPlainDiagnostic,
@@ -160,12 +160,10 @@ diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason o
    ErrorWithoutFlag
      -> (SevError, reason)
 --- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
 --- 'DiagOpts'.
 -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
 -mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code
 +mkLintWarning :: DiagOpts -> SrcSpan -> SDoc -> SDoc
 +mkLintWarning opts span = formatDiagnostic True span severity reason Nothing
    where
 -    (sev, reason') = diag_reason_severity opts reason
 +    (severity, reason) = diag_reason_severity opts WarningWithoutFlag
  --
  -- Creating MsgEnvelope(s)