Add UnliftIO variant

ChangeLog.md

@@ -2,6 +2,13 @@
 
 ## Unreleased changes
 
+## 0.1.2.0
+
+- [#6](https://github.com/parsonsmatt/annotated-exception/pull/6)
+    - Add `Control.Exception.Annotated.UnliftIO` that uses `MonadUnliftIO`
+      instead of `MonadCatch` and `MonadThrow`.
+    - Actually expose `catches`
+
 ## 0.1.1.0
 
 - [#4](https://github.com/parsonsmatt/annotated-exception/pull/4)

annotated-exception.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           annotated-exception
-version:        0.1.1.0
+version:        0.1.2.0
 synopsis:       Exceptions, with checkpoints and context.
 description:    Please see the README on Github at <https://github.com/parsonsmatt/annotated-exception#readme>
 category:       Control
@@ -28,6 +28,7 @@ source-repository head
 library
   exposed-modules:
       Control.Exception.Annotated
+      Control.Exception.Annotated.UnliftIO
       Data.Annotation
   other-modules:
       Paths_annotated_exception
@@ -39,6 +40,7 @@ library
     , containers
     , safe-exceptions
     , text
+    , unliftio-core
   default-language: Haskell2010
 
 test-suite annotated-exception-test
@@ -60,4 +62,5 @@ test-suite annotated-exception-test
     , hspec
     , safe-exceptions
     , text
+    , unliftio-core
   default-language: Haskell2010

package.yaml

@@ -1,5 +1,5 @@
 name:                annotated-exception
-version:             0.1.1.0
+version:             0.1.2.0
 github:              "parsonsmatt/annotated-exception"
 license:             BSD3
 author:              "Matt Parsons"
@@ -24,6 +24,7 @@ dependencies:
 - safe-exceptions
 - containers
 - text
+- unliftio-core
 
 library:
   source-dirs: src

src/Control/Exception/Annotated.hs

@@ -37,6 +37,7 @@ module Control.Exception.Annotated
     , checkpointCallStackWith
     -- * Handling Exceptions
     , catch
+    , catches
     , tryAnnotated
     , try
 
@@ -183,7 +184,7 @@ catch action handler =
 -- | Like 'Safe.catches', but this function enhance the provided 'Handler's
 -- to "see through" any 'AnnotatedException's.
 --
--- @since 0.1.1.0
+-- @since 0.1.2.0
 catches :: (MonadCatch m) => m a -> [Handler m a] -> m a
 catches action handlers =
     Safe.catches action (mkAnnotatedHandlers handlers)

src/Control/Exception/Annotated/UnliftIO.hs

@@ -0,0 +1,146 @@
+{-# language ExplicitForAll #-}
+
+-- | This module presents the same interface as
+-- "Control.Exception.Annotated", but uses 'MonadUnliftIO' instead of
+-- 'MonadCatch' or 'MonadThrow'.
+--
+-- @since 0.1.2.0
+module Control.Exception.Annotated.UnliftIO
+    ( -- * The Main Type
+      AnnotatedException(..)
+    , new
+    , throwWithCallStack
+    -- * Annotating Exceptions
+    , checkpoint
+    , checkpointMany
+    , checkpointCallStack
+    , checkpointCallStackWith
+    -- * Handling Exceptions
+    , catch
+    , catches
+    , tryAnnotated
+    , try
+
+    -- * Manipulating Annotated Exceptions
+    , check
+    , hide
+    , annotatedExceptionCallStack
+    , addCallStackToException
+
+    -- * Re-exports from "Data.Annotation"
+    , Annotation(..)
+    , CallStackAnnotation(..)
+    -- * Re-exports from "Control.Exception.Safe"
+    , Exception(..)
+    , Safe.SomeException(..)
+    , throw
+    , Handler (..)
+    , MonadIO(..)
+    , MonadUnliftIO(..)
+    ) where
+
+import Control.Exception.Annotated hiding
+       ( catch
+       , catches
+       , checkpoint
+       , checkpointCallStackWith
+       , checkpointMany
+       , throw
+       , throwWithCallStack
+       , try
+       , tryAnnotated
+       )
+import qualified Control.Exception.Annotated as Catch
+import qualified Control.Exception.Safe as Safe
+import Control.Monad.IO.Unlift
+import GHC.Stack
+
+-- | Like 'Catch.throwWithCallStack', but uses 'MonadIO' instead of
+-- 'MonadThrow'.
+--
+-- @since 0.1.2.0
+throwWithCallStack
+    :: forall e m a. (MonadIO m, Exception e, HasCallStack)
+    => e -> m a
+throwWithCallStack = liftIO . Catch.throwWithCallStack
+
+-- | Like 'Catch.throw', but uses 'MonadIO' instead of 'MonadThrow'.
+--
+-- @since 0.1.2.0
+throw :: forall e m a. (MonadIO m, Exception e) => e -> m a
+throw = liftIO . Catch.throw
+
+-- | Like 'Catch.checkpoint', but uses 'MonadUnliftIO' instead of 'MonadCatch'.
+--
+-- @since 0.1.2.0
+checkpoint :: forall m a. (MonadUnliftIO m) => Annotation -> m a -> m a
+checkpoint ann action = withRunInIO $ \runInIO ->
+    liftIO $ Catch.checkpoint ann (runInIO action)
+
+-- | Like 'Catch.checkpointMany', but uses 'MonadUnliftIO' instead of
+-- 'MonadCatch'.
+--
+-- @since 0.1.2.0
+checkpointMany :: forall m a. (MonadUnliftIO m) => [Annotation] -> m a -> m a
+checkpointMany anns action =
+    withRunInIO $ \runInIO ->
+        liftIO $ Catch.checkpointMany anns (runInIO action)
+
+-- | Like 'Catch.checkpointCallStackWith', but uses 'MonadUnliftIO' instead of
+-- 'MonadCatch'.
+--
+-- @since 0.1.2.0
+checkpointCallStackWith
+    :: forall m a. (MonadUnliftIO m, HasCallStack)
+    => [Annotation] -> m a -> m a
+checkpointCallStackWith anns action =
+    withRunInIO $ \runInIO ->
+        liftIO $ Catch.checkpointCallStackWith anns (runInIO action)
+
+-- | Like 'Catch.catch', but uses 'MonadUnliftIO' instead of 'MonadCatch'.
+--
+-- @since 0.1.2.0
+catch
+    :: forall e m a. (MonadUnliftIO m, Exception e)
+    => m a
+    -> (e -> m a)
+    -> m a
+catch action handler =
+    withRunInIO $ \runInIO ->
+        liftIO $ Catch.catch (runInIO action) (\e -> runInIO $ handler e)
+
+-- | Like 'Catch.tryAnnotated' but uses 'MonadUnliftIO' instead of 'MonadCatch'.
+--
+-- @since 0.1.2.0
+tryAnnotated
+    :: forall e m a. (MonadUnliftIO m, Exception e)
+    => m a
+    -> m (Either (AnnotatedException e) a)
+tryAnnotated action =
+    withRunInIO $ \runInIO ->
+        liftIO $ Catch.tryAnnotated (runInIO action)
+
+-- | Like 'Catch.try' but uses 'MonadUnliftIO' instead of 'MonadCatch'.
+--
+-- @since 0.1.2.0
+try
+    :: forall e m a. (MonadUnliftIO m, Exception e)
+    => m a
+    -> m (Either e a)
+try action =
+    withRunInIO $ \runInIO ->
+        liftIO $ Catch.try (runInIO action)
+
+-- | Like 'Catch.catches', bt uses 'MonadUnliftIO' instead of 'MonadCatch'.
+--
+-- @since 0.1.2.0
+catches
+    :: forall m a. MonadUnliftIO m
+    => m a
+    -> [Handler m a]
+    -> m a
+catches action handlers =
+    withRunInIO $ \runInIO -> do
+        let f (Handler k) = Handler (\e -> runInIO (k e))
+        liftIO $ catches (runInIO action) (map f handlers)
+  where

test/Control/Exception/AnnotatedSpec.hs

@@ -114,6 +114,14 @@ spec = do
                     exn `shouldBe` TestException
             action `shouldThrow` (== new TestException)
 
+    describe "catches" $ do
+        it "is exported" $ do
+            let
+                _x :: IO a -> [Handler IO a] -> IO a
+                _x = catches
+            pass
+
+
     describe "checkpoint" $ do
         it "adds annotations" $ do
             Left exn <- try (checkpoint "Here" (throw TestException))