Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f8d9d016 by Andrew Lelechenko at 2025-07-22T21:13:28-04:00 Fix issues with toRational for types capable to represent infinite and not-a-number values This commit fixes all of the following pitfalls:
toRational (read "Infinity" :: Double) 179769313486231590772930519078902473361797697894230657273430081157732675805500963132708477322407536021120113879871393357658789768814416622492847430639474124377767893424865485276302219601246094119453082952085005768838150682342462881473913110540827237163350510684586298239947245938479716304835356329624224137216 % 1 toRational (read "NaN" :: Double) 269653970229347386159395778618353710042696546841345985910145121736599013708251444699062715983611304031680170819807090036488184653221624933739271145959211186566651840137298227914453329401869141179179624428127508653257226023513694322210869665811240855745025766026879447359920868907719574457253034494436336205824 % 1
realToFrac (read "NaN" :: Double) -- With -O0 Infinity realToFrac (read "NaN" :: Double) -- With -O1 NaN
realToFrac (read "NaN" :: Double) :: CDouble Infinity realToFrac (read "NaN" :: CDouble) :: Double Infinity
Implements https://github.com/haskell/core-libraries-committee/issues/338
- - - - -
5dabc718 by Zubin Duggal at 2025-07-22T21:14:10-04:00
haddock: Don't warn about missing link destinations for derived names.
Fixes #26114
- - - - -
9c3a0937 by Matthew Pickering at 2025-07-22T21:14:52-04:00
template haskell: use a precise condition when implicitly lifting
Implicit lifting corrects a level error by replacing references to `x`
with `$(lift x)`, therefore you can use a level `n` binding at level `n
+ 1`, if it can be lifted.
Therefore, we now have a precise check that the use level is 1 more than
the bind level.
Before this bug was not observable as you only had 0 and 1 contexts but
it is easily evident when using explicit level imports.
Fixes #26088
- - - - -
5144b22f by Andreas Klebinger at 2025-07-22T21:15:34-04:00
Add since tag and more docs for do-clever-arg-eta-expansion
Fixes #26113
- - - - -
c865623b by Andreas Klebinger at 2025-07-22T21:15:34-04:00
Add since tag for -fexpose-overloaded-unfoldings
Fixes #26112
- - - - -
49a44ab7 by Simon Hengel at 2025-07-23T17:59:55+07:00
Refactor GHC.Driver.Errors.printMessages
- - - - -
1b80f483 by Simon Hengel at 2025-07-23T18:08:17+07:00
Include the rendered message in -fdiagnostics-as-json output
This implements #26173.
- - - - -
46d49146 by Ben Gamari at 2025-07-23T10:02:48-04:00
rts/Interpreter: Factor out ctoi tuple info tables into data
Instead of a massive case let's put this into data which we can reuse
elsewhere.
- - - - -
24 changed files:
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/9.14.1-notes.rst
- + docs/users_guide/diagnostics-as-json-schema-1_2.json
- docs/users_guide/using-optimisation.rst
- docs/users_guide/using.rst
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/Real.hs
- rts/Interpreter.c
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
- testsuite/tests/haddock/haddock_testsuite/Makefile
- + testsuite/tests/haddock/haddock_testsuite/T26114.hs
- + testsuite/tests/haddock/haddock_testsuite/T26114.stdout
- testsuite/tests/haddock/haddock_testsuite/all.T
- testsuite/tests/numeric/should_run/T9810.stdout
- + testsuite/tests/splice-imports/T26088.stderr
- + testsuite/tests/splice-imports/T26088A.hs
- + testsuite/tests/splice-imports/T26088B.hs
- testsuite/tests/splice-imports/all.T
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -7,27 +7,59 @@ module GHC.Driver.Errors (
import GHC.Driver.Errors.Types
import GHC.Prelude
+import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
+import GHC.Utils.Json
import GHC.Utils.Error
-import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext )
+import GHC.Utils.Outputable
import GHC.Utils.Logger
printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
-printMessages logger msg_opts opts msgs
- = sequence_ [ let style = mkErrStyle name_ppr_ctx
- ctx = (diag_ppr_ctx opts) { sdocStyle = style }
- in (if log_diags_as_json
- then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg
- else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $
- updSDocContext (\_ -> ctx) (messageWithHints dia))
- | msg@MsgEnvelope { errMsgSpan = s,
- errMsgDiagnostic = dia,
- errMsgSeverity = sev,
- errMsgReason = reason,
- errMsgContext = name_ppr_ctx }
- <- sortMsgBag (Just opts) (getMessages msgs) ]
+printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages
where
+ sortMessages :: Messages a -> [MsgEnvelope a]
+ sortMessages = sortMsgBag (Just opts) . getMessages
+
+printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
+printMessage logger msg_opts opts message
+ | log_diags_as_json = do
+ decorated <- decorateDiagnostic logflags messageClass location doc
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) decorated
+
+ jsonMessage :: JsonDoc
+ jsonMessage = jsonDiagnostic rendered message
+
+ logJsonMsg logger messageClass jsonMessage
+
+ | otherwise = logMsg logger messageClass location doc
+ where
+ logflags :: LogFlags
+ logflags = logFlags logger
+
+ doc :: SDoc
+ doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
+
+ messageClass :: MessageClass
+ messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic)
+
+ style :: PprStyle
+ style = mkErrStyle (errMsgContext message)
+
+ location :: SrcSpan
+ location = errMsgSpan message
+
+ ctx :: SDocContext
+ ctx = (diag_ppr_ctx opts) { sdocStyle = style }
+
+ diagnostic :: a
+ diagnostic = errMsgDiagnostic message
+
+ severity :: Severity
+ severity = errMsgSeverity message
+
messageWithHints :: a -> SDoc
messageWithHints e =
let main_msg = formatBulleted $ diagnosticMessage msg_opts e
@@ -36,6 +68,8 @@ printMessages logger msg_opts opts msgs
[h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
hs -> main_msg $$ hang (text "Suggested fixes:") 2
(formatBulleted $ mkDecorated . map ppr $ hs)
+
+ log_diags_as_json :: Bool
log_diags_as_json = log_diagnostics_as_json (logFlags logger)
-- | Given a bag of diagnostics, turn them into an exception if
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec )
import GHC.Types.SourceText ( SourceText(..) )
+import GHC.Types.ThLevelIndex
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.SrcLoc
@@ -1001,7 +1002,7 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
, xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var)
-- 4. Name is in a bracket, and lifting is allowed
| Brack _ pending <- use_lvl
- , any (use_lvl_idx >=) (Set.toList bind_lvl)
+ , any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl)
, allow_lifting
= do
let mgre = case reason of
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -73,6 +73,9 @@ module GHC.Types.Error
, mkLocMessage
, mkLocMessageWarningGroups
, getCaretDiagnostic
+
+ , jsonDiagnostic
+
-- * Queries
, isIntrinsicErrorMessage
, isExtrinsicErrorMessage
@@ -109,7 +112,7 @@ import GHC.Utils.Panic
import GHC.Version (cProjectVersion)
import Data.Bifunctor
-import Data.Foldable ( fold, toList )
+import Data.Foldable
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
@@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where
pprDiagnostic (errMsgDiagnostic envelope)
]
-instance (Diagnostic e) => ToJson (Messages e) where
- json msgs = JSArray . toList $ json <$> getMessages msgs
-
{- Note [Discarding Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
@@ -586,15 +586,17 @@ https://json-schema.org
-}
schemaVersion :: String
-schemaVersion = "1.1"
+schemaVersion = "1.2"
+
-- See Note [Diagnostic Message JSON Schema] before editing!
-instance Diagnostic e => ToJson (MsgEnvelope e) where
- json m = JSObject $ [
+jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
+jsonDiagnostic rendered m = JSObject $ [
("version", JSString schemaVersion),
("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
("span", json $ errMsgSpan m),
("severity", json $ errMsgSeverity m),
("code", maybe JSNull json (diagnosticCode diag)),
+ ("rendered", JSString rendered),
("message", JSArray $ map renderToJSString diagMsg),
("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
++ [ ("reason", reasonJson)
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -62,6 +62,8 @@ module GHC.Utils.Logger
, logJsonMsg
, logDumpMsg
+ , decorateDiagnostic
+
-- * Dumping
, defaultDumpAction
, putDumpFile
@@ -419,26 +421,62 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
MCInfo -> printErrs msg
MCFatal -> printErrs msg
MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message
- MCDiagnostic _sev _rea _code -> printDiagnostics
+ MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
where
printOut = defaultLogActionHPrintDoc logflags False out
printErrs = defaultLogActionHPrintDoc logflags False err
putStrSDoc = defaultLogActionHPutStrDoc logflags False out
+
+-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
+-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
+-- message on `-fdiagnostics-as-json`.
+--
+-- We would want to eventually consolidate this. However, this is currently
+-- not feasible for the following reasons:
+--
+-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
+-- can not decorate the message in `printMessages`.
+--
+-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
+-- that reason we can not decorate the message in `defaultLogActionWithHandles`.
+--
+-- See also Note [JSON Error Messages]:
+--
+-- `jsonLogAction` should be removed along with -ddump-json
+--
+-- Also note that (1) is the reason why some parts of the compiler produce
+-- diagnostics that don't respect `-fdiagnostics-as-json`.
+--
+-- The plan as I see it is as follows:
+--
+-- 1. Refactor all places in the compiler that report diagnostics to go
+-- through `GHC.Driver.Errors.printMessages`.
+--
+-- (It's easy to find all those places by looking for who creates
+-- MCDiagnostic, either directly or via `mkMCDiagnostic` or
+-- `errorDiagnostic`.)
+--
+-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
+-- decoration at one place (either `printMessages` or
+-- `defaultLogActionWithHandles`)
+--
+-- This story is tracked by #24113.
+decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
+decorateDiagnostic logflags msg_class srcSpan msg = addCaret
+ where
-- Pretty print the warning flag, if any (#10752)
+ message :: SDoc
message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
- printDiagnostics = do
+ addCaret :: IO SDoc
+ addCaret = do
caretDiagnostic <-
if log_show_caret logflags
then getCaretDiagnostic msg_class srcSpan
else pure empty
- printErrs $ getPprStyle $ \style ->
+ return $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
(message $+$ caretDiagnostic $+$ blankLine)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
@@ -603,8 +641,8 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
-logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
-logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d)
+logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
+logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -147,6 +147,11 @@ Compiler
integer operations. Also, ``shuffleFloatX4#`` and ``shuffleDoubleX2#`` no longer
require ``-mavx``.
+- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
+ include the `rendered` diagnostics message, in the exact same format as what
+ GHC would have produced without -fdiagnostics-as-json (including ANSI escape
+ sequences).
+
GHCi
~~~~
=====================================
docs/users_guide/diagnostics-as-json-schema-1_2.json
=====================================
@@ -0,0 +1,144 @@
+{
+ "$schema": "https://json-schema.org/draft/2020-12/schema",
+ "title": "JSON Diagnostic Schema",
+ "description": "A Schema for specifying GHC diagnostics output as JSON",
+ "type": "object",
+ "properties": {
+ "version": {
+ "description": "The current JSON schema version this object conforms to",
+ "type": "string"
+ },
+ "ghcVersion": {
+ "description": "The GHC version",
+ "type": "string"
+ },
+ "span": {
+ "oneOf": [
+ { "$ref": "#/$defs/span" },
+ { "type": "null" }
+ ]
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "rendered": {
+ "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
+ "type": "string"
+ },
+ "message": {
+ "description": "The string output of the diagnostic message by GHC",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "hints": {
+ "description": "The suggested fixes",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "reason" : {
+ "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+ "oneOf": [
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by one or more GHC flags",
+ "properties": {
+ "flags": {
+ "type": "array",
+ "items": {
+ "description": "The name of a GHC flag controlling the diagnostic message",
+ "type": "string"
+ },
+ "minItems": 1
+ }
+ },
+ "required": ["flags"]
+ },
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+ "properties": {
+ "category": {
+ "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+ "type": "string"
+ }
+ },
+ "required": ["category"]
+ }
+ ]
+ }
+ },
+
+ "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.",
+ "required": [
+ "version",
+ "ghcVersion",
+ "span",
+ "severity",
+ "code",
+ "message",
+ "hints"
+ ],
+
+ "additionalProperties": false,
+ "$defs": {
+ "span": {
+ "description": "The span of the diagnostic",
+ "type": "object",
+ "properties": {
+ "file": {
+ "description": "The file in which the diagnostic occurs",
+ "type": "string"
+ },
+ "start": {
+ "description": "The start location of the diagnostic",
+ "$ref": "#/$defs/location"
+ },
+ "end": {
+ "description": "The end location of the diagnostic",
+ "$ref": "#/$defs/location"
+ }
+ },
+ "required": [
+ "file",
+ "start",
+ "end"
+ ],
+ "additionalProperties": false
+ },
+ "location": {
+ "description": "A location in a text file",
+ "type": "object",
+ "properties": {
+ "line": {
+ "description": "The line number",
+ "type": "integer"
+ },
+ "column": {
+ "description": "The column number",
+ "type": "integer"
+ }
+ },
+ "required": [
+ "line",
+ "column"
+ ],
+ "additionalProperties": false
+ }
+ }
+}
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -547,16 +547,24 @@ as such you shouldn't need to set any of them explicitly. A flag
Eta-expand let-bindings to increase their arity.
.. ghc-flag:: -fdo-clever-arg-eta-expansion
- :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O2`.
+ :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O`.
:type: dynamic
:reverse: -fno-do-clever-arg-eta-expansion
:category:
:default: off
+ :since: 9.10.1
Eta-expand arguments to increase their arity to avoid allocating unnecessary
thunks for them.
+ For example in code like `foo = f (g x)` this flag will determine which analysis
+ is used to decide the arity of `g x`, with the goal of avoiding a thunk for `g x`
+ in cases where `g` is a function with an arity higher than one.
+
+ Enabling the flag enables a more sophisticated analysis, resulting in better
+ runtime but longer compile time.
+
.. ghc-flag:: -feager-blackholing
:shortdesc: Turn on :ref:`eager blackholing <parallel-compile-options>`
:type: dynamic
@@ -617,6 +625,7 @@ as such you shouldn't need to set any of them explicitly. A flag
:category:
:default: off
+ :since: 9.12.1
This experimental flag is a slightly less heavy weight alternative
to :ghc-flag:`-fexpose-all-unfoldings`.
=====================================
docs/users_guide/using.rst
=====================================
@@ -1428,7 +1428,7 @@ messages and in GHCi:
a new line.
The structure of the output is described by a `JSON Schema https://json-schema.org/`_.
- The schema can be downloaded :download:`here
participants (1)
-
Marge Bot (＠marge-bot)