exceptions-0.10.4/0000755000000000000000000000000007346545000012146 5ustar0000000000000000exceptions-0.10.4/.ghci0000755000000000000000000000010707346545000013062 0ustar0000000000000000:set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h exceptions-0.10.4/.gitignore0000755000000000000000000000047707346545000014151 0ustar0000000000000000dist 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-install GNUmakefile ghc.mk exceptions-0.10.4/.travis.yml0000755000000000000000000003061607346545000014270 0ustar0000000000000000# This Travis job script has been generated by a script via # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.9.20191213 # version: ~> 1.0 language: c os: linux dist: xenial git: # whether to recursively clone submodules submodules: false notifications: irc: channels: - irc.freenode.org#haskell-lens skip_join: true template: - "\"\\x0313exceptions\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store - $HOME/.hlint before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage jobs: include: - compiler: ghc-8.10.1 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.0"]}} os: linux - compiler: ghc-8.8.1 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}} os: linux - compiler: ghc-8.6.5 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} os: linux - compiler: ghc-8.4.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} os: linux - compiler: ghc-8.2.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} os: linux - compiler: ghc-8.0.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} os: linux - compiler: ghc-7.10.3 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.0"]}} os: linux - compiler: ghc-7.8.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.0"]}} os: linux - compiler: ghc-7.6.3 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.0"]}} os: linux - compiler: ghc-7.4.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.0"]}} os: linux - compiler: ghc-7.2.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.2.2","cabal-install-3.0"]}} os: linux - compiler: ghc-7.0.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.0.4","cabal-install-3.0"]}} os: linux allow_failures: - compiler: ghc-7.0.4 - compiler: ghc-7.2.2 - compiler: ghc-8.10.1 before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - TOP=$(pwd) - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER - CABAL="$CABAL -vnormal+nowrap+markoutput" - set -o pipefail - | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk echo 'BEGIN { state = "output"; }' >> .colorful.awk echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk echo ' if (state == "cabal") {' >> .colorful.awk echo ' print blue($0)' >> .colorful.awk echo ' } else {' >> .colorful.awk echo ' print $0' >> .colorful.awk echo ' }' >> .colorful.awk echo '}' >> .colorful.awk - cat .colorful.awk - | color_cabal_output () { awk -f $TOP/.colorful.awk } - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - HEADHACKAGE=false - if [ $HCNUMVER -ge 81000 ] ; then HEADHACKAGE=true ; fi - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config echo "remote-build-reporting: anonymous" >> $CABALHOME/config echo "write-ghc-environment-files: always" >> $CABALHOME/config echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config echo "world-file: $CABALHOME/world" >> $CABALHOME/config echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config echo "installdir: $CABALHOME/bin" >> $CABALHOME/config echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config echo "store-dir: $CABALHOME/store" >> $CABALHOME/config echo "install-dirs user" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config echo " secure: True" >> $CABALHOME/config echo " key-threshold: 3" >> $CABALHOME/config echo " root-keys:" >> $CABALHOME/config echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config - | if $HEADHACKAGE; then echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config echo " secure: True" >> $CABALHOME/config echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config echo " key-threshold: 3" >> $CABALHOME/config fi - | echo "program-default-options" >> $CABALHOME/config echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ." >> cabal.project - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(exceptions)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - PKGDIR_exceptions="$(find . -maxdepth 1 -type d -regex '.*/exceptions-[0-9.]*')" # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ${PKGDIR_exceptions}" >> cabal.project - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(exceptions)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building with tests and benchmarks... # build & run tests, build benchmarks - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # Testing... - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # cabal check... - (cd ${PKGDIR_exceptions} && ${CABAL} -vnormal check) # haddock... - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output # REGENDATA ("0.9.20191213",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) # EOF exceptions-0.10.4/.vim.custom0000755000000000000000000000137707346545000014266 0ustar0000000000000000" 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 :exec ":!hasktags -x -c --ignore src" " 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" exceptions-0.10.4/AUTHORS.markdown0000755000000000000000000000013007346545000015034 0ustar0000000000000000`exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero). exceptions-0.10.4/CHANGELOG.markdown0000755000000000000000000000532707346545000015213 0ustar00000000000000000.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 exceptions-0.10.4/LICENSE0000644000000000000000000000271307346545000013156 0ustar0000000000000000Copyright 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. exceptions-0.10.4/README.markdown0000755000000000000000000000107707346545000014657 0ustar0000000000000000exceptions ========== [![Hackage](https://img.shields.io/hackage/v/exceptions.svg)](https://hackage.haskell.org/package/exceptions) [![Build Status](https://secure.travis-ci.org/ekmett/exceptions.png?branch=master)](http://travis-ci.org/ekmett/exceptions) 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-0.10.4/Setup.lhs0000644000000000000000000000016507346545000013760 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain exceptions-0.10.4/exceptions.cabal0000644000000000000000000000517407346545000015322 0ustar0000000000000000name: exceptions category: Control, Exceptions, Monad version: 0.10.4 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett 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.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 , GHC == 8.10.1 synopsis: Extensible optionally-pure exceptions description: Extensible optionally-pure exceptions. extra-source-files: .travis.yml .ghci .gitignore .vim.custom travis/cabal-apt-install travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/exceptions.git flag transformers-0-4 description: Use @transformers-0.4@ or later. default: True library build-depends: base >= 4.3 && < 5, stm >= 2.2 && < 3, template-haskell >= 2.2 && < 2.17, mtl >= 2.0 && < 2.3 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* if flag(transformers-0-4) build-depends: transformers >= 0.4 && < 0.6 else build-depends: transformers >= 0.2 && < 0.4, transformers-compat >= 0.3 && < 0.7 exposed-modules: Control.Monad.Catch Control.Monad.Catch.Pure ghc-options: -Wall -fwarn-tabs -O2 hs-source-dirs: src test-suite exceptions-tests main-is: Tests.hs other-modules: Control.Monad.Catch.Tests hs-source-dirs: tests ghc-options: -Wall -fwarn-tabs 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.14 if flag(transformers-0-4) build-depends: transformers >= 0.4 && < 0.6 else build-depends: transformers >= 0.2 && < 0.4, transformers-compat >= 0.3 && < 0.7 exceptions-0.10.4/src/Control/Monad/0000755000000000000000000000000007346545000015413 5ustar0000000000000000exceptions-0.10.4/src/Control/Monad/Catch.hs0000644000000000000000000011456207346545000017002 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} #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 {-# OPTIONS_GHC -fno-warn-deprecations #-} -------------------------------------------------------------------- -- | -- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012 -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- 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 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.List (ListT(..), runListT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Identity import Control.Monad.Reader as Reader import 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 ------------------------------------------------------------------------------ -- $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 :: 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 :: 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 overriden by the deeper layers. -- For example, @StateT s Maybe a@ represents a value of type @s -> Maybe (a, -- s)@, so if an error thrown from @f@ causes this function to return @Nothing@, -- any changes to the state which @f@ also performed will be erased. As a -- result, @g@ will see the state as it was before @f@. Once @g@ completes, -- @f@'s error will be rethrown, so @g@' state changes will be erased as well. -- This is the normal interaction between effects in a monad transformer stack. -- -- By contrast, 's -- version of 'finally' always discards all of @g@'s non-IO effects, and @g@ -- never sees any of @f@'s non-IO effects, regardless of the layer ordering and -- regardless of whether @f@ throws an error. This is not the result of -- interacting effects, but a consequence of @MonadBaseControl@'s approach. class MonadCatch m => MonadMask m where -- | Runs an action with asynchronous exceptions disabled. The action is -- provided a method for restoring the async. environment to what it was -- at the 'mask' call. See "Control.Exception"'s 'ControlException.mask'. mask :: ((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 :: ((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 :: 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) -- 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) -- | 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 (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) -- | 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 ------------------------------------------------------------------------------ -- $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_ :: MonadMask m => m a -> m a mask_ io = mask $ \_ -> io -- | Like 'uninterruptibleMask', but does not pass a @restore@ action to the -- argument. uninterruptibleMask_ :: MonadMask m => m a -> m a uninterruptibleMask_ io = uninterruptibleMask $ \_ -> 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 :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchAll = catch -- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too -- general, but better than using 'catchAll'. See 'catchIf' for an easy way -- of catching specific 'IOError's based on the predicates in "System.IO.Error". catchIOError :: MonadCatch m => m a -> (IOError -> m a) -> m a catchIOError = catch -- | Catch exceptions only if they pass some predicate. Often useful with the -- predicates for testing 'IOError' values in "System.IO.Error". catchIf :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> (e -> m a) -> m a catchIf f a b = a `catch` \e -> if f e then b e else throwM e -- | A more generalized way of determining which exceptions to catch at -- run time. catchJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e -- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'. handle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a handle = flip catch {-# INLINE handle #-} -- | Flipped 'catchIOError' handleIOError :: MonadCatch m => (IOError -> m a) -> m a -> m a handleIOError = handle -- | Flipped 'catchAll' handleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a handleAll = handle -- | Flipped 'catchIf' handleIf :: (MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a handleIf f = flip (catchIf f) -- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'. handleJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a handleJust f = flip (catchJust f) {-# INLINE handleJust #-} -- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s -- 'Control.Exception.try'. try :: (MonadCatch m, Exception e) => m a -> m (Either e a) try a = catch (Right `liftM` a) (return . Left) -- | A variant of 'try' that takes an exception predicate to select -- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust' tryJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a) tryJust f a = 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 :: (Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a catches a hs = a `catch` 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 :: MonadCatch m => m a -> m b -> m a onException action handler = action `catchAll` \e -> handler >> throwM e -- | Run an action only if an error is thrown in the main action. Unlike -- 'onException', this works with every kind of error, not just exceptions. For -- example, if @f@ is an 'ExceptT' computation which aborts with a 'Left', the -- computation @onError f g@ will execute @g@, while @onException f g@ will not. -- -- This distinction is only meaningful for monads which have multiple exit -- points, such as 'Except' and 'MaybeT'. For monads that only have a single -- exit point, there is no difference between 'onException' and 'onError', -- except that 'onError' has a more constrained type. -- -- @since 0.10.0 onError :: MonadMask m => m a -> m b -> m a onError action handler = bracketOnError (return ()) (const handler) (const action) -- | Generalized abstracted pattern of safe resource acquisition and release -- in the face of 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 :: MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b bracket acquire release = liftM fst . generalBracket acquire (\a _exitCase -> release a) -- | Version of 'bracket' without any value being passed to the second and -- third actions. bracket_ :: MonadMask m => m a -> m c -> m b -> m b bracket_ before after action = bracket before (const after) (const action) -- | Perform an action with a finalizer action that is run, even if an -- error occurs. finally :: MonadMask m => m a -> m b -> m a finally action finalizer = bracket_ (return ()) finalizer action -- | Like 'bracket', but only performs the final action if an error is -- thrown by the in-between computation. bracketOnError :: MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b bracketOnError acquire release = liftM fst . generalBracket acquire (\a exitCase -> case exitCase of ExitCaseSuccess _ -> return () _ -> do _ <- release a return ()) exceptions-0.10.4/src/Control/Monad/Catch/0000755000000000000000000000000007346545000016435 5ustar0000000000000000exceptions-0.10.4/src/Control/Monad/Catch/Pure.hs0000644000000000000000000001531607346545000017712 0ustar0000000000000000{-# 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 -- 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.Reader as Reader import Control.Monad.RWS #if __GLASGOW_HASKELL__ < 710 import Data.Foldable #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) exceptions-0.10.4/tests/Control/Monad/Catch/0000755000000000000000000000000007346545000017010 5ustar0000000000000000exceptions-0.10.4/tests/Control/Monad/Catch/Tests.hs0000644000000000000000000002210107346545000020442 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} module Control.Monad.Catch.Tests (tests) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706) import Prelude hiding (catch) #endif import Control.Applicative ((<*>)) import Control.Monad (unless) import Data.Data (Data, Typeable) import Data.IORef (newIORef, writeIORef, readIORef) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Reader (ReaderT(..)) import Control.Monad.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Error (ErrorT(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.STM (STM, atomically) --import Control.Monad.Cont (ContT(..)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Property, once) import Test.QuickCheck.Monadic (monadic, run, assert) import Test.QuickCheck.Property (morallyDubiousIOProperty) 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 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 mspecListTIO , SomeMSpec mspecMaybeTIO , SomeMSpec mspecErrorTIO , 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 mspecListTIO :: MSpec (ListT IO) mspecListTIO = MSpec "ListT IO" $ \m -> io $ fmap (\[x] -> x) (runListT m) mspecMaybeTIO :: MSpec (MaybeT IO) mspecMaybeTIO = MSpec "MaybeT IO" $ \m -> io $ fmap (maybe undefined id) (runMaybeT m) mspecErrorTIO :: MSpec (ErrorT String IO) mspecErrorTIO = MSpec "ErrorT IO" $ \m -> io $ fmap (either error id) (runErrorT m) mspecSTM :: MSpec STM mspecSTM = MSpec "STM" $ io . atomically --mspecContTIO :: MSpec (ContT () IO) --mspecContTIO = MSpec "ContT IO" $ \m -> io $ runContT m return mspecCatchTIdentity :: MSpec Catch mspecCatchTIdentity = MSpec "Catch" $ fromRight . runCatch mspecEitherSomeException :: MSpec (Either SomeException) mspecEitherSomeException = MSpec "Either SomeException" fromRight tfst :: (Property, ()) -> Property = fst fromRight (Left _) = error "fromRight" fromRight (Right a) = a io = morallyDubiousIOProperty detectableEffects = [ SomeDetectableEffect $ detectableEffectIO , SomeDetectableEffect detectableEffectLazyStateTIO , SomeDetectableEffect detectableEffectStrictStateTIO , SomeDetectableEffect detectableEffectLazyRWSTIO , SomeDetectableEffect detectableEffectStrictRWSTIO ] detectableEffectIO :: DetectableEffect IO detectableEffectIO = DetectableEffect mspecIO $ do ref <- newIORef False return (writeIORef ref True, readIORef ref) detectableEffectLazyStateTIO :: DetectableEffect (LazyState.StateT Bool IO) detectableEffectLazyStateTIO = DetectableEffect mspecLazyStateTIO $ do LazyState.put False return (LazyState.put True, LazyState.get) detectableEffectStrictStateTIO :: DetectableEffect (StrictState.StateT Bool IO) detectableEffectStrictStateTIO = DetectableEffect mspecStrictStateTIO $ do StrictState.put False return (StrictState.put True, StrictState.get) detectableEffectLazyRWSTIO :: DetectableEffect (LazyRWS.RWST () () Bool IO) detectableEffectLazyRWSTIO = DetectableEffect mspecLazyRWSTIO $ do LazyRWS.put False return (LazyRWS.put True, LazyRWS.get) detectableEffectStrictRWSTIO :: DetectableEffect (StrictRWS.RWST () () Bool IO) detectableEffectStrictRWSTIO = DetectableEffect mspecStrictRWSTIO $ do StrictRWS.put False return (StrictRWS.put True, StrictRWS.get) mkMonadCatch = mkMSpecTest "MonadCatch" testMonadCatch mkCatchJust = mkMSpecTest "catchJust" testCatchJust mkDetectableEffect = mkDetectableEffectTest "effect during release" testDetectableEffect mkMSpecTest :: String -> (SomeMSpec -> Property) -> SomeMSpec -> Test mkMSpecTest name test = \someMSpec@(SomeMSpec spec) -> testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> Test mkDetectableEffectTest name test = \someDetectableEffect@(SomeDetectableEffect detectableEffect) -> let testName = name ++ " " ++ mspecName (detectableEffectMSpec detectableEffect) in testProperty testName $ once $ test someDetectableEffect exceptTLeft = do ref <- newIORef False Left () <- runExceptT $ ExceptT (return $ Left ()) `finally` lift (writeIORef ref True) val <- readIORef ref unless val $ error "Looks like cleanup didn't happen" -- if both 'use' and 'release' abort, the 'release' error should win releaseErrorWins = do Left val <- runExceptT $ ExceptT (return $ Left False) `finally` ExceptT (return $ Left True) unless val $ error "Looks like the 'use' error won" exceptions-0.10.4/tests/0000755000000000000000000000000007346545000013310 5ustar0000000000000000exceptions-0.10.4/tests/Tests.hs0000644000000000000000000000026107346545000014745 0ustar0000000000000000module Main where import Test.Framework (defaultMain) import qualified Control.Monad.Catch.Tests main :: IO () main = defaultMain [ Control.Monad.Catch.Tests.tests ] exceptions-0.10.4/travis/0000755000000000000000000000000007346545000013456 5ustar0000000000000000exceptions-0.10.4/travis/cabal-apt-install0000755000000000000000000000127207346545000016676 0ustar0000000000000000#! /bin/bash set -eu APT="sudo apt-get -q -y" CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" $APT update $APT install dctrl-tools # Find potential system packages to satisfy cabal dependencies deps() { local M='^\([^ ]\+\)-[0-9.]\+ (.*$' local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ | sed -ne "s/$M/$G/p" | sort -u)" grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u } $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage if ! $APT install hlint ; then $APT install $(deps hlint) cabal install hlint fi exceptions-0.10.4/travis/config0000755000000000000000000000120607346545000014650 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global