diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ dist +dist-newstyle docs wiki TAGS @@ -11,3 +12,21 @@ *.hi *~ *# +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,120 +1,147 @@ -# This file has been generated -- see https://github.com/hvr/multi-ghc-travis +# This Travis job script has been generated by a script via +# +# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' +# +# For more information, see https://github.com/hvr/multi-ghc-travis +# language: c sudo: false +git: + submodules: false # whether to recursively clone submodules + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313exceptions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + cache: directories: - - $HOME/.cabsnap - $HOME/.cabal/packages + - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $HOME/.cabal/packages/head.hackage + matrix: include: - - env: CABALVER=1.18 GHCVER=7.0.4 - compiler: ": #GHC 7.0.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.2.2 - compiler: ": #GHC 7.2.2" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.4.2 - compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.6.3 - compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.8.4 - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.3 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.1 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} - - env: CABALVER=head GHCVER=head - compiler: ": #GHC head" - addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} + - compiler: "ghc-7.0.4" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}} + - compiler: "ghc-7.2.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.2.2], sources: [hvr-ghc]}} + - compiler: "ghc-7.4.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} + - compiler: "ghc-7.6.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}} + - compiler: "ghc-7.8.4" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}} + - compiler: "ghc-7.10.3" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}} + - compiler: "ghc-8.0.2" + # env: TEST=--disable-tests BENCH=--disable-benchmarks + addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}} + - compiler: "ghc-8.2.2" + # 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]}} + - compiler: "ghc-head" + env: GHCHEAD=true + addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} allow_failures: - - env: CABALVER=1.18 GHCVER=7.0.4 - - env: CABALVER=1.18 GHCVER=7.2.2 - - env: CABALVER=head GHCVER=head + - compiler: "ghc-7.0.4" + - compiler: "ghc-7.2.2" + - compiler: "ghc-8.4.1" + - compiler: "ghc-head" before_install: - - unset CC - - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - ROOTDIR=$(pwd) + - mkdir -p $HOME/.local/bin + - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > - $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt - - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - HADDOCK=${HADDOCK-true} + - INSTALLED=${INSTALLED-true} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" + - rm -fv cabal.project cabal.project.local + # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - | + if $GHCHEAD; then + sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config -# check whether current requested install-plan matches cached package-db snapshot - - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j --only-dependencies --enable-tests; - fi + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config -# snapshot package-db on cache miss - - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi + cabal new-update head.hackage -v + fi + - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + - "printf 'packages: \".\"\\n' > cabal.project" + - cat cabal.project + - if [ -f "./configure.ac" ]; then + (cd "." && autoreconf -i); + fi + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all + - rm -rf "."/.ghc.environment.* "."/dist + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) -# Here starts the actual work to be performed for the package under -# test; any command which exits with a non-zero exit code causes the -# build to fail. +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. script: - # -v2 provides useful information for debugging - - cabal configure -v2 + # test that source-distributions can be generated + - (cd "." && cabal sdist) + - mv "."/dist/exceptions-*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; + - "printf 'packages: exceptions-*/*.cabal\\n' > cabal.project" + - cat cabal.project - # this builds all libraries and executables - # (including tests/benchmarks) - - cabal build - - cabal test --show-details=always - - # tests that a source-distribution can be generated - - cabal sdist + # build & run tests, build benchmarks + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - # check that the generated source-distribution can be built & installed - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install --force-reinstalls "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi + # cabal check + - (cd exceptions-* && cabal check) -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313exceptions\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" + # haddock + - rm -rf ./dist-newstyle + - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi +# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] # EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,13 @@ +0.9.0 +----- +* Add `generalBracket` to the `MonadMask` typeclass, allowing more + valid instances. + + Note that functions such as `bracket` and `finally` are now based off of + `generalBracket`, so if you are a library author that provides a `MonadMask` + instance, you will need to provide an implementation of this method. +* Add `MonadMask` instances for `ExceptT` and `ErrorT` + 0.8.3 ----- * `MonadCatch` and `MonadMask` instances for `Either SomeException` 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.8.3 +version: 0.9.0 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -12,9 +12,9 @@ copyright: Copyright (C) 2013-2015 Edward A. Kmett Copyright (C) 2012 Google Inc. build-type: Simple -tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.0.20150307 +tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 synopsis: Extensible optionally-pure exceptions -description: Extensible optionally-pure exceptions +description: Extensible optionally-pure exceptions. extra-source-files: .travis.yml @@ -35,9 +35,9 @@ build-depends: base >= 4.3 && < 5, stm >= 2.2 && < 3, - template-haskell >= 2.2 && < 2.12, + template-haskell >= 2.2 && < 2.14, transformers >= 0.2 && < 0.6, - transformers-compat >= 0.3 && < 0.6, + transformers-compat >= 0.3 && < 0.7, mtl >= 2.0 && < 2.3 exposed-modules: @@ -49,7 +49,10 @@ test-suite exceptions-tests main-is: Tests.hs - other-modules: Control.Monad.Catch.Tests + other-modules: + Control.Monad.Catch + Control.Monad.Catch.Pure + Control.Monad.Catch.Tests hs-source-dirs: src, tests ghc-options: -Wall -fwarn-tabs type: exitcode-stdio-1.0 @@ -59,7 +62,8 @@ template-haskell, transformers, transformers-compat, - mtl, + mtl >= 2.2, test-framework >= 0.8 && < 0.9, + test-framework-hunit >= 0.3 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4, - QuickCheck >= 2.5 && < 2.10 + QuickCheck >= 2.5 && < 2.12 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 @@ -148,11 +148,10 @@ -- 'ControlException.catch'. catch :: Exception e => m a -> (e -> m a) -> m a --- | A class for monads which provide for the ability to account for all --- possible exit points from a computation, and to mask asynchronous --- exceptions. Continuation-based monads, and stacks such as @ErrorT e IO@ --- which provide for multiple failure modes, are invalid instances of this --- class. +-- | A class for monads which provide for the ability to account for +-- all possible exit points from a computation, and to mask +-- 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 @@ -179,6 +178,78 @@ -- 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. + -- + -- /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 + -- 'uninterruptibleMask' functions only, disallowing some classes of + -- 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: + -- + -- @ + -- 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) + -- @ + -- + -- 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: + -- + -- @ + -- generalBracket acquire release cleanup use = ExceptT $ + -- 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 ()) + -- (either (return . Left) (runExceptT . use)) + -- @ + -- + -- 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 -> m b) + -- ^ inner action to perform with the resource + -> m b + instance MonadThrow [] where throwM _ = [] instance MonadThrow Maybe where @@ -193,6 +264,13 @@ instance MonadMask IO where mask = ControlException.mask uninterruptibleMask = ControlException.uninterruptibleMask + generalBracket acquire release cleanup use = mask $ \unmasked -> do + resource <- acquire + result <- unmasked (use resource) `catch` \e -> do + _ <- cleanup resource e + throwM e + _ <- release resource + return result instance MonadThrow STM where throwM = STM.throwSTM @@ -213,6 +291,16 @@ mask f = f id uninterruptibleMask f = f id + generalBracket acquire release cleanup 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 + instance MonadThrow m => MonadThrow (IdentityT m) where throwM e = lift $ throwM e instance MonadCatch m => MonadCatch (IdentityT m) where @@ -226,6 +314,13 @@ where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a q u = IdentityT . u . runIdentityT + generalBracket acquire release cleanup use = IdentityT $ + generalBracket + (runIdentityT acquire) + (runIdentityT . release) + (\resource e -> runIdentityT (cleanup resource e)) + (\resource -> runIdentityT (use resource)) + instance MonadThrow m => MonadThrow (LazyS.StateT s m) where throwM e = lift $ throwM e instance MonadCatch m => MonadCatch (LazyS.StateT s m) where @@ -239,6 +334,18 @@ 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 + (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) -> LazyS.runStateT (use resource) s1) + instance MonadThrow m => MonadThrow (StrictS.StateT s m) where throwM e = lift $ throwM e instance MonadCatch m => MonadCatch (StrictS.StateT s m) where @@ -252,6 +359,13 @@ 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 + (StrictS.runStateT acquire s0) + (\(resource, s1) -> StrictS.runStateT (release resource) s1) + (\(resource, s1) e -> StrictS.runStateT (cleanup resource e) s1) + (\(resource, s1) -> StrictS.runStateT (use resource) s1) + instance MonadThrow m => MonadThrow (ReaderT r m) where throwM e = lift $ throwM e instance MonadCatch m => MonadCatch (ReaderT r m) where @@ -265,6 +379,13 @@ 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 + (runReaderT acquire r) + (\resource -> runReaderT (release resource) r) + (\resource e -> runReaderT (cleanup resource e) r) + (\resource -> runReaderT (use resource) r) + instance (MonadThrow m, Monoid w) => MonadThrow (StrictW.WriterT w m) where throwM e = lift $ throwM e instance (MonadCatch m, Monoid w) => MonadCatch (StrictW.WriterT w m) where @@ -278,6 +399,19 @@ 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 + (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) -> do + (a, w2) <- StrictW.runWriterT (use resource) + return (a, mappend w1 w2)) + instance (MonadThrow m, Monoid w) => MonadThrow (LazyW.WriterT w m) where throwM e = lift $ throwM e instance (MonadCatch m, Monoid w) => MonadCatch (LazyW.WriterT w m) where @@ -291,6 +425,17 @@ 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 + (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) -> do + (a, w2) <- LazyW.runWriterT (use resource) + return (a, mappend w1 w2)) + instance (MonadThrow m, Monoid w) => MonadThrow (LazyRWS.RWST r w s m) where throwM e = lift $ throwM e instance (MonadCatch m, Monoid w) => MonadCatch (LazyRWS.RWST r w s m) where @@ -304,6 +449,18 @@ 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 + (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) -> do + (a, s2, w2) <- LazyRWS.runRWST (use resource) r s1 + return (a, s2, mappend w1 w2)) + instance (MonadThrow m, Monoid w) => MonadThrow (StrictRWS.RWST r w s m) where throwM e = lift $ throwM e instance (MonadCatch m, Monoid w) => MonadCatch (StrictRWS.RWST r w s m) where @@ -317,6 +474,17 @@ 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 + (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) -> do + (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1 + return (a, s2, mappend w1 w2)) + -- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask instance MonadThrow m => MonadThrow (ListT m) where throwM = lift . throwM @@ -336,14 +504,62 @@ -- | Catches exceptions from the base monad. instance (Error e, MonadCatch m) => MonadCatch (ErrorT e m) where catch (ErrorT m) f = ErrorT $ catch m (runErrorT . f) +instance (Error e, MonadMask m) => MonadMask (ErrorT e m) where + mask f = ErrorT $ mask $ \u -> runErrorT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ErrorT e m a -> ErrorT e m a + q u (ErrorT b) = ErrorT (u b) + uninterruptibleMask f = ErrorT $ uninterruptibleMask $ \u -> runErrorT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ErrorT e m a -> ErrorT e m a + q u (ErrorT b) = ErrorT (u b) + generalBracket acquire release cleanup use = ErrorT $ + 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 ()) + (either (return . Left) (runErrorT . use)) + -- | Throws exceptions into the base monad. instance MonadThrow m => MonadThrow (ExceptT e m) where throwM = lift . throwM -- | Catches exceptions from the base monad. instance MonadCatch m => MonadCatch (ExceptT e m) where catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f) +instance MonadMask m => MonadMask (ExceptT e m) where + mask f = ExceptT $ mask $ \u -> runExceptT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ExceptT e m a -> ExceptT e m a + q u (ExceptT b) = ExceptT (u b) + uninterruptibleMask f = ExceptT $ uninterruptibleMask $ \u -> runExceptT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ExceptT e m a -> ExceptT e m a + q u (ExceptT b) = ExceptT (u b) + generalBracket acquire release cleanup use = ExceptT $ + 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 ()) + (either (return . Left) (runExceptT . use)) + instance MonadThrow m => MonadThrow (ContT r m) where throwM = lift . throwM -- I don't believe any valid of MonadCatch exists for ContT. @@ -447,12 +663,18 @@ -- -- If an exception occurs during the use, the release still happens before the -- exception 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 = mask $ \unmasked -> do - resource <- acquire - result <- unmasked (use resource) `onException` release resource - _ <- release resource - return result +bracket acquire release use = generalBracket + acquire + release + (\a _e -> release a) + use -- | Version of 'bracket' without any value being passed to the second and -- third actions. @@ -467,6 +689,8 @@ -- | 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 = mask $ \unmasked -> do - resource <- acquire - unmasked (use resource) `onException` release resource +bracketOnError acquire release use = generalBracket + acquire + (\_ -> return ()) + (\a _e -> release a) + use 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 @@ -159,6 +159,19 @@ instance Monad m => MonadMask (CatchT m) where mask a = a id uninterruptibleMask a = a id + generalBracket acquire release cleanup 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 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 @@ -11,16 +11,21 @@ #endif import Control.Applicative ((<*>)) +import Control.Monad (unless) import Data.Data (Data, Typeable) +import Data.IORef (newIORef, writeIORef, readIORef) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Reader (ReaderT(..)) import Control.Monad.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.STM (STM, atomically) --import Control.Monad.Cont (ContT(..)) import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Property, once) import Test.QuickCheck.Monadic (monadic, run, assert) @@ -67,9 +72,11 @@ tests :: Test tests = testGroup "Control.Monad.Catch.Tests" $ - [ mkMonadCatch + ([ mkMonadCatch , mkCatchJust - ] <*> mspecs + ] <*> mspecs) ++ + [ testCase "ExceptT+Left" exceptTLeft + ] where mspecs = [ MSpec "IO" io @@ -102,3 +109,9 @@ mkTestType name test = \spec -> testProperty (name ++ " " ++ mspecName spec) $ once $ test spec + + 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"