change functions to use generalBracket where appropriate

Author: delfigamer

ChangeLog.md

@@ -1,5 +1,10 @@
 # ChangeLog for safe-exceptions
 
+## 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

safe-exceptions.cabal

@@ -1,5 +1,5 @@
 name:                safe-exceptions
-version:             0.1.7.1
+version:             0.1.7.2
 synopsis:            Safe, consistent, and easy exception handling
 description:         Please see README.md
 homepage:            https://github.com/fpco/safe-exceptions#readme
@@ -18,7 +18,7 @@ library
   exposed-modules:     Control.Exception.Safe
   build-depends:       base >= 4.7 && < 5
                      , deepseq >= 1.2 && < 1.5
-                     , exceptions >= 0.8 && < 0.11
+                     , exceptions >= 0.10 && < 0.11
                      , transformers >= 0.2 && < 0.6
   default-language:    Haskell2010
 
@@ -30,6 +30,7 @@ test-suite safe-exceptions-test
   build-depends:       base
                      , hspec
                      , safe-exceptions
+                     , transformers
                      , void
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010

src/Control/Exception/Safe.hs

@@ -93,7 +93,7 @@ import Control.Exception (Exception (..), SomeException (..), SomeAsyncException
 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)
 
@@ -366,13 +366,12 @@ onException thing after = withException thing (\(_ :: SomeException) -> after)
 -- @since 0.1.0.0
 withException :: (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'
 --
@@ -392,31 +391,25 @@ bracket_ before after thing = bracket before (const after) (const thing)
 -- @since 0.1.0.0
 finally :: 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
                => 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 $ 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.
@@ -431,22 +424,21 @@ bracketOnError_ before after thing = bracketOnError before (const after) (const
 -- @since 0.1.7.0
 bracketWithError :: forall m a b c. 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 $ 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

stack.yaml

@@ -1,3 +1,3 @@
 resolver: lts-10.5
-#extra-deps:
-#- exceptions-0.9.0
+extra-deps:
+- exceptions-0.10.0

test/Control/Exception/SafeSpec.hs

@@ -8,6 +8,9 @@ import Control.Exception (ArithException (..), AsyncException (..), BlockedIndef
 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 @@ exceptions =
 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 @@ spec = do
     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]
+