mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
Prevent errorToIOFinal
from mixing errors up (#444)
This commit is contained in:
parent
dd65cc3bae
commit
8450bff3d8
@ -16,6 +16,8 @@
|
||||
`resourceToIOFinal` instead.
|
||||
- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use
|
||||
`fixpointToFinal` instead.
|
||||
- Changed semantics of `errorToIOFinal` so that it no longer catches errors
|
||||
from other handlers of the same type.
|
||||
|
||||
### Other Changes
|
||||
|
||||
|
@ -25,14 +25,16 @@ module Polysemy.Error
|
||||
, errorToIOFinal
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import qualified Control.Exception as X
|
||||
import Control.Monad
|
||||
import qualified Control.Monad.Trans.Except as E
|
||||
import Data.Typeable
|
||||
import Data.Unique (Unique, hashUnique, newUnique)
|
||||
import GHC.Exts (Any)
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
|
||||
data Error e m a where
|
||||
@ -44,7 +46,7 @@ makeSem ''Error
|
||||
|
||||
hush :: Either e a -> Maybe a
|
||||
hush (Right a) = Just a
|
||||
hush (Left _) = Nothing
|
||||
hush (Left _) = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -55,7 +57,7 @@ fromEither
|
||||
:: Member (Error e) r
|
||||
=> Either e a
|
||||
-> Sem r a
|
||||
fromEither (Left e) = throw e
|
||||
fromEither (Left e) = throw e
|
||||
fromEither (Right a) = pure a
|
||||
{-# INLINABLE fromEither #-}
|
||||
|
||||
@ -103,7 +105,7 @@ fromExceptionVia
|
||||
fromExceptionVia f m = do
|
||||
r <- embed $ X.try m
|
||||
case r of
|
||||
Left e -> throw $ f e
|
||||
Left e -> throw $ f e
|
||||
Right a -> pure a
|
||||
{-# INLINABLE fromExceptionVia #-}
|
||||
|
||||
@ -137,7 +139,7 @@ fromExceptionSemVia f m = do
|
||||
s <- getInitialStateS
|
||||
pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s))
|
||||
case r of
|
||||
Left e -> throw $ f e
|
||||
Left e -> throw $ f e
|
||||
Right a -> pure a
|
||||
{-# INLINABLE fromExceptionSemVia #-}
|
||||
|
||||
@ -168,7 +170,7 @@ tryJust f m = do
|
||||
Right v -> return (Right v)
|
||||
Left e -> case f e of
|
||||
Nothing -> throw e
|
||||
Just b -> return $ Left b
|
||||
Just b -> return $ Left b
|
||||
{-# INLINABLE tryJust #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -184,7 +186,7 @@ catchJust ef m bf = catch m handler
|
||||
where
|
||||
handler e = case ef e of
|
||||
Nothing -> throw e
|
||||
Just b -> bf b
|
||||
Just b -> bf b
|
||||
{-# INLINABLE catchJust #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -242,14 +244,24 @@ mapError f = interpretH $ \case
|
||||
{-# INLINE mapError #-}
|
||||
|
||||
|
||||
newtype WrappedExc e = WrappedExc { unwrapExc :: e }
|
||||
deriving (Typeable)
|
||||
data WrappedExc = WrappedExc !Unique Any
|
||||
|
||||
instance Typeable e => Show (WrappedExc e) where
|
||||
show = mappend "WrappedExc: " . show . typeRep
|
||||
instance Show WrappedExc where
|
||||
show (WrappedExc uid _) =
|
||||
"errorToIOFinal: Escaped opaque exception. Unique hash is: " <>
|
||||
show (hashUnique uid) <> "This should only happen if the computation that " <>
|
||||
"threw the exception was somehow invoked outside of the argument of 'errorToIOFinal'; " <>
|
||||
"for example, if you 'async' an exceptional computation inside of the argument " <>
|
||||
"provided to 'errorToIOFinal', and then 'await' on it *outside* of the argument " <>
|
||||
"provided to 'errorToIOFinal'. If that or any similar shenanigans seems unlikely, " <>
|
||||
"please open an issue on the GitHub repository."
|
||||
|
||||
instance (Typeable e) => X.Exception (WrappedExc e)
|
||||
instance X.Exception WrappedExc
|
||||
|
||||
catchWithUid :: forall e a. Unique -> IO a -> (e -> IO a) -> IO a
|
||||
catchWithUid uid m h = X.catch m $ \exc@(WrappedExc uid' e) ->
|
||||
if uid == uid' then h (unsafeCoerce e) else X.throwIO exc
|
||||
{-# INLINE catchWithUid #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This
|
||||
@ -261,35 +273,31 @@ instance (Typeable e) => X.Exception (WrappedExc e)
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
errorToIOFinal
|
||||
:: ( Typeable e
|
||||
, Member (Final IO) r
|
||||
:: forall e r a
|
||||
. ( Member (Final IO) r
|
||||
)
|
||||
=> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
errorToIOFinal sem = withStrategicToFinal @IO $ do
|
||||
m' <- runS (runErrorAsExcFinal sem)
|
||||
m' <- bindS (`runErrorAsExcFinal` sem)
|
||||
s <- getInitialStateS
|
||||
pure $
|
||||
either
|
||||
((<$ s) . Left . unwrapExc)
|
||||
(fmap Right)
|
||||
<$> X.try m'
|
||||
pure $ do
|
||||
uid <- newUnique
|
||||
catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left)
|
||||
{-# INLINE errorToIOFinal #-}
|
||||
|
||||
runErrorAsExcFinal
|
||||
:: forall e r a
|
||||
. ( Typeable e
|
||||
, Member (Final IO) r
|
||||
. ( Member (Final IO) r
|
||||
)
|
||||
=> Sem (Error e ': r) a
|
||||
=> Unique
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r a
|
||||
runErrorAsExcFinal = interpretFinal $ \case
|
||||
Throw e -> pure $ X.throwIO $ WrappedExc e
|
||||
runErrorAsExcFinal uid = interpretFinal $ \case
|
||||
Throw e -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e)
|
||||
Catch m h -> do
|
||||
m' <- runS m
|
||||
h' <- bindS h
|
||||
s <- getInitialStateS
|
||||
pure $ X.catch m' $ \(se :: WrappedExc e) ->
|
||||
h' (unwrapExc se <$ s)
|
||||
pure $ catchWithUid uid m' $ \e -> h' (e <$ s)
|
||||
{-# INLINE runErrorAsExcFinal #-}
|
||||
|
||||
|
@ -7,4 +7,3 @@ packages:
|
||||
extra-deps:
|
||||
- dump-core-0.1.3.2 # used when the dump-core flag is toggled
|
||||
- monadLib-3.10 # used by the dump-core library when the dump-core flag is toggled
|
||||
|
||||
|
@ -2,6 +2,7 @@ module ErrorSpec where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.Error
|
||||
import Polysemy.Resource
|
||||
import Test.Hspec
|
||||
@ -35,4 +36,21 @@ spec = parallel $ do
|
||||
pure ()
|
||||
) $ pure $ error "this exception shouldn't happen"
|
||||
a `shouldBe` (Left $ MyExc "hello")
|
||||
describe "errorToIOFinal" $ do
|
||||
it "should catch errors only for the interpreted Error" $ do
|
||||
res1 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do
|
||||
raise $ throw () `catch` \() -> return ()
|
||||
res1 `shouldBe` Right (Right ())
|
||||
res2 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do
|
||||
raise (throw ()) `catch` \() -> return ()
|
||||
res2 `shouldBe` Left ()
|
||||
|
||||
it "should propagate errors thrown in 'async'" $ do
|
||||
res1 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do
|
||||
a <- async $ throw ()
|
||||
await a
|
||||
res1 `shouldBe` (Left () :: Either () (Maybe ()))
|
||||
res2 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do
|
||||
a <- async $ throw ()
|
||||
await a `catch` \() -> return $ Just ()
|
||||
res2 `shouldBe` Right (Just ())
|
||||
|
Loading…
Reference in New Issue
Block a user