Add fromException and fromExceptionVia (#270)

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.24
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5fb909edb732407e798db0fa3e2e0a62dbeb807e960b77564b99b34a3235fdb3
+-- hash: 8a6be6da10631778dfdd107f8abaf266ea185e5b22d4a9ba78283ec5eff648b2
 
 name:           polysemy
 version:        1.2.3.0
@@ -126,6 +126,7 @@ test-suite polysemy-test
       AsyncSpec
       BracketSpec
       DoctestSpec
+      ErrorSpec
       FailSpec
       FinalSpec
       FixpointSpec

src/Polysemy/Error.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 module Polysemy.Error
   ( -- * Effect
@@ -9,6 +10,8 @@ module Polysemy.Error
   , catch
   , fromEither
   , fromEitherM
+  , fromException
+  , fromExceptionVia
 
     -- * Interpretations
   , runError
@@ -67,6 +70,37 @@ fromEitherM
 fromEitherM = fromEither <=< embed
 
 
+------------------------------------------------------------------------------
+-- | Lift an exception generated from an 'IO' action into an 'Error'.
+fromException
+    :: forall e r a
+     . ( X.Exception e
+       , Member (Error e) r
+       , Member (Embed IO) r
+       )
+    => IO a
+    -> Sem r a
+fromException = fromExceptionVia @e id
+
+
+------------------------------------------------------------------------------
+-- | Like 'fromException', but with the ability to transform the exception
+-- before turning it into an 'Error'.
+fromExceptionVia
+    :: ( X.Exception exc
+       , Member (Error err) r
+       , Member (Embed IO) r
+       )
+    => (exc -> err)
+    -> IO a
+    -> Sem r a
+fromExceptionVia f m = do
+  r <- embed $ X.try m
+  case r of
+    Left e -> throw $ f e
+    Right a -> pure a
+
+
 ------------------------------------------------------------------------------
 -- | Run an 'Error' effect in the style of
 -- 'Control.Monad.Trans.Except.ExceptT'.

test/ErrorSpec.hs

@@ -0,0 +1,38 @@
+module ErrorSpec where
+
+import qualified Control.Exception as X
+import           Polysemy
+import           Polysemy.Error
+import           Polysemy.Resource
+import           Test.Hspec
+
+newtype MyExc = MyExc String
+  deriving (Show, Eq)
+
+instance X.Exception MyExc
+
+spec :: Spec
+spec = parallel $ do
+  describe "fromException" $ do
+    it "should catch exceptions" $ do
+      a <-
+        runM $ runError $ fromException @MyExc $ do
+          _ <- X.throwIO $ MyExc "hello"
+          pure ()
+      a `shouldBe` (Left $ MyExc "hello")
+
+    it "should not catch non-exceptions" $ do
+      a <-
+        runM $ runError @MyExc $ fromException @MyExc $ pure ()
+      a `shouldBe` Right ()
+
+    it "should happen before Resource" $ do
+      a <-
+        runM $ resourceToIO $ runError @MyExc $ do
+          onException
+            (fromException @MyExc $ do
+              _ <- X.throwIO $ MyExc "hello"
+              pure ()
+            ) $ pure $ error "this exception shouldn't happen"
+      a `shouldBe` (Left $ MyExc "hello")
+