From 254e184e58aac121d733eabb2b882161d7931e0b Mon Sep 17 00:00:00 2001
From: John Ky <john.ky@iohk.io>
Date: Tue, 17 Jan 2023 17:57:24 +1100
Subject: [PATCH] New onExceptionM and onExceptionThrowM functions

---
 oops.cabal                |  2 ++
 src/Control/Monad/Oops.hs | 27 +++++++++++++++++++++++++--
 2 files changed, 27 insertions(+), 2 deletions(-)

diff --git a/oops.cabal b/oops.cabal
index 41b7675..de153b9 100644
--- a/oops.cabal
+++ b/oops.cabal
@@ -26,6 +26,7 @@ common Glob                           { build-depends: Glob
 common doctest                        { build-depends: doctest                        >= 0.16.2     && < 0.21   }
 common doctest-discover               { build-depends: doctest-discover               >= 0.2        && < 0.3    }
 common doctest-prop                   { build-depends: doctest-prop                   >= 0.2.0.1    && < 0.3    }
+common exceptions                     { build-depends: exceptions                                               }
 common hedgehog-quickcheck            { build-depends: hedgehog-quickcheck                                      }
 common hedgehog                       { build-depends: hedgehog                                                 }
 common hspec                          { build-depends: hspec                                                    }
@@ -42,6 +43,7 @@ common project-config
 
 library
   import:               base, project-config,
+                        exceptions,
                         mtl,
                         QuickCheck,
                         transformers,
diff --git a/src/Control/Monad/Oops.hs b/src/Control/Monad/Oops.hs
index 1ab2424..0eae3d1 100644
--- a/src/Control/Monad/Oops.hs
+++ b/src/Control/Monad/Oops.hs
@@ -52,6 +52,9 @@ module Control.Monad.Oops
     recoverM,
     recoverOrVoidM,
 
+    onExceptionThrowM,
+    onExceptionM,
+
     DV.CouldBeF (..),
     DV.CouldBe  (..),
     DV.CouldBeAnyOfF,
@@ -71,8 +74,9 @@ import Data.Functor.Identity (Identity (..))
 import Data.Variant (Catch, CatchF(..), CouldBe, CouldBeF(..), Variant, VariantF, preposterous)
 import Data.Void (Void, absurd)
 
-import qualified Data.Variant as DV
-import qualified System.Exit  as IO
+import qualified Control.Monad.Catch as CMC
+import qualified Data.Variant        as DV
+import qualified System.Exit         as IO
 
 -- | When working in some monadic context, using 'catch' becomes trickier. The
 -- intuitive behaviour is that each 'catch' shrinks the variant in the left
@@ -292,3 +296,22 @@ recoverOrVoidM :: forall x e m. ()
   => ExceptT (Variant (x : e)) m Void
   -> ExceptT (Variant e) m x
 recoverOrVoidM f = either pure absurd =<< (fmap Right f & catchM @x (pure . Left))
+
+-- | Catch an exception of the specified type 'x' and throw it as an error
+onExceptionThrowM :: forall x e m a. ()
+  => CMC.MonadCatch m
+  => CMC.Exception x
+  => MonadError (Variant e) m
+  => CouldBeF e x
+  => m a
+  -> m a
+onExceptionThrowM = onExceptionM @x throwM
+
+-- | Catch an exception of the specified type 'x' and call the the handler 'h'
+onExceptionM :: forall x m a. ()
+  => CMC.MonadCatch m
+  => CMC.Exception x
+  => (x -> m a)
+  -> m a
+  -> m a
+onExceptionM h f = either h pure =<< CMC.try f