exceptions 0.10.7 → 0.10.8
raw patch · 13 files changed
+1767/−1763 lines, 13 filesdep ~QuickCheckdep ~template-haskellsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: QuickCheck, template-haskell
API changes (from Hackage documentation)
- Control.Monad.Catch: instance (Control.Monad.Trans.Error.Error e, Control.Monad.Catch.MonadCatch m) => Control.Monad.Catch.MonadCatch (Control.Monad.Trans.Error.ErrorT e m)
- Control.Monad.Catch: instance (Control.Monad.Trans.Error.Error e, Control.Monad.Catch.MonadMask m) => Control.Monad.Catch.MonadMask (Control.Monad.Trans.Error.ErrorT e m)
- Control.Monad.Catch: instance (Control.Monad.Trans.Error.Error e, Control.Monad.Catch.MonadThrow m) => Control.Monad.Catch.MonadThrow (Control.Monad.Trans.Error.ErrorT e m)
- Control.Monad.Catch: instance Control.Monad.Catch.MonadCatch m => Control.Monad.Catch.MonadCatch (Control.Monad.Trans.List.ListT m)
- Control.Monad.Catch: instance Control.Monad.Catch.MonadThrow m => Control.Monad.Catch.MonadThrow (Control.Monad.Trans.List.ListT m)
- Control.Monad.Catch: data SomeException
+ Control.Monad.Catch: data () => SomeException
Files
- .ghci +1/−1
- .gitignore +38/−38
- .vim.custom +31/−31
- AUTHORS.markdown +1/−1
- CHANGELOG.markdown +142/−137
- LICENSE +31/−31
- README.markdown +15/−15
- Setup.lhs +7/−7
- exceptions.cabal +99/−96
- src/Control/Monad/Catch.hs +909/−913
- src/Control/Monad/Catch/Pure.hs +225/−225
- tests/Control/Monad/Catch/Tests.hs +258/−258
- tests/Tests.hs +10/−10
.ghci view
@@ -1,1 +1,1 @@-:set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h +:set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -1,38 +1,38 @@-dist -dist-newstyle -docs -wiki -TAGS -tags -wip -.DS_Store -.*.swp -.*.swo -*.o -*.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.* - -# GHC -dist-boot -dist-install -GNUmakefile -ghc.mk +dist+dist-newstyle+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.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.*++# GHC+dist-boot+dist-install+GNUmakefile+ghc.mk
.vim.custom view
@@ -1,31 +1,31 @@-" Add the following to your .vimrc to automatically load this on startup - -" if filereadable(".vim.custom") -" so .vim.custom -" endif - -function StripTrailingWhitespace() - let myline=line(".") - let mycolumn = col(".") - silent %s/ *$// - call cursor(myline, mycolumn) -endfunction - -" enable syntax highlighting -syntax on - -" search for the tags file anywhere between here and / -set tags=TAGS;/ - -" highlight tabs and trailing spaces -set listchars=tab:‗‗,trail:‗ -set list - -" f2 runs hasktags -map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> - -" strip trailing whitespace before saving -" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() - -" rebuild hasktags after saving -au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" +" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+" so .vim.custom+" endif++function StripTrailingWhitespace()+ let myline=line(".")+ let mycolumn = col(".")+ silent %s/ *$//+ call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
AUTHORS.markdown view
@@ -1,1 +1,1 @@-`exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero). +`exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero).
CHANGELOG.markdown view
@@ -1,137 +1,142 @@-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 - 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` - -0.8.1 ------ -* Support for throwing in the `template-haskell` `Q` monad -* Support for `transformers` 0.5 - -0.8.0.1 -------- -* Resolved warnings on GHC 7.10 and with transformers 0.4. - -0.8 ---- -* Use `transformers-compat` to allow support for `ExceptT` even on older `transformers` versions. - -0.7 ---- -* `stm` support - -0.6 ---- -* Split out `MonadMask` -* Added `transformers` 0.4 support - -0.5 ---- -* Added instances of `MonadThrow` for `ListT`, `MaybeT`, `ErrorT` and `ContT`. - -0.4 ---- -* Factored out a separate `MonadThrow`. - -0.3.3.1 -------- -* QuickCheck dependency bump - -0.3.3 ------ -* Relicensed under the 3-clause BSD license. - -0.3.2 ------ -* Better documentation for `CatchT`. -* Added `handle`-like analogues for parity with `Control.Exception`. - -0.3.1 ------ -* Fixed test suite. - -0.3 ---- -* Moved `CatchT` to `Control.Monad.Catch.Pure` to make it clear it isn't required for working with `IO`. - -0.2.1 ---- -* Added `mask_` and `uninterruptibleMask_` to `Control.Monad.Catch`. - -0.2 ---- -* Added `uninterruptibleMask` to `MonadCatch`. - -0.1.1 ------ -* Flagged `Control.Monad.Catch` as `Trustworthy` - -0.1.0.1 ------ -* License fix. We were accidentally listing both an APL and BSD3 license in the same module - -0.1 ---- -* Repository initialized +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+ 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`++0.8.1+-----+* Support for throwing in the `template-haskell` `Q` monad+* Support for `transformers` 0.5++0.8.0.1+-------+* Resolved warnings on GHC 7.10 and with transformers 0.4.++0.8+---+* Use `transformers-compat` to allow support for `ExceptT` even on older `transformers` versions.++0.7+---+* `stm` support++0.6+---+* Split out `MonadMask`+* Added `transformers` 0.4 support++0.5+---+* Added instances of `MonadThrow` for `ListT`, `MaybeT`, `ErrorT` and `ContT`.++0.4+---+* Factored out a separate `MonadThrow`.++0.3.3.1+-------+* QuickCheck dependency bump++0.3.3+-----+* Relicensed under the 3-clause BSD license.++0.3.2+-----+* Better documentation for `CatchT`.+* Added `handle`-like analogues for parity with `Control.Exception`.++0.3.1+-----+* Fixed test suite.++0.3+---+* Moved `CatchT` to `Control.Monad.Catch.Pure` to make it clear it isn't required for working with `IO`.++0.2.1+---+* Added `mask_` and `uninterruptibleMask_` to `Control.Monad.Catch`.++0.2+---+* Added `uninterruptibleMask` to `MonadCatch`.++0.1.1+-----+* Flagged `Control.Monad.Catch` as `Trustworthy`++0.1.0.1+-----+* License fix. We were accidentally listing both an APL and BSD3 license in the same module++0.1+---+* Repository initialized
LICENSE view
@@ -1,31 +1,31 @@-Copyright 2013-2015 Edward Kmett -Copyright 2012 Google Inc. - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +Copyright 2013-2015 Edward Kmett+Copyright 2012 Google Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
README.markdown view
@@ -1,15 +1,15 @@-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. - -Contact Information -------------------- - -Contributions and bug reports are welcome! - -Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. - --Edward Kmett +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.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell -> module Main (main) where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
exceptions.cabal view
@@ -1,96 +1,99 @@-name: exceptions -category: Control, Exceptions, Monad -version: 0.10.7 -cabal-version: >= 1.10 -license: BSD3 -license-file: LICENSE -author: Edward A. Kmett -maintainer: Edward A. Kmett <ekmett@gmail.com> -stability: provisional -homepage: http://github.com/ekmett/exceptions/ -bug-reports: http://github.com/ekmett/exceptions/issues -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.3 - , 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.2 -synopsis: Extensible optionally-pure exceptions -description: Extensible optionally-pure exceptions. - -extra-source-files: - .ghci - .gitignore - .vim.custom - AUTHORS.markdown - README.markdown - CHANGELOG.markdown - -source-repository head - type: git - location: git://github.com/ekmett/exceptions.git - -flag transformers-0-4 - description: Use @transformers-0.4@ or later. - default: True - -library - build-depends: - base >= 4.5 && < 5, - stm >= 2.2 && < 3, - template-haskell >= 2.7 && < 2.20, - mtl >= 2.0 && < 2.4 - - if !impl(ghc >= 8.0) - build-depends: fail == 4.9.* - - if flag(transformers-0-4) - build-depends: - transformers >= 0.4 && < 0.7 - else - build-depends: - transformers >= 0.2 && < 0.4, - transformers-compat >= 0.3 && < 0.8 - - exposed-modules: - Control.Monad.Catch - Control.Monad.Catch.Pure - - ghc-options: -Wall -fwarn-tabs -O2 - hs-source-dirs: src - default-language: Haskell2010 - -test-suite exceptions-tests - main-is: Tests.hs - other-modules: Control.Monad.Catch.Tests - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs - default-language: Haskell2010 - type: exitcode-stdio-1.0 - build-depends: - base, - exceptions, - stm, - template-haskell, - mtl >= 2.0, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4, - test-framework-quickcheck2 >= 0.3 && < 0.4, - QuickCheck >= 2.5 && < 2.15 - - if flag(transformers-0-4) - build-depends: - transformers >= 0.4 && < 0.7 - else - build-depends: - transformers >= 0.2 && < 0.4, - transformers-compat >= 0.3 && < 0.8 +name: exceptions+category: Control, Exceptions, Monad+version: 0.10.8+cabal-version: >= 1.10+license: BSD3+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/exceptions/+bug-reports: http://github.com/ekmett/exceptions/issues+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.3+ , 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.4+ , GHC == 9.8.1+synopsis: Extensible optionally-pure exceptions+description: Extensible optionally-pure exceptions.++extra-source-files:+ .ghci+ .gitignore+ .vim.custom+ AUTHORS.markdown+ README.markdown+ CHANGELOG.markdown++source-repository head+ type: git+ location: https://github.com/ekmett/exceptions.git++flag transformers-0-4+ description: Use @transformers-0.4@ or later.+ default: True++library+ build-depends:+ base >= 4.5 && < 5,+ stm >= 2.2 && < 3,+ template-haskell >= 2.7 && < 2.23,+ mtl >= 2.0 && < 2.4++ if !impl(ghc >= 8.0)+ build-depends: fail == 4.9.*++ if flag(transformers-0-4)+ build-depends:+ transformers >= 0.4 && < 0.7+ else+ build-depends:+ transformers >= 0.2 && < 0.4,+ transformers-compat >= 0.3 && < 0.8++ exposed-modules:+ Control.Monad.Catch+ Control.Monad.Catch.Pure++ ghc-options: -Wall -fwarn-tabs -O2+ hs-source-dirs: src+ default-language: Haskell2010++test-suite exceptions-tests+ main-is: Tests.hs+ other-modules: Control.Monad.Catch.Tests+ hs-source-dirs: tests+ ghc-options: -Wall -fwarn-tabs+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ build-depends:+ base,+ exceptions,+ stm,+ template-haskell,+ mtl >= 2.0,+ test-framework >= 0.8 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4,+ test-framework-quickcheck2 >= 0.3 && < 0.4,+ QuickCheck >= 2.5 && < 2.15++ if flag(transformers-0-4)+ build-depends:+ transformers >= 0.4 && < 0.7+ else+ build-depends:+ transformers >= 0.2 && < 0.4,+ transformers-compat >= 0.3 && < 0.8
src/Control/Monad/Catch.hs view
@@ -1,913 +1,909 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - -#if !(MIN_VERSION_transformers(0,6,0)) -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif --------------------------------------------------------------------- --- | --- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012 --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- This module supports monads that can throw extensible exceptions. The --- exceptions are the very same from "Control.Exception", and the operations --- offered very similar, but here they are not limited to 'IO'. --- --- This code is in the style of both transformers and mtl, and is compatible --- 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 --- "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. --------------------------------------------------------------------- - -module Control.Monad.Catch ( - -- * Typeclass - -- $mtl - MonadThrow(..) - , MonadCatch(..) - , MonadMask(..) - , ExitCase(..) - - -- * Utilities - -- $utilities - , mask_ - , uninterruptibleMask_ - , catchAll - , catchIOError - , catchJust - , catchIf - , Handler(..), catches - , handle - , handleAll - , handleIOError - , handleJust - , handleIf - , try - , tryJust - , onException - , onError - , bracket - , bracket_ - , finally - , bracketOnError - -- * Re-exports from Control.Exception - , Exception(..) - , SomeException(..) - ) where - -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 -import qualified Control.Monad.Trans.State.Lazy as LazyS -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.STM (STM) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Trans.Cont (ContT) -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) - -import Language.Haskell.TH.Syntax (Q) - -#if MIN_VERSION_base(4,4,0) -import Control.Monad.ST.Unsafe (unsafeIOToST) -#else -import Control.Monad.ST (unsafeIOToST) -#endif - -#if __GLASGOW_HASKELL__ < 706 -import Prelude hiding (catch, foldr) -import Data.Foldable -import Data.Monoid -#elif __GLASGOW_HASKELL__ < 710 -import Prelude hiding (foldr) -import Data.Foldable -import Data.Monoid -#endif - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -#if __GLASGOW_HASKELL__ >= 800 -import GHC.Stack (HasCallStack, withFrozenCallStack) -#endif - -#if !(MIN_VERSION_transformers(0,6,0)) -import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT) -import Control.Monad.Trans.List (ListT(..), runListT) -#endif - --- We use the following bit of CPP to enable the use of HasCallStack --- constraints without breaking the build for pre-8.0 GHCs, which did not --- provide GHC.Stack. We are careful to always write constraints like this: --- --- HAS_CALL_STACK => MonadThrow m => ... --- --- Instead of like this: --- --- (HAS_CALL_STACK, MonadThrow e) => ... --- --- The latter is equivalent to (() :: Constraint, MonadThrow e) => ..., which --- requires ConstraintKinds. More importantly, it's slightly less efficient, --- since it requires passing an empty constraint tuple dictionary around. --- --- Note that we do /not/ depend on the call-stack compatibility library to --- provide HasCallStack on older GHCs. We tried this at one point, but we --- discovered that downstream libraries failed to build because combining --- call-stack with GeneralizedNewtypeDeriving on older GHCs would require the --- use of ConstraintKinds/FlexibleContexts, which downstream libraries did not --- enable. (See #91.) The CPP approach that we use now, while somewhat clunky, --- avoids these issues by not requiring any additional language extensions for --- downstream users. -#if __GLASGOW_HASKELL__ >= 800 -# define HAS_CALL_STACK HasCallStack -#else -# define HAS_CALL_STACK () - -withFrozenCallStack :: a -> a -withFrozenCallStack a = a -#endif - ------------------------------------------------------------------------------- --- $mtl --- The mtl style typeclass ------------------------------------------------------------------------------- - --- | A class for monads in which exceptions may be thrown. --- --- Instances should obey the following law: --- --- > throwM e >> x = throwM e --- --- In other words, throwing an exception short-circuits the rest of the monadic --- computation. -class Monad m => MonadThrow m where - -- | Throw an exception. Note that this throws when this action is run in - -- the monad @m@, not when it is applied. It is a generalization of - -- "Control.Exception"'s 'ControlException.throwIO'. - -- - -- Should satisfy the law: - -- - -- > throwM e >> f = throwM e - throwM :: HAS_CALL_STACK => Exception e => e -> m a - --- | A class for monads which allow exceptions to be caught, in particular --- exceptions which were thrown by 'throwM'. --- --- Instances should obey the following law: --- --- > catch (throwM e) f = f e --- --- Note that the ability to catch an exception does /not/ guarantee that we can --- deal with all possible exit points from a computation. Some monads, such as --- continuation-based stacks, allow for more than just a success/failure --- strategy, and therefore @catch@ /cannot/ be used by those monads to properly --- implement a function such as @finally@. For more information, see --- 'MonadMask'. -class MonadThrow m => MonadCatch m where - -- | Provide a handler for exceptions thrown during execution of the first - -- 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 :: HAS_CALL_STACK => 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 are invalid --- instances of this class. --- --- Instances should ensure that, in the following code: --- --- > fg = f `finally` g --- --- The action @g@ is called regardless of what occurs within @f@, including --- 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 :: HAS_CALL_STACK => ((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: - -- Only use if you need to mask exceptions around an interruptible operation - -- 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 :: HAS_CALL_STACK => ((forall a. m a -> m a) -> m b) -> m b - - -- | 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 - -- multi-exit-point transformers like 'ExceptT'). If you are a - -- library author, you'll now need to provide an implementation for - -- this method. The @StateT@ implementation demonstrates most of the - -- subtleties: - -- - -- @ - -- 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) - -- @ - -- - -- The @StateT s m@ implementation of @generalBracket@ delegates to the @m@ - -- implementation of @generalBracket@. The @acquire@, @use@, and @release@ - -- arguments given to @StateT@'s implementation produce actions of type - -- @StateT s m a@, @StateT s m b@, and @StateT s m c@. In order to run those - -- actions in the base monad, we need to call @runStateT@, from which we - -- obtain actions of type @m (a, s)@, @m (b, s)@, and @m (c, s)@. Since each - -- action produces the next state, it is important to feed the state produced - -- by the previous action to the next action. - -- - -- In the 'ExitCaseSuccess' case, the state starts at @s0@, flows through - -- @acquire@ to become @s1@, flows through @use@ to become @s2@, and finally - -- flows through @release@ to become @s3@. In the other two cases, @release@ - -- does not receive the value @s2@, so its action cannot see the state changes - -- performed by @use@. This is fine, because in those two cases, an error was - -- thrown in the base monad, so as per the usual interaction between effects - -- in a monad transformer stack, those state changes get reverted. So we start - -- from @s1@ instead. - -- - -- Finally, the @m@ implementation of @generalBracket@ returns the pairs - -- @(b, s)@ and @(c, s)@. For monad transformers other than @StateT@, this - -- will be some other type representing the effects and values performed and - -- returned by the @use@ and @release@ actions. The effect part of the @use@ - -- result, in this case @_s2@, usually needs to be discarded, since those - -- effects have already been incorporated in the @release@ action. - -- - -- The only effect which is intentionally not incorporated in the @release@ - -- action is the effect of throwing an error. In that case, the error must be - -- re-thrown. One subtlety which is easy to miss is that in the case in which - -- @use@ and @release@ both throw an error, the error from @release@ should - -- take priority. Here is an implementation for @ExceptT@ which demonstrates - -- how to do this. - -- - -- @ - -- generalBracket acquire release 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 - :: HAS_CALL_STACK - => m a - -- ^ acquire some resource - -> (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, 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 -instance MonadThrow Q where - throwM = fail . show - -instance MonadThrow IO where - throwM = ControlException.throwIO -instance MonadCatch IO where - catch = ControlException.catch -instance MonadMask IO where - mask = ControlException.mask - uninterruptibleMask = ControlException.uninterruptibleMask - generalBracket acquire release use = mask $ \unmasked -> do - resource <- acquire - b <- unmasked (use resource) `catch` \e -> do - _ <- release resource (ExitCaseException e) - throwM e - c <- release resource (ExitCaseSuccess b) - return (b, c) - -instance MonadThrow (ST s) where - throwM = unsafeIOToST . ControlException.throwIO - -instance MonadThrow STM where - throwM = STM.throwSTM -instance MonadCatch STM where - catch = STM.catchSTM - -instance e ~ SomeException => MonadThrow (Either e) where - throwM = Left . toException --- | @since 0.8.3 -instance e ~ SomeException => MonadCatch (Either e) where - catch (Left e) f = - case fromException e of - Nothing -> Left e - Just e' -> f e' - catch x@(Right _) _ = x --- | @since 0.8.3 -instance e ~ SomeException => MonadMask (Either e) where - mask f = f id - uninterruptibleMask f = f id - - generalBracket acquire release use = - case acquire of - Left e -> Left e - Right resource -> - case use resource of - 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 -instance MonadCatch m => MonadCatch (IdentityT m) where - catch (IdentityT m) f = IdentityT (catch m (runIdentityT . f)) -instance MonadMask m => MonadMask (IdentityT m) where - mask a = IdentityT $ mask $ \u -> runIdentityT (a $ q u) - where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a - q u = IdentityT . u . runIdentityT - uninterruptibleMask a = - IdentityT $ uninterruptibleMask $ \u -> runIdentityT (a $ q u) - where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a - q u = IdentityT . u . runIdentityT - - generalBracket acquire release use = IdentityT $ - generalBracket - (runIdentityT acquire) - (\resource exitCase -> runIdentityT (release resource exitCase)) - (\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 - catch = LazyS.liftCatch catch -instance MonadMask m => MonadMask (LazyS.StateT s m) where - mask a = LazyS.StateT $ \s -> mask $ \u -> LazyS.runStateT (a $ q u) s - 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) - uninterruptibleMask a = - LazyS.StateT $ \s -> uninterruptibleMask $ \u -> LazyS.runStateT (a $ q u) s - 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 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) - (\(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 -instance MonadCatch m => MonadCatch (StrictS.StateT s m) where - catch = StrictS.liftCatch catch -instance MonadMask m => MonadMask (StrictS.StateT s m) where - mask a = StrictS.StateT $ \s -> mask $ \u -> StrictS.runStateT (a $ q u) s - 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) - uninterruptibleMask a = - StrictS.StateT $ \s -> uninterruptibleMask $ \u -> StrictS.runStateT (a $ q u) s - 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 use = StrictS.StateT $ \s0 -> do - ((b, _s2), (c, s3)) <- generalBracket - (StrictS.runStateT acquire s0) - (\(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 -instance MonadCatch m => MonadCatch (ReaderT r m) where - catch (ReaderT m) c = ReaderT $ \r -> m r `catch` \e -> runReaderT (c e) r -instance MonadMask m => MonadMask (ReaderT r m) where - mask a = ReaderT $ \e -> mask $ \u -> runReaderT (a $ q u) e - where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a - q u (ReaderT b) = ReaderT (u . b) - uninterruptibleMask a = - ReaderT $ \e -> uninterruptibleMask $ \u -> runReaderT (a $ q u) e - where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a - q u (ReaderT b) = ReaderT (u . b) - - generalBracket acquire release use = ReaderT $ \r -> - generalBracket - (runReaderT acquire r) - (\resource exitCase -> runReaderT (release resource exitCase) 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 - catch (StrictW.WriterT m) h = StrictW.WriterT $ m `catch ` \e -> StrictW.runWriterT (h e) -instance (MonadMask m, Monoid w) => MonadMask (StrictW.WriterT w m) where - mask a = StrictW.WriterT $ mask $ \u -> StrictW.runWriterT (a $ q u) - 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) - uninterruptibleMask a = - StrictW.WriterT $ uninterruptibleMask $ \u -> StrictW.runWriterT (a $ q u) - 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 use = StrictW.WriterT $ do - ((b, _w12), (c, w123)) <- generalBracket - (StrictW.runWriterT acquire) - (\(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 -instance (MonadCatch m, Monoid w) => MonadCatch (LazyW.WriterT w m) where - catch (LazyW.WriterT m) h = LazyW.WriterT $ m `catch ` \e -> LazyW.runWriterT (h e) -instance (MonadMask m, Monoid w) => MonadMask (LazyW.WriterT w m) where - mask a = LazyW.WriterT $ mask $ \u -> LazyW.runWriterT (a $ q u) - 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) - uninterruptibleMask a = - LazyW.WriterT $ uninterruptibleMask $ \u -> LazyW.runWriterT (a $ q u) - 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 use = LazyW.WriterT $ do - ((b, _w12), (c, w123)) <- generalBracket - (LazyW.runWriterT acquire) - (\(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 -instance (MonadCatch m, Monoid w) => MonadCatch (LazyRWS.RWST r w s m) where - catch (LazyRWS.RWST m) h = LazyRWS.RWST $ \r s -> m r s `catch` \e -> LazyRWS.runRWST (h e) r s -instance (MonadMask m, Monoid w) => MonadMask (LazyRWS.RWST r w s m) where - mask a = LazyRWS.RWST $ \r s -> mask $ \u -> LazyRWS.runRWST (a $ q u) r s - 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) - uninterruptibleMask a = - LazyRWS.RWST $ \r s -> uninterruptibleMask $ \u -> LazyRWS.runRWST (a $ q u) r s - 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 use = LazyRWS.RWST $ \r s0 -> do - ((b, _s2, _w12), (c, s3, w123)) <- generalBracket - (LazyRWS.runRWST acquire r s0) - (\(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 -instance (MonadCatch m, Monoid w) => MonadCatch (StrictRWS.RWST r w s m) where - catch (StrictRWS.RWST m) h = StrictRWS.RWST $ \r s -> m r s `catch` \e -> StrictRWS.runRWST (h e) r s -instance (MonadMask m, Monoid w) => MonadMask (StrictRWS.RWST r w s m) where - mask a = StrictRWS.RWST $ \r s -> mask $ \u -> StrictRWS.runRWST (a $ q u) r s - 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) - uninterruptibleMask a = - StrictRWS.RWST $ \r s -> uninterruptibleMask $ \u -> StrictRWS.runRWST (a $ q u) r s - 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 use = StrictRWS.RWST $ \r s0 -> do - ((b, _s2, _w12), (c, s3, w123)) <- generalBracket - (StrictRWS.runRWST acquire r s0) - (\(resource, s1, w1) exitCase -> case exitCase of - ExitCaseSuccess (b, s2, w12) -> do - (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseSuccess b)) r s2 - return (c, s3, mappend w12 w3) - -- In the two other cases, the base monad overrides @use@'s state - -- changes and the state reverts to @s1@ and @w1@. - ExitCaseException e -> do - (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseException e)) r s1 - return (c, s3, mappend w1 w3) - ExitCaseAbort -> do - (c, s3, w3) <- StrictRWS.runRWST (release resource ExitCaseAbort) r s1 - return (c, s3, mappend w1 w3)) - (\(resource, s1, w1) -> do - (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1 - return (a, s2, mappend w1 w2)) - return ((b, c), s3, w123) - --- | Throws exceptions into the base monad. -instance MonadThrow m => MonadThrow (MaybeT m) where - throwM = lift . throwM --- | Catches exceptions from the base monad. -instance MonadCatch m => MonadCatch (MaybeT m) where - catch (MaybeT m) f = MaybeT $ catch m (runMaybeT . f) --- | @since 0.10.0 -instance MonadMask m => MonadMask (MaybeT m) where - mask f = MaybeT $ mask $ \u -> runMaybeT $ f (q u) - where - q :: (m (Maybe a) -> m (Maybe a)) - -> MaybeT m a -> MaybeT m a - q u (MaybeT b) = MaybeT (u b) - uninterruptibleMask f = MaybeT $ uninterruptibleMask $ \u -> runMaybeT $ f (q u) - where - q :: (m (Maybe a) -> m (Maybe a)) - -> MaybeT m a -> MaybeT m a - q u (MaybeT b) = MaybeT (u b) - - generalBracket acquire release use = MaybeT $ do - (eb, ec) <- generalBracket - (runMaybeT acquire) - (\resourceMay exitCase -> case resourceMay of - Nothing -> return Nothing -- nothing to release, acquire didn't succeed - Just resource -> case exitCase of - ExitCaseSuccess (Just b) -> runMaybeT (release resource (ExitCaseSuccess b)) - ExitCaseException e -> runMaybeT (release resource (ExitCaseException e)) - _ -> runMaybeT (release resource ExitCaseAbort)) - (\resourceMay -> case resourceMay of - Nothing -> return Nothing - Just resource -> runMaybeT (use resource)) - -- The order in which we perform those two 'Maybe' effects doesn't matter, - -- since the error message is the same regardless. - return ((,) <$> eb <*> ec) - --- | Throws exceptions into the base monad. -instance 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) --- | @since 0.9.0 -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 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 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,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 --- based on methods from the 'MonadCatch' typeclass. See --- "Control.Exception" for API usage. ------------------------------------------------------------------------------- - --- | Like 'mask', but does not pass a @restore@ action to the argument. -mask_ :: HAS_CALL_STACK => 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_ :: HAS_CALL_STACK => 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. --- --- /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 :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) => - (e -> Bool) -> m a -> (e -> m a) -> m a -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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) => - (e -> Maybe b) -> m a -> (b -> m a) -> m a -catchJust f a b = withFrozenCallStack catch a (\e -> maybe (throwM e) b $ f e) - --- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'. -handle :: HAS_CALL_STACK => (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a -handle = flip (withFrozenCallStack catch) -{-# INLINE handle #-} - --- | Flipped 'catchIOError' -handleIOError :: HAS_CALL_STACK => MonadCatch m => (IOError -> m a) -> m a -> m a -handleIOError = withFrozenCallStack handle - --- | Flipped 'catchAll' -handleAll :: HAS_CALL_STACK => MonadCatch m => (SomeException -> m a) -> m a -> m a -handleAll = withFrozenCallStack handle - --- | Flipped 'catchIf' -handleIf :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) => - (e -> Maybe b) -> m a -> m (Either b a) -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) - -instance Monad m => Functor (Handler m) where - fmap f (Handler h) = Handler (liftM f . h) - --- | Catches different sorts of exceptions. See "Control.Exception"'s 'ControlException.catches' -catches :: HAS_CALL_STACK => (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 - probe (Handler h) xs = maybe xs h (ControlException.fromException e) - --- | Run an action only if an exception is thrown in the main action. The --- exception is not caught, simply rethrown. --- --- /NOTE/ The action is only run if an /exception/ is thrown. If the monad --- supports other ways of aborting the computation, the action won't run if --- those other kinds of errors are thrown. See 'onError'. -onException :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => 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 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 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 :: HAS_CALL_STACK => MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b -bracket acquire release = liftM fst . withFrozenCallStack generalBracket - acquire - (\a _exitCase -> release a) - --- | Version of 'bracket' without any value being passed to the second and --- third actions. -bracket_ :: HAS_CALL_STACK => 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 --- error occurs. -finally :: HAS_CALL_STACK => 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 an error is --- thrown by the in-between computation. -bracketOnError :: HAS_CALL_STACK => MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b -bracketOnError acquire release = liftM fst . withFrozenCallStack generalBracket - acquire - (\a exitCase -> case exitCase of - ExitCaseSuccess _ -> return () - _ -> do - _ <- release a - return ()) +{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif+--------------------------------------------------------------------+-- |+-- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This module supports monads that can throw extensible exceptions. The+-- exceptions are the very same from "Control.Exception", and the operations+-- offered very similar, but here they are not limited to 'IO'.+--+-- This code is in the style of both transformers and mtl, and is compatible+-- 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+-- "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.+--------------------------------------------------------------------++module Control.Monad.Catch (+ -- * Typeclass+ -- $mtl+ MonadThrow(..)+ , MonadCatch(..)+ , MonadMask(..)+ , ExitCase(..)++ -- * Utilities+ -- $utilities+ , mask_+ , uninterruptibleMask_+ , catchAll+ , catchIOError+ , catchJust+ , catchIf+ , Handler(..), catches+ , handle+ , handleAll+ , handleIOError+ , handleJust+ , handleIf+ , try+ , tryJust+ , onException+ , onError+ , bracket+ , bracket_+ , finally+ , bracketOnError+ -- * Re-exports from Control.Exception+ , Exception(..)+ , SomeException(..)+ ) where++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+import qualified Control.Monad.Trans.State.Lazy as LazyS+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.STM (STM)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)++import Language.Haskell.TH.Syntax (Q)++#if MIN_VERSION_base(4,4,0)+import Control.Monad.ST.Unsafe (unsafeIOToST)+#else+import Control.Monad.ST (unsafeIOToST)+#endif++#if __GLASGOW_HASKELL__ < 706+import Prelude hiding (catch, foldr)+import Data.Foldable+import Data.Monoid+#elif __GLASGOW_HASKELL__ < 710+import Prelude hiding (foldr)+import Data.Foldable+import Data.Monoid+#endif++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++#if __GLASGOW_HASKELL__ >= 800+import GHC.Stack (HasCallStack, withFrozenCallStack)+#endif++#if !(MIN_VERSION_transformers(0,6,0))+import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT)+import Control.Monad.Trans.List (ListT(..), runListT)+#endif++-- We use the following bit of CPP to enable the use of HasCallStack+-- constraints without breaking the build for pre-8.0 GHCs, which did not+-- provide GHC.Stack. We are careful to always write constraints like this:+--+-- HAS_CALL_STACK => MonadThrow m => ...+--+-- Instead of like this:+--+-- (HAS_CALL_STACK, MonadThrow e) => ...+--+-- The latter is equivalent to (() :: Constraint, MonadThrow e) => ..., which+-- requires ConstraintKinds. More importantly, it's slightly less efficient,+-- since it requires passing an empty constraint tuple dictionary around.+--+-- Note that we do /not/ depend on the call-stack compatibility library to+-- provide HasCallStack on older GHCs. We tried this at one point, but we+-- discovered that downstream libraries failed to build because combining+-- call-stack with GeneralizedNewtypeDeriving on older GHCs would require the+-- use of ConstraintKinds/FlexibleContexts, which downstream libraries did not+-- enable. (See #91.) The CPP approach that we use now, while somewhat clunky,+-- avoids these issues by not requiring any additional language extensions for+-- downstream users.+#if __GLASGOW_HASKELL__ >= 800+# define HAS_CALL_STACK HasCallStack+#else+# define HAS_CALL_STACK ()++withFrozenCallStack :: a -> a+withFrozenCallStack a = a+#endif++------------------------------------------------------------------------------+-- $mtl+-- The mtl style typeclass+------------------------------------------------------------------------------++-- | A class for monads in which exceptions may be thrown.+--+-- Instances should obey the following law:+--+-- > throwM e >> x = throwM e+--+-- In other words, throwing an exception short-circuits the rest of the monadic+-- computation.+class Monad m => MonadThrow m where+ -- | Throw an exception. Note that this throws when this action is run in+ -- the monad @m@, not when it is applied. It is a generalization of+ -- "Control.Exception"'s 'ControlException.throwIO'.+ --+ -- Should satisfy the law:+ --+ -- > throwM e >> f = throwM e+ throwM :: HAS_CALL_STACK => Exception e => e -> m a++-- | A class for monads which allow exceptions to be caught, in particular+-- exceptions which were thrown by 'throwM'.+--+-- Instances should obey the following law:+--+-- > catch (throwM e) f = f e+--+-- Note that the ability to catch an exception does /not/ guarantee that we can+-- deal with all possible exit points from a computation. Some monads, such as+-- continuation-based stacks, allow for more than just a success/failure+-- strategy, and therefore @catch@ /cannot/ be used by those monads to properly+-- implement a function such as @finally@. For more information, see+-- 'MonadMask'.+class MonadThrow m => MonadCatch m where+ -- | Provide a handler for exceptions thrown during execution of the first+ -- 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 :: HAS_CALL_STACK => 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 are invalid+-- instances of this class.+--+-- Instances should ensure that, in the following code:+--+-- > fg = f `finally` g+--+-- The action @g@ is called regardless of what occurs within @f@, including+-- 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 :: HAS_CALL_STACK => ((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:+ -- Only use if you need to mask exceptions around an interruptible operation+ -- 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 :: HAS_CALL_STACK => ((forall a. m a -> m a) -> m b) -> m b++ -- | 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+ -- multi-exit-point transformers like 'ExceptT'). If you are a+ -- library author, you'll now need to provide an implementation for+ -- this method. The @StateT@ implementation demonstrates most of the+ -- subtleties:+ --+ -- > 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)+ --+ -- The @StateT s m@ implementation of @generalBracket@ delegates to the @m@+ -- implementation of @generalBracket@. The @acquire@, @use@, and @release@+ -- arguments given to @StateT@'s implementation produce actions of type+ -- @StateT s m a@, @StateT s m b@, and @StateT s m c@. In order to run those+ -- actions in the base monad, we need to call @runStateT@, from which we+ -- obtain actions of type @m (a, s)@, @m (b, s)@, and @m (c, s)@. Since each+ -- action produces the next state, it is important to feed the state produced+ -- by the previous action to the next action.+ --+ -- In the 'ExitCaseSuccess' case, the state starts at @s0@, flows through+ -- @acquire@ to become @s1@, flows through @use@ to become @s2@, and finally+ -- flows through @release@ to become @s3@. In the other two cases, @release@+ -- does not receive the value @s2@, so its action cannot see the state changes+ -- performed by @use@. This is fine, because in those two cases, an error was+ -- thrown in the base monad, so as per the usual interaction between effects+ -- in a monad transformer stack, those state changes get reverted. So we start+ -- from @s1@ instead.+ --+ -- Finally, the @m@ implementation of @generalBracket@ returns the pairs+ -- @(b, s)@ and @(c, s)@. For monad transformers other than @StateT@, this+ -- will be some other type representing the effects and values performed and+ -- returned by the @use@ and @release@ actions. The effect part of the @use@+ -- result, in this case @_s2@, usually needs to be discarded, since those+ -- effects have already been incorporated in the @release@ action.+ --+ -- The only effect which is intentionally not incorporated in the @release@+ -- action is the effect of throwing an error. In that case, the error must be+ -- re-thrown. One subtlety which is easy to miss is that in the case in which+ -- @use@ and @release@ both throw an error, the error from @release@ should+ -- take priority. Here is an implementation for @ExceptT@ which demonstrates+ -- how to do this.+ --+ -- > generalBracket acquire release 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+ :: HAS_CALL_STACK+ => m a+ -- ^ acquire some resource+ -> (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, 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+instance MonadThrow Q where+ throwM = fail . show++instance MonadThrow IO where+ throwM = ControlException.throwIO+instance MonadCatch IO where+ catch = ControlException.catch+instance MonadMask IO where+ mask = ControlException.mask+ uninterruptibleMask = ControlException.uninterruptibleMask+ generalBracket acquire release use = mask $ \unmasked -> do+ resource <- acquire+ b <- unmasked (use resource) `catch` \e -> do+ _ <- release resource (ExitCaseException e)+ throwM e+ c <- release resource (ExitCaseSuccess b)+ return (b, c)++instance MonadThrow (ST s) where+ throwM = unsafeIOToST . ControlException.throwIO++instance MonadThrow STM where+ throwM = STM.throwSTM+instance MonadCatch STM where+ catch = STM.catchSTM++instance e ~ SomeException => MonadThrow (Either e) where+ throwM = Left . toException+-- | @since 0.8.3+instance e ~ SomeException => MonadCatch (Either e) where+ catch (Left e) f =+ case fromException e of+ Nothing -> Left e+ Just e' -> f e'+ catch x@(Right _) _ = x+-- | @since 0.8.3+instance e ~ SomeException => MonadMask (Either e) where+ mask f = f id+ uninterruptibleMask f = f id++ generalBracket acquire release use =+ case acquire of+ Left e -> Left e+ Right resource ->+ case use resource of+ 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+instance MonadCatch m => MonadCatch (IdentityT m) where+ catch (IdentityT m) f = IdentityT (catch m (runIdentityT . f))+instance MonadMask m => MonadMask (IdentityT m) where+ mask a = IdentityT $ mask $ \u -> runIdentityT (a $ q u)+ where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a+ q u = IdentityT . u . runIdentityT+ uninterruptibleMask a =+ IdentityT $ uninterruptibleMask $ \u -> runIdentityT (a $ q u)+ where q :: (m a -> m a) -> IdentityT m a -> IdentityT m a+ q u = IdentityT . u . runIdentityT++ generalBracket acquire release use = IdentityT $+ generalBracket+ (runIdentityT acquire)+ (\resource exitCase -> runIdentityT (release resource exitCase))+ (\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+ catch = LazyS.liftCatch catch+instance MonadMask m => MonadMask (LazyS.StateT s m) where+ mask a = LazyS.StateT $ \s -> mask $ \u -> LazyS.runStateT (a $ q u) s+ 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)+ uninterruptibleMask a =+ LazyS.StateT $ \s -> uninterruptibleMask $ \u -> LazyS.runStateT (a $ q u) s+ 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 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)+ (\(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+instance MonadCatch m => MonadCatch (StrictS.StateT s m) where+ catch = StrictS.liftCatch catch+instance MonadMask m => MonadMask (StrictS.StateT s m) where+ mask a = StrictS.StateT $ \s -> mask $ \u -> StrictS.runStateT (a $ q u) s+ 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)+ uninterruptibleMask a =+ StrictS.StateT $ \s -> uninterruptibleMask $ \u -> StrictS.runStateT (a $ q u) s+ 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 use = StrictS.StateT $ \s0 -> do+ ((b, _s2), (c, s3)) <- generalBracket+ (StrictS.runStateT acquire s0)+ (\(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+instance MonadCatch m => MonadCatch (ReaderT r m) where+ catch (ReaderT m) c = ReaderT $ \r -> m r `catch` \e -> runReaderT (c e) r+instance MonadMask m => MonadMask (ReaderT r m) where+ mask a = ReaderT $ \e -> mask $ \u -> runReaderT (a $ q u) e+ where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a+ q u (ReaderT b) = ReaderT (u . b)+ uninterruptibleMask a =+ ReaderT $ \e -> uninterruptibleMask $ \u -> runReaderT (a $ q u) e+ where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a+ q u (ReaderT b) = ReaderT (u . b)++ generalBracket acquire release use = ReaderT $ \r ->+ generalBracket+ (runReaderT acquire r)+ (\resource exitCase -> runReaderT (release resource exitCase) 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+ catch (StrictW.WriterT m) h = StrictW.WriterT $ m `catch ` \e -> StrictW.runWriterT (h e)+instance (MonadMask m, Monoid w) => MonadMask (StrictW.WriterT w m) where+ mask a = StrictW.WriterT $ mask $ \u -> StrictW.runWriterT (a $ q u)+ 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)+ uninterruptibleMask a =+ StrictW.WriterT $ uninterruptibleMask $ \u -> StrictW.runWriterT (a $ q u)+ 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 use = StrictW.WriterT $ do+ ((b, _w12), (c, w123)) <- generalBracket+ (StrictW.runWriterT acquire)+ (\(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+instance (MonadCatch m, Monoid w) => MonadCatch (LazyW.WriterT w m) where+ catch (LazyW.WriterT m) h = LazyW.WriterT $ m `catch ` \e -> LazyW.runWriterT (h e)+instance (MonadMask m, Monoid w) => MonadMask (LazyW.WriterT w m) where+ mask a = LazyW.WriterT $ mask $ \u -> LazyW.runWriterT (a $ q u)+ 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)+ uninterruptibleMask a =+ LazyW.WriterT $ uninterruptibleMask $ \u -> LazyW.runWriterT (a $ q u)+ 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 use = LazyW.WriterT $ do+ ((b, _w12), (c, w123)) <- generalBracket+ (LazyW.runWriterT acquire)+ (\(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+instance (MonadCatch m, Monoid w) => MonadCatch (LazyRWS.RWST r w s m) where+ catch (LazyRWS.RWST m) h = LazyRWS.RWST $ \r s -> m r s `catch` \e -> LazyRWS.runRWST (h e) r s+instance (MonadMask m, Monoid w) => MonadMask (LazyRWS.RWST r w s m) where+ mask a = LazyRWS.RWST $ \r s -> mask $ \u -> LazyRWS.runRWST (a $ q u) r s+ 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)+ uninterruptibleMask a =+ LazyRWS.RWST $ \r s -> uninterruptibleMask $ \u -> LazyRWS.runRWST (a $ q u) r s+ 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 use = LazyRWS.RWST $ \r s0 -> do+ ((b, _s2, _w12), (c, s3, w123)) <- generalBracket+ (LazyRWS.runRWST acquire r s0)+ (\(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+instance (MonadCatch m, Monoid w) => MonadCatch (StrictRWS.RWST r w s m) where+ catch (StrictRWS.RWST m) h = StrictRWS.RWST $ \r s -> m r s `catch` \e -> StrictRWS.runRWST (h e) r s+instance (MonadMask m, Monoid w) => MonadMask (StrictRWS.RWST r w s m) where+ mask a = StrictRWS.RWST $ \r s -> mask $ \u -> StrictRWS.runRWST (a $ q u) r s+ 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)+ uninterruptibleMask a =+ StrictRWS.RWST $ \r s -> uninterruptibleMask $ \u -> StrictRWS.runRWST (a $ q u) r s+ 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 use = StrictRWS.RWST $ \r s0 -> do+ ((b, _s2, _w12), (c, s3, w123)) <- generalBracket+ (StrictRWS.runRWST acquire r s0)+ (\(resource, s1, w1) exitCase -> case exitCase of+ ExitCaseSuccess (b, s2, w12) -> do+ (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseSuccess b)) r s2+ return (c, s3, mappend w12 w3)+ -- In the two other cases, the base monad overrides @use@'s state+ -- changes and the state reverts to @s1@ and @w1@.+ ExitCaseException e -> do+ (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseException e)) r s1+ return (c, s3, mappend w1 w3)+ ExitCaseAbort -> do+ (c, s3, w3) <- StrictRWS.runRWST (release resource ExitCaseAbort) r s1+ return (c, s3, mappend w1 w3))+ (\(resource, s1, w1) -> do+ (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1+ return (a, s2, mappend w1 w2))+ return ((b, c), s3, w123)++-- | Throws exceptions into the base monad.+instance MonadThrow m => MonadThrow (MaybeT m) where+ throwM = lift . throwM+-- | Catches exceptions from the base monad.+instance MonadCatch m => MonadCatch (MaybeT m) where+ catch (MaybeT m) f = MaybeT $ catch m (runMaybeT . f)+-- | @since 0.10.0+instance MonadMask m => MonadMask (MaybeT m) where+ mask f = MaybeT $ mask $ \u -> runMaybeT $ f (q u)+ where+ q :: (m (Maybe a) -> m (Maybe a))+ -> MaybeT m a -> MaybeT m a+ q u (MaybeT b) = MaybeT (u b)+ uninterruptibleMask f = MaybeT $ uninterruptibleMask $ \u -> runMaybeT $ f (q u)+ where+ q :: (m (Maybe a) -> m (Maybe a))+ -> MaybeT m a -> MaybeT m a+ q u (MaybeT b) = MaybeT (u b)++ generalBracket acquire release use = MaybeT $ do+ (eb, ec) <- generalBracket+ (runMaybeT acquire)+ (\resourceMay exitCase -> case resourceMay of+ Nothing -> return Nothing -- nothing to release, acquire didn't succeed+ Just resource -> case exitCase of+ ExitCaseSuccess (Just b) -> runMaybeT (release resource (ExitCaseSuccess b))+ ExitCaseException e -> runMaybeT (release resource (ExitCaseException e))+ _ -> runMaybeT (release resource ExitCaseAbort))+ (\resourceMay -> case resourceMay of+ Nothing -> return Nothing+ Just resource -> runMaybeT (use resource))+ -- The order in which we perform those two 'Maybe' effects doesn't matter,+ -- since the error message is the same regardless.+ return ((,) <$> eb <*> ec)++-- | Throws exceptions into the base monad.+instance 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)+-- | @since 0.9.0+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 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 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,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+-- based on methods from the 'MonadCatch' typeclass. See+-- "Control.Exception" for API usage.+------------------------------------------------------------------------------++-- | Like 'mask', but does not pass a @restore@ action to the argument.+mask_ :: HAS_CALL_STACK => 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_ :: HAS_CALL_STACK => 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.+--+-- /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 :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) =>+ (e -> Bool) -> m a -> (e -> m a) -> m a+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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) =>+ (e -> Maybe b) -> m a -> (b -> m a) -> m a+catchJust f a b = withFrozenCallStack catch a (\e -> maybe (throwM e) b $ f e)++-- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'.+handle :: HAS_CALL_STACK => (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a+handle = flip (withFrozenCallStack catch)+{-# INLINE handle #-}++-- | Flipped 'catchIOError'+handleIOError :: HAS_CALL_STACK => MonadCatch m => (IOError -> m a) -> m a -> m a+handleIOError = withFrozenCallStack handle++-- | Flipped 'catchAll'+handleAll :: HAS_CALL_STACK => MonadCatch m => (SomeException -> m a) -> m a -> m a+handleAll = withFrozenCallStack handle++-- | Flipped 'catchIf'+handleIf :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (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 :: HAS_CALL_STACK => (MonadCatch m, Exception e) =>+ (e -> Maybe b) -> m a -> m (Either b a)+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)++instance Monad m => Functor (Handler m) where+ fmap f (Handler h) = Handler (liftM f . h)++-- | Catches different sorts of exceptions. See "Control.Exception"'s 'ControlException.catches'+catches :: HAS_CALL_STACK => (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+ probe (Handler h) xs = maybe xs h (ControlException.fromException e)++-- | Run an action only if an exception is thrown in the main action. The+-- exception is not caught, simply rethrown.+--+-- /NOTE/ The action is only run if an /exception/ is thrown. If the monad+-- supports other ways of aborting the computation, the action won't run if+-- those other kinds of errors are thrown. See 'onError'.+onException :: HAS_CALL_STACK => 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 :: HAS_CALL_STACK => 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 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 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 :: HAS_CALL_STACK => MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b+bracket acquire release = liftM fst . withFrozenCallStack generalBracket+ acquire+ (\a _exitCase -> release a)++-- | Version of 'bracket' without any value being passed to the second and+-- third actions.+bracket_ :: HAS_CALL_STACK => 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+-- error occurs.+finally :: HAS_CALL_STACK => 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 an error is+-- thrown by the in-between computation.+bracketOnError :: HAS_CALL_STACK => MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b+bracketOnError acquire release = liftM fst . withFrozenCallStack generalBracket+ acquire+ (\a exitCase -> case exitCase of+ ExitCaseSuccess _ -> return ()+ _ -> do+ _ <- release a+ return ())
src/Control/Monad/Catch/Pure.hs view
@@ -1,225 +1,225 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# 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 --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett <ekmett@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- This module supplies a \'pure\' monad transformer that can be used for --- mock-testing code that throws exceptions, so long as those exceptions --- are always thrown with 'throwM'. --- --- Do not mix 'CatchT' with 'IO'. Choose one or the other for the --- bottom of your transformer stack! --------------------------------------------------------------------- - -module Control.Monad.Catch.Pure ( - -- * Transformer - -- $transformer - CatchT(..), Catch - , runCatch - , mapCatchT - - -- * Typeclass - -- $mtl - , 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 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(..)) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Monoid (Monoid(..)) -#endif -import Data.Functor.Identity -import Data.Traversable as Traversable - ------------------------------------------------------------------------------- --- $mtl --- The mtl style typeclass ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- $transformer --- The @transformers@-style monad transfomer ------------------------------------------------------------------------------- - --- | Add 'Exception' handling abilities to a 'Monad'. --- --- This should /never/ be used in combination with 'IO'. Think of 'CatchT' --- as an alternative base monad for use with mocking code that solely throws --- exceptions via 'throwM'. --- --- Note: that 'IO' monad has these abilities already, so stacking 'CatchT' on top --- of it does not add any value and can possibly be confusing: --- --- >>> (error "Hello!" :: IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e) --- Hello! --- --- >>> runCatchT $ (error "Hello!" :: CatchT IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e) --- *** Exception: Hello! --- --- >>> runCatchT $ (throwM (ErrorCall "Hello!") :: CatchT IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e) --- Hello! - -newtype CatchT m a = CatchT { runCatchT :: m (Either SomeException a) } - -type Catch = CatchT Identity - -runCatch :: Catch a -> Either SomeException a -runCatch = runIdentity . runCatchT - -instance Monad m => Functor (CatchT m) where - fmap f (CatchT m) = CatchT (liftM (fmap f) m) - -instance Monad m => Applicative (CatchT m) where - pure a = CatchT (return (Right a)) - (<*>) = ap - -instance Monad m => Monad (CatchT m) where - return = pure - 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 - mfix f = CatchT $ mfix $ \a -> runCatchT $ f $ case a of - Right r -> r - _ -> error "empty mfix argument" - -instance Foldable m => Foldable (CatchT m) where - foldMap f (CatchT m) = foldMap (foldMapEither f) m where - foldMapEither g (Right a) = g a - foldMapEither _ (Left _) = mempty - -instance (Monad m, Traversable m) => Traversable (CatchT m) where - traverse f (CatchT m) = CatchT <$> Traversable.traverse (traverseEither f) m where - traverseEither g (Right a) = Right <$> g a - traverseEither _ (Left e) = pure (Left e) - -instance Monad m => Alternative (CatchT m) where - empty = mzero - (<|>) = mplus - -instance Monad m => MonadPlus (CatchT m) where - mzero = CatchT $ return $ Left $ toException $ userError "" - mplus (CatchT m) (CatchT n) = CatchT $ m >>= \ea -> case ea of - Left _ -> n - Right a -> return (Right a) - -instance MonadTrans CatchT where - lift m = CatchT $ do - a <- m - return $ Right a - -instance MonadIO m => MonadIO (CatchT m) where - liftIO m = CatchT $ do - a <- liftIO m - return $ Right a - -instance Monad m => MonadThrow (CatchT m) where - throwM = CatchT . return . Left . toException -instance Monad m => MonadCatch (CatchT m) where - catch (CatchT m) c = CatchT $ m >>= \ea -> case ea of - Left e -> case fromException e of - Just e' -> runCatchT (c e') - Nothing -> return (Left e) - 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 use = CatchT $ do - eresource <- runCatchT acquire - case eresource of - Left e -> return $ Left e - Right resource -> do - 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 - local f (CatchT m) = CatchT (local f m) - -instance MonadWriter w m => MonadWriter w (CatchT m) where - tell = lift . tell - listen = mapCatchT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a - pass = mapCatchT $ \ m -> pass $ do - a <- m - 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) - --- | Map the unwrapped computation using the given function. --- --- @'runCatchT' ('mapCatchT' f m) = f ('runCatchT' m)@ -mapCatchT :: (m (Either SomeException a) -> n (Either SomeException b)) - -> CatchT m a - -> CatchT n b -mapCatchT f m = CatchT $ f (runCatchT m) +{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# 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+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This module supplies a \'pure\' monad transformer that can be used for+-- mock-testing code that throws exceptions, so long as those exceptions+-- are always thrown with 'throwM'.+--+-- Do not mix 'CatchT' with 'IO'. Choose one or the other for the+-- bottom of your transformer stack!+--------------------------------------------------------------------++module Control.Monad.Catch.Pure (+ -- * Transformer+ -- $transformer+ CatchT(..), Catch+ , runCatch+ , mapCatchT++ -- * Typeclass+ -- $mtl+ , 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 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(..))+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Monoid (Monoid(..))+#endif+import Data.Functor.Identity+import Data.Traversable as Traversable++------------------------------------------------------------------------------+-- $mtl+-- The mtl style typeclass+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- $transformer+-- The @transformers@-style monad transfomer+------------------------------------------------------------------------------++-- | Add 'Exception' handling abilities to a 'Monad'.+--+-- This should /never/ be used in combination with 'IO'. Think of 'CatchT'+-- as an alternative base monad for use with mocking code that solely throws+-- exceptions via 'throwM'.+--+-- Note: that 'IO' monad has these abilities already, so stacking 'CatchT' on top+-- of it does not add any value and can possibly be confusing:+--+-- >>> (error "Hello!" :: IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e)+-- Hello!+--+-- >>> runCatchT $ (error "Hello!" :: CatchT IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e)+-- *** Exception: Hello!+--+-- >>> runCatchT $ (throwM (ErrorCall "Hello!") :: CatchT IO ()) `catch` (\(e :: ErrorCall) -> liftIO $ print e)+-- Hello!++newtype CatchT m a = CatchT { runCatchT :: m (Either SomeException a) }++type Catch = CatchT Identity++runCatch :: Catch a -> Either SomeException a+runCatch = runIdentity . runCatchT++instance Monad m => Functor (CatchT m) where+ fmap f (CatchT m) = CatchT (liftM (fmap f) m)++instance Monad m => Applicative (CatchT m) where+ pure a = CatchT (return (Right a))+ (<*>) = ap++instance Monad m => Monad (CatchT m) where+ return = pure+ 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+ mfix f = CatchT $ mfix $ \a -> runCatchT $ f $ case a of+ Right r -> r+ _ -> error "empty mfix argument"++instance Foldable m => Foldable (CatchT m) where+ foldMap f (CatchT m) = foldMap (foldMapEither f) m where+ foldMapEither g (Right a) = g a+ foldMapEither _ (Left _) = mempty++instance (Monad m, Traversable m) => Traversable (CatchT m) where+ traverse f (CatchT m) = CatchT <$> Traversable.traverse (traverseEither f) m where+ traverseEither g (Right a) = Right <$> g a+ traverseEither _ (Left e) = pure (Left e)++instance Monad m => Alternative (CatchT m) where+ empty = mzero+ (<|>) = mplus++instance Monad m => MonadPlus (CatchT m) where+ mzero = CatchT $ return $ Left $ toException $ userError ""+ mplus (CatchT m) (CatchT n) = CatchT $ m >>= \ea -> case ea of+ Left _ -> n+ Right a -> return (Right a)++instance MonadTrans CatchT where+ lift m = CatchT $ do+ a <- m+ return $ Right a++instance MonadIO m => MonadIO (CatchT m) where+ liftIO m = CatchT $ do+ a <- liftIO m+ return $ Right a++instance Monad m => MonadThrow (CatchT m) where+ throwM = CatchT . return . Left . toException+instance Monad m => MonadCatch (CatchT m) where+ catch (CatchT m) c = CatchT $ m >>= \ea -> case ea of+ Left e -> case fromException e of+ Just e' -> runCatchT (c e')+ Nothing -> return (Left e)+ 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 use = CatchT $ do+ eresource <- runCatchT acquire+ case eresource of+ Left e -> return $ Left e+ Right resource -> do+ 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+ local f (CatchT m) = CatchT (local f m)++instance MonadWriter w m => MonadWriter w (CatchT m) where+ tell = lift . tell+ listen = mapCatchT $ \ m -> do+ (a, w) <- listen m+ return $! fmap (\ r -> (r, w)) a+ pass = mapCatchT $ \ m -> pass $ do+ a <- m+ 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)++-- | Map the unwrapped computation using the given function.+--+-- @'runCatchT' ('mapCatchT' f m) = f ('runCatchT' m)@+mapCatchT :: (m (Either SomeException a) -> n (Either SomeException b))+ -> CatchT m a+ -> CatchT n b+mapCatchT f m = CatchT $ f (runCatchT m)
tests/Control/Monad/Catch/Tests.hs view
@@ -1,258 +1,258 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE CPP #-} - -#if !(MIN_VERSION_transformers(0,6,0)) -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif - -module Control.Monad.Catch.Tests (tests) where - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706) -import Prelude hiding (catch) -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<*>)) -#endif -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.Trans.Maybe (MaybeT(..)) -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, ioProperty, once) -import Test.QuickCheck.Monadic (monadic, run, assert) -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.Error (ErrorT(..)) -import Control.Monad.List (ListT(..)) -#endif - -import Control.Monad.Catch -import Control.Monad.Catch.Pure - -data TestException = TestException String - deriving (Show, Eq, Data, Typeable) - -instance Exception TestException - -data MSpec m = MSpec - { mspecName :: String - , mspecRunner :: (m Property -> Property) - } - --- 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 :: 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 - assert $ bad == ("neg", True) - where - testException (TestException s) = if s == "pos" then Just True else Nothing - posHandler x = return ("pos", x) - negHandler (_ :: TestException) = return ("neg", True) - posFailure = throwM (TestException "pos") >> error "testCatchJust pos" - negFailure = throwM (TestException "neg") >> error "testCatchJust neg" - -testDetectableEffect :: SomeDetectableEffect -> Property -testDetectableEffect (SomeDetectableEffect (DetectableEffect mspec effectDetector)) = do - monadic (mspecRunner mspec) $ do - effectWasPerformed <- run $ do - (effect, detector) <- effectDetector - _ <- runExceptT $ ExceptT (return $ Left ()) `finally` lift effect - detector - assert effectWasPerformed - -tests :: Test -tests = testGroup "Control.Monad.Catch.Tests" $ - ([ mkMonadCatch - , mkCatchJust - ] <*> mspecs) ++ - ([ mkDetectableEffect - ] <*> detectableEffects) ++ - [ testCase "ExceptT+Left" exceptTLeft - , testCase "release error wins" releaseErrorWins - ] - where - mspecs = - [ SomeMSpec mspecIO - , SomeMSpec mspecIdentityTIO - , SomeMSpec mspecLazyStateTIO - , SomeMSpec mspecStrictStateTIO - , SomeMSpec mspecReaderTIO - , SomeMSpec mspecLazyWriterTIO - , SomeMSpec mspecStrictWriterTIO - , SomeMSpec mspecLazyRWSTIO - , SomeMSpec mspecStrictRWSTIO - - , SomeMSpec mspecMaybeTIO -#if !(MIN_VERSION_transformers(0,6,0)) - , SomeMSpec mspecErrorTIO - , SomeMSpec mspecListTIO -#endif - , SomeMSpec mspecSTM - --, SomeMSpec mspecContTIO - - , 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 = ioProperty - - detectableEffects = - [ SomeDetectableEffect $ detectableEffectIO - , SomeDetectableEffect detectableEffectLazyStateTIO - , SomeDetectableEffect detectableEffectStrictStateTIO - , SomeDetectableEffect detectableEffectLazyRWSTIO - , SomeDetectableEffect detectableEffectStrictRWSTIO - ] - - 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 -> Test - mkMSpecTest name test = \someMSpec@(SomeMSpec spec) -> - testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec - - mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> Test - mkDetectableEffectTest name test = \someDetectableEffect@(SomeDetectableEffect detectableEffect) -> - let testName = name ++ " " ++ mspecName (detectableEffectMSpec detectableEffect) - in testProperty testName $ once $ test someDetectableEffect - - exceptTLeft = do - ref <- newIORef False - Left () <- runExceptT $ ExceptT (return $ Left ()) `finally` lift (writeIORef ref True) - val <- readIORef ref - unless val $ error "Looks like cleanup didn't happen" - - -- if both 'use' and 'release' abort, the 'release' error should win - releaseErrorWins = do - Left val <- runExceptT $ ExceptT (return $ Left False) `finally` ExceptT (return $ Left True) - unless val $ error "Looks like the 'use' error won" +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}++#if !(MIN_VERSION_transformers(0,6,0))+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif++module Control.Monad.Catch.Tests (tests) where++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)+import Prelude hiding (catch)+#endif++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<*>))+#endif+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.Trans.Maybe (MaybeT(..))+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, ioProperty, once)+import Test.QuickCheck.Monadic (monadic, run, assert)+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)++instance Exception TestException++data MSpec m = MSpec+ { mspecName :: String+ , mspecRunner :: (m Property -> Property)+ }++-- 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 :: 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+ assert $ bad == ("neg", True)+ where+ testException (TestException s) = if s == "pos" then Just True else Nothing+ posHandler x = return ("pos", x)+ negHandler (_ :: TestException) = return ("neg", True)+ posFailure = throwM (TestException "pos") >> error "testCatchJust pos"+ negFailure = throwM (TestException "neg") >> error "testCatchJust neg"++testDetectableEffect :: SomeDetectableEffect -> Property+testDetectableEffect (SomeDetectableEffect (DetectableEffect mspec effectDetector)) = do+ monadic (mspecRunner mspec) $ do+ effectWasPerformed <- run $ do+ (effect, detector) <- effectDetector+ _ <- runExceptT $ ExceptT (return $ Left ()) `finally` lift effect+ detector+ assert effectWasPerformed++tests :: Test+tests = testGroup "Control.Monad.Catch.Tests" $+ ([ mkMonadCatch+ , mkCatchJust+ ] <*> mspecs) +++ ([ mkDetectableEffect+ ] <*> detectableEffects) +++ [ testCase "ExceptT+Left" exceptTLeft+ , testCase "release error wins" releaseErrorWins+ ]+ where+ mspecs =+ [ SomeMSpec mspecIO+ , SomeMSpec mspecIdentityTIO+ , SomeMSpec mspecLazyStateTIO+ , SomeMSpec mspecStrictStateTIO+ , SomeMSpec mspecReaderTIO+ , SomeMSpec mspecLazyWriterTIO+ , SomeMSpec mspecStrictWriterTIO+ , SomeMSpec mspecLazyRWSTIO+ , SomeMSpec mspecStrictRWSTIO++ , SomeMSpec mspecMaybeTIO+#if !(MIN_VERSION_transformers(0,6,0))+ , SomeMSpec mspecErrorTIO+ , SomeMSpec mspecListTIO+#endif+ , SomeMSpec mspecSTM+ --, SomeMSpec mspecContTIO++ , 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 = ioProperty++ detectableEffects =+ [ SomeDetectableEffect $ detectableEffectIO+ , SomeDetectableEffect detectableEffectLazyStateTIO+ , SomeDetectableEffect detectableEffectStrictStateTIO+ , SomeDetectableEffect detectableEffectLazyRWSTIO+ , SomeDetectableEffect detectableEffectStrictRWSTIO+ ]++ 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 -> Test+ mkMSpecTest name test = \someMSpec@(SomeMSpec spec) ->+ testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec++ mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> Test+ mkDetectableEffectTest name test = \someDetectableEffect@(SomeDetectableEffect detectableEffect) ->+ let testName = name ++ " " ++ mspecName (detectableEffectMSpec detectableEffect)+ in testProperty testName $ once $ test someDetectableEffect++ exceptTLeft = do+ ref <- newIORef False+ Left () <- runExceptT $ ExceptT (return $ Left ()) `finally` lift (writeIORef ref True)+ val <- readIORef ref+ unless val $ error "Looks like cleanup didn't happen"++ -- if both 'use' and 'release' abort, the 'release' error should win+ releaseErrorWins = do+ Left val <- runExceptT $ ExceptT (return $ Left False) `finally` ExceptT (return $ Left True)+ unless val $ error "Looks like the 'use' error won"
tests/Tests.hs view
@@ -1,10 +1,10 @@-module Main where - -import Test.Framework (defaultMain) - -import qualified Control.Monad.Catch.Tests - -main :: IO () -main = defaultMain - [ Control.Monad.Catch.Tests.tests - ] +module Main where++import Test.Framework (defaultMain)++import qualified Control.Monad.Catch.Tests++main :: IO ()+main = defaultMain+ [ Control.Monad.Catch.Tests.tests+ ]