exceptions 0.9.0 → 0.10.12
raw patch · 11 files changed
Files
- .gitignore +9/−0
- .travis.yml +0/−147
- CHANGELOG.markdown +82/−0
- README.markdown +1/−1
- exceptions.cabal +36/−27
- src/Control/Monad/Catch.hs +470/−241
- src/Control/Monad/Catch/Pure.hs +30/−34
- tests/Control/Monad/Catch/Tests.hs +176/−42
- tests/Tests.hs +3/−2
- travis/cabal-apt-install +0/−27
- travis/config +0/−16
.gitignore view
@@ -30,3 +30,12 @@ cabal.project.local~ .HTF/ .ghc.environment.*++# GHC+dist-boot+dist-install+GNUmakefile+ghc.mk++# MHS+dist-mcabal
− .travis.yml
@@ -1,147 +0,0 @@-# 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/.cabal/packages- - $HOME/.cabal/store--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- # 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:- - 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:- - compiler: "ghc-7.0.4"- - compiler: "ghc-7.2.2"- - compiler: "ghc-8.4.1"- - compiler: "ghc-head"--before_install:- - 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 "$(${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-- 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-- 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.-script:- # 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--- # 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-- # cabal check- - (cd exceptions-* && cabal check)-- # 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
CHANGELOG.markdown view
@@ -1,3 +1,85 @@+0.10.12 [2026.01.10]+--------------------+* Add `Monad{Throw,Catch,Mask}` instances for `AccumT` when building with+ `transformers-0.5.6` or later.+* Remove unused `template-haskell` dependency in the test suite.++0.10.11 [2025.10.13]+--------------------+* Add a `rethrowM` method to the `MonadThrow` class and a `catchNoPropagate`+ method to the `MonadCatch` class, which are available when building with+ `base-4.21` (GHC 9.12) or later. These are like `throwM` and `catch`,+ respectively (and use them as their default implementations), but these+ methods do not add new backtraces (for `rethrowM`) or annotate the handler+ with the exception that was caught (for `catchNoPropagate`).+* Support building with MicroHs.++0.10.10 [2025.06.17]+--------------------+* Replace `test-framework` with `tasty` in the test suite.++0.10.9 [2024.10.31]+-------------------+* Drop support for pre-8.0 versions of GHC.++0.10.8 [2024.04.20]+-------------------+* Allow building with `template-haskell-2.22.*`.+* Make the test suite build with GHC 9.4 and `mtl-2.3.1`.++0.10.7 [2022.12.04]+-------------------+* On pre-8.0 GHCs, drop the `call-stack` dependency. This dependency was+ introduced in `exceptions-0.10.6`, but it induced breakage in libraries+ that derived instances of `MonadThrow`, `MonadCatch`, or `MonadMask` for+ newtypes without first enabling `ConstraintKinds` and `FlexibleContexts`.+ (Later versions of GHC do not require these language extensions for derived+ instances, so only old GHCs were affected.) To avoid breakage, `exceptions`+ no longer uses `HasCallStack` constraints on pre-8.0 versions of GHC.++ Note that `exceptions` still uses `HasCallStack` constraints on GHC 8.0 and+ later, and as a result, these versions of GHC are unaffected by this change.++0.10.6 [2022.11.30]+-------------------+* The class methods and functions in `Control.Monad.Catch` now have+ `HasCallStack` constraints.+* Drop support for GHC 7.0 and 7.2.++0.10.5 [2022.05.07]+-------------------+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.++0.10.4 [2019.12.26]+-------------------+* Allow building with `template-haskell-2.16.*`.+* Only depend on `transformers-compat` on old versions of GHC.++0.10.3 [2019.08.27]+-------------------+* `MonadThrow` instance for the strict `ST` monad.++0.10.2 [2019.05.02]+-------------------+* Allow building with `base-4.13`/`template-haskell-2.15`.++0.10.1 [2019.03.26]+-------------------+* Define a `MonadFail` instance for `CatchT`.+* Allow `QuickCheck-2.13` in the test suite.++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
README.markdown view
@@ -1,7 +1,7 @@ exceptions ========== -[](https://hackage.haskell.org/package/exceptions) [](http://travis-ci.org/ekmett/exceptions)+[](https://hackage.haskell.org/package/exceptions) [](https://github.com/ekmett/exceptions/actions?query=workflow%3AHaskell-CI) This package provides (optionally pure) extensible exceptions that are compatible with the monad transformer library.
exceptions.cabal view
@@ -1,7 +1,7 @@ name: exceptions category: Control, Exceptions, Monad-version: 0.9.0-cabal-version: >= 1.8+version: 0.10.12+cabal-version: >= 1.10 license: BSD3 license-file: LICENSE author: Edward A. Kmett@@ -12,58 +12,67 @@ copyright: Copyright (C) 2013-2015 Edward A. Kmett Copyright (C) 2012 Google Inc. build-type: Simple-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+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 synopsis: Extensible optionally-pure exceptions description: Extensible optionally-pure exceptions. extra-source-files:- .travis.yml .ghci .gitignore .vim.custom- travis/cabal-apt-install- travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown source-repository head type: git- location: git://github.com/ekmett/exceptions.git+ location: https://github.com/ekmett/exceptions.git library build-depends:- base >= 4.3 && < 5,+ base >= 4.9 && < 5,+ mtl >= 2.2 && < 2.4, stm >= 2.2 && < 3,- template-haskell >= 2.2 && < 2.14,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.3 && < 0.7,- mtl >= 2.0 && < 2.3+ transformers >= 0.5.2.0 && < 0.7+ if impl(ghc)+ build-depends:+ template-haskell >= 2.11 && < 2.25 exposed-modules: Control.Monad.Catch Control.Monad.Catch.Pure - ghc-options: -Wall -fwarn-tabs -O2+ ghc-options: -Wall -Wtabs -O2 hs-source-dirs: src+ default-language: Haskell2010 test-suite exceptions-tests main-is: Tests.hs- other-modules:- Control.Monad.Catch- Control.Monad.Catch.Pure- Control.Monad.Catch.Tests- hs-source-dirs: src, tests- ghc-options: -Wall -fwarn-tabs+ other-modules: Control.Monad.Catch.Tests+ hs-source-dirs: tests+ ghc-options: -Wall -Wtabs+ default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends: base,+ exceptions,+ mtl, stm,- template-haskell,- transformers,- transformers-compat,- 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.12+ transformers >= 0.5.2.0 && < 0.7,+ tasty >= 1.4 && < 1.6,+ tasty-hunit >= 0.10 && < 0.11,+ tasty-quickcheck >= 0.10 && < 0.12,+ QuickCheck >= 2.5 && < 2.18
src/Control/Monad/Catch.hs view
@@ -1,25 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}-#endif--#ifndef MIN_VERSION_transformers-#define MIN_VERSION_transformers(x,y,z) 1-#endif+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1+#if !MIN_VERSION_transformers(0,6,0)+{-# OPTIONS_GHC -Wno-deprecations #-} #endif--{-# OPTIONS_GHC -fno-warn-deprecations #-} -------------------------------------------------------------------- -- | -- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012@@ -36,7 +30,7 @@ -- with them, though doesn't mimic the module structure or offer the complete -- range of features in those packages. ----- This is very similar to 'ErrorT' and 'MonadError', but based on features of+-- This is very similar to 'ExceptT' and 'MonadError', but based on features of -- "Control.Exception". In particular, it handles the complex case of -- asynchronous exceptions by including 'mask' in the typeclass. Note that the -- extensible exceptions feature relies on the RankNTypes language extension.@@ -48,6 +42,7 @@ MonadThrow(..) , MonadCatch(..) , MonadMask(..)+ , ExitCase(..) -- * Utilities -- $utilities@@ -66,6 +61,7 @@ , try , tryJust , onException+ , onError , bracket , bracket_ , finally@@ -77,6 +73,7 @@ import Control.Exception (Exception(..), SomeException(..)) import qualified Control.Exception as ControlException+import Control.Monad (liftM) import qualified Control.Monad.STM as STM import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS import qualified Control.Monad.Trans.RWS.Strict as StrictRWS@@ -84,27 +81,34 @@ import qualified Control.Monad.Trans.State.Strict as StrictS import qualified Control.Monad.Trans.Writer.Lazy as LazyW import qualified Control.Monad.Trans.Writer.Strict as StrictW+import Control.Monad.ST (ST)+import Control.Monad.ST.Unsafe (unsafeIOToST) import Control.Monad.STM (STM)-import Control.Monad.Trans.List (ListT(..), runListT)+import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)-import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Identity-import Control.Monad.Reader as Reader+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) -import Language.Haskell.TH.Syntax (Q)+import GHC.Stack (HasCallStack, withFrozenCallStack) -#if __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch, foldr)-import Data.Foldable-import Data.Monoid-#elif __GLASGOW_HASKELL__ < 710-import Prelude hiding (foldr)+#if defined(__MHS__)+import Prelude hiding(foldr) import Data.Foldable-import Data.Monoid+#else+import Language.Haskell.TH.Syntax (Q) #endif +#if MIN_VERSION_transformers(0,5,6)+import Control.Monad.Trans.Accum (AccumT (..), runAccumT, evalAccumT)+#endif++#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT)+import Control.Monad.Trans.List (ListT(..), runListT)+#endif+ ------------------------------------------------------------------------------ -- $mtl -- The mtl style typeclass@@ -126,8 +130,20 @@ -- Should satisfy the law: -- -- > throwM e >> f = throwM e- throwM :: Exception e => e -> m a+ throwM :: (HasCallStack, Exception e) => e -> m a +#if MIN_VERSION_base(4,21,0)+ -- | A utility to use when rethrowing exceptions, no new backtrace will be+ -- attached when rethrowing an exception but you must supply the existing+ -- context.+ --+ -- It is a generalization of "Control.Exception"'s+ -- 'ControlException.rethrowIO' and is only defined using @base-4.21@ (GHC+ -- 9.12) or later.+ rethrowM :: Exception e => ControlException.ExceptionWithContext e -> m a+ rethrowM = throwM+#endif+ -- | A class for monads which allow exceptions to be caught, in particular -- exceptions which were thrown by 'throwM'. --@@ -146,29 +162,62 @@ -- action. Note that type of the type of the argument to the handler will -- constrain which exceptions are caught. See "Control.Exception"'s -- 'ControlException.catch'.- catch :: Exception e => m a -> (e -> m a) -> m a+ catch :: (HasCallStack, Exception e) => m a -> (e -> m a) -> m a+#if MIN_VERSION_base(4,21,0)+ -- | A variant of 'catch' which doesn't annotate the handler with the exception+ -- which was caught. This function should be used when you are implementing+ -- your own error handling functions which may rethrow the exceptions.+ --+ -- In the case where you rethrow an exception without modifying it, you+ -- should rethrow the exception with the old exception context.+ --+ -- It is a generalization of "Control.Exception"'s+ -- 'ControlException.catchNoPropagate' and is only defined using @base-4.21@+ -- (GHC 9.12) or later.+ catchNoPropagate :: Exception e => m a -> (ControlException.ExceptionWithContext e -> m a) -> m a+ catchNoPropagate = catch+#endif -- | 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--- 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 overridden 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, <https://hackage.haskell.org/package/lifted-base lifted-base>'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 -- at the 'mask' call. See "Control.Exception"'s 'ControlException.mask'.- mask :: ((forall a. m a -> m a) -> m b) -> m b+ mask :: HasCallStack => ((forall a. m a -> m a) -> m b) -> m b -- | Like 'mask', but the masked computation is not interruptible (see -- "Control.Exception"'s 'ControlException.uninterruptibleMask'. WARNING:@@ -176,102 +225,165 @@ -- AND you can guarantee the interruptible operation will only block for a -- short period of time. Otherwise you render the program/thread unresponsive -- and/or unkillable.- uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b+ uninterruptibleMask :: HasCallStack => ((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 -- 'uninterruptibleMask' functions only, disallowing some classes of- -- tranformers from having @MonadMask@ instances (notably+ -- transformers 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. --- -- @- -- 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 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. --- -- 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@.+ -- 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. --- -- 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@.+ -- 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 use = ExceptT $ do+ -- > (eb, ec) <- generalBracket+ -- > (runExceptT acquire)+ -- > (\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)+ -- -- @since 0.9.0 generalBracket- :: m a+ :: HasCallStack+ => 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 throwM _ = Nothing+#if !defined(__MHS__) instance MonadThrow Q where throwM = fail . show+#endif instance MonadThrow IO where throwM = ControlException.throwIO+#if MIN_VERSION_base(4,21,0)+ rethrowM = ControlException.rethrowIO+#endif instance MonadCatch IO where catch = ControlException.catch+#if MIN_VERSION_base(4,21,0)+ catchNoPropagate = ControlException.catchNoPropagate+#endif instance MonadMask IO where mask = ControlException.mask uninterruptibleMask = ControlException.uninterruptibleMask- generalBracket acquire release cleanup use = mask $ \unmasked -> do+++#if MIN_VERSION_base(4,21,0)+ generalBracket acquire release use = mask $ \unmasked -> do resource <- acquire- result <- unmasked (use resource) `catch` \e -> do- _ <- cleanup resource e++ b <- unmasked (use resource) `catchNoPropagate` \e -> do+ _ <- release resource (ExitCaseException $ ControlException.toException e)+ rethrowM @IO @SomeException e+ c <- release resource (ExitCaseSuccess b)+ return (b, c)+#else+ generalBracket acquire release use = mask $ \unmasked -> do+ resource <- acquire++ 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)+#endif +instance MonadThrow (ST s) where+ throwM = unsafeIOToST . ControlException.throwIO+#if MIN_VERSION_base(4,21,0)+ rethrowM = unsafeIOToST . ControlException.rethrowIO+#endif+ instance MonadThrow STM where throwM = STM.throwSTM instance MonadCatch STM where@@ -291,15 +403,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 +426,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 +445,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 +473,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 +498,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 +517,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 +550,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 +583,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,22 +616,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))---- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask-instance MonadThrow m => MonadThrow (ListT m) where- throwM = lift . throwM-instance MonadCatch m => MonadCatch (ListT m) where- catch (ListT m) f = ListT $ catch m (runListT . f)+ return ((b, c), s3, w123) -- | Throws exceptions into the base monad. instance MonadThrow m => MonadThrow (MaybeT m) where@@ -497,37 +642,34 @@ -- | Catches exceptions from the base monad. instance MonadCatch m => MonadCatch (MaybeT m) where catch (MaybeT m) f = MaybeT $ catch m (runMaybeT . f)---- | Throws exceptions into the base monad.-instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where- throwM = lift . throwM--- | 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)+-- | @since 0.10.0+instance MonadMask m => MonadMask (MaybeT m) where+ mask f = MaybeT $ mask $ \u -> runMaybeT $ 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)+ 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 (Either e a) -> m (Either e a))- -> ErrorT e m a -> ErrorT e m a- q u (ErrorT b) = ErrorT (u b)+ q :: (m (Maybe a) -> m (Maybe a))+ -> MaybeT m a -> MaybeT m a+ q u (MaybeT b) = MaybeT (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))+ 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 MonadThrow m => MonadThrow (ExceptT e m) where@@ -535,6 +677,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,24 +690,89 @@ -> 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 -- I don't believe any valid of MonadCatch exists for ContT. -- instance MonadCatch m => MonadCatch (ContT r m) where +#if MIN_VERSION_transformers(0,5,6)+instance (Monoid w, MonadThrow m) => MonadThrow (AccumT w m) where+ throwM = lift . throwM++instance (MonadCatch m, Monoid w) => MonadCatch (AccumT w m) where+ catch (AccumT m) f = AccumT $ \w -> catch (m w) $ \e -> runAccumT (f e) w++instance (MonadMask m, Monoid w) => MonadMask (AccumT w m) where+ mask f = AccumT $ \w -> mask $ \g -> flip runAccumT w $ f $ \(AccumT m) -> AccumT $ \w' -> g $ m w'+ uninterruptibleMask f = AccumT $ \w -> uninterruptibleMask $ \g -> flip runAccumT w $ f $ \(AccumT m) -> AccumT $ \w' -> g $ m w'+ generalBracket m f g = AccumT $ \w -> (\(b, (c, w')) -> ((b, c), w')) <$> generalBracket (runAccumT m w) (\(a, w') exitCase -> runAccumT (f a exitCase) (w <> w')) (\(a, w') -> evalAccumT (g a) (w <> w'))+#endif++#if !MIN_VERSION_transformers(0,6,0)+-- | Throws exceptions into the base monad.+instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where+ throwM = lift . throwM+-- | 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 use = ErrorT $ do+ (eb, ec) <- generalBracket+ (runErrorT acquire)+ (\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)++-- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask+instance MonadThrow m => MonadThrow (ListT m) where+ throwM = lift . throwM+instance MonadCatch m => MonadCatch (ListT m) where+ catch (ListT m) f = ListT $ catch m (runListT . f)+#endif+ ------------------------------------------------------------------------------ -- $utilities -- These functions follow those from "Control.Exception", except that they are@@ -573,69 +781,72 @@ ------------------------------------------------------------------------------ -- | Like 'mask', but does not pass a @restore@ action to the argument.-mask_ :: MonadMask m => m a -> m a-mask_ io = mask $ \_ -> io+mask_ :: (HasCallStack, MonadMask m) => m a -> m a+mask_ io = withFrozenCallStack (\f -> mask (\x -> f x)) (\_ -> io) -- | Like 'uninterruptibleMask', but does not pass a @restore@ action to the -- argument.-uninterruptibleMask_ :: MonadMask m => m a -> m a-uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io+uninterruptibleMask_ :: (HasCallStack, MonadMask m) => m a -> m a+uninterruptibleMask_ io = withFrozenCallStack (\f -> uninterruptibleMask (\x -> f x)) (\_ -> io) -- | Catches all exceptions, and somewhat defeats the purpose of the extensible -- exception system. Use sparingly.-catchAll :: MonadCatch m => m a -> (SomeException -> m a) -> m a-catchAll = catch+--+-- /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 :: (HasCallStack, MonadCatch m) => m a -> (SomeException -> m a) -> m a+catchAll = withFrozenCallStack catch -- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too -- general, but better than using 'catchAll'. See 'catchIf' for an easy way -- of catching specific 'IOError's based on the predicates in "System.IO.Error".-catchIOError :: MonadCatch m => m a -> (IOError -> m a) -> m a-catchIOError = catch+catchIOError :: (HasCallStack, MonadCatch m) => m a -> (IOError -> m a) -> m a+catchIOError = withFrozenCallStack catch -- | Catch exceptions only if they pass some predicate. Often useful with the -- predicates for testing 'IOError' values in "System.IO.Error".-catchIf :: (MonadCatch m, Exception e) =>+catchIf :: (HasCallStack, MonadCatch m, Exception e) => (e -> Bool) -> m a -> (e -> m a) -> m a-catchIf f a b = a `catch` \e -> if f e then b e else throwM e+catchIf f a b = withFrozenCallStack catch a (\e -> if f e then b e else throwM e) -- | A more generalized way of determining which exceptions to catch at -- run time.-catchJust :: (MonadCatch m, Exception e) =>+catchJust :: (HasCallStack, MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a-catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e+catchJust f a b = withFrozenCallStack catch a (\e -> maybe (throwM e) b $ f e) -- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'.-handle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a-handle = flip catch+handle :: (HasCallStack, MonadCatch m, Exception e) => (e -> m a) -> m a -> m a+handle = flip (withFrozenCallStack catch) {-# INLINE handle #-} -- | Flipped 'catchIOError'-handleIOError :: MonadCatch m => (IOError -> m a) -> m a -> m a-handleIOError = handle+handleIOError :: (HasCallStack, MonadCatch m) => (IOError -> m a) -> m a -> m a+handleIOError = withFrozenCallStack handle -- | Flipped 'catchAll'-handleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a-handleAll = handle+handleAll :: (HasCallStack, MonadCatch m) => (SomeException -> m a) -> m a -> m a+handleAll = withFrozenCallStack handle -- | Flipped 'catchIf'-handleIf :: (MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a-handleIf f = flip (catchIf f)+handleIf :: (HasCallStack, MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a+handleIf f = flip (withFrozenCallStack catchIf f) -- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'.-handleJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a-handleJust f = flip (catchJust f)+handleJust :: (HasCallStack, MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a+handleJust f = flip (withFrozenCallStack catchJust f) {-# INLINE handleJust #-} -- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s -- 'Control.Exception.try'.-try :: (MonadCatch m, Exception e) => m a -> m (Either e a)-try a = catch (Right `liftM` a) (return . Left)+try :: (HasCallStack, MonadCatch m, Exception e) => m a -> m (Either e a)+try a = withFrozenCallStack catch (Right `liftM` a) (return . Left) -- | A variant of 'try' that takes an exception predicate to select -- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust'-tryJust :: (MonadCatch m, Exception e) =>+tryJust :: (HasCallStack, MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)-tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e))+tryJust f a = withFrozenCallStack catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e)) -- | Generalized version of 'ControlException.Handler' data Handler m a = forall e . ControlException.Exception e => Handler (e -> m a)@@ -644,8 +855,8 @@ fmap f (Handler h) = Handler (liftM f . h) -- | Catches different sorts of exceptions. See "Control.Exception"'s 'ControlException.catches'-catches :: (Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a-catches a hs = a `catch` handler+catches :: (HasCallStack, Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a+catches a hs = withFrozenCallStack catch a handler where handler e = foldr probe (throwM e) hs where@@ -653,44 +864,62 @@ -- | Run an action only if an exception is thrown in the main action. The -- exception is not caught, simply rethrown.-onException :: MonadCatch m => m a -> m b -> m a-onException action handler = action `catchAll` \e -> handler >> throwM e+--+-- /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 :: (HasCallStack, MonadCatch m) => m a -> m b -> m a+onException action handler = withFrozenCallStack catchAll action (\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 :: (HasCallStack, MonadMask m) => m a -> m b -> m a+onError action handler = withFrozenCallStack 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 :: (HasCallStack, MonadMask m) => m a -> (a -> m c) -> (a -> m b) -> m b+bracket acquire release = liftM fst . withFrozenCallStack 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_ before after action = bracket before (const after) (const action)+bracket_ :: (HasCallStack, MonadMask m) => m a -> m c -> m b -> m b+bracket_ before after action = withFrozenCallStack bracket before (const after) (const action) -- | Perform an action with a finalizer action that is run, even if an--- exception occurs.-finally :: MonadMask m => m a -> m b -> m a-finally action finalizer = bracket_ (return ()) finalizer action+-- error occurs.+finally :: (HasCallStack, MonadMask m) => m a -> m b -> m a+finally action finalizer = withFrozenCallStack 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 :: (HasCallStack, MonadMask m) => m a -> (a -> m c) -> (a -> m b) -> m b+bracketOnError acquire release = liftM fst . withFrozenCallStack generalBracket acquire- (\_ -> return ())- (\a _e -> release a)- use+ (\a exitCase -> case exitCase of+ ExitCaseSuccess _ -> return ()+ _ -> do+ _ <- release a+ return ())
src/Control/Monad/Catch/Pure.hs view
@@ -5,19 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -#ifndef MIN_VERSION_transformers-#define MIN_VERSION_transformers(x,y,z) 1-#endif--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif- -------------------------------------------------------------------- -- | -- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012@@ -46,21 +35,24 @@ , module Control.Monad.Catch ) where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 706) import Prelude hiding (foldr)-#else-import Prelude hiding (catch, foldr)-#endif import Control.Applicative import Control.Monad.Catch-import Control.Monad.Reader as Reader-import Control.Monad.RWS-#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-#endif+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix (MonadFix(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (MonadPlus(..), ap, liftM)+import Control.Monad.Reader (MonadReader(..))+import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Writer (MonadWriter(..)) import Data.Functor.Identity import Data.Traversable as Traversable+#if defined(__MHS__)+import Data.Foldable+#endif ------------------------------------------------------------------------------ -- $mtl@@ -69,7 +61,7 @@ ------------------------------------------------------------------------------ -- $transformer--- The @transformers@-style monad transfomer+-- The @transformers@-style monad transformer ------------------------------------------------------------------------------ -- | Add 'Exception' handling abilities to a 'Monad'.@@ -109,6 +101,11 @@ CatchT m >>= k = CatchT $ m >>= \ea -> case ea of Left e -> return (Left e) Right a -> runCatchT (k a)+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Monad m => Fail.MonadFail (CatchT m) where fail = CatchT . return . Left . toException . userError instance MonadFix m => MonadFix (CatchT m) where@@ -156,29 +153,30 @@ 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 put = lift . put-#if MIN_VERSION_mtl(2,1,0) state = lift . state-#endif instance MonadReader e m => MonadReader e (CatchT m) where ask = lift ask@@ -194,9 +192,7 @@ return $! case a of Left l -> (Left l, id) Right (r, f) -> (Right r, f)-#if MIN_VERSION_mtl(2,1,0) writer aw = CatchT (Right `liftM` writer aw)-#endif instance MonadRWS r w s m => MonadRWS r w s (CatchT m)
tests/Control/Monad/Catch/Tests.hs view
@@ -4,61 +4,71 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} -module Control.Monad.Catch.Tests (tests) where--#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)-import Prelude hiding (catch)+#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -Wno-deprecations #-} #endif -import Control.Applicative ((<*>))+module Control.Monad.Catch.Tests (tests) where+ import Control.Monad (unless)-import Data.Data (Data, Typeable)+import Data.Data (Data) 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.Trans.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 (Property, ioProperty, once) import Test.QuickCheck.Monadic (monadic, run, assert)-import Test.QuickCheck.Property (morallyDubiousIOProperty)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty) import qualified Control.Monad.State.Lazy as LazyState import qualified Control.Monad.State.Strict as StrictState import qualified Control.Monad.Writer.Lazy as LazyWriter import qualified Control.Monad.Writer.Strict as StrictWriter import qualified Control.Monad.RWS.Lazy as LazyRWS import qualified Control.Monad.RWS.Strict as StrictRWS+#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error (ErrorT(..))+import Control.Monad.Trans.List (ListT(..))+#endif import Control.Monad.Catch import Control.Monad.Catch.Pure data TestException = TestException String- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq, Data) 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,172 @@ posFailure = throwM (TestException "pos") >> error "testCatchJust pos" negFailure = throwM (TestException "neg") >> error "testCatchJust neg" -tests :: Test+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 :: TestTree 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 mspecMaybeTIO+#if !(MIN_VERSION_transformers(0,6,0))+ , SomeMSpec mspecErrorTIO+ , SomeMSpec mspecListTIO+#endif+ , 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++ mspecMaybeTIO :: MSpec (MaybeT IO)+ mspecMaybeTIO = MSpec "MaybeT IO" $ \m -> io $ fmap (maybe undefined id) (runMaybeT m)++#if !(MIN_VERSION_transformers(0,6,0))+ mspecErrorTIO :: MSpec (ErrorT String IO)+ mspecErrorTIO = MSpec "ErrorT IO" $ \m -> io $ fmap (either error id) (runErrorT m)++ mspecListTIO :: MSpec (ListT IO)+ mspecListTIO = MSpec "ListT IO" $ \m -> io $ fmap (foldr const undefined) (runListT m)+#endif++ 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+ io = ioProperty - 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+ { detectableEffectMSpec = mspecIO+ , detectableEffectEffectDetector = do+ ref <- newIORef False+ return (writeIORef ref True, readIORef ref)+ } + detectableEffectLazyStateTIO :: DetectableEffect (LazyState.StateT Bool IO)+ detectableEffectLazyStateTIO = DetectableEffect+ { detectableEffectMSpec = mspecLazyStateTIO+ , detectableEffectEffectDetector = do+ LazyState.put False+ return (LazyState.put True, LazyState.get)+ }++ detectableEffectStrictStateTIO :: DetectableEffect (StrictState.StateT Bool IO)+ detectableEffectStrictStateTIO = DetectableEffect+ { detectableEffectMSpec = mspecStrictStateTIO+ , detectableEffectEffectDetector = do+ StrictState.put False+ return (StrictState.put True, StrictState.get)+ }++ detectableEffectLazyRWSTIO :: DetectableEffect (LazyRWS.RWST () () Bool IO)+ detectableEffectLazyRWSTIO = DetectableEffect+ { detectableEffectMSpec = mspecLazyRWSTIO+ , detectableEffectEffectDetector = do+ LazyRWS.put False+ return (LazyRWS.put True, LazyRWS.get)+ }++ detectableEffectStrictRWSTIO :: DetectableEffect (StrictRWS.RWST () () Bool IO)+ detectableEffectStrictRWSTIO = DetectableEffect+ { detectableEffectMSpec = mspecStrictRWSTIO+ , detectableEffectEffectDetector = 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 -> TestTree+ mkMSpecTest name test = \someMSpec@(SomeMSpec spec) ->+ testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec++ mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> TestTree+ 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"
tests/Tests.hs view
@@ -1,10 +1,11 @@ module Main where -import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) import qualified Control.Monad.Catch.Tests main :: IO ()-main = defaultMain+main = defaultMain $+ testGroup "exceptions" [ Control.Monad.Catch.Tests.tests ]
− travis/cabal-apt-install
@@ -1,27 +0,0 @@-#! /bin/bash-set -eu--APT="sudo apt-get -q -y"-CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall"--$APT update-$APT install dctrl-tools--# Find potential system packages to satisfy cabal dependencies-deps()-{- local M='^\([^ ]\+\)-[0-9.]\+ (.*$'- local G=' -o ( -FPackage -X libghc-\L\1\E-dev )'- local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \- | sed -ne "s/$M/$G/p" | sort -u)"- grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u-}--$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special-$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage--if ! $APT install hlint ; then- $APT install $(deps hlint)- cabal install hlint-fi-
− travis/config
@@ -1,16 +0,0 @@--- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix------ This is particularly useful for travis-ci to get it to stop complaining--- about a broken build when everything is still correct on our end.------ This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead------ To enable this, uncomment the before_script in .travis.yml--remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive-remote-repo-cache: ~/.cabal/packages-world-file: ~/.cabal/world-build-summary: ~/.cabal/logs/build.log-remote-build-reporting: anonymous-install-dirs user-install-dirs global