exceptions 0.8.3 → 0.9.0

raw patch · 7 files changed

+425/−115 lines, 7 filesdep +test-framework-hunitdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: test-framework-hunit

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• .gitignore +19/−0
• .travis.yml +119/−92
• CHANGELOG.markdown +10/−0
• exceptions.cabal +12/−8
• src/Control/Monad/Catch.hs +237/−13
• src/Control/Monad/Catch/Pure.hs +13/−0
• tests/Control/Monad/Catch/Tests.hs +15/−2

@@ -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.*

@@ -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

@@ -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`

@@ -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

@@ -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

@@ -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

@@ -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"