Skip to content

Commit 158f8ad

Browse files
cootcoot
committed
Added annotateIO to MonadThrow
1 parent 8ec0546 commit 158f8ad

File tree

7 files changed

+72
-12
lines changed

7 files changed

+72
-12
lines changed

‎io-classes-mtl/CHANGELOG.md

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,15 @@
11
# Revision history for io-classes-mtl
22

3-
## new version
3+
## 0.1.2.0
44

55
### Non breaking changes
66

7-
- Added `writeTMVar` to `MonadSTM` instances.
7+
* Added `writeTMVar` to `MonadSTM` instances.
8+
* Support `io-classes-1.5.0.0`.
89

910
## 0.1.1.0
1011

11-
* Support `io-classes-1.4.1.0`
12+
* Support `io-classes-1.4.1.0`.
1213

1314
## 0.1.0.2
1415

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,9 @@ instance ( MonadSTM m
6868
, MonadThrow.MonadCatch (STM m)
6969
) => MonadThrow.MonadThrow (ContTSTM r m) where
7070
throwIO = ContTSTM . MonadThrow.throwIO
71+
#if __GLASGOW_HASKELL__ >= 910
72+
annotateIO ann (ContTSTM stm) = ContTSTM (MonadThrow.annotateIO ann stm)
73+
#endif
7174

7275
instance ( MonadSTM m
7376
, MonadThrow.MonadThrow (STM m)

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

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE RankNTypes #-}
23
{-# OPTIONS_GHC -Wno-orphans #-}
34
module Control.Monad.Class.MonadThrow.Trans () where
@@ -21,6 +22,10 @@ import Control.Monad.Class.MonadThrow
2122

2223
instance MonadCatch m => MonadThrow (ExceptT e m) where
2324
throwIO = lift . throwIO
25+
#if __GLASGOW_HASKELL__ >= 910
26+
annotateIO ann (ExceptT io) = ExceptT (annotateIO ann io)
27+
#endif
28+
2429

2530
instance MonadCatch m => MonadCatch (ExceptT e m) where
2631
catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f)
@@ -63,6 +68,10 @@ instance MonadMask m => MonadMask (ExceptT e m) where
6368
instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.WriterT w m) where
6469
throwIO = lift . throwIO
6570

71+
#if __GLASGOW_HASKELL__ >= 910
72+
annotateIO ann (Lazy.WriterT io) = Lazy.WriterT (annotateIO ann io)
73+
#endif
74+
6675
-- | @since 1.0.0.0
6776
instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.WriterT w m) where
6877
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
102111
-- | @since 1.0.0.0
103112
instance (Monoid w, MonadCatch m) => MonadThrow (Strict.WriterT w m) where
104113
throwIO = lift . throwIO
114+
#if __GLASGOW_HASKELL__ >= 910
115+
annotateIO ann (Strict.WriterT io) = Strict.WriterT (annotateIO ann io)
116+
#endif
105117

106118
-- | @since 1.0.0.0
107119
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
143155
-- | @since 1.0.0.0
144156
instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.RWST r w s m) where
145157
throwIO = lift . throwIO
158+
#if __GLASGOW_HASKELL__ >= 910
159+
annotateIO ann (Lazy.RWST io) = Lazy.RWST (\r s -> annotateIO ann (io r s))
160+
#endif
146161

147162
-- | @since 1.0.0.0
148163
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
186201
-- | @since 1.0.0.0
187202
instance (Monoid w, MonadCatch m) => MonadThrow (Strict.RWST r w s m) where
188203
throwIO = lift . throwIO
204+
#if __GLASGOW_HASKELL__ >= 910
205+
annotateIO ann (Strict.RWST io) = Strict.RWST (\r s -> annotateIO ann (io r s))
206+
#endif
189207

190208
-- | @since 1.0.0.0
191209
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
229247
-- | @since 1.0.0.0
230248
instance MonadCatch m => MonadThrow (Lazy.StateT s m) where
231249
throwIO = lift . throwIO
250+
#if __GLASGOW_HASKELL__ >= 910
251+
annotateIO ann (Lazy.StateT io) = Lazy.StateT (\s -> annotateIO ann (io s))
252+
#endif
232253

233254
-- | @since 1.0.0.0
234255
instance MonadCatch m => MonadCatch (Lazy.StateT s m) where
@@ -270,6 +291,9 @@ instance MonadMask m => MonadMask (Lazy.StateT s m) where
270291
-- | @since 1.0.0.0
271292
instance MonadCatch m => MonadThrow (Strict.StateT s m) where
272293
throwIO = lift . throwIO
294+
#if __GLASGOW_HASKELL__ >= 910
295+
annotateIO ann (Strict.StateT io) = Strict.StateT (\s -> annotateIO ann (io s))
296+
#endif
273297

274298
-- | @since 1.0.0.0
275299
instance MonadCatch m => MonadCatch (Strict.StateT s m) where

‎io-classes/CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@
1010

1111
* `MonadST` depends on `PrimMonad`.
1212
* Provide a default implementation of `withLiftST`.
13+
* Added `annotateIO` to `MonadThrow` (only supported for ghc-9.10 or newer).
1314

1415
## 1.4.1.0
1516

‎io-classes/io-classes.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,8 @@ library
101101
primitive >= 0.7 && <0.11,
102102
stm >=2.5 && <2.6,
103103
time >=1.9.1 && <1.13
104+
if impl(ghc >= 9.10)
105+
build-depends: ghc-internal
104106

105107
if flag(asserts)
106108
ghc-options: -fno-ignore-asserts

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

Lines changed: 27 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE DefaultSignatures #-}
23
{-# LANGUAGE DeriveFunctor #-}
34
{-# LANGUAGE ExistentialQuantification #-}
@@ -34,18 +35,30 @@ import Control.Monad.Reader (ReaderT (..), lift, runReaderT)
3435
import Control.Monad.STM (STM)
3536
import Control.Monad.STM qualified as STM
3637

38+
#if __GLASGOW_HASKELL__ >= 910
39+
import GHC.Internal.Exception.Context (ExceptionAnnotation)
40+
#endif
41+
3742
-- | Throwing exceptions, and resource handling in the presence of exceptions.
3843
--
3944
-- Does not include the ability to respond to exceptions.
4045
--
4146
class Monad m => MonadThrow m where
4247

48+
#if __GLASGOW_HASKELL__ >= 910
49+
{-# MINIMAL throwIO, annotateIO #-}
50+
#else
4351
{-# MINIMAL throwIO #-}
52+
#endif
53+
4454
throwIO :: Exception e => e -> m a
4555

4656
bracket :: m a -> (a -> m b) -> (a -> m c) -> m c
4757
bracket_ :: m a -> m b -> m c -> m c
4858
finally :: m a -> m b -> m a
59+
#if __GLASGOW_HASKELL__ >= 910
60+
annotateIO :: forall e a. ExceptionAnnotation e => e -> m a -> m a
61+
#endif
4962

5063
default bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c
5164

@@ -206,11 +219,14 @@ class MonadThrow m => MonadEvaluate m where
206219

207220
instance MonadThrow IO where
208221

209-
throwIO = IO.throwIO
222+
throwIO = IO.throwIO
210223

211-
bracket = IO.bracket
212-
bracket_ = IO.bracket_
213-
finally = IO.finally
224+
bracket = IO.bracket
225+
bracket_ = IO.bracket_
226+
finally = IO.finally
227+
#if __GLASGOW_HASKELL__ >= 910
228+
annotateIO = IO.annotateIO
229+
#endif
214230

215231

216232
instance MonadCatch IO where
@@ -249,6 +265,9 @@ instance MonadEvaluate IO where
249265

250266
instance MonadThrow STM where
251267
throwIO = STM.throwSTM
268+
#if __GLASGOW_HASKELL__ >= 910
269+
annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
270+
#endif
252271

253272
instance MonadCatch STM where
254273
catch = STM.catchSTM
@@ -273,6 +292,10 @@ instance MonadThrow m => MonadThrow (ReaderT r m) where
273292
( runReaderT acquire env)
274293
(\a -> runReaderT (release a) env)
275294
(\a -> runReaderT (use a) env)
295+
#if __GLASGOW_HASKELL__ >= 910
296+
annotateIO ann io = ReaderT $ \env ->
297+
annotateIO ann (runReaderT io env)
298+
#endif
276299

277300
instance MonadCatch m => MonadCatch (ReaderT r m) where
278301
catch act handler = ReaderT $ \env ->

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

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@
1616
{-# LANGUAGE TypeFamilies #-}
1717

1818
-- Needed for `SimEvent` type.
19-
{-# OPTIONS_GHC -Wno-partial-fields #-}
19+
{-# OPTIONS_GHC -Wno-partial-fields #-}
2020

2121
module Control.Monad.IOSim.Types
2222
( IOSim (..)
@@ -75,8 +75,8 @@ module Control.Monad.IOSim.Types
7575
) where
7676

7777
import Control.Applicative
78-
import Control.Exception (ErrorCall (..), asyncExceptionFromException,
79-
asyncExceptionToException)
78+
import Control.Exception (ErrorCall (..))
79+
import Control.Exception qualified as IO
8080
import Control.Monad
8181
import Control.Monad.Fix (MonadFix (..))
8282

@@ -340,6 +340,9 @@ instance MonadSay (IOSim s) where
340340

341341
instance MonadThrow (IOSim s) where
342342
throwIO e = IOSim $ oneShot $ \_ -> Throw (toException e)
343+
#if __GLASGOW_HASKELL__ >= 910
344+
annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
345+
#endif
343346

344347
instance MonadEvaluate (IOSim s) where
345348
evaluate a = IOSim $ oneShot $ \k -> Evaluate a k
@@ -354,6 +357,9 @@ instance Exceptions.MonadThrow (IOSim s) where
354357

355358
instance MonadThrow (STM s) where
356359
throwIO e = STM $ oneShot $ \_ -> ThrowStm (toException e)
360+
#if __GLASGOW_HASKELL__ >= 910
361+
annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)
362+
#endif
357363

358364
-- Since these involve re-throwing the exception and we don't provide
359365
-- CatchSTM at all, then we can get away with trivial versions:
@@ -742,8 +748,8 @@ instance Show TimeoutException where
742748
show (TimeoutException tmid) = "<<timeout " ++ show tmid ++ " >>"
743749

744750
instance Exception TimeoutException where
745-
toException = asyncExceptionToException
746-
fromException = asyncExceptionFromException
751+
toException = IO.asyncExceptionToException
752+
fromException = IO.asyncExceptionFromException
747753

748754
-- | Wrapper for Eventlog events so they can be retrieved from the trace with
749755
-- 'selectTraceEventsDynamic'.

0 commit comments

Comments
 (0)