diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -61,8 +61,8 @@ # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} - compiler: "ghc-8.4.1" - env: GHCHEAD=true - addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}} - compiler: "ghc-head" env: GHCHEAD=true addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} @@ -70,7 +70,6 @@ allow_failures: - compiler: "ghc-7.0.4" - compiler: "ghc-7.2.2" - - compiler: "ghc-8.4.1" - compiler: "ghc-head" before_install: diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,15 @@ +0.10.0 +------ +* Fix a regression in 0.9.0 whereby the non-IO effects in `bracket`'s `use` + action were not visible to the `release` action, and the non-IO effects in the + `release` action were not visible after the `bracket` call. +* The type of `generalBracket` was changed in order to restore those non-IO + effects, so if you are a library author that provides a `MonadMask` instance, + you will need to update your implementation of this method. +* Add `MonadMask` instance for `MaybeT` +* Add `onError` function whose action also runs on errors which are not + exceptions, such as a `Nothing` or a `Left`. + 0.9.0 ----- * Add `generalBracket` to the `MonadMask` typeclass, allowing more diff --git a/exceptions.cabal b/exceptions.cabal --- a/exceptions.cabal +++ b/exceptions.cabal @@ -1,6 +1,6 @@ name: exceptions category: Control, Exceptions, Monad -version: 0.9.0 +version: 0.10.0 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs --- a/src/Control/Monad/Catch.hs +++ b/src/Control/Monad/Catch.hs @@ -48,6 +48,7 @@ MonadThrow(..) , MonadCatch(..) , MonadMask(..) + , ExitCase(..) -- * Utilities -- $utilities @@ -66,6 +67,7 @@ , try , tryJust , onException + , onError , bracket , bracket_ , finally @@ -105,6 +107,10 @@ import Data.Monoid #endif +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif + ------------------------------------------------------------------------------ -- $mtl -- The mtl style typeclass @@ -153,17 +159,36 @@ -- asynchronous exceptions. Continuation-based monads are invalid -- instances of this class. -- --- Note that this package /does/ provide a @MonadMask@ instance for @CatchT@. --- This instance is /only/ valid if the base monad provides no ability to --- provide multiple exit. For example, @IO@ or @Either@ would be invalid base --- monads, but @Reader@ or @State@ would be acceptable. --- -- Instances should ensure that, in the following code: -- --- > f `finally` g +-- > fg = f `finally` g -- -- The action @g@ is called regardless of what occurs within @f@, including --- async exceptions. +-- async exceptions. Some monads allow @f@ to abort the computation via other +-- effects than throwing an exception. For simplicity, we will consider aborting +-- and throwing an exception to be two forms of "throwing an error". +-- +-- If @f@ and @g@ both throw an error, the error thrown by @fg@ depends on which +-- errors we're talking about. In a monad transformer stack, the deeper layers +-- override the effects of the inner layers; for example, @ExceptT e1 (Except +-- e2) a@ represents a value of type @Either e2 (Either e1 a)@, so throwing both +-- an @e1@ and an @e2@ will result in @Left e2@. If @f@ and @g@ both throw an +-- error from the same layer, instances should ensure that the error from @g@ +-- wins. +-- +-- Effects other than throwing an error are also overriden by the deeper layers. +-- For example, @StateT s Maybe a@ represents a value of type @s -> Maybe (a, +-- s)@, so if an error thrown from @f@ causes this function to return @Nothing@, +-- any changes to the state which @f@ also performed will be erased. As a +-- result, @g@ will see the state as it was before @f@. Once @g@ completes, +-- @f@'s error will be rethrown, so @g@' state changes will be erased as well. +-- This is the normal interaction between effects in a monad transformer stack. +-- +-- By contrast, 's +-- version of 'finally' always discards all of @g@'s non-IO effects, and @g@ +-- never sees any of @f@'s non-IO effects, regardless of the layer ordering and +-- regardless of whether @f@ throws an error. This is not the result of +-- interacting effects, but a consequence of @MonadBaseControl@'s approach. class MonadCatch m => MonadMask m where -- | Runs an action with asynchronous exceptions disabled. The action is -- provided a method for restoring the async. environment to what it was @@ -178,15 +203,17 @@ -- and/or unkillable. uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b - -- | A generalized version of the standard bracket function which allows - -- distinguishing different exit cases. Instead of providing it a single - -- release action, this function takes two different actions: one for the - -- case of a successful run of the inner function, and one in the case of an - -- exception. The former function is provided the acquired value, while - -- the exception release function is provided both the acquired value and - -- the exception that was thrown. The result values of both of these - -- functions are ignored. + -- | A generalized version of 'bracket' which uses 'ExitCase' to distinguish + -- the different exit cases, and returns the values of both the 'use' and + -- 'release' actions. In practice, this extra information is rarely needed, + -- so it is often more convenient to use one of the simpler functions which + -- are defined in terms of this one, such as 'bracket', 'finally', 'onError', + -- and 'bracketOnError'. -- + -- This function exists because in order to thread their effects through the + -- execution of 'bracket', monad transformers need values to be threaded from + -- 'use' to 'release' and from 'release' to the output value. + -- -- /NOTE/ This method was added in version 0.9.0 of this -- library. Previously, implementation of functions like 'bracket' -- and 'finally' in this module were based on the 'mask' and @@ -194,62 +221,98 @@ -- tranformers from having @MonadMask@ instances (notably -- multi-exit-point transformers like 'ExceptT'). If you are a -- library author, you'll now need to provide an implementation for - -- this method. As two examples, here is a @ReaderT@ implementation: + -- this method. The @StateT@ implementation demonstrates most of the + -- subtleties: -- -- @ - -- generalBracket acquire release cleanup use = ReaderT $ \r -> - -- generalBracket - -- (runReaderT acquire r) - -- (\resource -> runReaderT (release resource) r) - -- (\resource e -> runReaderT (cleanup resource e) r) - -- (\resource -> runReaderT (use resource) r) + -- generalBracket acquire release use = StateT $ \s0 -> do + -- ((b, _s2), (c, s3)) <- generalBracket + -- (runStateT acquire s0) + -- (\(resource, s1) exitCase -> case exitCase of + -- ExitCaseSuccess (b, s2) -> runStateT (release resource (ExitCaseSuccess b)) s2 + -- + -- -- In the two other cases, the base monad overrides @use@'s state + -- -- changes and the state reverts to @s1@. + -- ExitCaseException e -> runStateT (release resource (ExitCaseException e)) s1 + -- ExitCaseAbort -> runStateT (release resource ExitCaseAbort) s1 + -- ) + -- (\(resource, s1) -> runStateT (use resource) s1) + -- return ((b, c), s3) -- @ -- - -- This implementation reuses the base monad's @generalBracket@, and - -- simply uses the @ReaderT@ environment to run the relevant - -- @acquire@, @release@, @cleanup@ (for exceptions), and @use@ - -- actions. A more complicated example is the implementation for - -- @ExceptT@, which must implement @ExceptT@'s short-circuit logic - -- itself: + -- The @StateT s m@ implementation of @generalBracket@ delegates to the @m@ + -- implementation of @generalBracket@. The @acquire@, @use@, and @release@ + -- arguments given to @StateT@'s implementation produce actions of type + -- @StateT s m a@, @StateT s m b@, and @StateT s m c@. In order to run those + -- actions in the base monad, we need to call @runStateT@, from which we + -- obtain actions of type @m (a, s)@, @m (b, s)@, and @m (c, s)@. Since each + -- action produces the next state, it is important to feed the state produced + -- by the previous action to the next action. -- + -- In the 'ExitCaseSuccess' case, the state starts at @s0@, flows through + -- @acquire@ to become @s1@, flows through @use@ to become @s2@, and finally + -- flows through @release@ to become @s3@. In the other two cases, @release@ + -- does not receive the value @s2@, so its action cannot see the state changes + -- performed by @use@. This is fine, because in those two cases, an error was + -- thrown in the base monad, so as per the usual interaction between effects + -- in a monad transformer stack, those state changes get reverted. So we start + -- from @s1@ instead. + -- + -- Finally, the @m@ implementation of @generalBracket@ returns the pairs + -- @(b, s)@ and @(c, s)@. For monad transformers other than @StateT@, this + -- will be some other type representing the effects and values performed and + -- returned by the @use@ and @release@ actions. The effect part of the @use@ + -- result, in this case @_s2@, usually needs to be discarded, since those + -- effects have already been incorporated in the @release@ action. + -- + -- The only effect which is intentionally not incorporated in the @release@ + -- action is the effect of throwing an error. In that case, the error must be + -- re-thrown. One subtlety which is easy to miss is that in the case in which + -- @use@ and @release@ both throw an error, the error from @release@ should + -- take priority. Here is an implementation for @ExceptT@ which demonstrates + -- how to do this. + -- -- @ - -- generalBracket acquire release cleanup use = ExceptT $ - -- generalBracket + -- generalBracket acquire release use = ExceptT $ do + -- (eb, ec) <- generalBracket -- (runExceptT acquire) - -- (\eresource -> - -- case eresource of - -- Left _ -> return () - -- Right resource -> runExceptT (release resource) >> return ()) - -- (\eresource e -> - -- case eresource of - -- Left _ -> return () - -- Right resource -> runExceptT (cleanup resource e) >> return ()) + -- (\eresource exitCase -> case eresource of + -- Left e -> return (Left e) -- nothing to release, acquire didn't succeed + -- Right resource -> case exitCase of + -- ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b)) + -- ExitCaseException e -> runExceptT (release resource (ExitCaseException e)) + -- _ -> runExceptT (release resource ExitCaseAbort)) -- (either (return . Left) (runExceptT . use)) + -- return $ do + -- -- The order in which we perform those two 'Either' effects determines + -- -- which error will win if they are both 'Left's. We want the error from + -- -- 'release' to win. + -- c <- ec + -- b <- eb + -- return (b, c) -- @ -- - -- In this implementation, we need to deal with the potential that - -- the @acquire@ action returned a @Left@ (as opposed to succeeding - -- with a @Right@ or throwing an exception via @throwM@), and - -- therefore have to handle the @Left@ case explicitly when provide - -- @release@, @cleanup@, and @use@ actions to the base monad's - -- implementation of @generalBracket@. - -- - -- You should ensure that in all cases of the @acquire@ action - -- completing successfully, either the @release@ or @cleanup@ - -- actions are called, regardless of what occurs in @use@. - -- -- @since 0.9.0 generalBracket :: m a -- ^ acquire some resource - -> (a -> m ignored1) - -- ^ release, no exception thrown - -> (a -> SomeException -> m ignored2) - -- ^ release, some exception thrown; the exception will be rethrown + -> (a -> ExitCase b -> m c) + -- ^ release the resource, observing the outcome of the inner action -> (a -> m b) -- ^ inner action to perform with the resource - -> m b + -> m (b, c) +-- | A 'MonadMask' computation may either succeed with a value, abort with an +-- exception, or abort for some other reason. For example, in @ExceptT e IO@ +-- you can use 'throwM' to abort with an exception ('ExitCaseException') or +-- 'Control.Monad.Trans.Except.throwE' to abort with a value of type 'e' +-- ('ExitCaseAbort'). +data ExitCase a + = ExitCaseSuccess a + | ExitCaseException SomeException + | ExitCaseAbort + deriving Show + instance MonadThrow [] where throwM _ = [] instance MonadThrow Maybe where @@ -264,13 +327,13 @@ instance MonadMask IO where mask = ControlException.mask uninterruptibleMask = ControlException.uninterruptibleMask - generalBracket acquire release cleanup use = mask $ \unmasked -> do + generalBracket acquire release use = mask $ \unmasked -> do resource <- acquire - result <- unmasked (use resource) `catch` \e -> do - _ <- cleanup resource e + b <- unmasked (use resource) `catch` \e -> do + _ <- release resource (ExitCaseException e) throwM e - _ <- release resource - return result + c <- release resource (ExitCaseSuccess b) + return (b, c) instance MonadThrow STM where throwM = STM.throwSTM @@ -291,15 +354,15 @@ mask f = f id uninterruptibleMask f = f id - generalBracket acquire release cleanup use = + generalBracket acquire release use = case acquire of Left e -> Left e Right resource -> case use resource of - Left e -> cleanup resource e >> Left e - Right result -> do - _ <- release resource - return result + Left e -> release resource (ExitCaseException e) >> Left e + Right b -> do + c <- release resource (ExitCaseSuccess b) + return (b, c) instance MonadThrow m => MonadThrow (IdentityT m) where throwM e = lift $ throwM e @@ -314,11 +377,10 @@ where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a q u = IdentityT . u . runIdentityT - generalBracket acquire release cleanup use = IdentityT $ + generalBracket acquire release use = IdentityT $ generalBracket (runIdentityT acquire) - (runIdentityT . release) - (\resource e -> runIdentityT (cleanup resource e)) + (\resource exitCase -> runIdentityT (release resource exitCase)) (\resource -> runIdentityT (use resource)) instance MonadThrow m => MonadThrow (LazyS.StateT s m) where @@ -334,17 +396,20 @@ where q :: (m (a, s) -> m (a, s)) -> LazyS.StateT s m a -> LazyS.StateT s m a q u (LazyS.StateT b) = LazyS.StateT (u . b) - generalBracket acquire release cleanup use = LazyS.StateT $ \s0 -> - generalBracket + generalBracket acquire release use = LazyS.StateT $ \s0 -> do + -- This implementation is given as an example in the documentation of + -- 'generalBracket', so when changing it, remember to update the + -- documentation's copy as well + ((b, _s2), (c, s3)) <- generalBracket (LazyS.runStateT acquire s0) - - -- Note that we're reverting to s1 here, the state after the - -- acquire step, and _not_ getting the state from the successful - -- run of the inner action. This is because we may be on top of - -- something like ExceptT, where no updated state is available. - (\(resource, s1) -> LazyS.runStateT (release resource) s1) - (\(resource, s1) e -> LazyS.runStateT (cleanup resource e) s1) + (\(resource, s1) exitCase -> case exitCase of + ExitCaseSuccess (b, s2) -> LazyS.runStateT (release resource (ExitCaseSuccess b)) s2 + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @s1@. + ExitCaseException e -> LazyS.runStateT (release resource (ExitCaseException e)) s1 + ExitCaseAbort -> LazyS.runStateT (release resource ExitCaseAbort) s1) (\(resource, s1) -> LazyS.runStateT (use resource) s1) + return ((b, c), s3) instance MonadThrow m => MonadThrow (StrictS.StateT s m) where throwM e = lift $ throwM e @@ -359,12 +424,17 @@ where q :: (m (a, s) -> m (a, s)) -> StrictS.StateT s m a -> StrictS.StateT s m a q u (StrictS.StateT b) = StrictS.StateT (u . b) - generalBracket acquire release cleanup use = StrictS.StateT $ \s0 -> - generalBracket + generalBracket acquire release use = StrictS.StateT $ \s0 -> do + ((b, _s2), (c, s3)) <- generalBracket (StrictS.runStateT acquire s0) - (\(resource, s1) -> StrictS.runStateT (release resource) s1) - (\(resource, s1) e -> StrictS.runStateT (cleanup resource e) s1) + (\(resource, s1) exitCase -> case exitCase of + ExitCaseSuccess (b, s2) -> StrictS.runStateT (release resource (ExitCaseSuccess b)) s2 + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @s1@. + ExitCaseException e -> StrictS.runStateT (release resource (ExitCaseException e)) s1 + ExitCaseAbort -> StrictS.runStateT (release resource ExitCaseAbort) s1) (\(resource, s1) -> StrictS.runStateT (use resource) s1) + return ((b, c), s3) instance MonadThrow m => MonadThrow (ReaderT r m) where throwM e = lift $ throwM e @@ -379,11 +449,10 @@ where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a q u (ReaderT b) = ReaderT (u . b) - generalBracket acquire release cleanup use = ReaderT $ \r -> + generalBracket acquire release use = ReaderT $ \r -> generalBracket (runReaderT acquire r) - (\resource -> runReaderT (release resource) r) - (\resource e -> runReaderT (cleanup resource e) r) + (\resource exitCase -> runReaderT (release resource exitCase) r) (\resource -> runReaderT (use resource) r) instance (MonadThrow m, Monoid w) => MonadThrow (StrictW.WriterT w m) where @@ -399,18 +468,25 @@ where q :: (m (a, w) -> m (a, w)) -> StrictW.WriterT w m a -> StrictW.WriterT w m a q u b = StrictW.WriterT $ u (StrictW.runWriterT b) - generalBracket acquire release cleanup use = StrictW.WriterT $ - generalBracket + generalBracket acquire release use = StrictW.WriterT $ do + ((b, _w12), (c, w123)) <- generalBracket (StrictW.runWriterT acquire) - -- NOTE: The updated writer values here are actually going to be - -- lost, as the return value of this cleanup is discarded - (StrictW.runWriterT . release . fst) - (\(resource, w1) e -> do - (a, w2) <- StrictW.runWriterT (cleanup resource e) - return (a, mappend w1 w2)) + (\(resource, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, w12) -> do + (c, w3) <- StrictW.runWriterT (release resource (ExitCaseSuccess b)) + return (c, mappend w12 w3) + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @w1@. + ExitCaseException e -> do + (c, w3) <- StrictW.runWriterT (release resource (ExitCaseException e)) + return (c, mappend w1 w3) + ExitCaseAbort -> do + (c, w3) <- StrictW.runWriterT (release resource ExitCaseAbort) + return (c, mappend w1 w3)) (\(resource, w1) -> do (a, w2) <- StrictW.runWriterT (use resource) return (a, mappend w1 w2)) + return ((b, c), w123) instance (MonadThrow m, Monoid w) => MonadThrow (LazyW.WriterT w m) where throwM e = lift $ throwM e @@ -425,16 +501,25 @@ where q :: (m (a, w) -> m (a, w)) -> LazyW.WriterT w m a -> LazyW.WriterT w m a q u b = LazyW.WriterT $ u (LazyW.runWriterT b) - generalBracket acquire release cleanup use = LazyW.WriterT $ - generalBracket + generalBracket acquire release use = LazyW.WriterT $ do + ((b, _w12), (c, w123)) <- generalBracket (LazyW.runWriterT acquire) - (LazyW.runWriterT . release . fst) - (\(resource, w1) e -> do - (a, w2) <- LazyW.runWriterT (cleanup resource e) - return (a, mappend w1 w2)) + (\(resource, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, w12) -> do + (c, w3) <- LazyW.runWriterT (release resource (ExitCaseSuccess b)) + return (c, mappend w12 w3) + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @w1@. + ExitCaseException e -> do + (c, w3) <- LazyW.runWriterT (release resource (ExitCaseException e)) + return (c, mappend w1 w3) + ExitCaseAbort -> do + (c, w3) <- LazyW.runWriterT (release resource ExitCaseAbort) + return (c, mappend w1 w3)) (\(resource, w1) -> do (a, w2) <- LazyW.runWriterT (use resource) return (a, mappend w1 w2)) + return ((b, c), w123) instance (MonadThrow m, Monoid w) => MonadThrow (LazyRWS.RWST r w s m) where throwM e = lift $ throwM e @@ -449,17 +534,25 @@ where q :: (m (a, s, w) -> m (a, s, w)) -> LazyRWS.RWST r w s m a -> LazyRWS.RWST r w s m a q u (LazyRWS.RWST b) = LazyRWS.RWST $ \ r s -> u (b r s) - generalBracket acquire release cleanup use = LazyRWS.RWST $ \r s0 -> - generalBracket + generalBracket acquire release use = LazyRWS.RWST $ \r s0 -> do + ((b, _s2, _w12), (c, s3, w123)) <- generalBracket (LazyRWS.runRWST acquire r s0) - -- All comments from StateT and WriterT apply here too - (\(resource, s1, _) -> LazyRWS.runRWST (release resource) r s1) - (\(resource, s1, w1) e -> do - (a, s2, w2) <- LazyRWS.runRWST (cleanup resource e) r s1 - return (a, s2, mappend w1 w2)) + (\(resource, s1, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, s2, w12) -> do + (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseSuccess b)) r s2 + return (c, s3, mappend w12 w3) + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @s1@ and @w1@. + ExitCaseException e -> do + (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseException e)) r s1 + return (c, s3, mappend w1 w3) + ExitCaseAbort -> do + (c, s3, w3) <- LazyRWS.runRWST (release resource ExitCaseAbort) r s1 + return (c, s3, mappend w1 w3)) (\(resource, s1, w1) -> do (a, s2, w2) <- LazyRWS.runRWST (use resource) r s1 return (a, s2, mappend w1 w2)) + return ((b, c), s3, w123) instance (MonadThrow m, Monoid w) => MonadThrow (StrictRWS.RWST r w s m) where throwM e = lift $ throwM e @@ -474,16 +567,25 @@ where q :: (m (a, s, w) -> m (a, s, w)) -> StrictRWS.RWST r w s m a -> StrictRWS.RWST r w s m a q u (StrictRWS.RWST b) = StrictRWS.RWST $ \ r s -> u (b r s) - generalBracket acquire release cleanup use = StrictRWS.RWST $ \r s0 -> - generalBracket + generalBracket acquire release use = StrictRWS.RWST $ \r s0 -> do + ((b, _s2, _w12), (c, s3, w123)) <- generalBracket (StrictRWS.runRWST acquire r s0) - (\(resource, s1, _) -> StrictRWS.runRWST (release resource) r s1) - (\(resource, s1, w1) e -> do - (a, s2, w2) <- StrictRWS.runRWST (cleanup resource e) r s1 - return (a, s2, mappend w1 w2)) + (\(resource, s1, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, s2, w12) -> do + (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseSuccess b)) r s2 + return (c, s3, mappend w12 w3) + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @s1@ and @w1@. + ExitCaseException e -> do + (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseException e)) r s1 + return (c, s3, mappend w1 w3) + ExitCaseAbort -> do + (c, s3, w3) <- StrictRWS.runRWST (release resource ExitCaseAbort) r s1 + return (c, s3, mappend w1 w3)) (\(resource, s1, w1) -> do (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1 return (a, s2, mappend w1 w2)) + return ((b, c), s3, w123) -- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask instance MonadThrow m => MonadThrow (ListT m) where @@ -497,7 +599,35 @@ -- | Catches exceptions from the base monad. instance MonadCatch m => MonadCatch (MaybeT m) where catch (MaybeT m) f = MaybeT $ catch m (runMaybeT . f) +-- | @since 0.10.0 +instance MonadMask m => MonadMask (MaybeT m) where + mask f = MaybeT $ mask $ \u -> runMaybeT $ f (q u) + where + q :: (m (Maybe a) -> m (Maybe a)) + -> MaybeT m a -> MaybeT m a + q u (MaybeT b) = MaybeT (u b) + uninterruptibleMask f = MaybeT $ uninterruptibleMask $ \u -> runMaybeT $ f (q u) + where + q :: (m (Maybe a) -> m (Maybe a)) + -> MaybeT m a -> MaybeT m a + q u (MaybeT b) = MaybeT (u b) + generalBracket acquire release use = MaybeT $ do + (eb, ec) <- generalBracket + (runMaybeT acquire) + (\resourceMay exitCase -> case resourceMay of + Nothing -> return Nothing -- nothing to release, acquire didn't succeed + Just resource -> case exitCase of + ExitCaseSuccess (Just b) -> runMaybeT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runMaybeT (release resource (ExitCaseException e)) + _ -> runMaybeT (release resource ExitCaseAbort)) + (\resourceMay -> case resourceMay of + Nothing -> return Nothing + Just resource -> runMaybeT (use resource)) + -- The order in which we perform those two 'Maybe' effects doesn't matter, + -- since the error message is the same regardless. + return ((,) <$> eb <*> ec) + -- | Throws exceptions into the base monad. instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where throwM = lift . throwM @@ -516,18 +646,23 @@ -> ErrorT e m a -> ErrorT e m a q u (ErrorT b) = ErrorT (u b) - generalBracket acquire release cleanup use = ErrorT $ - generalBracket + generalBracket acquire release use = ErrorT $ do + (eb, ec) <- generalBracket (runErrorT acquire) - (\eresource -> - case eresource of - Left _ -> return () -- nothing to release, it didn't succeed - Right resource -> runErrorT (release resource) >> return ()) - (\eresource e -> - case eresource of - Left _ -> return () - Right resource -> runErrorT (cleanup resource e) >> return ()) + (\eresource exitCase -> case eresource of + Left e -> return (Left e) -- nothing to release, acquire didn't succeed + Right resource -> case exitCase of + ExitCaseSuccess (Right b) -> runErrorT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runErrorT (release resource (ExitCaseException e)) + _ -> runErrorT (release resource ExitCaseAbort)) (either (return . Left) (runErrorT . use)) + return $ do + -- The order in which we perform those two 'Either' effects determines + -- which error will win if they are both 'Left's. We want the error from + -- 'release' to win. + c <- ec + b <- eb + return (b, c) -- | Throws exceptions into the base monad. instance MonadThrow m => MonadThrow (ExceptT e m) where @@ -535,6 +670,7 @@ -- | Catches exceptions from the base monad. instance MonadCatch m => MonadCatch (ExceptT e m) where catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f) +-- | @since 0.9.0 instance MonadMask m => MonadMask (ExceptT e m) where mask f = ExceptT $ mask $ \u -> runExceptT $ f (q u) where @@ -547,18 +683,26 @@ -> ExceptT e m a -> ExceptT e m a q u (ExceptT b) = ExceptT (u b) - generalBracket acquire release cleanup use = ExceptT $ - generalBracket + generalBracket acquire release use = ExceptT $ do + -- This implementation is given as an example in the documentation of + -- 'generalBracket', so when changing it, remember to update the + -- documentation's copy as well + (eb, ec) <- generalBracket (runExceptT acquire) - (\eresource -> - case eresource of - Left _ -> return () - Right resource -> runExceptT (release resource) >> return ()) - (\eresource e -> - case eresource of - Left _ -> return () - Right resource -> runExceptT (cleanup resource e) >> return ()) + (\eresource exitCase -> case eresource of + Left e -> return (Left e) -- nothing to release, acquire didn't succeed + Right resource -> case exitCase of + ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runExceptT (release resource (ExitCaseException e)) + _ -> runExceptT (release resource ExitCaseAbort)) (either (return . Left) (runExceptT . use)) + return $ do + -- The order in which we perform those two 'Either' effects determines + -- which error will win if they are both 'Left's. We want the error from + -- 'release' to win. + c <- ec + b <- eb + return (b, c) instance MonadThrow m => MonadThrow (ContT r m) where throwM = lift . throwM @@ -583,6 +727,9 @@ -- | Catches all exceptions, and somewhat defeats the purpose of the extensible -- exception system. Use sparingly. +-- +-- /NOTE/ This catches all /exceptions/, but if the monad supports other ways of +-- aborting the computation, those other kinds of errors will not be caught. catchAll :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchAll = catch @@ -653,44 +800,62 @@ -- | Run an action only if an exception is thrown in the main action. The -- exception is not caught, simply rethrown. +-- +-- /NOTE/ The action is only run if an /exception/ is thrown. If the monad +-- supports other ways of aborting the computation, the action won't run if +-- those other kinds of errors are thrown. See 'onError'. onException :: MonadCatch m => m a -> m b -> m a onException action handler = action `catchAll` \e -> handler >> throwM e +-- | Run an action only if an error is thrown in the main action. Unlike +-- 'onException', this works with every kind of error, not just exceptions. For +-- example, if @f@ is an 'ExceptT' computation which aborts with a 'Left', the +-- computation @onError f g@ will execute @g@, while @onException f g@ will not. +-- +-- This distinction is only meaningful for monads which have multiple exit +-- points, such as 'Except' and 'MaybeT'. For monads that only have a single +-- exit point, there is no difference between 'onException' and 'onError', +-- except that 'onError' has a more constrained type. +-- +-- @since 0.10.0 +onError :: MonadMask m => m a -> m b -> m a +onError action handler = bracketOnError (return ()) (const handler) (const action) + -- | Generalized abstracted pattern of safe resource acquisition and release --- in the face of exceptions. The first action \"acquires\" some value, which +-- in the face of errors. The first action \"acquires\" some value, which -- is \"released\" by the second action at the end. The third action \"uses\" -- the value and its result is the result of the 'bracket'. -- --- If an exception occurs during the use, the release still happens before the --- exception is rethrown. +-- If an error is thrown during the use, the release still happens before the +-- error is rethrown. -- -- Note that this is essentially a type-specialized version of -- 'generalBracket'. This function has a more common signature (matching the -- signature from "Control.Exception"), and is often more convenient to use. By -- contrast, 'generalBracket' is more expressive, allowing us to implement -- other functions like 'bracketOnError'. -bracket :: MonadMask m => m a -> (a -> m b) -> (a -> m c) -> m c -bracket acquire release use = generalBracket +bracket :: MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b +bracket acquire release = liftM fst . generalBracket acquire - release - (\a _e -> release a) - use + (\a _exitCase -> release a) -- | Version of 'bracket' without any value being passed to the second and -- third actions. -bracket_ :: MonadMask m => m a -> m b -> m c -> m c +bracket_ :: MonadMask m => m a -> m c -> m b -> m b bracket_ before after action = bracket before (const after) (const action) -- | Perform an action with a finalizer action that is run, even if an --- exception occurs. +-- error occurs. finally :: MonadMask m => m a -> m b -> m a finally action finalizer = bracket_ (return ()) finalizer action --- | Like 'bracket', but only performs the final action if there was an --- exception raised by the in-between computation. -bracketOnError :: MonadMask m => m a -> (a -> m b) -> (a -> m c) -> m c -bracketOnError acquire release use = generalBracket +-- | Like 'bracket', but only performs the final action if an error is +-- thrown by the in-between computation. +bracketOnError :: MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b +bracketOnError acquire release = liftM fst . generalBracket acquire - (\_ -> return ()) - (\a _e -> release a) - use + (\a exitCase -> case exitCase of + ExitCaseSuccess _ -> return () + _ -> do + _ <- release a + return ()) diff --git a/src/Control/Monad/Catch/Pure.hs b/src/Control/Monad/Catch/Pure.hs --- a/src/Control/Monad/Catch/Pure.hs +++ b/src/Control/Monad/Catch/Pure.hs @@ -156,22 +156,25 @@ Right a -> return (Right a) -- | Note: This instance is only valid if the underlying monad has a single -- exit point! +-- +-- For example, @IO@ or @Either@ would be invalid base monads, but +-- @Reader@ or @State@ would be acceptable. instance Monad m => MonadMask (CatchT m) where mask a = a id uninterruptibleMask a = a id - generalBracket acquire release cleanup use = CatchT $ do + generalBracket acquire release use = CatchT $ do eresource <- runCatchT acquire case eresource of Left e -> return $ Left e Right resource -> do - eresult <- runCatchT (use resource) - case eresult of - Left e -> do - _ <- runCatchT (cleanup resource e) - return $ Left e - Right result -> do - _ <- runCatchT (release resource) - return $ Right result + eb <- runCatchT (use resource) + case eb of + Left e -> runCatchT $ do + _ <- release resource (ExitCaseException e) + throwM e + Right b -> runCatchT $ do + c <- release resource (ExitCaseSuccess b) + return (b, c) instance MonadState s m => MonadState s (CatchT m) where get = lift get diff --git a/tests/Control/Monad/Catch/Tests.hs b/tests/Control/Monad/Catch/Tests.hs --- a/tests/Control/Monad/Catch/Tests.hs +++ b/tests/Control/Monad/Catch/Tests.hs @@ -45,20 +45,30 @@ instance Exception TestException -data MSpec = forall m. (MonadCatch m) => MSpec +data MSpec m = MSpec { mspecName :: String , mspecRunner :: (m Property -> Property) } -testMonadCatch :: MSpec -> Property -testMonadCatch MSpec { mspecRunner } = monadic mspecRunner $ +-- the @m Bool@ determines whether the @m ()@ has executed +data DetectableEffect m = DetectableEffect + { detectableEffectMSpec :: MSpec m + , detectableEffectEffectDetector :: m (m (), m Bool) + } + +data SomeMSpec = forall m. (MonadCatch m) => SomeMSpec (MSpec m) + +data SomeDetectableEffect = forall m. (MonadMask m) => SomeDetectableEffect (DetectableEffect m) + +testMonadCatch :: SomeMSpec -> Property +testMonadCatch (SomeMSpec MSpec { mspecRunner }) = monadic mspecRunner $ run $ catch failure handler where failure = throwM (TestException "foo") >> error "testMonadCatch" handler (_ :: TestException) = return () -testCatchJust :: MSpec -> Property -testCatchJust MSpec { mspecRunner } = monadic mspecRunner $ do +testCatchJust :: SomeMSpec -> Property +testCatchJust (SomeMSpec MSpec { mspecRunner }) = monadic mspecRunner $ do nice <- run $ catchJust testException posFailure posHandler assert $ nice == ("pos", True) bad <- run $ catch (catchJust testException negFailure posHandler) negHandler @@ -70,48 +80,153 @@ posFailure = throwM (TestException "pos") >> error "testCatchJust pos" negFailure = throwM (TestException "neg") >> error "testCatchJust neg" +testDetectableEffect :: SomeDetectableEffect -> Property +testDetectableEffect (SomeDetectableEffect (DetectableEffect mspec effectDetector)) = do + monadic (mspecRunner mspec) $ do + effectWasPerformed <- run $ do + (effect, detector) <- effectDetector + runExceptT $ ExceptT (return $ Left ()) `finally` lift effect + detector + assert effectWasPerformed + tests :: Test tests = testGroup "Control.Monad.Catch.Tests" $ ([ mkMonadCatch , mkCatchJust ] <*> mspecs) ++ + ([ mkDetectableEffect + ] <*> detectableEffects) ++ [ testCase "ExceptT+Left" exceptTLeft + , testCase "release error wins" releaseErrorWins ] where mspecs = - [ MSpec "IO" io - , MSpec "IdentityT IO" $ io . runIdentityT - , MSpec "LazyState.StateT IO" $ io . flip LazyState.evalStateT () - , MSpec "StrictState.StateT IO" $ io . flip StrictState.evalStateT () - , MSpec "ReaderT IO" $ io . flip runReaderT () - , MSpec "LazyWriter.WriterT IO" $ io . fmap tfst . LazyWriter.runWriterT - , MSpec "StrictWriter.WriterT IO" $ io . fmap tfst . StrictWriter.runWriterT - , MSpec "LazyRWS.RWST IO" $ \m -> io $ fmap tfst $ LazyRWS.evalRWST m () () - , MSpec "StrictRWS.RWST IO" $ \m -> io $ fmap tfst $ StrictRWS.evalRWST m () () + [ SomeMSpec mspecIO + , SomeMSpec mspecIdentityTIO + , SomeMSpec mspecLazyStateTIO + , SomeMSpec mspecStrictStateTIO + , SomeMSpec mspecReaderTIO + , SomeMSpec mspecLazyWriterTIO + , SomeMSpec mspecStrictWriterTIO + , SomeMSpec mspecLazyRWSTIO + , SomeMSpec mspecStrictRWSTIO - , MSpec "ListT IO" $ \m -> io $ fmap (\[x] -> x) (runListT m) - , MSpec "MaybeT IO" $ \m -> io $ fmap (maybe undefined id) (runMaybeT m) - , MSpec "ErrorT IO" $ \m -> io $ fmap (either error id) (runErrorT m) - , MSpec "STM" $ io . atomically - --, MSpec "ContT IO" $ \m -> io $ runContT m return + , SomeMSpec mspecListTIO + , SomeMSpec mspecMaybeTIO + , SomeMSpec mspecErrorTIO + , SomeMSpec mspecSTM + --, SomeMSpec mspecContTIO - , MSpec "CatchT Identity" $ fromRight . runCatch - , MSpec "Either SomeException" fromRight + , SomeMSpec mspecCatchTIdentity + , SomeMSpec mspecEitherSomeException ] + mspecIO :: MSpec IO + mspecIO = MSpec "IO" io + + mspecIdentityTIO :: MSpec (IdentityT IO) + mspecIdentityTIO = MSpec "IdentityT IO" $ io . runIdentityT + + mspecLazyStateTIO :: MSpec (LazyState.StateT Bool IO) + mspecLazyStateTIO = MSpec "LazyState.StateT IO" $ io . flip LazyState.evalStateT False + + mspecStrictStateTIO :: MSpec (StrictState.StateT Bool IO) + mspecStrictStateTIO = MSpec "StrictState.StateT IO" $ io . flip StrictState.evalStateT False + + mspecReaderTIO :: MSpec (ReaderT () IO) + mspecReaderTIO = MSpec "ReaderT IO" $ io . flip runReaderT () + + mspecLazyWriterTIO :: MSpec (LazyWriter.WriterT () IO) + mspecLazyWriterTIO = MSpec "LazyWriter.WriterT IO" $ io . fmap tfst . LazyWriter.runWriterT + + mspecStrictWriterTIO :: MSpec (StrictWriter.WriterT () IO) + mspecStrictWriterTIO = MSpec "StrictWriter.WriterT IO" $ io . fmap tfst . StrictWriter.runWriterT + + mspecLazyRWSTIO :: MSpec (LazyRWS.RWST () () Bool IO) + mspecLazyRWSTIO = MSpec "LazyRWS.RWST IO" $ \m -> io $ fmap tfst $ LazyRWS.evalRWST m () False + + mspecStrictRWSTIO :: MSpec (StrictRWS.RWST () () Bool IO) + mspecStrictRWSTIO = MSpec "StrictRWS.RWST IO" $ \m -> io $ fmap tfst $ StrictRWS.evalRWST m () False + + mspecListTIO :: MSpec (ListT IO) + mspecListTIO = MSpec "ListT IO" $ \m -> io $ fmap (\[x] -> x) (runListT m) + + mspecMaybeTIO :: MSpec (MaybeT IO) + mspecMaybeTIO = MSpec "MaybeT IO" $ \m -> io $ fmap (maybe undefined id) (runMaybeT m) + + mspecErrorTIO :: MSpec (ErrorT String IO) + mspecErrorTIO = MSpec "ErrorT IO" $ \m -> io $ fmap (either error id) (runErrorT m) + + mspecSTM :: MSpec STM + mspecSTM = MSpec "STM" $ io . atomically + + --mspecContTIO :: MSpec (ContT () IO) + --mspecContTIO = MSpec "ContT IO" $ \m -> io $ runContT m return + + mspecCatchTIdentity :: MSpec Catch + mspecCatchTIdentity = MSpec "Catch" $ fromRight . runCatch + + mspecEitherSomeException :: MSpec (Either SomeException) + mspecEitherSomeException = MSpec "Either SomeException" fromRight + tfst :: (Property, ()) -> Property = fst fromRight (Left _) = error "fromRight" fromRight (Right a) = a io = morallyDubiousIOProperty - mkMonadCatch = mkTestType "MonadCatch" testMonadCatch - mkCatchJust = mkTestType "catchJust" testCatchJust + detectableEffects = + [ SomeDetectableEffect $ detectableEffectIO + , SomeDetectableEffect detectableEffectLazyStateTIO + , SomeDetectableEffect detectableEffectStrictStateTIO + , SomeDetectableEffect detectableEffectLazyRWSTIO + , SomeDetectableEffect detectableEffectStrictRWSTIO + ] - mkTestType name test = \spec -> - testProperty (name ++ " " ++ mspecName spec) $ once $ test spec + detectableEffectIO :: DetectableEffect IO + detectableEffectIO = DetectableEffect mspecIO $ do + ref <- newIORef False + return (writeIORef ref True, readIORef ref) + detectableEffectLazyStateTIO :: DetectableEffect (LazyState.StateT Bool IO) + detectableEffectLazyStateTIO = DetectableEffect mspecLazyStateTIO $ do + LazyState.put False + return (LazyState.put True, LazyState.get) + + detectableEffectStrictStateTIO :: DetectableEffect (StrictState.StateT Bool IO) + detectableEffectStrictStateTIO = DetectableEffect mspecStrictStateTIO $ do + StrictState.put False + return (StrictState.put True, StrictState.get) + + detectableEffectLazyRWSTIO :: DetectableEffect (LazyRWS.RWST () () Bool IO) + detectableEffectLazyRWSTIO = DetectableEffect mspecLazyRWSTIO $ do + LazyRWS.put False + return (LazyRWS.put True, LazyRWS.get) + + detectableEffectStrictRWSTIO :: DetectableEffect (StrictRWS.RWST () () Bool IO) + detectableEffectStrictRWSTIO = DetectableEffect mspecStrictRWSTIO $ do + StrictRWS.put False + return (StrictRWS.put True, StrictRWS.get) + + mkMonadCatch = mkMSpecTest "MonadCatch" testMonadCatch + mkCatchJust = mkMSpecTest "catchJust" testCatchJust + mkDetectableEffect = mkDetectableEffectTest "effect during release" testDetectableEffect + + mkMSpecTest :: String -> (SomeMSpec -> Property) -> SomeMSpec -> Test + mkMSpecTest name test = \someMSpec@(SomeMSpec spec) -> + testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec + + mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> Test + mkDetectableEffectTest name test = \someDetectableEffect@(SomeDetectableEffect detectableEffect) -> + let testName = name ++ " " ++ mspecName (detectableEffectMSpec detectableEffect) + in testProperty testName $ once $ test someDetectableEffect + exceptTLeft = do ref <- newIORef False Left () <- runExceptT $ ExceptT (return $ Left ()) `finally` lift (writeIORef ref True) val <- readIORef ref unless val $ error "Looks like cleanup didn't happen" + + -- if both 'use' and 'release' abort, the 'release' error should win + releaseErrorWins = do + Left val <- runExceptT $ ExceptT (return $ Left False) `finally` ExceptT (return $ Left True) + unless val $ error "Looks like the 'use' error won"