.ghci

+:set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h

.github/workflows/haskell-ci.yml

+# This GitHub workflow config has been generated by a script via
+#
+#   haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.19.20250216
+#
+# REGENDATA ("0.19.20250216",["github","--config=cabal.haskell-ci","cabal.project"])
+#
+name: Haskell-CI
+on:
+  - push
+  - pull_request
+jobs:
+  linux:
+    name: Haskell-CI - Linux - ${{ matrix.compiler }}
+    runs-on: ubuntu-24.04
+    timeout-minutes:
+      60
+    container:
+      image: buildpack-deps:jammy
+    continue-on-error: ${{ matrix.allow-failure }}
+    strategy:
+      matrix:
+        include:
+          - compiler: ghc-9.12.1
+            compilerKind: ghc
+            compilerVersion: 9.12.1
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.10.1
+            compilerKind: ghc
+            compilerVersion: 9.10.1
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.8.4
+            compilerKind: ghc
+            compilerVersion: 9.8.4
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.6.6
+            compilerKind: ghc
+            compilerVersion: 9.6.6
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.4.8
+            compilerKind: ghc
+            compilerVersion: 9.4.8
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.2.8
+            compilerKind: ghc
+            compilerVersion: 9.2.8
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.0.2
+            compilerKind: ghc
+            compilerVersion: 9.0.2
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.10.7
+            compilerKind: ghc
+            compilerVersion: 8.10.7
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.8.4
+            compilerKind: ghc
+            compilerVersion: 8.8.4
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.6.5
+            compilerKind: ghc
+            compilerVersion: 8.6.5
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.4.4
+            compilerKind: ghc
+            compilerVersion: 8.4.4
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.2.2
+            compilerKind: ghc
+            compilerVersion: 8.2.2
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.0.2
+            compilerKind: ghc
+            compilerVersion: 8.0.2
+            setup-method: ghcup
+            allow-failure: false
+      fail-fast: false
+    steps:
+      - name: apt-get install
+        run: |
+          apt-get update
+          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
+      - name: Install GHCup
+        run: |
+          mkdir -p "$HOME/.ghcup/bin"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
+          chmod a+x "$HOME/.ghcup/bin/ghcup"
+      - name: Install cabal-install
+        run: |
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+      - name: Install GHC (GHCup)
+        if: matrix.setup-method == 'ghcup'
+        run: |
+          "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: Set PATH and environment variables
+        run: |
+          echo "$HOME/.cabal/bin" >> $GITHUB_PATH
+          echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
+          echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
+          echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
+          HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
+          echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
+          echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
+          echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
+          echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+          echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: env
+        run: |
+          env
+      - name: write cabal config
+        run: |
+          mkdir -p $CABAL_DIR
+          cat >> $CABAL_CONFIG <<EOF
+          remote-build-reporting: anonymous
+          write-ghc-environment-files: never
+          remote-repo-cache: $CABAL_DIR/packages
+          logs-dir:          $CABAL_DIR/logs
+          world-file:        $CABAL_DIR/world
+          extra-prog-path:   $CABAL_DIR/bin
+          symlink-bindir:    $CABAL_DIR/bin
+          installdir:        $CABAL_DIR/bin
+          build-summary:     $CABAL_DIR/logs/build.log
+          store-dir:         $CABAL_DIR/store
+          install-dirs user
+            prefix: $CABAL_DIR
+          repository hackage.haskell.org
+            url: http://hackage.haskell.org/
+          EOF
+          cat >> $CABAL_CONFIG <<EOF
+          program-default-options
+            ghc-options: $GHCJOBS +RTS -M3G -RTS
+          EOF
+          cat $CABAL_CONFIG
+      - name: versions
+        run: |
+          $HC --version || true
+          $HC --print-project-git-commit-id || true
+          $CABAL --version || true
+      - name: update cabal index
+        run: |
+          $CABAL v2-update -v
+      - name: install cabal-plan
+        run: |
+          mkdir -p $HOME/.cabal/bin
+          curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
+          echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2  cabal-plan.xz' | sha256sum -c -
+          xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
+          rm -f cabal-plan.xz
+          chmod a+x $HOME/.cabal/bin/cabal-plan
+          cabal-plan --version
+      - name: checkout
+        uses: actions/checkout@v4
+        with:
+          path: source
+      - name: initial cabal.project for sdist
+        run: |
+          touch cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
+          cat cabal.project
+      - name: sdist
+        run: |
+          mkdir -p sdist
+          $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
+      - name: unpack
+        run: |
+          mkdir -p unpacked
+          find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
+      - name: generate cabal.project
+        run: |
+          PKGDIR_exceptions="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/exceptions-[0-9.]*')"
+          echo "PKGDIR_exceptions=${PKGDIR_exceptions}" >> "$GITHUB_ENV"
+          rm -f cabal.project cabal.project.local
+          touch cabal.project
+          touch cabal.project.local
+          echo "packages: ${PKGDIR_exceptions}" >> cabal.project
+          if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package exceptions" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "    ghc-options: -Werror=missing-methods" >> cabal.project ; fi
+          cat >> cabal.project <<EOF
+          EOF
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(exceptions)$/; }' >> cabal.project.local
+          cat cabal.project
+          cat cabal.project.local
+      - name: dump install plan
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
+          cabal-plan
+      - name: restore cache
+        uses: actions/cache/restore@v4
+        with:
+          key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+          path: ~/.cabal/store
+          restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
+      - name: install dependencies
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
+      - name: build
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
+      - name: tests
+        run: |
+          $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
+      - name: cabal check
+        run: |
+          cd ${PKGDIR_exceptions} || false
+          ${CABAL} -vnormal check
+      - name: haddock
+        run: |
+          $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
+      - name: save cache
+        if: always()
+        uses: actions/cache/save@v4
+        with:
+          key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+          path: ~/.cabal/store

.gitignore

+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
+
+# MHS
+dist-mcabal

.vim.custom

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

+`exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero).

CHANGELOG.markdown

+next [????.??.??]
+-----------------
+* Add `Monad{Throw,Catch,Mask}` instances for `AccumT` when building with
+  `transformers-0.5.6` or later.
+
+0.10.11 [2025.10.13]
+--------------------
+* Add a `rethrowM` method to the `MonadThrow` class and a `catchNoPropagate`
+  method to the `MonadCatch` class, which are available when building with
+  `base-4.21` (GHC 9.12) or later. These are like `throwM` and `catch`,
+  respectively (and use them as their default implementations), but these
+  methods do not add new backtraces (for `rethrowM`) or annotate the handler
+  with the exception that was caught (for `catchNoPropagate`).
+* Support building with MicroHs.
+
+0.10.10 [2025.06.17]
+--------------------
+* Replace `test-framework` with `tasty` in the test suite.
+
+0.10.9 [2024.10.31]
+-------------------
+* Drop support for pre-8.0 versions of GHC.
+
+0.10.8 [2024.04.20]
+-------------------
+* Allow building with `template-haskell-2.22.*`.
+* Make the test suite build with GHC 9.4 and `mtl-2.3.1`.
+
+0.10.7 [2022.12.04]
+-------------------
+* On pre-8.0 GHCs, drop the `call-stack` dependency. This dependency was
+  introduced in `exceptions-0.10.6`, but it induced breakage in libraries
+  that derived instances of `MonadThrow`, `MonadCatch`, or `MonadMask` for
+  newtypes without first enabling `ConstraintKinds` and `FlexibleContexts`.
+  (Later versions of GHC do not require these language extensions for derived
+  instances, so only old GHCs were affected.) To avoid breakage, `exceptions`
+  no longer uses `HasCallStack` constraints on pre-8.0 versions of GHC.
+
+  Note that `exceptions` still uses `HasCallStack` constraints on GHC 8.0 and
+  later, and as a result, these versions of GHC are unaffected by this change.
+
+0.10.6 [2022.11.30]
+-------------------
+* The class methods and functions in `Control.Monad.Catch` now have
+  `HasCallStack` constraints.
+* Drop support for GHC 7.0 and 7.2.
+
+0.10.5 [2022.05.07]
+-------------------
+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.
+
+0.10.4 [2019.12.26]
+-------------------
+* Allow building with `template-haskell-2.16.*`.
+* Only depend on `transformers-compat` on old versions of GHC.
+
+0.10.3 [2019.08.27]
+-------------------
+* `MonadThrow` instance for the strict `ST` monad.
+
+0.10.2 [2019.05.02]
+-------------------
+* Allow building with `base-4.13`/`template-haskell-2.15`.
+
+0.10.1 [2019.03.26]
+-------------------
+* Define a `MonadFail` instance for `CatchT`.
+* Allow `QuickCheck-2.13` in the test suite.
+
+0.10.0
+------
+* Fix a regression in 0.9.0 whereby the non-IO effects in `bracket`'s `use`
+  action were not visible to the `release` action, and the non-IO effects in the
+  `release` action were not visible after the `bracket` call.
+* The type of `generalBracket` was changed in order to restore those non-IO
+  effects, so if you are a library author that provides a `MonadMask` instance,
+  you will need to update your implementation of this method.
+* Add `MonadMask` instance for `MaybeT`
+* Add `onError` function whose action also runs on errors which are not
+  exceptions, such as a `Nothing` or a `Left`.
+
+0.9.0
+-----
+* Add `generalBracket` to the `MonadMask` typeclass, allowing more
+  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

+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

+exceptions
+==========
+
+[![Hackage](https://img.shields.io/hackage/v/exceptions.svg)](https://hackage.haskell.org/package/exceptions) [![Build Status](https://github.com/ekmett/exceptions/workflows/Haskell-CI/badge.svg)](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

+#!/usr/bin/runhaskell
+> module Main (main) where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

cabal.haskell-ci

+distribution:           jammy
+no-tests-no-benchmarks: False
+unconstrained:          False
+-- irc-channels:           irc.freenode.org#haskell-lens
+irc-if-in-origin-repo:  True

cabal.project

+packages: .

exceptions.cabal

+name:          exceptions
+category:      Control, Exceptions, Monad
+version:       0.10.11
+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 == 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.6
+             , GHC == 9.8.4
+             , GHC == 9.10.1
+             , GHC == 9.12.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
+
+library
+  build-depends:
+    base                       >= 4.9      && < 5,
+    mtl                        >= 2.2      && < 2.4,
+    stm                        >= 2.2      && < 3,
+    transformers               >= 0.5.2.0  && < 0.7
+  if impl(ghc)
+    build-depends:
+      template-haskell         >= 2.11     && < 2.25
+
+  exposed-modules:
+    Control.Monad.Catch
+    Control.Monad.Catch.Pure
+
+  ghc-options: -Wall -Wtabs -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 -Wtabs
+  default-language: Haskell2010
+  type: exitcode-stdio-1.0
+  build-depends:
+    base,
+    exceptions,
+    mtl,
+    stm,
+    template-haskell,
+    transformers     >= 0.5.2.0 && < 0.7,
+    tasty            >= 1.4     && < 1.6,
+    tasty-hunit      >= 0.10    && < 0.11,
+    tasty-quickcheck >= 0.10    && < 0.12,
+    QuickCheck       >= 2.5     && < 2.18

src/Control/Monad/Catch.hs

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if !MIN_VERSION_transformers(0,6,0)
+{-# OPTIONS_GHC -Wno-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 'ExceptT' and 'MonadError', but based on features of
+-- "Control.Exception". In particular, it handles the complex case of
+-- asynchronous exceptions by including 'mask' in the typeclass. Note that the
+-- extensible exceptions feature relies on the RankNTypes language extension.
+--------------------------------------------------------------------
+
+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.ST.Unsafe (unsafeIOToST)
+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 GHC.Stack (HasCallStack, withFrozenCallStack)
+
+#if defined(__MHS__)
+import Prelude hiding(foldr)
+import Data.Foldable
+#else
+import Language.Haskell.TH.Syntax (Q)
+#endif
+
+#if MIN_VERSION_transformers(0,5,6)
+import Control.Monad.Trans.Accum (AccumT (..), runAccumT, evalAccumT)
+#endif
+
+#if !MIN_VERSION_transformers(0,6,0)
+import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT)
+import Control.Monad.Trans.List (ListT(..), runListT)
+#endif
+
+------------------------------------------------------------------------------
+-- $mtl
+-- The mtl style typeclass
+------------------------------------------------------------------------------
+
+-- | 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 :: (HasCallStack, Exception e) => e -> m a
+
+#if MIN_VERSION_base(4,21,0)
+  -- | A utility to use when rethrowing exceptions, no new backtrace will be
+  -- attached when rethrowing an exception but you must supply the existing
+  -- context.
+  --
+  -- It is a generalization of "Control.Exception"'s
+  -- 'ControlException.rethrowIO' and is only defined using @base-4.21@ (GHC
+  -- 9.12) or later.
+  rethrowM :: Exception e => ControlException.ExceptionWithContext e -> m a
+  rethrowM = throwM
+#endif
+
+-- | A class for monads which allow exceptions to be caught, in particular
+-- exceptions which were thrown by 'throwM'.
+--
+-- 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 :: (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
+#if MIN_VERSION_base(4,21,0)
+  -- | A variant of 'catch' which doesn't annotate the handler with the exception
+  -- which was caught. This function should be used when you are implementing
+  -- your own error handling functions which may rethrow the exceptions.
+  --
+  -- In the case where you rethrow an exception without modifying it, you
+  -- should rethrow the exception with the old exception context.
+  --
+  -- It is a generalization of "Control.Exception"'s
+  -- 'ControlException.catchNoPropagate' and is only defined using @base-4.21@
+  -- (GHC 9.12) or later.
+  catchNoPropagate :: Exception e => m a -> (ControlException.ExceptionWithContext e -> m a) -> m a
+  catchNoPropagate = catch
+#endif
+
+-- | A class for monads which provide for the ability to account for
+-- all possible exit points from a computation, and to mask
+-- asynchronous exceptions. Continuation-based monads are invalid
+-- instances of this class.
+--
+-- 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 :: HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
+
+  -- | Like 'mask', but the masked computation is not interruptible (see
+  -- "Control.Exception"'s 'ControlException.uninterruptibleMask'. WARNING:
+  -- 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 :: HasCallStack => ((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
+    :: HasCallStack
+    => 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
+#if !defined(__MHS__)
+instance MonadThrow Q where
+  throwM = fail . show
+#endif
+
+instance MonadThrow IO where
+  throwM = ControlException.throwIO
+#if MIN_VERSION_base(4,21,0)
+  rethrowM = ControlException.rethrowIO
+#endif
+instance MonadCatch IO where
+  catch = ControlException.catch
+#if MIN_VERSION_base(4,21,0)
+  catchNoPropagate = ControlException.catchNoPropagate
+#endif
+instance MonadMask IO where
+  mask = ControlException.mask
+  uninterruptibleMask = ControlException.uninterruptibleMask
+
+
+#if MIN_VERSION_base(4,21,0)
+  generalBracket acquire release use = mask $ \unmasked -> do
+    resource <- acquire
+
+    b <- unmasked (use resource) `catchNoPropagate` \e -> do
+      _ <- release resource (ExitCaseException $ ControlException.toException e)
+      rethrowM @IO @SomeException e
+    c <- release resource (ExitCaseSuccess b)
+    return (b, c)
+#else
+  generalBracket acquire release use = mask $ \unmasked -> do
+    resource <- acquire
+
+    b <- unmasked (use resource) `catch` \e -> do
+      _ <- release resource (ExitCaseException e)
+      throwM e
+    c <- release resource (ExitCaseSuccess b)
+    return (b, c)
+#endif
+
+instance MonadThrow (ST s) where
+  throwM = unsafeIOToST . ControlException.throwIO
+#if MIN_VERSION_base(4,21,0)
+  rethrowM = unsafeIOToST . ControlException.rethrowIO
+#endif
+
+instance MonadThrow STM where
+  throwM = STM.throwSTM
+instance MonadCatch STM where
+  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,5,6)
+instance (Monoid w, MonadThrow m) => MonadThrow (AccumT w m) where
+  throwM = lift . throwM
+
+instance (MonadCatch m, Monoid w) => MonadCatch (AccumT w m) where
+  catch (AccumT m) f = AccumT $ \w -> catch (m w) $ \e -> runAccumT (f e) w
+
+instance (MonadMask m, Monoid w) => MonadMask (AccumT w m) where
+  mask f = AccumT $ \w -> mask $ \g -> flip runAccumT w $ f $ \(AccumT m) -> AccumT $ \w' -> g $ m w'
+  uninterruptibleMask f = AccumT $ \w -> uninterruptibleMask $ \g -> flip runAccumT w $ f $ \(AccumT m) -> AccumT $ \w' -> g $ m w'
+  generalBracket m f g = AccumT $ \w -> (\(b, (c, w')) -> ((b, c), w')) <$> generalBracket (runAccumT m w) (\(a, w') exitCase -> runAccumT (f a exitCase) (w <> w')) (\(a, w') -> evalAccumT (g a) (w <> w'))
+#endif
+
+#if !MIN_VERSION_transformers(0,6,0)
+-- | Throws exceptions into the base monad.
+instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where
+  throwM = lift . throwM
+-- | Catches exceptions from the base monad.
+instance (Error e, MonadCatch m) => MonadCatch (ErrorT e m) where
+  catch (ErrorT m) f = ErrorT $ catch m (runErrorT . f)
+instance (Error e, MonadMask m) => MonadMask (ErrorT e m) where
+  mask f = ErrorT $ mask $ \u -> runErrorT $ f (q u)
+    where
+      q :: (m (Either e a) -> m (Either e a))
+        -> ErrorT e m a -> ErrorT e m a
+      q u (ErrorT b) = ErrorT (u b)
+  uninterruptibleMask f = ErrorT $ uninterruptibleMask $ \u -> runErrorT $ f (q u)
+    where
+      q :: (m (Either e a) -> m (Either e a))
+        -> ErrorT e m a -> ErrorT e m a
+      q u (ErrorT b) = ErrorT (u b)
+
+  generalBracket acquire release use = ErrorT $ do
+    (eb, ec) <- generalBracket
+      (runErrorT acquire)
+      (\eresource exitCase -> case eresource of
+        Left e -> return (Left e) -- nothing to release, acquire didn't succeed
+        Right resource -> case exitCase of
+          ExitCaseSuccess (Right b) -> runErrorT (release resource (ExitCaseSuccess b))
+          ExitCaseException e       -> runErrorT (release resource (ExitCaseException e))
+          _                         -> runErrorT (release resource ExitCaseAbort))
+      (either (return . Left) (runErrorT . use))
+    return $ do
+      -- The order in which we perform those two 'Either' effects determines
+      -- which error will win if they are both 'Left's. We want the error from
+      -- 'release' to win.
+      c <- ec
+      b <- eb
+      return (b, c)
+
+-- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask
+instance MonadThrow m => MonadThrow (ListT m) where
+  throwM = lift . throwM
+instance MonadCatch m => MonadCatch (ListT m) where
+  catch (ListT m) f = ListT $ catch m (runListT . f)
+#endif
+
+------------------------------------------------------------------------------
+-- $utilities
+-- These functions follow those from "Control.Exception", except that they are
+-- 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_ :: (HasCallStack, MonadMask m) => m a -> m a
+mask_ io = withFrozenCallStack (\f -> mask (\x -> f x)) (\_ -> io)
+
+-- | Like 'uninterruptibleMask', but does not pass a @restore@ action to the
+-- argument.
+uninterruptibleMask_ :: (HasCallStack, MonadMask m) => m a -> m a
+uninterruptibleMask_ io = withFrozenCallStack (\f -> uninterruptibleMask (\x -> f x)) (\_ -> io)
+
+-- | Catches all exceptions, and somewhat defeats the purpose of the extensible
+-- exception system. Use sparingly.
+--
+-- /NOTE/ This catches all /exceptions/, but if the monad supports other ways of
+-- aborting the computation, those other kinds of errors will not be caught.
+catchAll :: (HasCallStack, MonadCatch m) => m a -> (SomeException -> m a) -> m a
+catchAll = withFrozenCallStack catch
+
+-- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too
+-- general, but better than using 'catchAll'. See 'catchIf' for an easy way
+-- of catching specific 'IOError's based on the predicates in "System.IO.Error".
+catchIOError :: (HasCallStack, MonadCatch m) => m a -> (IOError -> m a) -> m a
+catchIOError = withFrozenCallStack catch
+
+-- | Catch exceptions only if they pass some predicate. Often useful with the
+-- predicates for testing 'IOError' values in "System.IO.Error".
+catchIf :: (HasCallStack, 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 :: (HasCallStack, 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 :: (HasCallStack, MonadCatch m, Exception e) => (e -> m a) -> m a -> m a
+handle = flip (withFrozenCallStack catch)
+{-# INLINE handle #-}
+
+-- | Flipped 'catchIOError'
+handleIOError :: (HasCallStack, MonadCatch m) => (IOError -> m a) -> m a -> m a
+handleIOError = withFrozenCallStack handle
+
+-- | Flipped 'catchAll'
+handleAll :: (HasCallStack, MonadCatch m) => (SomeException -> m a) -> m a -> m a
+handleAll = withFrozenCallStack handle
+
+-- | Flipped 'catchIf'
+handleIf :: (HasCallStack, MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a
+handleIf f = flip (withFrozenCallStack catchIf f)
+
+-- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'.
+handleJust :: (HasCallStack, MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a
+handleJust f = flip (withFrozenCallStack catchJust f)
+{-# INLINE handleJust #-}
+
+-- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s
+-- 'Control.Exception.try'.
+try :: (HasCallStack, MonadCatch m, Exception e) => m a -> m (Either e a)
+try a = withFrozenCallStack catch (Right `liftM` a) (return . Left)
+
+-- | A variant of 'try' that takes an exception predicate to select
+-- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust'
+tryJust :: (HasCallStack, 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 :: (HasCallStack, Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a
+catches a hs = withFrozenCallStack catch a handler
+  where
+    handler e = foldr probe (throwM e) hs
+      where
+        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 :: (HasCallStack, MonadCatch m) => m a -> m b -> m a
+onException action handler = withFrozenCallStack catchAll action (\e -> handler >> throwM e)
+
+-- | Run an action only if an error is thrown in the main action. Unlike
+-- 'onException', this works with every kind of error, not just exceptions. For
+-- example, if @f@ is an 'ExceptT' computation which aborts with a 'Left', the
+-- computation @onError f g@ will execute @g@, while @onException f g@ will not.
+--
+-- This distinction is only meaningful for monads which have multiple exit
+-- points, such as 'Except' and 'MaybeT'. For monads that only have a single
+-- exit point, there is no difference between 'onException' and 'onError',
+-- except that 'onError' has a more constrained type.
+--
+-- @since 0.10.0
+onError :: (HasCallStack, MonadMask m) => m a -> m b -> m a
+onError action handler = withFrozenCallStack bracketOnError (return ()) (const handler) (const action)
+
+-- | Generalized abstracted pattern of safe resource acquisition and release
+-- in the face of 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 :: (HasCallStack, 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_ :: (HasCallStack, MonadMask m) => m a -> m c -> m b -> m b
+bracket_ before after action = withFrozenCallStack bracket before (const after) (const action)
+
+-- | Perform an action with a finalizer action that is run, even if an
+-- error occurs.
+finally :: (HasCallStack, MonadMask m) => m a -> m b -> m a
+finally action finalizer = withFrozenCallStack bracket_ (return ()) finalizer action
+
+-- | Like 'bracket', but only performs the final action if an error is
+-- thrown by the in-between computation.
+bracketOnError :: (HasCallStack, MonadMask m) => m a -> (a -> m c) -> (a -> m b) -> m b
+bracketOnError acquire release = liftM fst . withFrozenCallStack generalBracket
+  acquire
+  (\a exitCase -> case exitCase of
+    ExitCaseSuccess _ -> return ()
+    _ -> do
+      _ <- release a
+      return ())

src/Control/Monad/Catch/Pure.hs

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE Trustworthy #-}
+
+--------------------------------------------------------------------
+-- |
+-- 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
+
+import Prelude hiding (foldr)
+
+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(..))
+import Data.Functor.Identity
+import Data.Traversable as Traversable
+#if defined(__MHS__)
+import Data.Foldable
+#endif
+
+------------------------------------------------------------------------------
+-- $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
+  state = lift . state
+
+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)
+  writer aw = CatchT (Right `liftM` writer aw)
+
+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

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+
+#if !(MIN_VERSION_transformers(0,6,0))
+{-# OPTIONS_GHC -Wno-deprecations #-}
+#endif
+
+module Control.Monad.Catch.Tests (tests) where
+
+import Control.Monad (unless)
+import Data.Data (Data)
+import Data.IORef (newIORef, writeIORef, readIORef)
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Identity (IdentityT(..))
+import Control.Monad.Reader (ReaderT(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Control.Monad.STM (STM, atomically)
+--import Control.Monad.Cont (ContT(..))
+import Test.QuickCheck (Property, ioProperty, once)
+import Test.QuickCheck.Monadic (monadic, run, assert)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import Test.Tasty.QuickCheck (testProperty)
+import qualified Control.Monad.State.Lazy as LazyState
+import qualified Control.Monad.State.Strict as StrictState
+import qualified Control.Monad.Writer.Lazy as LazyWriter
+import qualified Control.Monad.Writer.Strict as StrictWriter
+import qualified Control.Monad.RWS.Lazy as LazyRWS
+import qualified Control.Monad.RWS.Strict as StrictRWS
+#if !(MIN_VERSION_transformers(0,6,0))
+import Control.Monad.Trans.Error (ErrorT(..))
+import Control.Monad.Trans.List (ListT(..))
+#endif
+
+import Control.Monad.Catch
+import Control.Monad.Catch.Pure
+
+data TestException = TestException String
+    deriving (Show, Eq, Data)
+
+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 :: TestTree
+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 -> TestTree
+    mkMSpecTest name test = \someMSpec@(SomeMSpec spec) ->
+        testProperty (name ++ " " ++ mspecName spec) $ once $ test someMSpec
+
+    mkDetectableEffectTest :: String -> (SomeDetectableEffect -> Property) -> SomeDetectableEffect -> TestTree
+    mkDetectableEffectTest name test = \someDetectableEffect@(SomeDetectableEffect detectableEffect) ->
+        let testName = name ++ " " ++ mspecName (detectableEffectMSpec detectableEffect)
+        in testProperty testName $ once $ test someDetectableEffect
+
+    exceptTLeft = do
+      ref <- newIORef False
+      Left () <- runExceptT $ ExceptT (return $ Left ()) `finally` lift (writeIORef ref True)
+      val <- readIORef ref
+      unless val $ error "Looks like cleanup didn't happen"
+
+    -- if both 'use' and 'release' abort, the 'release' error should win
+    releaseErrorWins = do
+      Left val <- runExceptT $ ExceptT (return $ Left False) `finally` ExceptT (return $ Left True)
+      unless val $ error "Looks like the 'use' error won"

tests/Tests.hs

+module Main where
+
+import Test.Tasty (defaultMain, testGroup)
+
+import qualified Control.Monad.Catch.Tests
+
+main :: IO ()
+main = defaultMain $
+  testGroup "exceptions"
+    [ Control.Monad.Catch.Tests.tests
+    ]