Add try, catches

ChangeLog.md

@@ -2,6 +2,13 @@
 
 ## Unreleased changes
 
+## 0.1.1.0
+
+- [#4](https://github.com/parsonsmatt/annotated-exception/pull/4)
+    - Add `catches`
+    - Replace `Control.Exception.Safe.try` with `try` that can get an
+      `AnnotatedException e` or a regular, un-`Annotated` `e`.
+
 ## 0.1.0.0
 
 - Initial Release

annotated-exception.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           annotated-exception
-version:        0.1.0.0
+version:        0.1.1.0
 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.1.0.0
+version:             0.1.1.0
 github:              "parsonsmatt/annotated-exception"
 license:             BSD3
 author:              "Matt Parsons"

src/Control/Exception/Annotated.hs

@@ -38,6 +38,7 @@ module Control.Exception.Annotated
     -- * Handling Exceptions
     , catch
     , tryAnnotated
+    , try
 
     -- * Manipulating Annotated Exceptions
     , check
@@ -52,11 +53,11 @@ module Control.Exception.Annotated
     , Exception(..)
     , Safe.SomeException(..)
     , Safe.throw
-    , Safe.try
+    , Handler (..)
     ) where
 
 import Control.Exception.Safe
-       (Exception, MonadCatch, MonadThrow, SomeException(..))
+       (Exception, Handler(..), MonadCatch, MonadThrow, SomeException(..))
 import qualified Control.Exception.Safe as Safe
 import Data.Annotation
 import Data.Maybe
@@ -177,11 +178,26 @@ check = traverse Safe.fromException
 -- @since 0.1.0.0
 catch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a
 catch action handler =
-    Safe.catches
-        action
-        [ Safe.Handler handler
-        , Safe.Handler $ \(AnnotatedException anns e) ->
-            checkpointMany anns $ handler e
+    catches action [Handler handler]
+
+-- | Like 'Safe.catches', but this function enhance the provided 'Handler's
+-- to "see through" any 'AnnotatedException's.
+--
+-- @since 0.1.1.0
+catches :: (MonadCatch m) => m a -> [Handler m a] -> m a
+catches action handlers =
+    Safe.catches action (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 xs =
+    xs >>= \(Handler hndlr) ->
+        [ Handler hndlr
+        , Handler $ \(AnnotatedException anns e) ->
+            checkpointMany anns $ hndlr e
         ]
 
 -- | Like 'catch', but always returns a 'AnnotatedException'.
@@ -191,6 +207,26 @@ tryAnnotated :: (Exception e, MonadCatch m) => m a -> m (Either (AnnotatedExcept
 tryAnnotated action =
     (Right <$> action) `catch` (pure . Left)
 
+-- | Like 'Safe.try', but can also handle an 'AnnotatedException' or the
+-- underlying value. Useful when you want to 'try' to catch a type of
+-- exception, but you may not care about the 'Annotation's that it may or
+-- may not have.
+--
+-- Example:
+--
+-- > Left exn <- try $ throw (AnnotatedException [] TestException)
+-- > exn == TestException
+--
+-- > Left exn <- try $ throw TestException
+-- > exn == AnnotatedException [] TestException
+--
+-- @since 0.1.0.1
+try :: (Exception e, MonadCatch m) => m a -> m (Either e a)
+try action = do
+    (Right <$> action)
+      `catches`
+          mkAnnotatedHandlers [Handler (\exn -> pure $ Left exn)]
+
 -- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.
 --
 -- The 'CallStack' will *not* be present as a 'CallStack' - it will be

test/Control/Exception/AnnotatedSpec.hs

@@ -71,20 +71,44 @@ spec = do
                         pass
 
     describe "try" $ do
-        it "always adds a location" $ do
-            Left exn <- try (throw TestException)
-            exn `shouldBe` AnnotatedException [] TestException
-
-        it "does not nest locations" $ do
-            Left exn <- try $ throw $ new $ new $ new TestException
-            exn `shouldBe` new TestException
+        let subject :: (Exception e, Exception e') => e -> IO e'
+            subject exn = do
+                Left exn' <- try (throw exn)
+                pure exn'
+
+        describe "when throwing non-Annotated" $ do
+            it "can add an empty annotation for a non-Annotated exception" $ do
+                exn <- subject TestException
+                exn `shouldBe` AnnotatedException [] TestException
+
+            it "can catch a usual exception" $ do
+                exn <- subject TestException
+                exn `shouldBe` TestException
+
+        describe "when throwing Annotated" $ do
+            it "can catch a non-Annotated exception" $ do
+                exn <- subject $ new TestException
+                exn `shouldBe` TestException
+
+            it "can catch an Annotated exception" $ do
+                exn <- subject TestException
+                exn `shouldBe` new TestException
+
+        describe "nesting behavior" $ do
+            it "can catch at any level of nesting" $ do
+                subject TestException
+                    >>= (`shouldBe` new TestException)
+                subject TestException
+                    >>= (`shouldBe` new (new TestException))
+                subject TestException
+                    >>= (`shouldBe` new (new (new TestException)))
 
     describe "Safe.try" $ do
         it "can catch a located exception" $ do
             Left exn <- Safe.try (Safe.throw TestException)
             exn `shouldBe` new TestException
 
-        it "does not catch a AnnotatedException" $ do
+        it "does not catch an AnnotatedException" $ do
             let action = do
                     Left exn <- Safe.try (Safe.throw $ new TestException)
                     exn `shouldBe` TestException