packages feed

safe-exceptions 0.1.7.1 → 0.1.7.4

raw patch · 5 files changed

Files

ChangeLog.md view
@@ -1,5 +1,18 @@ # ChangeLog for safe-exceptions +## 0.1.7.4++* Add `HasCallStack` when `exceptions >= 0.10.6` [#41](https://github.com/fpco/safe-exceptions/issues/41)++## 0.1.7.3++* Allow transformers 0.6 [#39](https://github.com/fpco/safe-exceptions/issues/39)++## 0.1.7.2++* Changed `bracketWithError` and `bracketOnError` to use `generalBracket` from `MonadMask` [#36](https://github.com/fpco/safe-exceptions/issues/36)+* Raised dependency `exceptions` from `>= 0.8` to `>= 0.10`+ ## 0.1.7.1  * Doc update
README.md view
@@ -2,7 +2,8 @@  *Safe, consistent, and easy exception handling* -[![Build Status](https://travis-ci.org/fpco/safe-exceptions.svg?branch=master)](https://travis-ci.org/fpco/safe-exceptions) [![Stackage](http://stackage.org/package/safe-exceptions/badge/lts)](http://stackage.org/lts/package/safe-exceptions)+[![Tests](https://github.com/fpco/safe-exceptions/actions/workflows/tests.yml/badge.svg)](https://github.com/fpco/safe-exceptions/actions/workflows/tests.yml)+[![Stackage](http://stackage.org/package/safe-exceptions/badge/lts)](http://stackage.org/lts/package/safe-exceptions)  > The documentation for this library is available on [Stackage](http://stackage.org/lts/package/safe-exceptions)
safe-exceptions.cabal view
@@ -1,5 +1,5 @@ name:                safe-exceptions-version:             0.1.7.1+version:             0.1.7.4 synopsis:            Safe, consistent, and easy exception handling description:         Please see README.md homepage:            https://github.com/fpco/safe-exceptions#readme@@ -16,10 +16,10 @@ library   hs-source-dirs:      src   exposed-modules:     Control.Exception.Safe-  build-depends:       base >= 4.7 && < 5+  build-depends:       base >= 4.11 && < 5                      , deepseq >= 1.2 && < 1.5-                     , exceptions >= 0.8 && < 0.11-                     , transformers >= 0.2 && < 0.6+                     , exceptions >= 0.10 && < 0.11+                     , transformers >= 0.2 && < 0.7   default-language:    Haskell2010  test-suite safe-exceptions-test@@ -30,6 +30,7 @@   build-depends:       base                      , hspec                      , safe-exceptions+                     , transformers                      , void   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010
src/Control/Exception/Safe.hs view
@@ -93,7 +93,7 @@ import qualified Control.Exception as E import qualified Control.Monad.Catch as C import Control.Monad.Catch (Handler (..))-import Control.Monad (liftM)+import Control.Monad (liftM, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Typeable (Typeable, cast) @@ -102,23 +102,66 @@ import GHC.Stack.Types (HasCallStack, CallStack, getCallStack) #endif +#if MIN_VERSION_base(4,9,0) && MIN_VERSION_exceptions(0,10,6)+import GHC.Stack (withFrozenCallStack)+#endif++-- The exceptions package that safe-exceptions is based on added HasCallStack+-- to many of its functions in 0.10.6:+--+-- https://github.com/ekmett/exceptions/pull/90+-- https://github.com/ekmett/exceptions/pull/92+--+-- We make the same change here. The following comment has been lifted+-- verbatim from exceptions:+--+-- We use the following bit of CPP to enable the use of HasCallStack+-- constraints without breaking the build for pre-8.0 GHCs, which did not+-- provide GHC.Stack. We are careful to always write constraints like this:+--+--   HAS_CALL_STACK => MonadThrow m => ...+--+-- Instead of like this:+--+--   (HAS_CALL_STACK, MonadThrow e) => ...+--+-- The latter is equivalent to (() :: Constraint, MonadThrow e) => ..., which+-- requires ConstraintKinds. More importantly, it's slightly less efficient,+-- since it requires passing an empty constraint tuple dictionary around.+--+-- Note that we do /not/ depend on the call-stack compatibility library to+-- provide HasCallStack on older GHCs. We tried this at one point, but we+-- discovered that downstream libraries failed to build because combining+-- call-stack with GeneralizedNewtypeDeriving on older GHCs would require the+-- use of ConstraintKinds/FlexibleContexts, which downstream libraries did not+-- enable. (See #91.) The CPP approach that we use now, while somewhat clunky,+-- avoids these issues by not requiring any additional language extensions for+-- downstream users.+#if MIN_VERSION_base(4,9,0) && MIN_VERSION_exceptions(0,10,6)+# define HAS_CALL_STACK HasCallStack+#else+# define HAS_CALL_STACK ()+withFrozenCallStack :: a -> a+withFrozenCallStack a = a+#endif+ -- | Synchronously throw the given exception -- -- @since 0.1.0.0-throw :: (C.MonadThrow m, Exception e) => e -> m a+throw :: HAS_CALL_STACK => (C.MonadThrow m, Exception e) => e -> m a throw = C.throwM . toSyncException  -- | Synonym for 'throw' -- -- @since 0.1.0.0-throwIO :: (C.MonadThrow m, Exception e) => e -> m a-throwIO = throw+throwIO :: HAS_CALL_STACK => (C.MonadThrow m, Exception e) => e -> m a+throwIO = withFrozenCallStack throw  -- | Synonym for 'throw' -- -- @since 0.1.0.0-throwM :: (C.MonadThrow m, Exception e) => e -> m a-throwM = throw+throwM :: HAS_CALL_STACK => (C.MonadThrow m, Exception e) => e -> m a+throwM = withFrozenCallStack throw  -- | A convenience function for throwing a user error. This is useful -- for cases where it would be too high a burden to define your own@@ -193,14 +236,14 @@ -- see <https://github.com/fpco/safe-exceptions#quickstart> -- -- @since 0.1.0.0-impureThrow :: Exception e => e -> a+impureThrow :: HAS_CALL_STACK => Exception e => e -> a impureThrow = E.throw . toSyncException  -- | Same as upstream 'C.catch', but will not catch asynchronous -- exceptions -- -- @since 0.1.0.0-catch :: (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a+catch :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a catch f g = f `C.catch` \e ->     if isSyncException e         then g e@@ -211,22 +254,22 @@ -- | 'C.catch' specialized to only catching 'E.IOException's -- -- @since 0.1.3.0-catchIO :: C.MonadCatch m => m a -> (E.IOException -> m a) -> m a-catchIO = C.catch+catchIO :: HAS_CALL_STACK => C.MonadCatch m => m a -> (E.IOException -> m a) -> m a+catchIO = withFrozenCallStack C.catch  -- | 'catch' specialized to catch all synchronous exception -- -- @since 0.1.0.0-catchAny :: C.MonadCatch m => m a -> (SomeException -> m a) -> m a-catchAny = catch+catchAny :: HAS_CALL_STACK => C.MonadCatch m => m a -> (SomeException -> m a) -> m a+catchAny = withFrozenCallStack catch  -- | Same as 'catch', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.1.0-catchDeep :: (C.MonadCatch m, MonadIO m, Exception e, NFData a)+catchDeep :: HAS_CALL_STACK => (C.MonadCatch m, MonadIO m, Exception e, NFData a)           => m a -> (e -> m a) -> m a-catchDeep = catch . evaluateDeep+catchDeep = withFrozenCallStack catch . evaluateDeep  -- | Internal helper function evaluateDeep :: (MonadIO m, NFData a) => m a -> m a@@ -237,8 +280,8 @@ -- | 'catchDeep' specialized to catch all synchronous exception -- -- @since 0.1.1.0-catchAnyDeep :: (C.MonadCatch m, MonadIO m, NFData a) => m a -> (SomeException -> m a) -> m a-catchAnyDeep = catchDeep+catchAnyDeep :: HAS_CALL_STACK => (C.MonadCatch m, MonadIO m, NFData a) => m a -> (SomeException -> m a) -> m a+catchAnyDeep = withFrozenCallStack catchDeep  -- | 'catch' without async exception safety --@@ -247,7 +290,7 @@ -- <https://github.com/fpco/safe-exceptions#quickstart> -- -- @since 0.1.0.0-catchAsync :: (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a+catchAsync :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a catchAsync = C.catch  -- | 'catchJust' is like 'catch' but it takes an extra argument which@@ -255,39 +298,39 @@ -- exceptions we're interested in. -- -- @since 0.1.4.0-catchJust :: (C.MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a-catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e+catchJust :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a+catchJust f a b = withFrozenCallStack catch a (\e -> maybe (throwM e) b $ f e)  -- | Flipped version of 'catch' -- -- @since 0.1.0.0-handle :: (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a-handle = flip catch+handle :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a+handle = flip (withFrozenCallStack catch)  -- | 'C.handle' specialized to only catching 'E.IOException's -- -- @since 0.1.3.0-handleIO :: C.MonadCatch m => (E.IOException -> m a) -> m a -> m a-handleIO = C.handle+handleIO :: HAS_CALL_STACK => C.MonadCatch m => (E.IOException -> m a) -> m a -> m a+handleIO = withFrozenCallStack C.handle   -- | Flipped version of 'catchAny' -- -- @since 0.1.0.0-handleAny :: C.MonadCatch m => (SomeException -> m a) -> m a -> m a-handleAny = flip catchAny+handleAny :: HAS_CALL_STACK => C.MonadCatch m => (SomeException -> m a) -> m a -> m a+handleAny = flip (withFrozenCallStack catchAny)  -- | Flipped version of 'catchDeep' -- -- @since 0.1.1.0-handleDeep :: (C.MonadCatch m, Exception e, MonadIO m, NFData a) => (e -> m a) -> m a -> m a-handleDeep = flip catchDeep+handleDeep :: HAS_CALL_STACK => (C.MonadCatch m, Exception e, MonadIO m, NFData a) => (e -> m a) -> m a -> m a+handleDeep = flip (withFrozenCallStack catchDeep)  -- | Flipped version of 'catchAnyDeep' -- -- @since 0.1.1.0-handleAnyDeep :: (C.MonadCatch m, MonadIO m, NFData a) => (SomeException -> m a) -> m a -> m a-handleAnyDeep = flip catchAnyDeep+handleAnyDeep :: HAS_CALL_STACK => (C.MonadCatch m, MonadIO m, NFData a) => (SomeException -> m a) -> m a -> m a+handleAnyDeep = flip (withFrozenCallStack catchAnyDeep)  -- | Flipped version of 'catchAsync' --@@ -296,46 +339,46 @@ -- <https://github.com/fpco/safe-exceptions#quickstart> -- -- @since 0.1.0.0-handleAsync :: (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a+handleAsync :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a handleAsync = C.handle  -- | Flipped 'catchJust'. -- -- @since 0.1.4.0-handleJust :: (C.MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a-handleJust f = flip (catchJust f)+handleJust :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a+handleJust f = flip (withFrozenCallStack catchJust f)  -- | Same as upstream 'C.try', but will not catch asynchronous -- exceptions -- -- @since 0.1.0.0-try :: (C.MonadCatch m, E.Exception e) => m a -> m (Either e a)-try f = catch (liftM Right f) (return . Left)+try :: HAS_CALL_STACK => (C.MonadCatch m, E.Exception e) => m a -> m (Either e a)+try f = withFrozenCallStack catch (liftM Right f) (return . Left)  -- | 'C.try' specialized to only catching 'E.IOException's -- -- @since 0.1.3.0-tryIO :: C.MonadCatch m => m a -> m (Either E.IOException a)-tryIO = C.try+tryIO :: HAS_CALL_STACK => C.MonadCatch m => m a -> m (Either E.IOException a)+tryIO = withFrozenCallStack C.try  -- | 'try' specialized to catch all synchronous exceptions -- -- @since 0.1.0.0-tryAny :: C.MonadCatch m => m a -> m (Either SomeException a)-tryAny = try+tryAny :: HAS_CALL_STACK => C.MonadCatch m => m a -> m (Either SomeException a)+tryAny = withFrozenCallStack try  -- | Same as 'try', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.1.0-tryDeep :: (C.MonadCatch m, MonadIO m, E.Exception e, NFData a) => m a -> m (Either e a)-tryDeep f = catch (liftM Right (evaluateDeep f)) (return . Left)+tryDeep :: HAS_CALL_STACK => (C.MonadCatch m, MonadIO m, E.Exception e, NFData a) => m a -> m (Either e a)+tryDeep f = withFrozenCallStack catch (liftM Right (evaluateDeep f)) (return . Left)  -- | 'tryDeep' specialized to catch all synchronous exceptions -- -- @since 0.1.1.0-tryAnyDeep :: (C.MonadCatch m, MonadIO m, NFData a) => m a -> m (Either SomeException a)-tryAnyDeep = tryDeep+tryAnyDeep :: HAS_CALL_STACK => (C.MonadCatch m, MonadIO m, NFData a) => m a -> m (Either SomeException a)+tryAnyDeep = withFrozenCallStack tryDeep  -- | 'try' without async exception safety --@@ -344,110 +387,133 @@ -- <https://github.com/fpco/safe-exceptions#quickstart> -- -- @since 0.1.0.0-tryAsync :: (C.MonadCatch m, E.Exception e) => m a -> m (Either e a)+tryAsync :: HAS_CALL_STACK => (C.MonadCatch m, E.Exception e) => m a -> m (Either e a) tryAsync = C.try  -- | A variant of 'try' that takes an exception predicate to select -- which exceptions are caught. -- -- @since 0.1.4.0-tryJust :: (C.MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)-tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e))+tryJust :: HAS_CALL_STACK => (C.MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)+tryJust f a = withFrozenCallStack catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e))  -- | Async safe version of 'E.onException' -- -- @since 0.1.0.0-onException :: C.MonadMask m => m a -> m b -> m a-onException thing after = withException thing (\(_ :: SomeException) -> after)+onException :: HAS_CALL_STACK => C.MonadMask m => m a -> m b -> m a+onException thing after = withFrozenCallStack withException thing (\(_ :: SomeException) -> after) +-- Note: [withFrozenCallStack impredicativity]+--+-- We do not currently use 'withFrozenCallStack' in 'withException' or the similar+-- 'finally' due to impredicativity. That is, we would like to be consistent+-- with other functions and apply 'withFrozenCallStack' to the _handler only_ i.e.+--+--     withException thing after = withFrozenCallStack C.uninterruptibleMask $ \restore ...+--+-- Alas, that fails due to impredicativity:+--+--     • Couldn't match type: m a -> m a+--                      with: forall a1. m a1 -> m a1+--       Expected: (forall a1. m a1 -> m a1) -> m a+--         Actual: (m a -> m a) -> m a+--+-- Armed with -XImpredicativeTypes, we can define:+--+--     uninterruptibleMaskFrozen :: forall m b. C.MonadMask m => ((forall a. m a -> m a) -> m b) -> m b+--     uninterruptibleMaskFrozen = withFrozenCallStack C.uninterruptibleMask+--+-- and then+--+--     withException thing after = uninterruptibleMaskFrozen $ \restore -> do ...+--+-- But we cannot rely on -XImpredicativeTypes until GHC 9.2 is the oldest+-- supported release, and even then it is worth asking if the benefit+-- (consistency, omit handler from CallStack) is worth the cost (powerful,+-- relatively exotic extension).+ -- | Like 'onException', but provides the handler the thrown -- exception. -- -- @since 0.1.0.0-withException :: (C.MonadMask m, E.Exception e) => m a -> (e -> m b) -> m a+withException :: HAS_CALL_STACK => (C.MonadMask m, E.Exception e) => m a -> (e -> m b) -> m a withException thing after = C.uninterruptibleMask $ \restore -> do-    res1 <- C.try $ restore thing-    case res1 of-        Left e1 -> do-            -- see explanation in bracket-            _ :: Either SomeException b <- C.try $ after e1-            C.throwM e1-        Right x -> return x+    fmap fst $ C.generalBracket (pure ()) cAfter (const $ restore thing)+  where+    -- ignore the exception from after, see bracket for explanation+    cAfter () (C.ExitCaseException se) | Just ex <- fromException se =+        ignoreExceptions $ after ex+    cAfter () _ = pure ()  -- | Async safe version of 'E.bracket' -- -- @since 0.1.0.0-bracket :: forall m a b c. C.MonadMask m+bracket :: forall m a b c. HAS_CALL_STACK => C.MonadMask m         => m a -> (a -> m b) -> (a -> m c) -> m c-bracket before after = bracketWithError before (const after)+bracket before after = withFrozenCallStack bracketWithError before (const after)  -- | Async safe version of 'E.bracket_' -- -- @since 0.1.0.0-bracket_ :: C.MonadMask m => m a -> m b -> m c -> m c-bracket_ before after thing = bracket before (const after) (const thing)+bracket_ :: HAS_CALL_STACK => C.MonadMask m => m a -> m b -> m c -> m c+bracket_ before after thing = withFrozenCallStack bracket before (const after) (const thing) +-- See Note [withFrozenCallStack impredicativity]+ -- | Async safe version of 'E.finally' -- -- @since 0.1.0.0-finally :: C.MonadMask m => m a -> m b -> m a+finally :: HAS_CALL_STACK => C.MonadMask m => m a -> m b -> m a finally thing after = C.uninterruptibleMask $ \restore -> do-    res1 <- C.try $ restore thing-    case res1 of-        Left (e1 :: SomeException) -> do-            -- see bracket for explanation-            _ :: Either SomeException b <- C.try after-            C.throwM e1-        Right x -> do-            _ <- after-            return x+    fmap fst $ C.generalBracket (pure ()) cAfter (const $ restore thing)+  where+    -- ignore the exception from after, see bracket for explanation+    cAfter () (C.ExitCaseException se) =+        ignoreExceptions after+    cAfter () _ = void after  -- | Async safe version of 'E.bracketOnError' -- -- @since 0.1.0.0-bracketOnError :: forall m a b c. C.MonadMask m+bracketOnError :: forall m a b c. HAS_CALL_STACK => C.MonadMask m                => m a -> (a -> m b) -> (a -> m c) -> m c-bracketOnError before after thing = C.mask $ \restore -> do-    x <- before-    res1 <- C.try $ restore (thing x)-    case res1 of-        Left (e1 :: SomeException) -> do-            -- ignore the exception, see bracket for explanation-            _ :: Either SomeException b <--                C.try $ C.uninterruptibleMask_ $ after x-            C.throwM e1-        Right y -> return y+bracketOnError before after thing = fmap fst $ withFrozenCallStack C.generalBracket before cAfter thing+  where+    -- ignore the exception from after, see bracket for explanation+    cAfter x (C.ExitCaseException se) =+        C.uninterruptibleMask_ $ ignoreExceptions $ after x+    cAfter x _ = pure () + -- | A variant of 'bracketOnError' where the return value from the first -- computation is not required. -- -- @since 0.1.0.0-bracketOnError_ :: C.MonadMask m => m a -> m b -> m c -> m c-bracketOnError_ before after thing = bracketOnError before (const after) (const thing)+bracketOnError_ :: HAS_CALL_STACK => C.MonadMask m => m a -> m b -> m c -> m c+bracketOnError_ before after thing = withFrozenCallStack bracketOnError before (const after) (const thing)  -- | Async safe version of 'E.bracket' with access to the exception in the -- cleanup action. -- -- @since 0.1.7.0-bracketWithError :: forall m a b c. C.MonadMask m+bracketWithError :: forall m a b c. HAS_CALL_STACK => C.MonadMask m         => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c-bracketWithError before after thing = C.mask $ \restore -> do-    x <- before-    res1 <- C.try $ restore (thing x)-    case res1 of-        Left (e1 :: SomeException) -> do-            -- explicitly ignore exceptions from after. We know that-            -- no async exceptions were thrown there, so therefore-            -- the stronger exception must come from thing-            ---            -- https://github.com/fpco/safe-exceptions/issues/2-            _ :: Either SomeException b <--                C.try $ C.uninterruptibleMask_ $ after (Just e1) x-            C.throwM e1-        Right y -> do-            _ <- C.uninterruptibleMask_ $ after Nothing x-            return y+bracketWithError before after thing = fmap fst $ withFrozenCallStack C.generalBracket before cAfter thing+  where+    cAfter x (C.ExitCaseException se) =+        C.uninterruptibleMask_ $ ignoreExceptions $ after (Just se) x+    cAfter x _ =+        void $ C.uninterruptibleMask_ $ after Nothing x +-- | Internal function that swallows all exceptions, used in some bracket-like+-- combinators. When it's run inside of uninterruptibleMask, we know that+-- no async exceptions can be thrown from thing, so the other exception from+-- the combinator will not be overridden.+--+-- https://github.com/fpco/safe-exceptions/issues/2+ignoreExceptions :: C.MonadMask m => m a -> m ()+ignoreExceptions thing = void thing `C.catch` (\(_ :: SomeException) -> pure ())+ -- | Wrap up an asynchronous exception to be treated as a synchronous -- exception --@@ -542,15 +608,15 @@ -- exceptions -- -- @since 0.1.2.0-catches :: (C.MonadCatch m, C.MonadThrow m) => m a -> [Handler m a] -> m a-catches io handlers = io `catch` catchesHandler handlers+catches :: HAS_CALL_STACK => (C.MonadCatch m, C.MonadThrow m) => m a -> [Handler m a] -> m a+catches io handlers = withFrozenCallStack catch io (catchesHandler handlers)  -- | Same as 'catches', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.2.0-catchesDeep :: (C.MonadCatch m, C.MonadThrow m, MonadIO m, NFData a) => m a -> [Handler m a] -> m a-catchesDeep io handlers = evaluateDeep io `catch` catchesHandler handlers+catchesDeep :: HAS_CALL_STACK => (C.MonadCatch m, C.MonadThrow m, MonadIO m, NFData a) => m a -> [Handler m a] -> m a+catchesDeep io handlers = withFrozenCallStack catch (evaluateDeep io) (catchesHandler handlers)  -- | 'catches' without async exception safety --@@ -559,10 +625,10 @@ -- <https://github.com/fpco/safe-exceptions#quickstart> -- -- @since 0.1.2.0-catchesAsync :: (C.MonadCatch m, C.MonadThrow m) => m a -> [Handler m a] -> m a+catchesAsync :: HAS_CALL_STACK => (C.MonadCatch m, C.MonadThrow m) => m a -> [Handler m a] -> m a catchesAsync io handlers = io `catchAsync` catchesHandler handlers -catchesHandler :: (C.MonadThrow m) => [Handler m a] -> SomeException -> m a+catchesHandler :: HAS_CALL_STACK => (C.MonadThrow m) => [Handler m a] -> SomeException -> m a catchesHandler handlers e = foldr tryHandler (C.throwM e) handlers     where tryHandler (Handler handler) res               = case fromException e of
test/Control/Exception/SafeSpec.hs view
@@ -8,6 +8,9 @@ import qualified Control.Exception as E import Control.Exception.Safe import Control.Monad (forever)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (runExceptT, throwE)+import Data.IORef (modifyIORef, newIORef, readIORef) import Data.Typeable (Typeable) import Data.Void (Void, absurd) import System.IO.Unsafe (unsafePerformIO)@@ -50,6 +53,13 @@ withAll :: (SomeException -> Bool -> IO ()) -> Spec withAll f = mapM_ (\(e, b) -> it (show e) (f e b)) exceptions +data ResourceAction+  = ResourceAcquire+  | ResourceUse+  | ResourceRelease+  | ExceptionObserve ExceptionPred+  deriving (Show, Eq)+ spec :: Spec spec = do     describe "isSyncException" $ withAll@@ -132,3 +142,50 @@     describe "throwString" $ do       it "is a StringException" $         throwString "foo" `catch` \(StringException _ _) -> return () :: IO ()++    describe "bracketWithError" $ do+      it "should prioritize exceptions from thing" $ do+        actionLogRef <- newIORef []+        eiResult <-+          try $+            Control.Exception.Safe.bracketWithError+              ( do+                  modifyIORef actionLogRef (ResourceAcquire :)+              )+              ( \mbEx () -> do+                  case mbEx of+                      Just ex | Just exPred <- fromException ex ->+                          modifyIORef actionLogRef (ExceptionObserve exPred :)+                      _ -> pure ()+                  modifyIORef actionLogRef (ResourceRelease :)+                  throw $ ExceptionPred $ Just ()+              )+              ( \() -> do+                  modifyIORef actionLogRef (ResourceUse :)+                  throw $ ExceptionPred Nothing+                  pure ()+              )+        eiResult `shouldBe` Left (ExceptionPred Nothing)+        readIORef actionLogRef+          `shouldReturn` [ResourceRelease, ExceptionObserve (ExceptionPred Nothing), ResourceUse, ResourceAcquire]++      it "should lift through ExceptT" $ do+        actionLogRef <- newIORef []+        eiResult <-+          runExceptT $+            Control.Exception.Safe.bracketWithError+              ( do+                  lift $ modifyIORef actionLogRef (ResourceAcquire :)+              )+              ( \_ () -> do+                  lift $ modifyIORef actionLogRef (ResourceRelease :)+              )+              ( \() -> do+                  lift $ modifyIORef actionLogRef (ResourceUse :)+                  throwE $ ExceptionPred Nothing+                  pure ()+              )+        eiResult `shouldBe` Left (ExceptionPred Nothing)+        readIORef actionLogRef+          `shouldReturn` [ResourceRelease, ResourceUse, ResourceAcquire]+