Add HasCallStack to catch et al

ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for `annotated-exception`
 
+## 0.2.0.3
+
+- [#17](https://github.com/parsonsmatt/annotated-exception/pull/17)
+    - Add `HasCallStack` to `catch` and `catches`
+
 ## 0.2.0.2
 
 - [#14](https://github.com/parsonsmatt/annotated-exception/pull/14)

annotated-exception.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           annotated-exception
-version:        0.2.0.2
+version:        0.2.0.3
 synopsis:       Exceptions, with checkpoints and context.
 description:    Please see the README on Github at <https://github.com/parsonsmatt/annotated-exception#readme>
 category:       Control

package.yaml

@@ -1,5 +1,5 @@
 name:                annotated-exception
-version:             0.2.0.2
+version:             0.2.0.3
 github:              "parsonsmatt/annotated-exception"
 license:             BSD3
 author:              "Matt Parsons"

src/Control/Exception/Annotated.hs

@@ -183,23 +183,23 @@ check = traverse Safe.fromException
 -- >     putStrLn "ok!"
 --
 -- @since 0.1.0.0
-catch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a
+catch :: (HasCallStack, Exception e, MonadCatch m) => m a -> (e -> m a) -> m a
 catch action handler =
-    catches action [Handler handler]
+    withFrozenCallStack catches action [Handler handler]
 
 -- | Like 'Safe.catches', but this function enhance the provided 'Handler's
 -- to "see through" any 'AnnotatedException's.
 --
 -- @since 0.1.2.0
-catches :: (MonadCatch m) => m a -> [Handler m a] -> m a
+catches :: (MonadCatch m, HasCallStack) => m a -> [Handler m a] -> m a
 catches action handlers =
-    Safe.catches action (mkAnnotatedHandlers handlers)
+    Safe.catches action (withFrozenCallStack mkAnnotatedHandlers handlers)
 
 -- | Extends each 'Handler' in the list with a variant that sees through
 -- the 'AnnotatedException' and re-annotates any rethrown exceptions.
 --
 -- @since 0.1.1.0
-mkAnnotatedHandlers :: MonadCatch m => [Handler m a] -> [Handler m a]
+mkAnnotatedHandlers :: (HasCallStack, MonadCatch m) => [Handler m a] -> [Handler m a]
 mkAnnotatedHandlers xs =
     xs >>= \(Handler hndlr) ->
         [ Handler hndlr

src/Control/Exception/Annotated/UnliftIO.hs

@@ -118,13 +118,13 @@ checkpointCallStackWith anns action =
 --
 -- @since 0.1.2.0
 catch
-    :: forall e m a. (MonadUnliftIO m, Exception e)
+    :: forall e m a. (MonadUnliftIO m, Exception e, HasCallStack)
     => m a
     -> (e -> m a)
     -> m a
 catch action handler =
     withRunInIO $ \runInIO ->
-        liftIO $ Catch.catch (runInIO action) (\e -> runInIO $ handler e)
+        liftIO $ withFrozenCallStack Catch.catch (runInIO action) (\e -> runInIO $ handler e)
 
 -- | Like 'Catch.tryAnnotated' but uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'.
 --
@@ -152,11 +152,11 @@ try action =
 --
 -- @since 0.1.2.0
 catches
-    :: forall m a. MonadUnliftIO m
+    :: forall m a. (MonadUnliftIO m, HasCallStack)
     => m a
     -> [Handler m a]
     -> m a
 catches action handlers =
     withRunInIO $ \runInIO -> do
         let f (Handler k) = Handler (\e -> runInIO (k e))
-        liftIO $ Catch.catches (runInIO action) (map f handlers)
+        liftIO $ withFrozenCallStack Catch.catches (runInIO action) (map f handlers)

test/Control/Exception/Annotated/UnliftIOSpec.hs

@@ -1,4 +1,4 @@
-{-# language RecordWildCards, StrictData, RankNTypes #-}
+{-# language ScopedTypeVariables, RecordWildCards, StrictData, RankNTypes #-}
 
 module Control.Exception.Annotated.UnliftIOSpec where
 
@@ -10,7 +10,10 @@ import Data.Annotation
 import GHC.Stack
 
 import Data.AnnotationSpec ()
-import Control.Exception.AnnotatedSpec (TestException(..))
+import Control.Exception.AnnotatedSpec
+    ( TestException(..)
+    , callStackFunctionNamesShouldBe
+    )
 import Data.Maybe
 
 asIO :: IO a -> IO a
@@ -34,8 +37,42 @@ spec = do
                                 expectationFailure "Should not catch"
                 action `shouldThrow` \(AnnotatedException _ e) ->
                     e == userError "oh no"
-
+        it "includes a callstack location" $ do
+            let
+                action =
+                    throw TestException
+                        `catch`
+                            \TestException ->
+                                throw TestException
+            action
+                `Safe.catch`
+                        \(e :: AnnotatedException TestException) -> do
+                            annotations e
+                                `callStackFunctionNamesShouldBe`
+                                    [ "throw"
+                                    , "throw"
+                                    , "catch"
+                                    ]
     describe "catches" $ do
+        it "has a callstack entry" $ do
+            let
+                action =
+                    throw TestException
+                        `catches`
+                            [ Handler $ \TestException ->
+                                throw TestException
+                            ]
+            action
+                `Safe.catch`
+                        \(e :: AnnotatedException TestException) -> do
+                            annotations e
+                                `callStackFunctionNamesShouldBe`
+                                    [ "throw"
+                                    , "throw"
+                                    , "catches"
+                                    ]
+
+
         describe "the right exception" $ do
             it "works" $ asIO $ do
                 throw TestException

test/Control/Exception/AnnotatedSpec.hs

@@ -122,6 +122,40 @@ spec = do
             action
                 `shouldThrow`
                     (userError "uh oh" ==)
+        it "includes a callstack location" $ do
+            let
+                action =
+                    throw TestException
+                        `catch`
+                            \TestException ->
+                                throw TestException
+            action
+                `Safe.catch`
+                        \(e :: AnnotatedException TestException) -> do
+                            annotations e
+                                `callStackFunctionNamesShouldBe`
+                                    [ "throw"
+                                    , "throw"
+                                    , "catch"
+                                    ]
+    describe "catches" $ do
+        it "has a callstack entry" $ do
+            let
+                action =
+                    throw TestException
+                        `catches`
+                            [ Handler $ \TestException ->
+                                throw TestException
+                            ]
+            action
+                `Safe.catch`
+                        \(e :: AnnotatedException TestException) -> do
+                            annotations e
+                                `callStackFunctionNamesShouldBe`
+                                    [ "throw"
+                                    , "throw"
+                                    , "catches"
+                                    ]
 
     describe "tryAnnotated" $ do
         let subject :: (Exception e, Exception e') => e -> IO (AnnotatedException e')
@@ -170,7 +204,7 @@ spec = do
                     `Safe.catch` \(e :: AnnotatedException TestException) -> do
                         annotations e
                             `callStackFunctionNamesShouldBe`
-                                ["throwWithCallStack"
+                                [ "throwWithCallStack"
                                 , "checkpointCallStack"
                                 ]