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

Commits:

13 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/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/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, [''])

  • 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/dddcdee342a578bbcc4601e010bcfeb8840b59db...1b3be33c377e2e712865d247351603bd18ae68ae at 1787667863