Skip to content

feat: support for exception context propagation #165

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

feat: support for exception context propagation #165

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
91c00c5
rethrow
guibou May 10, 2025
d374da2
Handle the case for waitSTM
guibou May 12, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
31 changes: 25 additions & 6 deletions Control/Concurrent/Async/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
#endif
{-# OPTIONS -Wall #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
Expand Down Expand Up @@ -182,10 +183,23 @@ withAsyncUsing doFork = \action inner -> do
let a = Async t (readTMVar var)
r <- restore (inner a) `catchAll` \e -> do
uninterruptibleCancel a
throwIO e
rethrowIO' e
uninterruptibleCancel a
return r


-- | This function attempts at rethrowing while keeping the context
-- This is internal and only working with GHC >=9.12
rethrowIO' :: SomeException -> IO a
#if MIN_VERSION_base(4,21,0)
rethrowIO' e =
case fromException e of
Just (e' :: ExceptionWithContext SomeException) -> rethrowIO e'
Nothing -> throwIO e
#else
rethrowIO' = throwIO
#endif

-- | Wait for an asynchronous action to complete, and return its
-- value. If the asynchronous action threw an exception, then the
-- exception is re-thrown by 'wait'.
Expand Down Expand Up @@ -228,7 +242,12 @@ poll = atomically . pollSTM
waitSTM :: Async a -> STM a
waitSTM a = do
r <- waitCatchSTM a
either throwSTM return r
either (rethrowSTM) return r

rethrowSTM e =
case fromException e of
Just (e' :: ExceptionWithContext SomeException) -> throwSTM (NoBacktrace e')
Nothing -> throwSTM e

-- | A version of 'waitCatch' that can be used inside an STM transaction.
--
Expand Down Expand Up @@ -613,7 +632,7 @@ race left right = concurrently' left right collect
collect m = do
e <- m
case e of
Left ex -> throwIO ex
Left ex -> rethrowIO' ex
Right r -> return r

-- race_ :: IO a -> IO b -> IO ()
Expand All @@ -627,7 +646,7 @@ concurrently left right = concurrently' left right (collect [])
collect xs m = do
e <- m
case e of
Left ex -> throwIO ex
Left ex -> rethrowIO' ex
Right r -> collect (r:xs) m

-- concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))
Expand All @@ -640,7 +659,7 @@ concurrentlyE left right = concurrently' left right (collect [])
collect xs m = do
e <- m
case e of
Left ex -> throwIO ex
Left ex -> rethrowIO' ex
Right r -> collect (r:xs) m

concurrently' :: IO a -> IO b
Expand Down Expand Up @@ -699,7 +718,7 @@ concurrently_ left right = concurrently' left right (collect 0)
collect i m = do
e <- m
case e of
Left ex -> throwIO ex
Left ex -> rethrowIO' ex
Right _ -> collect (i + 1 :: Int) m


Expand Down