Added annotateIO to MonadThrow

io-classes-mtl/src/Control/Monad/Class/MonadSTM/Trans.hs

@@ -68,6 +68,9 @@ instance ( MonadSTM m
          , MonadThrow.MonadCatch (STM m)
          ) => MonadThrow.MonadThrow (ContTSTM r m) where
   throwIO = ContTSTM . MonadThrow.throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (ContTSTM stm) = ContTSTM (MonadThrow.annotateIO ann stm)
+#endif
 
 instance ( MonadSTM m
          , MonadThrow.MonadThrow (STM m)

io-classes-mtl/src/Control/Monad/Class/MonadThrow/Trans.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE RankNTypes      #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Control.Monad.Class.MonadThrow.Trans () where
@@ -21,6 +22,10 @@ import           Control.Monad.Class.MonadThrow
 
 instance MonadCatch m => MonadThrow (ExceptT e m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (ExceptT io) = ExceptT (annotateIO ann io)
+#endif
+
 
 instance MonadCatch m => MonadCatch (ExceptT e m) where
   catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f)
@@ -63,6 +68,10 @@ instance MonadMask m => MonadMask (ExceptT e m) where
 instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.WriterT w m) where
   throwIO = lift . throwIO
 
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Lazy.WriterT io) = Lazy.WriterT (annotateIO ann io)
+#endif
+
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.WriterT w m) where
   catch (Lazy.WriterT m) f = Lazy.WriterT $ catch m (Lazy.runWriterT . f)
@@ -102,6 +111,9 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.WriterT w m) where
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadThrow (Strict.WriterT w m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Strict.WriterT io) = Strict.WriterT (annotateIO ann io)
+#endif
 
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadCatch (Strict.WriterT w m) where
@@ -143,6 +155,9 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.WriterT w m) where
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.RWST r w s m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Lazy.RWST io) = Lazy.RWST (\r s -> annotateIO ann (io r s))
+#endif
 
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.RWST r w s m) where
@@ -186,6 +201,9 @@ instance (Monoid w, MonadMask m) => MonadMask (Lazy.RWST r w s m) where
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadThrow (Strict.RWST r w s m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Strict.RWST io) = Strict.RWST (\r s -> annotateIO ann (io r s))
+#endif
 
 -- | @since 1.0.0.0
 instance (Monoid w, MonadCatch m) => MonadCatch (Strict.RWST r w s m) where
@@ -229,6 +247,9 @@ instance (Monoid w, MonadMask m) => MonadMask (Strict.RWST r w s m) where
 -- | @since 1.0.0.0
 instance MonadCatch m => MonadThrow (Lazy.StateT s m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Lazy.StateT io) = Lazy.StateT (\s -> annotateIO ann (io s))
+#endif
 
 -- | @since 1.0.0.0
 instance MonadCatch m => MonadCatch (Lazy.StateT s m) where
@@ -270,6 +291,9 @@ instance MonadMask m => MonadMask (Lazy.StateT s m) where
 -- | @since 1.0.0.0
 instance MonadCatch m => MonadThrow (Strict.StateT s m) where
   throwIO = lift . throwIO
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann (Strict.StateT io) = Strict.StateT (\s -> annotateIO ann (io s))
+#endif
 
 -- | @since 1.0.0.0
 instance MonadCatch m => MonadCatch (Strict.StateT s m) where

io-classes/CHANGELOG.md

@@ -10,6 +10,7 @@
 
 * `MonadST` depends on `PrimMonad`.
 * Provide a default implementation of `withLiftST`.
+* Added `annotateIO` to `MonadThrow` (only supported for ghc-9.10 or newer).
 
 ## 1.4.1.0
 

io-classes/io-classes.cabal

@@ -101,6 +101,8 @@ library
                        primitive >= 0.7 && <0.11,
                        stm   >=2.5 && <2.6,
                        time  >=1.9.1 && <1.13
+  if impl(ghc >= 9.10)
+    build-depends:     ghc-internal
 
   if flag(asserts)
     ghc-options: -fno-ignore-asserts

io-classes/src/Control/Monad/Class/MonadThrow.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                       #-}
 {-# LANGUAGE DefaultSignatures         #-}
 {-# LANGUAGE DeriveFunctor             #-}
 {-# LANGUAGE ExistentialQuantification #-}
@@ -34,18 +35,30 @@ import Control.Monad.Reader (ReaderT (..), lift, runReaderT)
 import Control.Monad.STM (STM)
 import Control.Monad.STM qualified as STM
 
+#if __GLASGOW_HASKELL__ >= 910
+import GHC.Internal.Exception.Context (ExceptionAnnotation)
+#endif
+
 -- | Throwing exceptions, and resource handling in the presence of exceptions.
 --
 -- Does not include the ability to respond to exceptions.
 --
 class Monad m => MonadThrow m where
 
+#if __GLASGOW_HASKELL__ >= 910
+  {-# MINIMAL throwIO, annotateIO #-}
+#else
   {-# MINIMAL throwIO #-}
+#endif
+
   throwIO :: Exception e => e -> m a
 
   bracket  :: m a -> (a -> m b) -> (a -> m c) -> m c
   bracket_ :: m a -> m b -> m c -> m c
   finally  :: m a -> m b -> m a
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO :: forall e a. ExceptionAnnotation e => e -> m a -> m a
+#endif
 
   default bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c
 
@@ -206,11 +219,14 @@ class MonadThrow m => MonadEvaluate m where
 
 instance MonadThrow IO where
 
-  throwIO  = IO.throwIO
+  throwIO    = IO.throwIO
 
-  bracket  = IO.bracket
-  bracket_ = IO.bracket_
-  finally  = IO.finally
+  bracket    = IO.bracket
+  bracket_   = IO.bracket_
+  finally    = IO.finally
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO = IO.annotateIO
+#endif
 
 
 instance MonadCatch IO where
@@ -249,6 +265,9 @@ instance MonadEvaluate IO where
 
 instance MonadThrow STM where
   throwIO = STM.throwSTM
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
+#endif
 
 instance MonadCatch STM where
   catch  = STM.catchSTM
@@ -273,6 +292,10 @@ instance MonadThrow m => MonadThrow (ReaderT r m) where
       (      runReaderT acquire     env)
       (\a -> runReaderT (release a) env)
       (\a -> runReaderT (use a)     env)
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann io = ReaderT $ \env ->
+    annotateIO ann (runReaderT io env)
+#endif
 
 instance MonadCatch m => MonadCatch (ReaderT r m) where
   catch act handler = ReaderT $ \env ->

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -16,7 +16,7 @@
 {-# LANGUAGE TypeFamilies              #-}
 
 -- Needed for `SimEvent` type.
-{-# OPTIONS_GHC -Wno-partial-fields     #-}
+{-# OPTIONS_GHC -Wno-partial-fields    #-}
 
 module Control.Monad.IOSim.Types
   ( IOSim (..)
@@ -75,8 +75,8 @@ module Control.Monad.IOSim.Types
   ) where
 
 import Control.Applicative
-import Control.Exception (ErrorCall (..), asyncExceptionFromException,
-           asyncExceptionToException)
+import Control.Exception (ErrorCall (..))
+import Control.Exception qualified as IO
 import Control.Monad
 import Control.Monad.Fix (MonadFix (..))
 
@@ -340,6 +340,9 @@ instance MonadSay (IOSim s) where
 
 instance MonadThrow (IOSim s) where
   throwIO e = IOSim $ oneShot $ \_ -> Throw (toException e)
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
+#endif
 
 instance MonadEvaluate (IOSim s) where
   evaluate a = IOSim $ oneShot $ \k -> Evaluate a k
@@ -354,6 +357,9 @@ instance Exceptions.MonadThrow (IOSim s) where
 
 instance MonadThrow (STM s) where
   throwIO e = STM $ oneShot $ \_ -> ThrowStm (toException e)
+#if __GLASGOW_HASKELL__ >= 910
+  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
+#endif
 
   -- Since these involve re-throwing the exception and we don't provide
   -- CatchSTM at all, then we can get away with trivial versions:
@@ -742,8 +748,8 @@ instance Show TimeoutException where
     show (TimeoutException tmid) = "<<timeout " ++ show tmid ++ " >>"
 
 instance Exception TimeoutException where
-  toException   = asyncExceptionToException
-  fromException = asyncExceptionFromException
+  toException   = IO.asyncExceptionToException
+  fromException = IO.asyncExceptionFromException
 
 -- | Wrapper for Eventlog events so they can be retrieved from the trace with
 -- 'selectTraceEventsDynamic'.