From 88814cf9076689add4be4bd3963f1c1deb9d3b42 Mon Sep 17 00:00:00 2001
From: Matt Parsons <parsonsmatt@gmail.com>
Date: Sat, 26 Nov 2022 18:41:48 -0700
Subject: [PATCH] Add `HasCallStack` to classes and functions (#90)

* Add `HasCallStack` to classes and functions

This PR adds `HasCallStack` constraints to the class methods on this library. This allows for callsites to be populated with interesting information.

The primary use case I can imagine here is supporting [`annotated-exception`](https://hackage.haskell.org/package/annotated-exception-0.2.0.4/docs/Control-Exception-Annotated.html), and allowing you to define an instance of `MonadThrow` that always annotates with callstack:

```haskell
instance MonadThrow AppM where
    throwM = throwWithCallStack
```

With this, anything that uses `throwM` at the `AppM` type gets a call stack on the attached exception.

While this only benefits users of `annotated-exception` currently, when the GHC proposal to [decorate all exceptions with backtrace information](https://github.com/ghc-proposals/ghc-proposals/pull/330) is implemented, then everyone benefits from this.

Without this constraint, the `CallStack` used by the above instance points to the instance definition site - not terribly useful.

* Use call-stack for backwards compatibility

* Only depend on call-stack if using an old GHC version

`exceptions` is a GHC boot package, so we want to make sure that it does not
incur any external depedencies when using a recent GHC version.

* Enable FlexibleContexts for the benefit of older GHCs

Older versions of GHC require `FlexibleContexts` to use `call-stack`'s
`type HasCallStack = (?callStack :: CallStack)` compatibility shim.

* Drop support for GHC 7.0 and 7.2

`call-stack`'s `HasCallStack` compatibility shim only supports back to GHC 7.4.
As a result, we can't reasonably support GHC 7.0 and 7.2 in `exceptions`
without a fair bit of grimy CPP. That being said, GHC 7.0 and 7.2 are quite
ancient by this point, so I'm comfortable with simply dropping support for
them. This patch makes the necessary `.cabal` and CI changes to accomplish that.

* Enable ConstraintKinds for the benefit of older GHCs

Older versions of GHC require `ConstraintKinds` to use `call-stack`'s
`type HasCallStack = (?callStack :: CallStack)` compatibility shim.

* Add withFrozenCallStack where possible

* withFrozenCallStack fix for old GHC

* freeze masks

Co-authored-by: Ryan Scott <ryan.gl.scott@gmail.com>
---
 .github/workflows/haskell-ci.yml | 127 +++++++++++++++++++++++--------
 cabal.haskell-ci                 |   1 -
 exceptions.cabal                 |  16 ++--
 src/Control/Monad/Catch.hs       | 104 ++++++++++++++-----------
 4 files changed, 163 insertions(+), 85 deletions(-)

diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
index f14b0ed..a64f7c9 100644
--- a/.github/workflows/haskell-ci.yml
+++ b/.github/workflows/haskell-ci.yml
@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.12.1
+# version: 0.14.3
 #
-# REGENDATA ("0.12.1",["github","--config=cabal.haskell-ci","cabal.project"])
+# REGENDATA ("0.14.3",["github","--config=cabal.haskell-ci","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -20,71 +20,131 @@ jobs:
   linux:
     name: Haskell-CI - Linux - ${{ matrix.compiler }}
     runs-on: ubuntu-18.04
+    timeout-minutes:
+      60
     container:
       image: buildpack-deps:bionic
     continue-on-error: ${{ matrix.allow-failure }}
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.0.1
+          - compiler: ghc-9.2.2
+            compilerKind: ghc
+            compilerVersion: 9.2.2
+            setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-8.10.4
+          - 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: hvr-ppa
             allow-failure: false
           - compiler: ghc-8.6.5
+            compilerKind: ghc
+            compilerVersion: 8.6.5
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-8.4.4
+            compilerKind: ghc
+            compilerVersion: 8.4.4
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-8.2.2
+            compilerKind: ghc
+            compilerVersion: 8.2.2
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-8.0.2
+            compilerKind: ghc
+            compilerVersion: 8.0.2
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-7.10.3
+            compilerKind: ghc
+            compilerVersion: 7.10.3
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-7.8.4
+            compilerKind: ghc
+            compilerVersion: 7.8.4
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-7.6.3
+            compilerKind: ghc
+            compilerVersion: 7.6.3
+            setup-method: hvr-ppa
             allow-failure: false
           - compiler: ghc-7.4.2
+            compilerKind: ghc
+            compilerVersion: 7.4.2
+            setup-method: hvr-ppa
             allow-failure: false
-          - compiler: ghc-7.2.2
-            allow-failure: true
-          - compiler: ghc-7.0.4
-            allow-failure: true
       fail-fast: false
     steps:
       - name: apt
         run: |
           apt-get update
-          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common
-          apt-add-repository -y 'ppa:hvr/ghc'
-          apt-get update
-          apt-get install -y $CC cabal-install-3.4
+          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+          else
+            apt-add-repository -y 'ppa:hvr/ghc'
+            apt-get update
+            apt-get install -y "$HCNAME"
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+          fi
         env:
-          CC: ${{ matrix.compiler }}
+          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
-          HCDIR=$(echo "/opt/$CC" | sed 's/-/\//')
-          HCNAME=ghc
-          HC=$HCDIR/bin/$HCNAME
-          echo "HC=$HC" >> $GITHUB_ENV
-          echo "HCPKG=$HCDIR/bin/$HCNAME-pkg" >> $GITHUB_ENV
-          echo "HADDOCK=$HCDIR/bin/haddock" >> $GITHUB_ENV
-          echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV
+          echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
+          echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
+          echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
+          HCDIR=/opt/$HCKIND/$HCVER
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          else
+            HC=$HCDIR/bin/$HCKIND
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          fi
+
           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=--$HCNAME --with-compiler=$HC" >> $GITHUB_ENV
-          echo "GHCJSARITH=0" >> $GITHUB_ENV
+          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"
+          echo "GHCJSARITH=0" >> "$GITHUB_ENV"
         env:
-          CC: ${{ matrix.compiler }}
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
       - name: env
         run: |
           env
@@ -107,6 +167,10 @@ jobs:
           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: |
@@ -145,7 +209,8 @@ jobs:
       - 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
+          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
diff --git a/cabal.haskell-ci b/cabal.haskell-ci
index 65674dd..a8560ad 100644
--- a/cabal.haskell-ci
+++ b/cabal.haskell-ci
@@ -1,6 +1,5 @@
 distribution:           bionic
 no-tests-no-benchmarks: False
 unconstrained:          False
-allow-failures:         <7.3
 -- irc-channels:           irc.freenode.org#haskell-lens
 irc-if-in-origin-repo:  True
diff --git a/exceptions.cabal b/exceptions.cabal
index 9faeef8..429f5e1 100644
--- a/exceptions.cabal
+++ b/exceptions.cabal
@@ -12,9 +12,7 @@ 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
+tested-with:   GHC == 7.4.2
              , GHC == 7.6.3
              , GHC == 7.8.4
              , GHC == 7.10.3
@@ -23,8 +21,9 @@ tested-with:   GHC == 7.0.4
              , GHC == 8.4.4
              , GHC == 8.6.5
              , GHC == 8.8.4
-             , GHC == 8.10.4
-             , GHC == 9.0.1
+             , GHC == 8.10.7
+             , GHC == 9.0.2
+             , GHC == 9.2.2
 synopsis:      Extensible optionally-pure exceptions
 description:   Extensible optionally-pure exceptions.
 
@@ -46,13 +45,14 @@ flag transformers-0-4
 
 library
   build-depends:
-    base                       >= 4.3      && < 5,
+    base                       >= 4.5      && < 5,
     stm                        >= 2.2      && < 3,
-    template-haskell           >= 2.2      && < 2.20,
+    template-haskell           >= 2.7      && < 2.20,
     mtl                        >= 2.0      && < 2.4
 
   if !impl(ghc >= 8.0)
-    build-depends: fail        == 4.9.*
+    build-depends: call-stack  >= 0.1      && < 0.5,
+                   fail        == 4.9.*
 
   if flag(transformers-0-4)
     build-depends:
diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs
index 3712b48..e0783fc 100644
--- a/src/Control/Monad/Catch.hs
+++ b/src/Control/Monad/Catch.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -117,11 +119,22 @@ import Data.Monoid
 import Control.Applicative
 #endif
 
+#if __GLASGOW_HASKELL__ >= 800
+import GHC.Stack (HasCallStack, withFrozenCallStack)
+#else
+import Data.CallStack (HasCallStack)
+#endif
+
 #if !(MIN_VERSION_transformers(0,6,0))
 import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT)
 import Control.Monad.Trans.List (ListT(..), runListT)
 #endif
 
+#if __GLASGOW_HASKELL__ < 800
+withFrozenCallStack :: a -> a
+withFrozenCallStack a = a
+#endif
+
 ------------------------------------------------------------------------------
 -- $mtl
 -- The mtl style typeclass
@@ -143,7 +156,7 @@ class Monad m => MonadThrow m where
   -- Should satisfy the law:
   --
   -- > throwM e >> f = throwM e
-  throwM :: Exception e => e -> m a
+  throwM :: (HasCallStack, Exception e) => e -> m a
 
 -- | A class for monads which allow exceptions to be caught, in particular
 -- exceptions which were thrown by 'throwM'.
@@ -163,7 +176,7 @@ class MonadThrow m => MonadCatch m where
   -- action. Note that type of the type of the argument to the handler will
   -- constrain which exceptions are caught. See "Control.Exception"'s
   -- 'ControlException.catch'.
-  catch :: Exception e => m a -> (e -> m a) -> m a
+  catch :: (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
 
 -- | A class for monads which provide for the ability to account for
 -- all possible exit points from a computation, and to mask
@@ -204,7 +217,7 @@ class MonadCatch m => MonadMask m where
   -- | Runs an action with asynchronous exceptions disabled. The action is
   -- provided a method for restoring the async. environment to what it was
   -- at the 'mask' call. See "Control.Exception"'s 'ControlException.mask'.
-  mask :: ((forall a. m a -> m a) -> m b) -> m b
+  mask :: HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
 
   -- | Like 'mask', but the masked computation is not interruptible (see
   -- "Control.Exception"'s 'ControlException.uninterruptibleMask'. WARNING:
@@ -212,7 +225,7 @@ class MonadCatch m => MonadMask m where
   -- AND you can guarantee the interruptible operation will only block for a
   -- short period of time. Otherwise you render the program/thread unresponsive
   -- and/or unkillable.
-  uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
+  uninterruptibleMask :: HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
 
   -- | A generalized version of 'bracket' which uses 'ExitCase' to distinguish
   -- the different exit cases, and returns the values of both the 'use' and
@@ -305,7 +318,8 @@ class MonadCatch m => MonadMask m where
   --
   -- @since 0.9.0
   generalBracket
-    :: m a
+    :: HasCallStack
+    => m a
     -- ^ acquire some resource
     -> (a -> ExitCase b -> m c)
     -- ^ release the resource, observing the outcome of the inner action
@@ -733,72 +747,72 @@ instance MonadCatch m => MonadCatch (ListT m) where
 ------------------------------------------------------------------------------
 
 -- | Like 'mask', but does not pass a @restore@ action to the argument.
-mask_ :: MonadMask m => m a -> m a
-mask_ io = mask $ \_ -> io
+mask_ :: (HasCallStack, MonadMask m) => m a -> m a
+mask_ io = withFrozenCallStack (\f -> mask (\x -> f x)) (\_ -> io)
 
 -- | Like 'uninterruptibleMask', but does not pass a @restore@ action to the
 -- argument.
-uninterruptibleMask_ :: MonadMask m => m a -> m a
-uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io
+uninterruptibleMask_ :: (HasCallStack, MonadMask m) => m a -> m a
+uninterruptibleMask_ io = withFrozenCallStack (\f -> uninterruptibleMask (\x -> f x)) (\_ -> io)
 
 -- | Catches all exceptions, and somewhat defeats the purpose of the extensible
 -- exception system. Use sparingly.
 --
 -- /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
+catchAll :: (HasCallStack, MonadCatch m) => m a -> (SomeException -> m a) -> m a
+catchAll = withFrozenCallStack catch
 
 -- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too
 -- general, but better than using 'catchAll'. See 'catchIf' for an easy way
 -- of catching specific 'IOError's based on the predicates in "System.IO.Error".
-catchIOError :: MonadCatch m => m a -> (IOError -> m a) -> m a
-catchIOError = catch
+catchIOError :: (HasCallStack, MonadCatch m) => m a -> (IOError -> m a) -> m a
+catchIOError = withFrozenCallStack catch
 
 -- | Catch exceptions only if they pass some predicate. Often useful with the
 -- predicates for testing 'IOError' values in "System.IO.Error".
-catchIf :: (MonadCatch m, Exception e) =>
+catchIf :: (HasCallStack, MonadCatch m, Exception e) =>
     (e -> Bool) -> m a -> (e -> m a) -> m a
-catchIf f a b = a `catch` \e -> if f e then b e else throwM e
+catchIf f a b = withFrozenCallStack catch a (\e -> if f e then b e else throwM e)
 
 -- | A more generalized way of determining which exceptions to catch at
 -- run time.
-catchJust :: (MonadCatch m, Exception e) =>
+catchJust :: (HasCallStack, MonadCatch m, Exception e) =>
     (e -> Maybe b) -> m a -> (b -> m a) -> m a
-catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e
+catchJust f a b = withFrozenCallStack catch a (\e -> maybe (throwM e) b $ f e)
 
 -- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'.
-handle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a
-handle = flip catch
+handle :: (HasCallStack, MonadCatch m, Exception e) => (e -> m a) -> m a -> m a
+handle = flip (withFrozenCallStack catch)
 {-# INLINE handle #-}
 
 -- | Flipped 'catchIOError'
-handleIOError :: MonadCatch m => (IOError -> m a) -> m a -> m a
-handleIOError = handle
+handleIOError :: (HasCallStack, MonadCatch m) => (IOError -> m a) -> m a -> m a
+handleIOError = withFrozenCallStack handle
 
 -- | Flipped 'catchAll'
-handleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a
-handleAll = handle
+handleAll :: (HasCallStack, MonadCatch m) => (SomeException -> m a) -> m a -> m a
+handleAll = withFrozenCallStack handle
 
 -- | Flipped 'catchIf'
-handleIf :: (MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a
-handleIf f = flip (catchIf f)
+handleIf :: (HasCallStack, MonadCatch m, Exception e) => (e -> Bool) -> (e -> m a) -> m a -> m a
+handleIf f = flip (withFrozenCallStack catchIf f)
 
 -- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'.
-handleJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a
-handleJust f = flip (catchJust f)
+handleJust :: (HasCallStack, MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a
+handleJust f = flip (withFrozenCallStack catchJust f)
 {-# INLINE handleJust #-}
 
 -- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s
 -- 'Control.Exception.try'.
-try :: (MonadCatch m, Exception e) => m a -> m (Either e a)
-try a = catch (Right `liftM` a) (return . Left)
+try :: (HasCallStack, MonadCatch m, Exception e) => m a -> m (Either e a)
+try a = withFrozenCallStack catch (Right `liftM` a) (return . Left)
 
 -- | A variant of 'try' that takes an exception predicate to select
 -- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust'
-tryJust :: (MonadCatch m, Exception e) =>
+tryJust :: (HasCallStack, MonadCatch m, Exception e) =>
     (e -> Maybe b) -> m a -> m (Either b a)
-tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e))
+tryJust f a = withFrozenCallStack catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e))
 
 -- | Generalized version of 'ControlException.Handler'
 data Handler m a = forall e . ControlException.Exception e => Handler (e -> m a)
@@ -807,8 +821,8 @@ 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
+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
@@ -820,8 +834,8 @@ catches a hs = a `catch` handler
 -- /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
+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
@@ -834,8 +848,8 @@ onException action handler = action `catchAll` \e -> handler >> throwM e
 -- 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)
+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
@@ -850,25 +864,25 @@ onError action handler = bracketOnError (return ()) (const handler) (const actio
 -- 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
+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_ :: MonadMask m => m a -> m c -> m b -> m b
-bracket_ before after action = bracket before (const after) (const action)
+bracket_ :: (HasCallStack, MonadMask m) => m a -> m c -> m b -> m b
+bracket_ before after action = withFrozenCallStack bracket before (const after) (const action)
 
 -- | Perform an action with a finalizer action that is run, even if an
 -- error occurs.
-finally :: MonadMask m => m a -> m b -> m a
-finally action finalizer = bracket_ (return ()) finalizer action
+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 :: MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b
-bracketOnError acquire release = liftM fst . generalBracket
+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 ()
-- 
GitLab