Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

24 changed files:

Changes:

  • compiler/GHC/Driver/Errors.hs
    ... ... @@ -7,27 +7,59 @@ module GHC.Driver.Errors (
    7 7
    8 8 
     import GHC.Driver.Errors.Types
    9 9 
     import GHC.Prelude
    10 
    +import GHC.Types.SrcLoc
    10 11 
     import GHC.Types.SourceError
    11 12 
     import GHC.Types.Error
    13 
    +import GHC.Utils.Json
    12 14 
     import GHC.Utils.Error
    13 
    -import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext )
    15 
    +import GHC.Utils.Outputable
    14 16 
     import GHC.Utils.Logger
    15 17
    16 18 
     printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
    17 
    -printMessages logger msg_opts opts msgs
    18 
    -  = sequence_ [ let style = mkErrStyle name_ppr_ctx
    19 
    -                    ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
    20 
    -                in (if log_diags_as_json
    21 
    -                    then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg
    22 
    -                    else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $
    23 
    -                  updSDocContext (\_ -> ctx) (messageWithHints dia))
    24 
    -              | msg@MsgEnvelope { errMsgSpan       = s,
    25 
    -                                  errMsgDiagnostic = dia,
    26 
    -                                  errMsgSeverity   = sev,
    27 
    -                                  errMsgReason     = reason,
    28 
    -                                  errMsgContext    = name_ppr_ctx }
    29 
    -                  <- sortMsgBag (Just opts) (getMessages msgs) ]
    19 
    +printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages
    30 20 
       where
    21 
    +    sortMessages :: Messages a -> [MsgEnvelope a]
    22 
    +    sortMessages = sortMsgBag (Just opts) . getMessages
    23 
    +
    24 
    +printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
    25 
    +printMessage logger msg_opts opts message
    26 
    +  | log_diags_as_json = do
    27 
    +      decorated <- decorateDiagnostic logflags messageClass location doc
    28 
    +      let
    29 
    +        rendered :: String
    30 
    +        rendered = renderWithContext (log_default_user_context logflags) decorated
    31 
    +
    32 
    +        jsonMessage :: JsonDoc
    33 
    +        jsonMessage = jsonDiagnostic rendered message
    34 
    +
    35 
    +      logJsonMsg logger messageClass jsonMessage
    36 
    +
    37 
    +  | otherwise = logMsg logger messageClass location doc
    38 
    +  where
    39 
    +    logflags :: LogFlags
    40 
    +    logflags = logFlags logger
    41 
    +
    42 
    +    doc :: SDoc
    43 
    +    doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
    44 
    +
    45 
    +    messageClass :: MessageClass
    46 
    +    messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic)
    47 
    +
    48 
    +    style :: PprStyle
    49 
    +    style = mkErrStyle (errMsgContext message)
    50 
    +
    51 
    +    location :: SrcSpan
    52 
    +    location = errMsgSpan message
    53 
    +
    54 
    +    ctx :: SDocContext
    55 
    +    ctx = (diag_ppr_ctx opts) { sdocStyle = style }
    56 
    +
    57 
    +    diagnostic :: a
    58 
    +    diagnostic = errMsgDiagnostic message
    59 
    +
    60 
    +    severity :: Severity
    61 
    +    severity = errMsgSeverity message
    62 
    +
    31 63 
         messageWithHints :: a -> SDoc
    32 64 
         messageWithHints e =
    33 65 
           let main_msg = formatBulleted $ diagnosticMessage msg_opts e
    ... ... @@ -36,6 +68,8 @@ printMessages logger msg_opts opts msgs
    36 68 
                    [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
    37 69 
                    hs  -> main_msg $$ hang (text "Suggested fixes:") 2
    38 70 
                                            (formatBulleted  $ mkDecorated . map ppr $ hs)
    71 
    +
    72 
    +    log_diags_as_json :: Bool
    39 73 
         log_diags_as_json = log_diagnostics_as_json (logFlags logger)
    40 74
    41 75 
     -- | 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 )
    35 35 
     import GHC.Types.Error
    36 36 
     import GHC.Types.Basic    ( TopLevelFlag, isTopLevel, maxPrec )
    37 37 
     import GHC.Types.SourceText ( SourceText(..) )
    38 
    +import GHC.Types.ThLevelIndex
    38 39 
     import GHC.Utils.Outputable
    39 40 
     import GHC.Unit.Module
    40 41 
     import GHC.Types.SrcLoc
    ... ... @@ -1001,7 +1002,7 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
    1001 1002 
       , xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var)
    1002 1003 
       -- 4. Name is in a bracket, and lifting is allowed
    1003 1004 
       | Brack _ pending <- use_lvl
    1004 
    -  , any (use_lvl_idx >=) (Set.toList bind_lvl)
    1005 
    +  , any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl)
    1005 1006 
       , allow_lifting
    1006 1007 
       = do
    1007 1008 
            let mgre = case reason of

  • compiler/GHC/Types/Error.hs
    ... ... @@ -73,6 +73,9 @@ module GHC.Types.Error
    73 73 
        , mkLocMessage
    74 74 
        , mkLocMessageWarningGroups
    75 75 
        , getCaretDiagnostic
    76 
    +
    77 
    +   , jsonDiagnostic
    78 
    +
    76 79 
        -- * Queries
    77 80 
        , isIntrinsicErrorMessage
    78 81 
        , isExtrinsicErrorMessage
    ... ... @@ -109,7 +112,7 @@ import GHC.Utils.Panic
    109 112
    110 113 
     import GHC.Version (cProjectVersion)
    111 114 
     import Data.Bifunctor
    112 
    -import Data.Foldable    ( fold, toList )
    115 
    +import Data.Foldable
    113 116 
     import Data.List.NonEmpty ( NonEmpty (..) )
    114 117 
     import qualified Data.List.NonEmpty as NE
    115 118 
     import Data.List ( intercalate )
    ... ... @@ -171,9 +174,6 @@ instance Diagnostic e => Outputable (Messages e) where
    171 174 
                    pprDiagnostic (errMsgDiagnostic envelope)
    172 175 
                  ]
    173 176
    174 
    -instance (Diagnostic e) => ToJson (Messages e) where
    175 
    -  json msgs =  JSArray . toList $ json <$> getMessages msgs
    176 
    -
    177 177 
     {- Note [Discarding Messages]
    178 178 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    179 179
    ... ... @@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
    573 573 
     {- Note [Diagnostic Message JSON Schema]
    574 574 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    575 575 
     The below instance of ToJson must conform to the JSON schema
    576 
    -specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
    576 
    +specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
    577 577 
     When the schema is altered, please bump the version.
    578 578 
     If the content is altered in a backwards compatible way,
    579 579 
     update the minor version (e.g. 1.3 ~> 1.4).
    ... ... @@ -586,15 +586,17 @@ https://json-schema.org
    586 586 
     -}
    587 587
    588 588 
     schemaVersion :: String
    589 
    -schemaVersion = "1.1"
    589 
    +schemaVersion = "1.2"
    590 
    +
    590 591 
     -- See Note [Diagnostic Message JSON Schema] before editing!
    591 
    -instance Diagnostic e => ToJson (MsgEnvelope e) where
    592 
    -  json m = JSObject $ [
    592 
    +jsonDiagnostic :: forall e. Diagnostic e => String -> MsgEnvelope e -> JsonDoc
    593 
    +jsonDiagnostic rendered m = JSObject $ [
    593 594 
         ("version", JSString schemaVersion),
    594 595 
         ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
    595 596 
         ("span", json $ errMsgSpan m),
    596 597 
         ("severity", json $ errMsgSeverity m),
    597 598 
         ("code", maybe JSNull json (diagnosticCode diag)),
    599 
    +    ("rendered", JSString rendered),
    598 600 
         ("message", JSArray $ map renderToJSString diagMsg),
    599 601 
         ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ]
    600 602 
         ++ [ ("reason", reasonJson)

  • compiler/GHC/Utils/Logger.hs
    ... ... @@ -62,6 +62,8 @@ module GHC.Utils.Logger
    62 62 
         , logJsonMsg
    63 63 
         , logDumpMsg
    64 64
    65 
    +    , decorateDiagnostic
    66 
    +
    65 67 
         -- * Dumping
    66 68 
         , defaultDumpAction
    67 69 
         , putDumpFile
    ... ... @@ -419,26 +421,62 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
    419 421 
           MCInfo                       -> printErrs msg
    420 422 
           MCFatal                      -> printErrs msg
    421 423 
           MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message
    422 
    -      MCDiagnostic _sev _rea _code -> printDiagnostics
    424 
    +      MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
    423 425 
         where
    424 426 
           printOut   = defaultLogActionHPrintDoc  logflags False out
    425 427 
           printErrs  = defaultLogActionHPrintDoc  logflags False err
    426 428 
           putStrSDoc = defaultLogActionHPutStrDoc logflags False out
    429 
    +
    430 
    +-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
    431 
    +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
    432 
    +-- message on `-fdiagnostics-as-json`.
    433 
    +--
    434 
    +-- We would want to eventually consolidate this.  However, this is currently
    435 
    +-- not feasible for the following reasons:
    436 
    +--
    437 
    +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
    438 
    +--    can not decorate the message in `printMessages`.
    439 
    +--
    440 
    +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
    441 
    +--    that reason we can not decorate the message in `defaultLogActionWithHandles`.
    442 
    +--
    443 
    +--    See also Note [JSON Error Messages]:
    444 
    +--
    445 
    +--      `jsonLogAction` should be removed along with -ddump-json
    446 
    +--
    447 
    +-- Also note that (1) is the reason why some parts of the compiler produce
    448 
    +-- diagnostics that don't respect `-fdiagnostics-as-json`.
    449 
    +--
    450 
    +-- The plan as I see it is as follows:
    451 
    +--
    452 
    +--  1. Refactor all places in the compiler that report diagnostics to go
    453 
    +--     through `GHC.Driver.Errors.printMessages`.
    454 
    +--
    455 
    +--     (It's easy to find all those places by looking for who creates
    456 
    +--     MCDiagnostic, either directly or via `mkMCDiagnostic` or
    457 
    +--     `errorDiagnostic`.)
    458 
    +--
    459 
    +--  2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
    460 
    +--     decoration at one place (either `printMessages` or
    461 
    +--     `defaultLogActionWithHandles`)
    462 
    +--
    463 
    +-- This story is tracked by #24113.
    464 
    +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
    465 
    +decorateDiagnostic logflags msg_class srcSpan msg = addCaret
    466 
    +    where
    427 467 
           -- Pretty print the warning flag, if any (#10752)
    468 
    +      message :: SDoc
    428 469 
           message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
    429 470
    430 
    -      printDiagnostics = do
    471 
    +      addCaret :: IO SDoc
    472 
    +      addCaret = do
    431 473 
             caretDiagnostic <-
    432 474 
                 if log_show_caret logflags
    433 475 
                 then getCaretDiagnostic msg_class srcSpan
    434 476 
                 else pure empty
    435 
    -        printErrs $ getPprStyle $ \style ->
    477 
    +        return $ getPprStyle $ \style ->
    436 478 
               withPprStyle (setStyleColoured True style)
    437 479 
                 (message $+$ caretDiagnostic $+$ blankLine)
    438 
    -        -- careful (#2302): printErrs prints in UTF-8,
    439 
    -        -- whereas converting to string first and using
    440 
    -        -- hPutStr would just emit the low 8 bits of
    441 
    -        -- each unicode char.
    442 480
    443 481 
     -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
    444 482 
     defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
    ... ... @@ -603,8 +641,8 @@ defaultTraceAction logflags title doc x =
    603 641 
     logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    604 642 
     logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
    605 643
    606 
    -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
    607 
    -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)
    644 
    +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
    645 
    +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
    608 646
    609 647 
     -- | Dump something
    610 648 
     logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

  • docs/users_guide/9.14.1-notes.rst
    ... ... @@ -147,6 +147,11 @@ Compiler
    147 147 
       integer operations.  Also, ``shuffleFloatX4#`` and ``shuffleDoubleX2#`` no longer
    148 148 
       require ``-mavx``.
    149 149
    150 
    +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
    151 
    +  include the `rendered` diagnostics message, in the exact same format as what
    152 
    +  GHC would have produced without -fdiagnostics-as-json (including ANSI escape
    153 
    +  sequences).
    154 
    +
    150 155 
     GHCi
    151 156 
     ~~~~
    152 157

  • docs/users_guide/diagnostics-as-json-schema-1_2.json
    1 
    +{
    2 
    +  "$schema": "https://json-schema.org/draft/2020-12/schema",
    3 
    +  "title": "JSON Diagnostic Schema",
    4 
    +  "description": "A Schema for specifying GHC diagnostics output as JSON",
    5 
    +  "type": "object",
    6 
    +  "properties": {
    7 
    +    "version": {
    8 
    +      "description": "The current JSON schema version this object conforms to",
    9 
    +      "type": "string"
    10 
    +    },
    11 
    +    "ghcVersion": {
    12 
    +      "description": "The GHC version",
    13 
    +      "type": "string"
    14 
    +    },
    15 
    +    "span": {
    16 
    +      "oneOf": [
    17 
    +        { "$ref": "#/$defs/span" },
    18 
    +        { "type": "null" }
    19 
    +      ]
    20 
    +    },
    21 
    +    "severity": {
    22 
    +      "description": "The diagnostic severity",
    23 
    +      "type": "string",
    24 
    +      "enum": [
    25 
    +        "Warning",
    26 
    +        "Error"
    27 
    +      ]
    28 
    +    },
    29 
    +    "code": {
    30 
    +      "description": "The diagnostic code (if it exists)",
    31 
    +      "type": [
    32 
    +        "integer",
    33 
    +        "null"
    34 
    +      ]
    35 
    +    },
    36 
    +    "rendered": {
    37 
    +      "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
    38 
    +      "type": "string"
    39 
    +    },
    40 
    +    "message": {
    41 
    +      "description": "The string output of the diagnostic message by GHC",
    42 
    +      "type": "array",
    43 
    +      "items": {
    44 
    +        "type": "string"
    45 
    +      }
    46 
    +    },
    47 
    +    "hints": {
    48 
    +      "description": "The suggested fixes",
    49 
    +      "type": "array",
    50 
    +      "items": {
    51 
    +        "type": "string"
    52 
    +      }
    53 
    +    },
    54 
    +    "reason" : {
    55 
    +      "description": "The GHC flag that was responsible for the emission of the diagnostic message",
    56 
    +      "oneOf": [
    57 
    +        {
    58 
    +          "type": "object",
    59 
    +          "description": "The diagnostic message was controlled by one or more GHC flags",
    60 
    +          "properties": {
    61 
    +            "flags": {
    62 
    +              "type": "array",
    63 
    +              "items": {
    64 
    +                "description": "The name of a GHC flag controlling the diagnostic message",
    65 
    +                "type": "string"
    66 
    +              },
    67 
    +              "minItems": 1
    68 
    +            }
    69 
    +          },
    70 
    +          "required": ["flags"]
    71 
    +        },
    72 
    +        {
    73 
    +          "type": "object",
    74 
    +          "description": "The diagnostic message was controlled by a GHC diagnostic message category",
    75 
    +          "properties": {
    76 
    +            "category": {
    77 
    +              "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
    78 
    +              "type": "string"
    79 
    +            }
    80 
    +          },
    81 
    +          "required": ["category"]
    82 
    +        }
    83 
    +      ]
    84 
    +    }
    85 
    +  },
    86 
    +
    87 
    +  "$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.",
    88 
    +  "required": [
    89 
    +    "version",
    90 
    +    "ghcVersion",
    91 
    +    "span",
    92 
    +    "severity",
    93 
    +    "code",
    94 
    +    "message",
    95 
    +    "hints"
    96 
    +  ],
    97 
    +
    98 
    +  "additionalProperties": false,
    99 
    +  "$defs": {
    100 
    +    "span": {
    101 
    +      "description": "The span of the diagnostic",
    102 
    +      "type": "object",
    103 
    +      "properties": {
    104 
    +        "file": {
    105 
    +          "description": "The file in which the diagnostic occurs",
    106 
    +          "type": "string"
    107 
    +        },
    108 
    +        "start": {
    109 
    +          "description": "The start location of the diagnostic",
    110 
    +          "$ref": "#/$defs/location"
    111 
    +        },
    112 
    +        "end": {
    113 
    +          "description": "The end location of the diagnostic",
    114 
    +          "$ref": "#/$defs/location"
    115 
    +        }
    116 
    +      },
    117 
    +      "required": [
    118 
    +        "file",
    119 
    +        "start",
    120 
    +        "end"
    121 
    +      ],
    122 
    +      "additionalProperties": false
    123 
    +    },
    124 
    +    "location": {
    125 
    +      "description": "A location in a text file",
    126 
    +      "type": "object",
    127 
    +      "properties": {
    128 
    +        "line": {
    129 
    +          "description": "The line number",
    130 
    +          "type": "integer"
    131 
    +        },
    132 
    +        "column": {
    133 
    +          "description": "The column number",
    134 
    +          "type": "integer"
    135 
    +        }
    136 
    +      },
    137 
    +      "required": [
    138 
    +        "line",
    139 
    +        "column"
    140 
    +      ],
    141 
    +      "additionalProperties": false
    142 
    +    }
    143 
    +  }
    144 
    +}

  • docs/users_guide/using-optimisation.rst
    ... ... @@ -547,16 +547,24 @@ as such you shouldn't need to set any of them explicitly. A flag
    547 547 
         Eta-expand let-bindings to increase their arity.
    548 548
    549 549 
     .. ghc-flag:: -fdo-clever-arg-eta-expansion
    550 
    -    :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O2`.
    550 
    +    :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O`.
    551 551 
         :type: dynamic
    552 552 
         :reverse: -fno-do-clever-arg-eta-expansion
    553 553 
         :category:
    554 554
    555 555 
         :default: off
    556 
    +    :since: 9.10.1
    556 557
    557 558 
         Eta-expand arguments to increase their arity to avoid allocating unnecessary
    558 559 
         thunks for them.
    559 560
    561 
    +    For example in code like `foo = f (g x)` this flag will determine which analysis
    562 
    +    is used to decide the arity of `g x`, with the goal of avoiding a thunk for `g x`
    563 
    +    in cases where `g` is a function with an arity higher than one.
    564 
    +
    565 
    +    Enabling the flag enables a more sophisticated analysis, resulting in better
    566 
    +    runtime but longer compile time.
    567 
    +
    560 568 
     .. ghc-flag:: -feager-blackholing
    561 569 
         :shortdesc: Turn on :ref:`eager blackholing <parallel-compile-options>`
    562 570 
         :type: dynamic
    ... ... @@ -617,6 +625,7 @@ as such you shouldn't need to set any of them explicitly. A flag
    617 625 
         :category:
    618 626
    619 627 
         :default: off
    628 
    +    :since: 9.12.1
    620 629
    621 630 
         This experimental flag is a slightly less heavy weight alternative
    622 631 
         to :ghc-flag:`-fexpose-all-unfoldings`.

  • docs/users_guide/using.rst
    ... ... @@ -1428,7 +1428,7 @@ messages and in GHCi:
    1428 1428 
         a new line.
    1429 1429
    1430 1430 
         The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
    1431 
    -    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
    1431 
    +    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`.
    1432 1432
    1433 1433 
     .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
    1434 1434 
         :shortdesc: Use colors in error messages

  • libraries/base/changelog.md
    ... ... @@ -2,6 +2,7 @@
    2 2
    3 3 
     ## 4.23.0.0 *TBA*
    4 4 
       * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337))
    5 
    +  * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338))
    5 6
    6 7 
     ## 4.22.0.0 *TBA*
    7 8 
       * Shipped with GHC 9.14.1

  • libraries/ghc-internal/src/GHC/Internal/Float.hs
    ... ... @@ -430,14 +430,10 @@ naturalToFloat# (NB b) = case integerToBinaryFloat' (IP b) of
    430 430
    431 431 
     -- | @since base-2.01
    432 432 
     --
    433 
    --- Beware that 'toRational' generates garbage for non-finite arguments:
    434 
    ---
    435 
    --- >>> toRational (1/0 :: Float)
    436 
    --- 340282366920938463463374607431768211456 % 1
    437 
    --- >>> toRational (0/0 :: Float)
    438 
    --- 510423550381407695195061911147652317184 % 1
    439 
    ---
    440 433 
     instance  Real Float  where
    434 
    +    toRational x
    435 
    +      | isInfinite x = if x > 0 then infinity else -infinity
    436 
    +      | isNaN x = notANumber
    441 437 
         toRational (F# x#)  =
    442 438 
             case decodeFloat_Int# x# of
    443 439 
               (# m#, e# #)
    ... ... @@ -686,14 +682,10 @@ naturalToDouble# (NB b) = case integerToBinaryFloat' (IP b) of
    686 682
    687 683 
     -- | @since base-2.01
    688 684 
     --
    689 
    --- Beware that 'toRational' generates garbage for non-finite arguments:
    690 
    ---
    691 
    --- >>> toRational (1/0)
    692 
    --- 179769313 (and 300 more digits...) % 1
    693 
    --- >>> toRational (0/0)
    694 
    --- 269653970 (and 300 more digits...) % 1
    695 
    ---
    696 685 
     instance  Real Double  where
    686 
    +    toRational x
    687 
    +      | isInfinite x = if x > 0 then infinity else -infinity
    688 
    +      | isNaN x = notANumber
    697 689 
         toRational (D# x#)  =
    698 690 
             case integerDecodeDouble# x# of
    699 691 
               (# m, e# #)

  • libraries/ghc-internal/src/GHC/Internal/Real.hs
    ... ... @@ -703,15 +703,6 @@ fromIntegral = fromInteger . toInteger
    703 703
    704 704 
     -- | General coercion to 'Fractional' types.
    705 705 
     --
    706 
    --- WARNING: This function goes through the 'Rational' type, which does not have values for 'NaN' for example.
    707 
    --- This means it does not round-trip.
    708 
    ---
    709 
    --- For 'Double' it also behaves differently with or without -O0:
    710 
    ---
    711 
    --- > Prelude> realToFrac nan -- With -O0
    712 
    --- > -Infinity
    713 
    --- > Prelude> realToFrac nan
    714 
    --- > NaN
    715 706 
     realToFrac :: (Real a, Fractional b) => a -> b
    716 707 
     {-# NOINLINE [1] realToFrac #-}
    717 708 
     -- See Note [Allow time for type-specialisation rules to fire]

  • rts/Interpreter.c
    ... ... @@ -473,6 +473,72 @@ void interp_shutdown( void ){
    473 473
    474 474 
     #endif
    475 475
    476 
    +const StgPtr ctoi_tuple_infos[] = {
    477 
    +    (StgPtr) &stg_ctoi_t0_info,
    478 
    +    (StgPtr) &stg_ctoi_t1_info,
    479 
    +    (StgPtr) &stg_ctoi_t2_info,
    480 
    +    (StgPtr) &stg_ctoi_t3_info,
    481 
    +    (StgPtr) &stg_ctoi_t4_info,
    482 
    +    (StgPtr) &stg_ctoi_t5_info,
    483 
    +    (StgPtr) &stg_ctoi_t6_info,
    484 
    +    (StgPtr) &stg_ctoi_t7_info,
    485 
    +    (StgPtr) &stg_ctoi_t8_info,
    486 
    +    (StgPtr) &stg_ctoi_t9_info,
    487 
    +    (StgPtr) &stg_ctoi_t10_info,
    488 
    +    (StgPtr) &stg_ctoi_t11_info,
    489 
    +    (StgPtr) &stg_ctoi_t12_info,
    490 
    +    (StgPtr) &stg_ctoi_t13_info,
    491 
    +    (StgPtr) &stg_ctoi_t14_info,
    492 
    +    (StgPtr) &stg_ctoi_t15_info,
    493 
    +    (StgPtr) &stg_ctoi_t16_info,
    494 
    +    (StgPtr) &stg_ctoi_t17_info,
    495 
    +    (StgPtr) &stg_ctoi_t18_info,
    496 
    +    (StgPtr) &stg_ctoi_t19_info,
    497 
    +    (StgPtr) &stg_ctoi_t20_info,
    498 
    +    (StgPtr) &stg_ctoi_t21_info,
    499 
    +    (StgPtr) &stg_ctoi_t22_info,
    500 
    +    (StgPtr) &stg_ctoi_t23_info,
    501 
    +    (StgPtr) &stg_ctoi_t24_info,
    502 
    +    (StgPtr) &stg_ctoi_t25_info,
    503 
    +    (StgPtr) &stg_ctoi_t26_info,
    504 
    +    (StgPtr) &stg_ctoi_t27_info,
    505 
    +    (StgPtr) &stg_ctoi_t28_info,
    506 
    +    (StgPtr) &stg_ctoi_t29_info,
    507 
    +    (StgPtr) &stg_ctoi_t30_info,
    508 
    +    (StgPtr) &stg_ctoi_t31_info,
    509 
    +    (StgPtr) &stg_ctoi_t32_info,
    510 
    +    (StgPtr) &stg_ctoi_t33_info,
    511 
    +    (StgPtr) &stg_ctoi_t34_info,
    512 
    +    (StgPtr) &stg_ctoi_t35_info,
    513 
    +    (StgPtr) &stg_ctoi_t36_info,
    514 
    +    (StgPtr) &stg_ctoi_t37_info,
    515 
    +    (StgPtr) &stg_ctoi_t38_info,
    516 
    +    (StgPtr) &stg_ctoi_t39_info,
    517 
    +    (StgPtr) &stg_ctoi_t40_info,
    518 
    +    (StgPtr) &stg_ctoi_t41_info,
    519 
    +    (StgPtr) &stg_ctoi_t42_info,
    520 
    +    (StgPtr) &stg_ctoi_t43_info,
    521 
    +    (StgPtr) &stg_ctoi_t44_info,
    522 
    +    (StgPtr) &stg_ctoi_t45_info,
    523 
    +    (StgPtr) &stg_ctoi_t46_info,
    524 
    +    (StgPtr) &stg_ctoi_t47_info,
    525 
    +    (StgPtr) &stg_ctoi_t48_info,
    526 
    +    (StgPtr) &stg_ctoi_t49_info,
    527 
    +    (StgPtr) &stg_ctoi_t50_info,
    528 
    +    (StgPtr) &stg_ctoi_t51_info,
    529 
    +    (StgPtr) &stg_ctoi_t52_info,
    530 
    +    (StgPtr) &stg_ctoi_t53_info,
    531 
    +    (StgPtr) &stg_ctoi_t54_info,
    532 
    +    (StgPtr) &stg_ctoi_t55_info,
    533 
    +    (StgPtr) &stg_ctoi_t56_info,
    534 
    +    (StgPtr) &stg_ctoi_t57_info,
    535 
    +    (StgPtr) &stg_ctoi_t58_info,
    536 
    +    (StgPtr) &stg_ctoi_t59_info,
    537 
    +    (StgPtr) &stg_ctoi_t60_info,
    538 
    +    (StgPtr) &stg_ctoi_t61_info,
    539 
    +    (StgPtr) &stg_ctoi_t62_info,
    540 
    +};
    541 
    +
    476 542 
     #if defined(PROFILING)
    477 543
    478 544 
     //
    ... ... @@ -1828,82 +1894,11 @@ run_BCO:
    1828 1894 
                 SpW(-1) = BCO_PTR(o_tuple_bco);
    1829 1895 
                 SpW(-2) = tuple_info;
    1830 1896 
                 SpW(-3) = BCO_PTR(o_bco);
    1831 
    -            W_ ctoi_t_offset;
    1832 1897 
                 int tuple_stack_words = (tuple_info >> 24) & 0xff;
    1833 
    -            switch(tuple_stack_words) {
    1834 
    -                case 0:  ctoi_t_offset = (W_)&stg_ctoi_t0_info;  break;
    1835 
    -                case 1:  ctoi_t_offset = (W_)&stg_ctoi_t1_info;  break;
    1836 
    -                case 2:  ctoi_t_offset = (W_)&stg_ctoi_t2_info;  break;
    1837 
    -                case 3:  ctoi_t_offset = (W_)&stg_ctoi_t3_info;  break;
    1838 
    -                case 4:  ctoi_t_offset = (W_)&stg_ctoi_t4_info;  break;
    1839 
    -                case 5:  ctoi_t_offset = (W_)&stg_ctoi_t5_info;  break;
    1840 
    -                case 6:  ctoi_t_offset = (W_)&stg_ctoi_t6_info;  break;
    1841 
    -                case 7:  ctoi_t_offset = (W_)&stg_ctoi_t7_info;  break;
    1842 
    -                case 8:  ctoi_t_offset = (W_)&stg_ctoi_t8_info;  break;
    1843 
    -                case 9:  ctoi_t_offset = (W_)&stg_ctoi_t9_info;  break;
    1844 
    -
    1845 
    -                case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
    1846 
    -                case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
    1847 
    -                case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
    1848 
    -                case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
    1849 
    -                case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
    1850 
    -                case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
    1851 
    -                case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
    1852 
    -                case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
    1853 
    -                case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
    1854 
    -                case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
    1855 
    -
    1856 
    -                case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
    1857 
    -                case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
    1858 
    -                case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
    1859 
    -                case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
    1860 
    -                case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
    1861 
    -                case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
    1862 
    -                case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
    1863 
    -                case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
    1864 
    -                case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
    1865 
    -                case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
    1866 
    -
    1867 
    -                case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
    1868 
    -                case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
    1869 
    -                case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
    1870 
    -                case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
    1871 
    -                case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
    1872 
    -                case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
    1873 
    -                case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
    1874 
    -                case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
    1875 
    -                case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
    1876 
    -                case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
    1877 
    -
    1878 
    -                case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
    1879 
    -                case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
    1880 
    -                case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
    1881 
    -                case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
    1882 
    -                case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
    1883 
    -                case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
    1884 
    -                case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
    1885 
    -                case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
    1886 
    -                case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
    1887 
    -                case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
    1888 
    -
    1889 
    -                case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
    1890 
    -                case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
    1891 
    -                case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
    1892 
    -                case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
    1893 
    -                case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
    1894 
    -                case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
    1895 
    -                case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
    1896 
    -                case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
    1897 
    -                case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
    1898 
    -                case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
    1899 
    -
    1900 
    -                case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
    1901 
    -                case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
    1902 
    -                case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
    1903 
    -
    1904 
    -                default: barf("unsupported tuple size %d", tuple_stack_words);
    1898 
    +            if (tuple_stack_words > 62) {
    1899 
    +                barf("unsupported tuple size %d", tuple_stack_words);
    1905 1900 
                 }
    1906 
    -
    1901 
    +            W_ ctoi_t_offset = (W_) ctoi_tuple_infos[tuple_stack_words];
    1907 1902 
                 SpW(-4) = ctoi_t_offset;
    1908 1903 
                 Sp_subW(4);
    1909 1904 
                 goto nextInsn;

  • testsuite/tests/driver/json.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
    1 
    +{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"rendered":"json.hs:9:11: error: [GHC-48010]\n    Empty list of alternatives in case expression\n    Suggested fix:\n      Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}

  • testsuite/tests/driver/json_warn.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
    1 
    +{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n    Defined but not used: \u2018x\u2019\n","message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    +{"version":"1.2","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n    In the use of \u2018head\u2019\n    (imported from Prelude, but defined in GHC.Internal.List):\n    \"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\"\n","message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}

  • testsuite/tests/haddock/haddock_testsuite/Makefile
    ... ... @@ -76,3 +76,7 @@ hypsrcTest:
    76 76 
     .PHONY: haddockForeignTest
    77 77 
     haddockForeignTest:
    78 78 
     	'$(HADDOCK)' A.hs B.hs F.hs arith.c
    79 
    +
    80 
    +.PHONY: T26114
    81 
    +T26114:
    82 
    +	'$(HADDOCK)' T26114.hs

  • testsuite/tests/haddock/haddock_testsuite/T26114.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +
    3 
    +-- | Module
    4 
    +module T26114 where
    5 
    +
    6 
    +-- | C1
    7 
    +class C1 t where
    8 
    +  type C2 t
    9 
    +
    10 
    +-- | A
    11 
    +data A = A
    12 
    +
    13 
    +instance C1 A where
    14 
    +  type C2 A = B
    15 
    +
    16 
    +-- | B
    17 
    +data B = B
    18 
    +
    19 
    +instance C1 B where
    20 
    +  type C2 B = C
    21 
    +
    22 
    +-- | C
    23 
    +data C = C

  • testsuite/tests/haddock/haddock_testsuite/T26114.stdout
    1 
    +[1 of 1] Compiling T26114           ( T26114.hs, nothing )
    2 
    +Haddock coverage:
    3 
    + 100% (  5 /  5) in 'T26114'

  • testsuite/tests/haddock/haddock_testsuite/all.T
    ... ... @@ -24,3 +24,8 @@ test('haddockForeignTest',
    24 24 
          [ignore_stdout, ignore_stderr, req_haddock, extra_files(['./haddock-th-foreign-repro/A.hs', './haddock-th-foreign-repro/B.hs', './haddock-th-foreign-repro/F.hs', './haddock-th-foreign-repro/arith.c'])],
    25 25 
          makefile_test,
    26 26 
          ['haddockForeignTest'])
    27 
    +
    28 
    +test('T26114',
    29 
    +   [ignore_stderr, req_haddock, extra_files(['T26114.hs'])],
    30 
    +   makefile_test,
    31 
    +   ['T26114'])

  • testsuite/tests/numeric/should_run/T9810.stdout
    1 1 
     ## Double ##
    2 2 
     Infinity
    3 3 
     -Infinity
    4 
    -Infinity
    4 
    +NaN
    5 5 
     Infinity
    6 6 
     -Infinity
    7 7 
     Infinity
    8 8 
     ## Float ##
    9 9 
     Infinity
    10 10 
     -Infinity
    11 
    -Infinity
    11 
    +NaN
    12 12 
     Infinity
    13 13 
     -Infinity
    14 14 
     Infinity

  • testsuite/tests/splice-imports/T26088.stderr
    1 
    +T26088A.hs:8:8: error: [GHC-28914]
    2 
    +    • Level error: ‘a’ is bound at level -1 but used at level 1
    3 
    +    • Available from the imports:
    4 
    +      • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21
    5 
    +    • In the Template Haskell quotation: [| a |]
    6 
    +

  • testsuite/tests/splice-imports/T26088A.hs
    1 
    +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-}
    2 
    +module T26088A where
    3 
    +
    4 
    +import splice T26088B
    5 
    +import Language.Haskell.TH.Syntax
    6 
    +
    7 
    +x :: Q Exp
    8 
    +x = [| a |]

  • testsuite/tests/splice-imports/T26088B.hs
    1 
    +module T26088B where
    2 
    +
    3 
    +a = ()

  • testsuite/tests/splice-imports/all.T
    ... ... @@ -47,3 +47,4 @@ test('SI35',
    47 47 
          ['-package ghc'])
    48 48 
     test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0'])
    49 49 
     test('T26087', [], multimod_compile_fail, ['T26087A', ''])
    50 
    +test('T26088', [], multimod_compile_fail, ['T26088A', '-v0'])

  • utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
    ... ... @@ -110,6 +110,7 @@ renameInterface ignoreSet renamingEnv expInfo warnings hoogle iface = do
    110 110 
             && isExternalName name
    111 111 
             && not (isBuiltInSyntax name)
    112 112 
             && not (isTyVarName name)
    113 
    +        && not (isDerivedOccName $ nameOccName name)
    113 114 
             && Exact name /= eqTyCon_RDR
    114 115 
             -- Must not be in the set of ignored symbols for the module or the
    115 116 
             -- unqualified ignored symbols

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