feat: support for exception context propagation

This is a WIP in order to have exception context propagation.

Instead of `catch`ing and `throw`ing, we `catchNoPropagate` and
`rethrow`:

- `catchNoPropagate` does not add the `WhileHandling` logic onto the
  exception (this is to be discussed, maybe we want to add a bit of
  context)
- `rethrow` does not add / override the backtrace.

I had to change many of the type signature of the library in a backward
incompatible manner AND this is only compatible with GHC 9.12 for now.

I will use this commit at work for a bit of time in order to gather some
feedback and maybe comeback with a more robust solution.

Example of usage / changes:

The following code:

```haskell
{-# LANGUAGE DeriveAnyClass #-}
import Control.Concurrent.Async
import Control.Exception
import Control.Exception.Context
import Control.Exception.Annotation
import Data.Typeable
import Data.Traversable
import GHC.Stack

data Ann = Ann String
  deriving (Show, ExceptionAnnotation)

asyncTask :: HasCallStack => IO ()
asyncTask = annotateIO (Ann "bonjour") $ do
  error "yoto"

asyncTask' :: HasCallStack => IO ()
asyncTask' = annotateIO (Ann "bonjour2") $ do
  error "yutu"

main = do
  -- withAsync asyncTask wait
  concurrently asyncTask asyncTask'
  -- race asyncTask asyncTask'
```

When run without this commit leads to:

```
ASyncException.hs: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall:

yoto

HasCallStack backtrace:
  throwIO, called at ./Control/Concurrent/Async/Internal.hs:630:24 in async-2.2.5-50rpfAJ7BEc1o5OswtTMUN:Control.Concurrent.Async.Internal
```

When run with this commit:

```
*** Exception: yoto

Ann "bonjour"
HasCallStack backtrace:
  error, called at /home/guillaume//ASyncException.hs:15:3 in async-2.2.5-inplace:Main
  asyncTask, called at /home/guillaume//ASyncException.hs:23:16 in async-2.2.5-inplace:Main
```

Author: guibou

Control/Concurrent/Async/Internal.hs

@@ -56,6 +56,7 @@ import Data.IORef
 import GHC.Exts
 import GHC.IO hiding (finally, onException)
 import GHC.Conc (ThreadId(..))
+import Control.Exception.Context
 
 -- -----------------------------------------------------------------------------
 -- STM Async API
@@ -70,7 +71,7 @@ data Async a = Async
   { asyncThreadId :: {-# UNPACK #-} !ThreadId
                   -- ^ Returns the 'ThreadId' of the thread running
                   -- the given 'Async'.
-  , _asyncWait    :: STM (Either SomeException a)
+  , _asyncWait    :: STM (Either (ExceptionWithContext SomeException) a)
   }
 
 instance Eq (Async a) where
@@ -178,11 +179,16 @@ withAsyncUsing :: (IO () -> IO ThreadId)
 withAsyncUsing doFork = \action inner -> do
   var <- newEmptyTMVarIO
   mask $ \restore -> do
-    t <- doFork $ try (restore action) >>= atomically . putTMVar var
+    t <- doFork $ tryWithContext (restore action) >>= atomically . putTMVar var
     let a = Async t (readTMVar var)
-    r <- restore (inner a) `catchAll` \e -> do
+    r <- restore (inner a) `catchAll` \e@(ExceptionWithContext ctx e') -> do
       uninterruptibleCancel a
-      throwIO e
+      print "e"
+      print $ displayException e
+      print "context"
+      print $ displayExceptionContext ctx
+      print "/context"
+      rethrowIO e
     uninterruptibleCancel a
     return r
 
@@ -206,7 +212,7 @@ wait = tryAgain . atomically . waitSTM
 -- > waitCatch = atomically . waitCatchSTM
 --
 {-# INLINE waitCatch #-}
-waitCatch :: Async a -> IO (Either SomeException a)
+waitCatch :: Async a -> IO (Either (ExceptionWithContext SomeException) a)
 waitCatch = tryAgain . atomically . waitCatchSTM
   where
     -- See: https://github.com/simonmar/async/issues/14
@@ -220,7 +226,7 @@ waitCatch = tryAgain . atomically . waitCatchSTM
 -- > poll = atomically . pollSTM
 --
 {-# INLINE poll #-}
-poll :: Async a -> IO (Maybe (Either SomeException a))
+poll :: Async a -> IO (Maybe (Either (ExceptionWithContext SomeException) a))
 poll = atomically . pollSTM
 
 -- | A version of 'wait' that can be used inside an STM transaction.
@@ -233,13 +239,13 @@ waitSTM a = do
 -- | A version of 'waitCatch' that can be used inside an STM transaction.
 --
 {-# INLINE waitCatchSTM #-}
-waitCatchSTM :: Async a -> STM (Either SomeException a)
+waitCatchSTM :: Async a -> STM (Either (ExceptionWithContext SomeException) a)
 waitCatchSTM (Async _ w) = w
 
 -- | A version of 'poll' that can be used inside an STM transaction.
 --
 {-# INLINE pollSTM #-}
-pollSTM :: Async a -> STM (Maybe (Either SomeException a))
+pollSTM :: Async a -> STM (Maybe (Either (ExceptionWithContext SomeException) a))
 pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing
 
 -- | Cancel an asynchronous action by throwing the @AsyncCancelled@
@@ -310,13 +316,13 @@ cancelWith a@(Async t _) e = throwTo t e <* waitCatch a
 -- returned corresponds to the first completed 'Async' in the list.
 --
 {-# INLINE waitAnyCatch #-}
-waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)
+waitAnyCatch :: [Async a] -> IO (Async a, Either (ExceptionWithContext SomeException) a)
 waitAnyCatch = atomically . waitAnyCatchSTM
 
 -- | A version of 'waitAnyCatch' that can be used inside an STM transaction.
 --
 -- @since 2.1.0
-waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)
+waitAnyCatchSTM :: [Async a] -> STM (Async a, Either (ExceptionWithContext SomeException) a)
 waitAnyCatchSTM [] =
     throwSTM $ ErrorCall
       "waitAnyCatchSTM: invalid argument: input list must be non-empty"
@@ -327,7 +333,7 @@ waitAnyCatchSTM asyncs =
 -- | Like 'waitAnyCatch', but also cancels the other asynchronous
 -- operations as soon as one has completed.
 --
-waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)
+waitAnyCatchCancel :: [Async a] -> IO (Async a, Either (ExceptionWithContext SomeException) a)
 waitAnyCatchCancel asyncs =
   waitAnyCatch asyncs `finally` cancelMany asyncs
 
@@ -364,8 +370,8 @@ waitAnyCancel asyncs =
 -- | Wait for the first of two @Async@s to finish.
 {-# INLINE waitEitherCatch #-}
 waitEitherCatch :: Async a -> Async b
-                -> IO (Either (Either SomeException a)
-                              (Either SomeException b))
+                -> IO (Either (Either (ExceptionWithContext SomeException) a)
+                              (Either (ExceptionWithContext SomeException) b))
 waitEitherCatch left right =
   tryAgain $ atomically (waitEitherCatchSTM left right)
   where
@@ -376,8 +382,8 @@ waitEitherCatch left right =
 --
 -- @since 2.1.0
 waitEitherCatchSTM :: Async a -> Async b
-                -> STM (Either (Either SomeException a)
-                               (Either SomeException b))
+                -> STM (Either (Either (ExceptionWithContext SomeException) a)
+                               (Either (ExceptionWithContext SomeException) b))
 waitEitherCatchSTM left right =
     (Left  <$> waitCatchSTM left)
       `orElse`
@@ -387,8 +393,8 @@ waitEitherCatchSTM left right =
 -- returning.
 --
 waitEitherCatchCancel :: Async a -> Async b
-                      -> IO (Either (Either SomeException a)
-                                    (Either SomeException b))
+                      -> IO (Either (Either (ExceptionWithContext SomeException) a)
+                                    (Either (ExceptionWithContext SomeException) b))
 waitEitherCatchCancel left right =
   waitEitherCatch left right `finally` cancelMany [() <$ left, () <$ right]
 
@@ -458,7 +464,7 @@ waitBothSTM left right = do
 -- Linking threads
 
 data ExceptionInLinkedThread =
-  forall a . ExceptionInLinkedThread (Async a) SomeException
+  forall a . ExceptionInLinkedThread (Async a) (ExceptionWithContext SomeException)
 #if __GLASGOW_HASKELL__ < 710
   deriving Typeable
 #endif
@@ -496,7 +502,7 @@ link = linkOnly (not . isCancel)
 -- thread should be propagated to the source thread.
 --
 linkOnly
-  :: (SomeException -> Bool)  -- ^ return 'True' if the exception
+  :: (ExceptionWithContext SomeException -> Bool)  -- ^ return 'True' if the exception
                               -- should be propagated, 'False'
                               -- otherwise.
   -> Async a
@@ -527,7 +533,7 @@ link2 = link2Only (not . isCancel)
 -- The supplied predicate determines which exceptions in the target
 -- thread should be propagated to the source thread.
 --
-link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()
+link2Only :: (ExceptionWithContext SomeException -> Bool) -> Async a -> Async b -> IO ()
 link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =
   void $ forkRepeat $ do
     r <- waitEitherCatch left right
@@ -538,8 +544,8 @@ link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =
         throwTo tl (ExceptionInLinkedThread right e)
       _ -> return ()
 
-isCancel :: SomeException -> Bool
-isCancel e
+isCancel :: (ExceptionWithContext SomeException) -> Bool
+isCancel (ExceptionWithContext ctx e)
   | Just AsyncCancelled <- fromException e = True
   | otherwise = False
 
@@ -613,7 +619,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 ()
@@ -627,7 +633,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))
@@ -640,11 +646,11 @@ 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
-             -> (IO (Either SomeException (Either a b)) -> IO r)
+             -> (IO (Either (ExceptionWithContext SomeException) (Either a b)) -> IO r)
              -> IO r
 concurrently' left right collect = do
     done <- newEmptyMVar
@@ -699,7 +705,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
 
 
@@ -854,11 +860,11 @@ forkRepeat action =
                   _      -> return ()
     in forkIO go
 
-catchAll :: IO a -> (SomeException -> IO a) -> IO a
-catchAll = catch
+catchAll :: IO a -> (ExceptionWithContext SomeException -> IO a) -> IO a
+catchAll = catchNoPropagate
 
-tryAll :: IO a -> IO (Either SomeException a)
-tryAll = try
+tryAll :: IO a -> IO (Either (ExceptionWithContext SomeException) a)
+tryAll = tryWithContext
 
 -- A version of forkIO that does not include the outer exception
 -- handler: saves a bit of time when we will be installing our own