Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • compiler/GHC/Driver/Errors.hs
    ... ... @@ -11,8 +11,9 @@ import GHC.Driver.Errors.Types
    11 11 
     import GHC.Prelude
    12 12 
     import GHC.Types.SourceError
    13 13 
     import GHC.Types.Error
    14 
    +import GHC.Utils.Json
    14 15 
     import GHC.Utils.Error
    15 
    -import GHC.Utils.Outputable (SDocContext, PprStyle, hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext)
    16 
    +import GHC.Utils.Outputable
    16 17 
     import GHC.Utils.Logger
    17 18
    18 19 
     printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
    ... ... @@ -23,9 +24,26 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages
    23 24
    24 25 
         printMessage :: MsgEnvelope a -> IO ()
    25 26 
         printMessage message
    26 
    -      | log_diags_as_json = logJsonMsg logger messageClass message
    27 
    +      | log_diags_as_json = do
    28 
    +          docWithHeader <- addCaret logflags messageClass location (addHeader doc)
    29 
    +          let
    30 
    +            rendered :: String
    31 
    +            rendered = renderWithContext (log_default_user_context logflags) docWithHeader
    32 
    +
    33 
    +            jsonMessage :: JsonDoc
    34 
    +            jsonMessage = case json message of
    35 
    +              JSObject xs -> JSObject (("rendered", JSString rendered) : xs)
    36 
    +              xs -> xs
    37 
    +          logJsonMsg logger messageClass jsonMessage
    38 
    +
    27 39 
           | otherwise = logMsg logger messageClass location doc
    28 40 
             where
    41 
    +          logflags :: LogFlags
    42 
    +          logflags = logFlags logger
    43 
    +
    44 
    +          addHeader :: SDoc -> SDoc
    45 
    +          addHeader = mkLocMessageWarningGroups (log_show_warn_groups logflags) messageClass location
    46 
    +
    29 47 
               doc :: SDoc
    30 48 
               doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
    31 49

  • compiler/GHC/Utils/Logger.hs
    ... ... @@ -21,6 +21,8 @@ module GHC.Utils.Logger
    21 21 
         , HasLogger (..)
    22 22 
         , ContainsLogger (..)
    23 23
    24 
    +    , addCaret
    25 
    +
    24 26 
         -- * Logger setup
    25 27 
         , initLogger
    26 28 
         , LogAction
    ... ... @@ -435,18 +437,51 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
    435 437 
           message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
    436 438
    437 439 
           printDiagnostics :: IO ()
    438 
    -      printDiagnostics = do
    439 
    -        caretDiagnostic <-
    440 
    -            if log_show_caret logflags
    441 
    -            then getCaretDiagnostic msg_class srcSpan
    442 
    -            else pure empty
    443 
    -        printErrs $ getPprStyle $ \style ->
    444 
    -          withPprStyle (setStyleColoured True style)
    445 
    -            (message $+$ caretDiagnostic $+$ blankLine)
    446 
    -        -- careful (#2302): printErrs prints in UTF-8,
    447 
    -        -- whereas converting to string first and using
    448 
    -        -- hPutStr would just emit the low 8 bits of
    449 
    -        -- each unicode char.
    440 
    +      printDiagnostics = addCaret logflags msg_class srcSpan message >>= printErrs
    441 
    +
    442 
    +-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
    443 
    +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
    444 
    +-- message on `-fdiagnostics-as-json`.
    445 
    +--
    446 
    +-- We would want to eventually consolidate this.  However, this is currently
    447 
    +-- not feasible for the following reasons:
    448 
    +--
    449 
    +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
    450 
    +--    can not decorate (`addCaret` + `defaultLogActionHPrintDoc`) the
    451 
    +--    message in `printMessages`.
    452 
    +--
    453 
    +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
    454 
    +--    that reason we can decorate the message in `defaultLogActionWithHandles`.
    455 
    +--
    456 
    +--    See also Note [JSON Error Messages]:
    457 
    +--
    458 
    +--      `jsonLogAction` should be removed along with -ddump-json
    459 
    +--
    460 
    +-- Also note that (1) is the reason why some parts of the compiler produce
    461 
    +-- diagnostics that don't respect `-fdiagnostics-as-json`.
    462 
    +--
    463 
    +-- The plan as I see it is as follows:
    464 
    +--
    465 
    +--  1. Refactor all places in the compiler that report diagnostics to go
    466 
    +--     through `GHC.Driver.Errors.printMessages`.
    467 
    +--
    468 
    +--     (It's easy to find all those places by looking for who creates
    469 
    +--     MCDiagnostic, either directly or via `mkMCDiagnostic` or
    470 
    +--     `errorDiagnostic`.)
    471 
    +--
    472 
    +--  2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
    473 
    +--     decoration at one place (either `printMessages` or
    474 
    +--     `defaultLogActionWithHandles`)
    475 
    +--
    476 
    +addCaret :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
    477 
    +addCaret logflags msg_class srcSpan message = do
    478 
    +  caretDiagnostic <-
    479 
    +      if log_show_caret logflags
    480 
    +      then getCaretDiagnostic msg_class srcSpan
    481 
    +      else pure empty
    482 
    +  return $ getPprStyle $ \style ->
    483 
    +    withPprStyle (setStyleColoured True style)
    484 
    +      (message $+$ caretDiagnostic $+$ blankLine)
    450 485
    451 486 
     -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
    452 487 
     defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
    ... ... @@ -482,6 +517,8 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
    482 517 
     -- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
    483 518 
     -- it should be removed along with -ddump-json. Similarly, the guard in
    484 519 
     -- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
    520 
    +--
    521 
    +--
    485 522
    486 523 
     -- | Default action for 'dumpAction' hook
    487 524 
     defaultDumpAction :: DumpCache -> LogAction -> DumpAction
    ... ... @@ -611,8 +648,8 @@ defaultTraceAction logflags title doc x =
    611 648 
     logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    612 649 
     logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
    613 650
    614 
    -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
    615 
    -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)
    651 
    +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
    652 
    +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
    616 653
    617 654 
     -- | Dump something
    618 655 
     logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help