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

Commits:

27 changed files:

Changes:

  • changelog.d/T27657
    1 
    +section: base
    2 
    +issues: #27657
    3 
    +mrs: !16508
    4 
    +synopsis:
    5 
    +  Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler
    6 
    +description:
    7 
    +  ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO
    8 
    +  ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the
    9 
    +  correct way to catch exceptions inside STM.

  • libraries/base/base.cabal.in
    ... ... @@ -117,6 +117,7 @@ Library
    117 117 
             , Data.Monoid
    118 118 
             , Data.Ord
    119 119 
             , Data.Proxy
    120 
    +        , Data.RealFloat
    120 121 
             , Data.STRef
    121 122 
             , Data.STRef.Strict
    122 123 
             , Data.String

  • libraries/base/changelog.md
    ... ... @@ -9,6 +9,8 @@
    9 9 
       * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378))
    10 10 
       * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413))
    11 11 
       * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428))
    12 
    +  * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394))
    13 
    +  * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394))
    12 14
    13 15 
     ## 4.23.0.0 *TBA*
    14 16 
       * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370))

  • libraries/base/src/Data/RealFloat.hs
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +{-# LANGUAGE PatternSynonyms #-}
    3 
    +{-# LANGUAGE Safe #-}
    4 
    +{-# LANGUAGE ViewPatterns #-}
    5 
    +
    6 
    +-- |
    7 
    +--
    8 
    +-- Module      :  Data.RealFloat
    9 
    +-- Copyright   :  (c) The University of Glasgow 2026
    10 
    +-- License     :  BSD-style (see the file libraries/base/LICENSE)
    11 
    +--
    12 
    +-- Maintainer  :  libraries@haskell.org
    13 
    +-- Stability   :  stable
    14 
    +-- Portability :  portable
    15 
    +--
    16 
    +
    17 
    +module Data.RealFloat (
    18 
    +  RealFloat (..),
    19 
    +
    20 
    +  -- * Infinity + NaN
    21 
    +  pattern Infinity,
    22 
    +  pattern NegInfinity,
    23 
    +  pattern NaN,
    24 
    +) where
    25 
    +
    26 
    +import Data.Bool (Bool (..), (&&))
    27 
    +import GHC.Internal.Data.Ord ((<), (>))
    28 
    +import GHC.Internal.Float (RealFloat (..))
    29 
    +import GHC.Internal.Real ((/))
    30 
    +#if __GLASGOW_HASKELL__ >= 1001
    31 
    +import qualified GHC.Essentials as Rebindable
    32 
    +#endif
    33 
    +
    34 
    +pattern Infinity :: (RealFloat a) => a
    35 
    +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0
    36 
    +
    37 
    +-- | Negative infinity
    38 
    +--
    39 
    +-- Provided for convenience. Could also use the following instead:
    40 
    +--   * Pattern matching: @(negate -> Infinity)@
    41 
    +--   * Expressions: @-Infinity@
    42 
    +pattern NegInfinity :: (RealFloat a) => a
    43 
    +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0
    44 
    +
    45 
    +-- | A pattern synonym for NaN values.
    46 
    +--
    47 
    +-- Note: Per IEEE 754, NaN is never equal to itself, thus these two snippets
    48 
    +-- have different behavior:
    49 
    +--
    50 
    +-- @
    51 
    +-- -- foo1 NaN == "a"
    52 
    +-- foo1 NaN = "a"
    53 
    +-- foo1 _ = "b"
    54 
    +--
    55 
    +-- -- foo2 NaN == "b"
    56 
    +-- foo2 x = if x == NaN then "a" else "b"
    57 
    +-- @
    58 
    +pattern NaN :: (RealFloat a) => a
    59 
    +pattern NaN <- (isNaN -> True) where NaN = 0/0

  • libraries/ghc-internal/src/GHC/Internal/STM.hs
    ... ... @@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation)
    31 31 
     import GHC.Internal.Exception.Type (WhileHandling(..))
    32 32 
     import GHC.Internal.Maybe (Maybe(..))
    33 33 
     import GHC.Internal.Prim (
    34 
    -    RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#,
    34 
    +    RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#,
    35 35 
         newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#,
    36 36 
       )
    37 37 
     import GHC.Internal.Prim.PtrEq (sameTVar#)
    ... ... @@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler'
    213 213 
     -- | Execute an 'STM' action, adding the given 'ExceptionContext'
    214 214 
     -- to any thrown synchronous exceptions.
    215 215 
     annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a
    216 
    -annotateSTM ann (STM io) = STM (catch# io handler)
    216 
    +annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657
    217 217 
       where
    218 218 
         handler se = raiseIO# (addExceptionContext ann se)
    219 219

  • rts/CloneStack.c
    ... ... @@ -88,6 +88,7 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
    88 88 
     void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){
    89 89 
       // We must check that the current owner of the thread we want to clone the stack for
    90 90 
       // is still this capability.
    91 
    +  // See Note [TSO owner may change in between Msg being sent and received]
    91 92 
       Capability *owner = RELAXED_LOAD(&msg->tso->cap);
    92 93 
       if (owner != cap) {
    93 94 
         // The target TSO may have migrated after the message was queued on the old

  • rts/Interpreter.c
    ... ... @@ -416,22 +416,14 @@ void rts_disableStopNextBreakpointAll(void)
    416 416
    417 417 
     void rts_enableStopNextBreakpoint(StgTSO* tso)
    418 418 
     {
    419 
    -#if defined(THREADED_RTS)
    420 419 
       Capability* cap = rts_unsafeGetMyCapability();
    421 420 
       setThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT);
    422 
    -#else
    423 
    -  tso->flags |= TSO_STOP_NEXT_BREAKPOINT;
    424 
    -#endif
    425 421 
     }
    426 422
    427 423 
     void rts_disableStopNextBreakpoint(StgTSO* tso)
    428 424 
     {
    429 
    -#if defined(THREADED_RTS)
    430 425 
       Capability* cap = rts_unsafeGetMyCapability();
    431 426 
       unsetThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT);
    432 
    -#else
    433 
    -  tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT;
    434 
    -#endif
    435 427 
     }
    436 428
    437 429 
     /* ---------------------------------------------------------------------------
    ... ... @@ -440,22 +432,14 @@ void rts_disableStopNextBreakpoint(StgTSO* tso)
    440 432
    441 433 
     void rts_enableStopAfterReturn(StgTSO* tso)
    442 434 
     {
    443 
    -#if defined(THREADED_RTS)
    444 435 
       Capability* cap = rts_unsafeGetMyCapability();
    445 436 
       setThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN);
    446 
    -#else
    447 
    -  tso->flags |= TSO_STOP_AFTER_RETURN;
    448 
    -#endif
    449 437 
     }
    450 438
    451 439 
     void rts_disableStopAfterReturn(StgTSO* tso)
    452 440 
     {
    453 
    -#if defined(THREADED_RTS)
    454 441 
       Capability* cap = rts_unsafeGetMyCapability();
    455 442 
       unsetThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN);
    456 
    -#else
    457 
    -  tso->flags &= ~TSO_STOP_AFTER_RETURN;
    458 
    -#endif
    459 443 
     }
    460 444
    461 445 
     /*

  • rts/Messages.c
    ... ... @@ -36,8 +36,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
    36 36 
                 i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked
    37 37 
                 i != &stg_WHITEHOLE_info &&
    38 38 
                 i != &stg_MSG_CLONE_STACK_info &&
    39 
    -            i != &stg_MSG_SET_TSO_FLAG_info &&
    40 
    -            i != &stg_MSG_UNSET_TSO_FLAG_info) {
    39 
    +            i != &stg_MSG_UPD_TSO_FLAG_info) {
    41 40 
                 barf("sendMessage: %p", i);
    42 41 
             }
    43 42 
         }
    ... ... @@ -67,6 +66,62 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg)
    67 66 
        Handle a message
    68 67 
        ------------------------------------------------------------------------- */
    69 68
    69 
    +/*
    70 
    +Note [TSO owner may change in between Msg being sent and received]
    71 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    72 
    +When a message is sent from Capability (C1) to a target TSO (T2) (e.g.
    73 
    +MessageUpdTSOFlag, MessageCloneStack, ...), it is queued on the TSO's owner
    74 
    +Capability (C3) inbox (inboxes are owned by Capabilities, not TSOs).
    75 
    +
    76 
    +At a later point, the Capability (C3) will process its inbox. Upon receiving
    77 
    +the message meant for a specific TSO (T2), it must first always check that the
    78 
    +TSO's owner is *still* itself (C3).
    79 
    +
    80 
    +The target TSO (T2) may have migrated after the message was queued on its old
    81 
    +capability (C3). In that case we must forward the request to the new owner
    82 
    +(say, C4); otherwise the Capability C3 could be modifying a TSO it no longer
    83 
    +owns, racing with its actual owner mutating it, since it is no longer the owner.
    84 
    +
    85 
    +The message meant for a TSO should only be executed when the receiving
    86 
    +Capability is still the owner of that TSO. Otherwise, it must be forwarded to
    87 
    +the new owner.
    88 
    +
    89 
    +The general pattern is one where there's a top-level function which assumes it
    90 
    +can be called by capabilities other than the TSO's owner. The function checks
    91 
    +whether the current capability is the TSO owner. If yes, execute the action. If
    92 
    +not, then it sends a message to the current TSO's owner. On receiving the
    93 
    +message, the new capability will just call that top-level function, which will
    94 
    +ensure the message is forwarded again if the TSO owner changed.
    95 
    +It will look something like:
    96 
    +
    97 
    +  runMyMsg(Capability *from, StgTSO *target, ...) {
    98 
    +
    99 
    +#if defined(THREADED_RTS)
    100 
    +    Capability *owner = RELAXED_LOAD(&target->cap)
    101 
    +    if (owner != from) {
    102 
    +      MessageMyMsg* msg = ...
    103 
    +      sendMessage(cap, owner, msg)
    104 
    +      return
    105 
    +    }
    106 
    +#endif
    107 
    +
    108 
    +    actuallyDoTheWork(...)
    109 
    +  }
    110 
    +
    111 
    +  executeMessage(...) {
    112 
    +
    113 
    +    if (i == &stg_MY_MSG_info) {
    114 
    +
    115 
    +      MessageMyMsg* msg = (MessageMyMsg*) m
    116 
    +      runMyMsg(cap, m->tso, ...)
    117 
    +
    118 
    +    }
    119 
    +  }
    120 
    +
    121 
    +See example `updThreadFlag` and `executeMessage`'s `stg_MSG_UPD_TSO_FLAG_info`,
    122 
    +or `tryWakeUpThread` and `stg_MSG_TRY_WAKEUP_info` for two live examples.
    123 
    +*/
    124 
    +
    70 125 
     #if defined(THREADED_RTS)
    71 126
    72 127 
     void
    ... ... @@ -141,15 +196,11 @@ loop:
    141 196 
             MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
    142 197 
             handleCloneStackMessage(cap, cloneStackMessage);
    143 198 
         }
    144 
    -    else if(i == &stg_MSG_SET_TSO_FLAG_info){
    199 
    +    else if(i == &stg_MSG_UPD_TSO_FLAG_info){
    145 200 
             MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m;
    146 
    -        u->tso->flags |= u->flag;
    147 
    -        return;
    148 
    -    }
    149 
    -    else if(i == &stg_MSG_UNSET_TSO_FLAG_info){
    150 
    -        MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m;
    151 
    -        u->tso->flags &= ~u->flag;
    152 
    -        return;
    201 
    +
    202 
    +        StgTSO *tso = RELAXED_LOAD(&u->tso);
    203 
    +        updThreadFlag(cap, tso, u->flag, u->set);
    153 204 
         }
    154 205 
         else
    155 206 
         {

  • rts/StgMiscClosures.cmm
    ... ... @@ -855,11 +855,8 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL")
    855 855 
     INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK")
    856 856 
     { ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; }
    857 857
    858 
    -INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,2,1,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG")
    859 
    -{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; }
    860 
    -
    861 
    -INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,2,1,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG")
    862 
    -{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; }
    858 
    +INFO_TABLE_CONSTR(stg_MSG_UPD_TSO_FLAG,2,2,0,PRIM,"MSG_UPD_TSO_FLAG","MSG_UPD_TSO_FLAG")
    859 
    +{ foreign "C" barf("stg_MSG_UPD_TSO_FLAG object (%p) entered!", R1) never returns; }
    863 860
    864 861 
     /* ----------------------------------------------------------------------------
    865 862 
        END_TSO_QUEUE

  • rts/Threads.c
    ... ... @@ -379,32 +379,46 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to)
    379 379 
        sets or unsets a flag in a given TSO
    380 380 
        ------------------------------------------------------------------------- */
    381 381
    382 
    -#if defined(THREADED_RTS)
    383 
    -static void
    384 
    -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info);
    385 
    -
    386 382 
     void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag)
    387 383 
     {
    388 
    -    updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info);
    384 
    +    updThreadFlag(from, tso, flag, true);
    389 385 
     }
    390 386
    391 387 
     void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag)
    392 388 
     {
    393 
    -    updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info);
    389 
    +    updThreadFlag(from, tso, flag, false);
    394 390 
     }
    395 391
    396 
    -static void
    397 
    -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info)
    392 
    +void
    393 
    +updThreadFlag(Capability *from USED_IF_THREADS, StgTSO *tso, StgWord32 flag, StgBool set /* true=set, false=unset */)
    398 394 
     {
    399 
    -    MessageUpdTSOFlag *msg;
    400 
    -    msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag));
    401 
    -    msg->tso  = tso;
    402 
    -    msg->flag = flag;
    403 
    -    SET_HDR_RELEASE(msg, info, CCS_SYSTEM);
    404 
    -    sendMessage(from, tso->cap, (Message*)msg);
    405 
    -}
    395 
    +#if defined(THREADED_RTS)
    396 
    +    // If we're the current owner of the thread we want to modify, do it.
    397 
    +    // Otherwise, we must forward the message to the actual owner.
    398 
    +    // When executing the upd message, we check again that we're still the TSO
    399 
    +    // owner (which may have changed since the message was queued on this cap.)
    400 
    +    // See Note [TSO owner may change in between Msg being sent and received]
    401 
    +    Capability *tso_owner = RELAXED_LOAD(&tso->cap);
    402 
    +    if (from != tso_owner) {
    403 
    +      MessageUpdTSOFlag *msg;
    404 
    +      msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag));
    405 
    +      msg->tso  = tso;
    406 
    +      msg->flag = flag;
    407 
    +      msg->set  = set;
    408 
    +      SET_HDR_RELEASE(msg, &stg_MSG_UPD_TSO_FLAG_info, CCS_SYSTEM);
    409 
    +      sendMessage(from, tso_owner, (Message*)msg);
    410 
    +      return;
    411 
    +    }
    406 412 
     #endif
    407 413
    414 
    +    if (set) {
    415 
    +      tso->flags |= flag;
    416 
    +    }
    417 
    +    else {
    418 
    +      tso->flags &= ~flag;
    419 
    +    }
    420 
    +}
    421 
    +
    408 422 
     /* ----------------------------------------------------------------------------
    409 423 
        awakenBlockedQueue
    410 424

  • rts/Threads.h
    ... ... @@ -19,10 +19,9 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso);
    19 19 
     void tryWakeupThread     (Capability *cap, StgTSO *tso);
    20 20 
     void migrateThread       (Capability *from, StgTSO *tso, Capability *to);
    21 21
    22 
    -#if defined(THREADED_RTS)
    23 22 
     void setThreadFlag       (Capability *from, StgTSO *tso, StgWord32 flag);
    24 23 
     void unsetThreadFlag     (Capability *from, StgTSO *tso, StgWord32 flag);
    25 
    -#endif
    24 
    +void updThreadFlag       (Capability *from, StgTSO *tso, StgWord32 flag, StgBool set);
    26 25
    27 26 
     // Wakes up a thread on a Capability (probably a different Capability
    28 27 
     // from the one held by the current Task).

  • rts/include/rts/storage/Closures.h
    ... ... @@ -625,6 +625,7 @@ typedef struct MessageUpdTSOFlag_ {
    625 625 
         Message   *link;
    626 626 
         StgTSO    *tso;
    627 627 
         StgWord   flag;
    628 
    +    StgWord   set; // bool: true=SET; false=UNSET
    628 629 
     } MessageUpdTSOFlag;
    629 630
    630 631 
     /* ----------------------------------------------------------------------------

  • rts/include/stg/MiscClosures.h
    ... ... @@ -151,8 +151,7 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP);
    151 151 
     RTS_ENTRY(stg_MSG_THROWTO);
    152 152 
     RTS_ENTRY(stg_MSG_BLACKHOLE);
    153 153 
     RTS_ENTRY(stg_MSG_CLONE_STACK);
    154 
    -RTS_ENTRY(stg_MSG_SET_TSO_FLAG);
    155 
    -RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG);
    154 
    +RTS_ENTRY(stg_MSG_UPD_TSO_FLAG);
    156 155 
     RTS_ENTRY(stg_MSG_NULL);
    157 156 
     RTS_ENTRY(stg_MVAR_TSO_QUEUE);
    158 157 
     RTS_ENTRY(stg_catch);

  • rts/linker/elf_reloc_riscv64.c
    ... ... @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) {
    679 679
    680 680 
       /* The main object code */
    681 681 
       void *codeBegin = oc->image + oc->misalignment;
    682 
    -  __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
    682 
    +  __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize));
    683 683
    684 684 
       /* Jump Islands */
    685 685 
       __builtin___clear_cache((void *)oc->symbol_extras,

  • testsuite/tests/concurrent/should_run/T27657a.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    2 
    +
    3 
    +-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO
    4 
    +-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper.
    5 
    +
    6 
    +import Control.Exception
    7 
    +import GHC.Conc
    8 
    +
    9 
    +main :: IO ()
    10 
    +main = do
    11 
    +  r <- atomically $
    12 
    +         catchSTM (throwSTM (ErrorCall "boom"))
    13 
    +                  (\(_ :: SomeException) -> retry)
    14 
    +           `orElse` pure "T27657a: completed"
    15 
    +  putStrLn r

  • testsuite/tests/concurrent/should_run/T27657a.stdout
    1 
    +T27657a: completed

  • testsuite/tests/concurrent/should_run/T27657b.hs
    1 
    +{-# LANGUAGE ScopedTypeVariables #-}
    2 
    +
    3 
    +-- An async exception delivered while a catchSTM handler runs must abort the
    4 
    +-- transaction, not be swallowed by a restart of the invalidated one.
    5 
    +
    6 
    +import Control.Concurrent.MVar
    7 
    +import Control.Exception
    8 
    +import GHC.Conc
    9 
    +
    10 
    +waitParked :: ThreadId -> IO ()
    11 
    +waitParked t = do
    12 
    +  s <- threadStatus t
    13 
    +  case s of
    14 
    +    ThreadBlocked BlockedOnMVar -> pure ()
    15 
    +    _                           -> threadDelay 1000 >> waitParked t
    16 
    +
    17 
    +main :: IO ()
    18 
    +main = do
    19 
    +  tv     <- newTVarIO (0 :: Int)
    20 
    +  park   <- newEmptyMVar
    21 
    +  result <- newEmptyMVar
    22 
    +  t <- forkIO $ do
    23 
    +    r <- try $ atomically $ do
    24 
    +      v <- readTVar tv
    25 
    +      catchSTM (throwSTM (ErrorCall "boom"))
    26 
    +               (\(_ :: SomeException) ->
    27 
    +                  if v == 0
    28 
    +                    then do unsafeIOToSTM (takeMVar park)
    29 
    +                            pure "handler resumed"
    30 
    +                    else pure "transaction restarted, exception dropped")
    31 
    +    putMVar result (r :: Either SomeException String)
    32 
    +  -- parked in the handler, so t cannot revalidate its trec before delivery
    33 
    +  waitParked t
    34 
    +  atomically (writeTVar tv 1)
    35 
    +  killThread t
    36 
    +  r <- takeMVar result
    37 
    +  putStrLn $ case r of
    38 
    +    Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered"
    39 
    +           | otherwise -> "T27657b: unexpected exception: " ++ displayException e
    40 
    +    Right s -> "T27657b: FAILED, " ++ s

  • testsuite/tests/concurrent/should_run/T27657b.stdout
    1 
    +T27657b: killThread delivered

  • testsuite/tests/concurrent/should_run/all.T
    ... ... @@ -340,3 +340,6 @@ test('T27105_fail',
    340 340 
           extra_run_opts('+RTS -C0.2 -RTS'), expect_fail,
    341 341 
           run_timeout_multiplier(0.05)],
    342 342 
          multimod_compile_and_run, ['T27105.hs', ''])
    343 
    +
    344 
    +test('T27657a', normal, compile_and_run, [''])
    345 
    +test('T27657b', normal, compile_and_run, [''])

  • testsuite/tests/interface-stability/base-exports.stdout
    No preview for this file type
  • testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
    No preview for this file type
  • testsuite/tests/interface-stability/base-exports.stdout-mingw32
    No preview for this file type
  • utils/check-exact/ExactPrint.hs
    ... ... @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where
    1465 1465 
                  Just exps -> do
    1466 1466 
                    let (op,cp,tcs) = am_exports $ anns an0
    1467 1467 
                    op' <- markEpToken op
    1468 
    -               exps' <- mapM markAnnotated exps
    1468 
    +               exps' <- mapM markAnnotated (filter notIEDoc exps)
    1469 1469 
                    tcs' <- mapM markEpToken tcs
    1470 1470 
                    cp' <- markEpToken cp
    1471 1471 
                    return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}})

  • utils/check-exact/Main.hs
    ... ... @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
    183 183 
      -- "../../testsuite/tests/printer/Test17519.hs" Nothing
    184 184 
      -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing
    185 185 
      -- "../../testsuite/tests/printer/Test19798.hs" Nothing
    186 
    - "../../testsuite/tests/printer/Test10309.hs" Nothing
    186 
    + -- "../../testsuite/tests/printer/Test10309.hs" Nothing
    187 
    + "../../testsuite/tests/printer/Haddock1.hs" Nothing
    187 188
    188 189 
      -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
    189 190 
      -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
    ... ... @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8
    304 305
    305 306 
     testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
    306 307 
     testOneFile _ libdir fileName mchanger = do
    307 
    -       (p,_toks) <- parseOneFile libdir fileName
    308 
    +       p <- parseOneFile libdir fileName
    308 309 
            let
    309 310 
              origAst = ppAst p
    310 311 
              pped    = exactPrint p
    ... ... @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do
    333 334 
                changedSource  <- readFile newFile
    334 335 
                return (expectedSource == changedSource, expectedSource, changedSource)
    335 336
    336 
    -       (p',_) <- parseOneFile libdir newFile
    337 
    +       p' <- parseOneFile libdir newFile
    337 338 
            let newAstStr :: String
    338 339 
                newAstStr = ppAst p'
    339 340 
            writeBinFile newAstFile newAstStr
    ... ... @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do
    364 365 
     ppAst :: Data a => a -> String
    365 366 
     ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
    366 367
    367 
    -
    368 
    -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token])
    368 
    +parseOneFile :: FilePath -> FilePath -> IO ParsedSource
    369 369 
     parseOneFile libdir fileName = do
    370 
    -  res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName
    370 
    +  res <- Parsers.parseModule libdir fileName
    371 371 
       case res of
    372 372 
         Left m -> error (internalDebugShowMessages m)
    373 
    -    Right (injectedComments, _dflags, pmod) -> do
    374 
    -      let !pmodWithComments = insertCppComments pmod injectedComments
    375 
    -      return (pmodWithComments, [])
    373 
    +    Right pmod -> return pmod
    376 374
    377 375 
     -- ---------------------------------------------------------------------
    378 376
    ... ... @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do
    519 517 
           replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
    520 518 
                             -> Transform (LMatch GhcPs (LHsExpr GhcPs))
    521 519 
           replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do
    522 
    -        let (oldDecls) = map unWrapValBind bs
    523 
    -        -- let decls = s:d:oldDecls
    520 
    +        let oldDecls = map unWrapValBind bs
    524 521 
             let oldDecls' = captureLineSpacing oldDecls
    525 522 
             let (VbSig o:oldBinds)  = map wrapValBind oldDecls'
    526 523 
                 o' = setEntryDP o (DifferentLine 2 0)

  • utils/check-exact/Parsers.hs
    ... ... @@ -46,6 +46,7 @@ module Parsers (
    46 46 
             ) where
    47 47
    48 48 
     import Preprocess
    49 
    +import Utils
    49 50
    50 51 
     import Data.Functor (void)
    51 52
    ... ... @@ -270,7 +271,10 @@ postParseTransform
    270 271 
       -> Either a (GHC.ParsedSource)
    271 272 
     postParseTransform parseRes = fmap mkAnns parseRes
    272 273 
       where
    273 
    -    mkAnns (_cs, _, m) = fixModuleComments m
    274 
    +    mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs)
    275 
    +    noIEDoc (GHC.L l m) = case GHC.hsmodExports m of
    276 
    +                  Nothing -> GHC.L l m
    277 
    +                  Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps }
    274 278
    275 279 
     fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
    276 280 
     fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p

  • utils/check-exact/Transform.hs
    ... ... @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail
    93 93 
     import GHC  hiding (parseModule, parsedSource)
    94 94 
     import GHC.Parser.PostProcess ( wrapValBind )
    95 95 
     import GHC.Data.FastString
    96 
    -import GHC.Types.SrcLoc
    97 96
    98 97 
     import Data.Data
    99 98 
     import Data.List (unsnoc)
    ... ... @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r)
    402 401 
         (a',b') = balanceComments a b
    403 402 
         r = balanceCommentsList' (b':ls)
    404 403
    404 
    +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a]
    405 
    +balanceCommentsListA [] = []
    406 
    +balanceCommentsListA [x] = [x]
    407 
    +balanceCommentsListA (a:b:ls) = (a':r)
    408 
    +  where
    409 
    +    (a',b') = balanceCommentsA a b
    410 
    +    r = balanceCommentsListA (b':ls)
    411 
    +
    405 412 
     -- |The GHC parser puts all comments appearing between the end of one AST
    406 413 
     -- item and the beginning of the next as 'annPriorComments' for the second one.
    407 414 
     -- This function takes two adjacent AST items and moves any 'annPriorComments'
    ... ... @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt)
    507 514 
           (HsValBinds _ vb') -> vb'
    508 515 
           _ -> ValBinds noExtField []
    509 516
    510 
    -
    511 
    -balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
    512 
    -balanceCommentsListA [] = []
    513 
    -balanceCommentsListA [x] = [x]
    514 
    -balanceCommentsListA (a:b:ls) = (a':r)
    515 
    -  where
    516 
    -    (a',b') = balanceCommentsA a b
    517 
    -    r = balanceCommentsListA (b':ls)
    518 
    -
    519 517 
     -- |Prior to moving an AST element, make sure any trailing comments belonging to
    520 518 
     -- it are attached to it, and not the following element. Of necessity this is a
    521 519 
     -- heuristic process, to be tuned later. Possibly a variant should be provided
    ... ... @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs)
    591 589
    592 590 
     -- ---------------------------------------------------------------------
    593 591
    594 
    --- | Split comments into ones occurring before the end of the reference
    595 
    --- span, and those after it.
    596 
    -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
    597 
    -splitComments p cs = (before, middle, after)
    598 
    -  where
    599 
    -    cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    600 
    -    cmpe (L _ _) = True
    601 
    -
    602 
    -    cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
    603 
    -    cmpb (L _ _) = True
    604 
    -
    605 
    -    (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
    606 
    -    (before, middle) = break cmpb beforeEnd
    607 
    -
    608 
    -
    609 
    --- | Split comments into ones occurring before the end of the reference
    610 
    --- span, and those after it.
    611 
    -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
    612 
    -splitCommentsEnd p (EpaComments cs) = cs'
    613 
    -  where
    614 
    -    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    615 
    -    cmp (L _ _) = True
    616 
    -    (before, after) = break cmp cs
    617 
    -    cs' = case after of
    618 
    -      [] -> EpaComments cs
    619 
    -      _ -> epaCommentsBalanced before after
    620 
    -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
    621 
    -  where
    622 
    -    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    623 
    -    cmp (L _ _) = True
    624 
    -    (before, after) = break cmp cs
    625 
    -    cs' = before
    626 
    -    ts' = after <> ts
    627 
    -
    628 
    --- | Split comments into ones occurring before the start of the reference
    629 
    --- span, and those after it.
    630 
    -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
    631 
    -splitCommentsStart p (EpaComments cs) = cs'
    632 
    -  where
    633 
    -    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    634 
    -    cmp (L _ _) = True
    635 
    -    (before, after) = break cmp cs
    636 
    -    cs' = case after of
    637 
    -      [] -> EpaComments cs
    638 
    -      _ -> epaCommentsBalanced before after
    639 
    -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
    640 
    -  where
    641 
    -    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    642 
    -    cmp (L _ _) = True
    643 
    -    (before, after) = break cmp cs
    644 
    -    cs' = before
    645 
    -    ts' = after <> ts
    646 
    -
    647 592 
     moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u)
    648 593 
       => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u)
    649 594 
     moveLeadingComments (L la a) lb = (L la' a, lb')
    ... ... @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
    680 625 
     anchorFromLocatedA :: LocatedA a -> RealSrcSpan
    681 626 
     anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc
    682 627
    683 
    --- | Get the full span of interest for comments from a LocatedA.
    684 
    --- This extends up to the last TrailingAnn
    685 
    -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
    686 
    -fullSpanFromLocatedA (L (EpAnn anc tas  _) _) = rr
    687 
    -  where
    688 
    -    r = epaLocationRealSrcSpan anc
    689 
    -    trailing_loc ta = case ta_location ta of
    690 
    -        EpaSpan (RealSrcSpan s _) -> [s]
    691 
    -        _ -> []
    692 
    -    rr = case reverse (concatMap trailing_loc tas) of
    693 
    -        [] -> r
    694 
    -        (s:_) -> combineRealSrcSpans r s
    695 
    -
    696 628 
     -- ---------------------------------------------------------------------
    697 629
    698 630 
     balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs))

  • utils/check-exact/Utils.hs
    ... ... @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
    228 228 
         (p2, remaining) = insertTopLevelCppComments p1 toplevel
    229 229
    230 230 
         addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
    231 
    -    addCommentsListItem = addComments
    231 
    +    addCommentsListItem = addCommentsA
    232 232
    233 233 
         addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList)
    234 234 
         addCommentsList = addComments
    ... ... @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining
    249 249
    250 250 
             _ -> return $ EpAnn anc an ocs
    251 251
    252 
    +    addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn])
    253 
    +    addCommentsA ann@(EpAnn anc an ocs) = do
    254 
    +      case anc of
    255 
    +        EpaSpan (RealSrcSpan s _) -> do
    256 
    +          unAllocated <- get
    257 
    +          let
    258 
    +            (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated
    259 
    +            balanced = splitCommentsEnd s (EpaComments these)
    260 
    +            cs' = sortEpAnnComments (ocs <> balanced)
    261 
    +          put rest
    262 
    +          return $ EpAnn anc an cs'
    263 
    +
    264 
    +        _ -> return $ EpAnn anc an ocs
    265 
    +
    252 266 
     workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
    253 267 
     workInComments ocs [] = ocs
    254 268 
     workInComments ocs new = cs'
    ... ... @@ -264,9 +278,14 @@ workInComments ocs new = cs'
    264 278 
                        = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) )
    265 279 
                                new
    266 280
    281 
    +sortEpAnnComments :: EpAnnComments -> EpAnnComments
    282 
    +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs)
    283 
    +sortEpAnnComments (EpaCommentsBalanced pc fc)
    284 
    +  = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc)
    285 
    +
    267 286 
     insertTopLevelCppComments ::  HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
    268 287 
     insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
    269 
    -  = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
    288 
    +  = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3)
    270 289 
         -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
    271 290 
         -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
    272 291 
       where
    ... ... @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
    297 316 
                 cs' = workInComments (comments an1) stay
    298 317 
             _ -> (an1,cs0a)
    299 318
    300 
    -    (mexports', an3, cs1) =
    301 
    -      case mexports of
    302 
    -        Nothing -> (Nothing, an2, cs0b)
    303 
    -        Just exports -> (Just exports', an3', cse)
    304 
    -           where
    305 
    -             (csh', cs0b') = case am_exports $ anns an2 of
    306 
    -               (tokOP, _tokCP, _tokCommas) ->
    307 
    -                 case tokOP of
    308 
    -                   (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n)
    309 
    -                     where
    310 
    -                       (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) )
    311 
    -                                     cs0b
    312 
    -
    313 
    -                   _ -> ([], cs0b)
    314 
    -             hc1' = workInComments (comments an2) csh'
    315 
    -             an3' = an2 { comments = hc1' }
    316 
    -             (exports', cse) = allocPreceding exports cs0b'
    317 
    -    (imports0, cs2) = allocPreceding imports cs1
    319 
    +    (imports0, cs2) = allocPreceding imports cs0b
    318 320 
         (imports', hc0i) = balanceFirstLocatedAComments imports0
    319 321
    320 322 
         (decls0, cs3) = allocPreceding decls cs2
    ... ... @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
    323 325 
         -- Either hc0i or hc0d should have comments. Combine them
    324 326 
         hc0 = hc0i ++ hc0d
    325 327
    326 
    -    (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3)  hc0
    327 
    -    hc2 = workInComments (comments an3) hc1
    328 
    -    an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
    328 
    +    (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2)  hc0
    329 
    +    hc2 = workInComments (comments an2) hc1
    330 
    +    an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 }
    329 331
    330 332 
         allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
    331 333 
         allocPreceding [] cs' = ([], cs')
    ... ... @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
    346 348 
     annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
    347 349 
     annListBracketsLocs ListNone         = (noAnn,              noAnn)
    348 350
    349 
    -
    350 351 
     data SplitWhere = Before | After
    351 352
    352 353 
     splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
    ... ... @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p'
    430 431
    431 432 
     -- ---------------------------------------------------------------------
    432 433
    434 
    +-- | Get the full span of interest for comments from a LocatedA.
    435 
    +-- This extends up to the last TrailingAnn
    436 
    +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan
    437 
    +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann
    438 
    +
    439 
    +-- | Get the full span of interest for comments from a LocatedA.
    440 
    +-- This extends up to the last TrailingAnn
    441 
    +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan
    442 
    +fullSpanFromEpAnnA (EpAnn anc tas  _) = rr
    443 
    +  where
    444 
    +    r = epaLocationRealSrcSpan anc
    445 
    +    trailing_loc ta = case ta_location ta of
    446 
    +        EpaSpan (RealSrcSpan s _) -> [s]
    447 
    +        _ -> []
    448 
    +    rr = case reverse (concatMap trailing_loc tas) of
    449 
    +        [] -> r
    450 
    +        (s:_) -> combineRealSrcSpans r s
    451 
    +
    452 
    +-- | Split comments into ones occurring before the end of the reference
    453 
    +-- span, and those after it.
    454 
    +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment])
    455 
    +splitComments p cs = (before, middle, after)
    456 
    +  where
    457 
    +    cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    458 
    +    cmpe (L _ _) = True
    459 
    +
    460 
    +    cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p
    461 
    +    cmpb (L _ _) = True
    462 
    +
    463 
    +    (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs))
    464 
    +    (before, middle) = break cmpb beforeEnd
    465 
    +
    466 
    +
    467 
    +-- | Split comments into ones occurring before the end of the reference
    468 
    +-- span, and those after it.
    469 
    +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
    470 
    +splitCommentsEnd p (EpaComments cs) = cs'
    471 
    +  where
    472 
    +    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    473 
    +    cmp (L _ _) = True
    474 
    +    (before, after) = break cmp cs
    475 
    +    cs' = case after of
    476 
    +      [] -> EpaComments cs
    477 
    +      _ -> epaCommentsBalanced before after
    478 
    +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
    479 
    +  where
    480 
    +    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    481 
    +    cmp (L _ _) = True
    482 
    +    (before, after) = break cmp cs
    483 
    +    cs' = before
    484 
    +    ts' = after <> ts
    485 
    +
    486 
    +-- | Split comments into ones occurring before the start of the reference
    487 
    +-- span, and those after it.
    488 
    +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments
    489 
    +splitCommentsStart p (EpaComments cs) = cs'
    490 
    +  where
    491 
    +    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    492 
    +    cmp (L _ _) = True
    493 
    +    (before, after) = break cmp cs
    494 
    +    cs' = case after of
    495 
    +      [] -> EpaComments cs
    496 
    +      _ -> epaCommentsBalanced before after
    497 
    +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts'
    498 
    +  where
    499 
    +    cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p
    500 
    +    cmp (L _ _) = True
    501 
    +    (before, after) = break cmp cs
    502 
    +    cs' = before
    503 
    +    ts' = after <> ts
    504 
    +
    505 
    +-- ---------------------------------------------------------------------
    506 
    +
    433 507 
     ghcCommentText :: LEpaComment -> String
    434 508 
     ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _))      = exactPrintHsDocString s
    435 509 
     ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _))      = s

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/1b3be33c377e2e712865d247351603bd18ae68ae...51021cd3b39c327a8cdef1f45632db55dd327113 at 1787678515