Add withException to Frontrow.App.Exception

freckle · Jan 31, 2024 · 1e86fc8 · 1e86fc8
1 parent 56a1b8b
commit 1e86fc8
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 0 deletions.
diff --git a/library/Freckle/App/Exception/MonadThrow.hs b/library/Freckle/App/Exception/MonadThrow.hs
@@ -8,6 +8,7 @@ module Freckle.App.Exception.MonadThrow
   , catches
   , try
   , tryJust
+  , withException
   , checkpoint
   , checkpointMany
   , checkpointCallStack
@@ -23,6 +24,7 @@ import Freckle.App.Exception.Types
 
 import Control.Applicative (pure)
 import Control.Exception.Annotated (checkpoint, checkpointMany)
+import Control.Monad (void)
 import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Data.Either (Either (..))
 import Data.Function (($), (.))
@@ -104,6 +106,17 @@ tryJust test action =
   withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->
     maybe (Control.Monad.Catch.throwM e) (pure . Left) (test e)
 
+withException
+  :: forall e a m b
+   . (Exception e, MonadCatch m, HasCallStack)
+  => m a
+  -> (e -> m b)
+  -> m a
+withException action onException =
+  withFrozenCallStack $ Annotated.catch action $ \e -> do
+    void $ onException e
+    Control.Monad.Catch.throwM e
+
 -- | When dealing with a library that does not use 'AnnotatedException',
 --   apply this function to augment its exceptions with call stacks.
 checkpointCallStack

diff --git a/library/Freckle/App/Exception/MonadUnliftIO.hs b/library/Freckle/App/Exception/MonadUnliftIO.hs
@@ -8,6 +8,7 @@ module Freckle.App.Exception.MonadUnliftIO
   , catches
   , try
   , tryJust
+  , withException
   , checkpoint
   , checkpointMany
   , checkpointCallStack
@@ -23,6 +24,7 @@ import Freckle.App.Exception.Types
 
 import Control.Applicative (pure)
 import Control.Exception.Annotated.UnliftIO (checkpoint, checkpointMany)
+import Control.Monad (void)
 import Data.Either (Either (..))
 import Data.Function (($), (.))
 import Data.Functor (fmap, (<$>))
@@ -105,6 +107,17 @@ tryJust test action =
   withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->
     maybe (UnliftIO.Exception.throwIO e) (pure . Left) (test e)
 
+withException
+  :: forall e a m b
+   . (Exception e, MonadUnliftIO m, HasCallStack)
+  => m a
+  -> (e -> m b)
+  -> m a
+withException action onException =
+  withFrozenCallStack $ Annotated.catch action $ \e -> do
+    void $ onException e
+    UnliftIO.Exception.throwIO e
+
 -- | When dealing with a library that does not use 'AnnotatedException',
 --   apply this function to augment its exceptions with call stacks.
 checkpointCallStack