mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-17 13:37:21 +03:00
Prevent errorToIOFinal
from mixing errors up (#444)
This commit is contained in:
parent
dd65cc3bae
commit
8450bff3d8
@ -16,6 +16,8 @@
|
|||||||
`resourceToIOFinal` instead.
|
`resourceToIOFinal` instead.
|
||||||
- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use
|
- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use
|
||||||
`fixpointToFinal` instead.
|
`fixpointToFinal` instead.
|
||||||
|
- Changed semantics of `errorToIOFinal` so that it no longer catches errors
|
||||||
|
from other handlers of the same type.
|
||||||
|
|
||||||
### Other Changes
|
### Other Changes
|
||||||
|
|
||||||
|
@ -25,14 +25,16 @@ module Polysemy.Error
|
|||||||
, errorToIOFinal
|
, errorToIOFinal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Control.Exception as X
|
import qualified Control.Exception as X
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Control.Monad.Trans.Except as E
|
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
|
||||||
import Polysemy.Final
|
import Polysemy.Final
|
||||||
import Polysemy.Internal
|
import Polysemy.Internal
|
||||||
import Polysemy.Internal.Union
|
import Polysemy.Internal.Union
|
||||||
|
import Unsafe.Coerce (unsafeCoerce)
|
||||||
|
|
||||||
|
|
||||||
data Error e m a where
|
data Error e m a where
|
||||||
@ -44,7 +46,7 @@ makeSem ''Error
|
|||||||
|
|
||||||
hush :: Either e a -> Maybe a
|
hush :: Either e a -> Maybe a
|
||||||
hush (Right a) = Just a
|
hush (Right a) = Just a
|
||||||
hush (Left _) = Nothing
|
hush (Left _) = Nothing
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
@ -55,7 +57,7 @@ fromEither
|
|||||||
:: Member (Error e) r
|
:: Member (Error e) r
|
||||||
=> Either e a
|
=> Either e a
|
||||||
-> Sem r a
|
-> Sem r a
|
||||||
fromEither (Left e) = throw e
|
fromEither (Left e) = throw e
|
||||||
fromEither (Right a) = pure a
|
fromEither (Right a) = pure a
|
||||||
{-# INLINABLE fromEither #-}
|
{-# INLINABLE fromEither #-}
|
||||||
|
|
||||||
@ -103,7 +105,7 @@ fromExceptionVia
|
|||||||
fromExceptionVia f m = do
|
fromExceptionVia f m = do
|
||||||
r <- embed $ X.try m
|
r <- embed $ X.try m
|
||||||
case r of
|
case r of
|
||||||
Left e -> throw $ f e
|
Left e -> throw $ f e
|
||||||
Right a -> pure a
|
Right a -> pure a
|
||||||
{-# INLINABLE fromExceptionVia #-}
|
{-# INLINABLE fromExceptionVia #-}
|
||||||
|
|
||||||
@ -137,7 +139,7 @@ fromExceptionSemVia f m = do
|
|||||||
s <- getInitialStateS
|
s <- getInitialStateS
|
||||||
pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s))
|
pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s))
|
||||||
case r of
|
case r of
|
||||||
Left e -> throw $ f e
|
Left e -> throw $ f e
|
||||||
Right a -> pure a
|
Right a -> pure a
|
||||||
{-# INLINABLE fromExceptionSemVia #-}
|
{-# INLINABLE fromExceptionSemVia #-}
|
||||||
|
|
||||||
@ -168,7 +170,7 @@ tryJust f m = do
|
|||||||
Right v -> return (Right v)
|
Right v -> return (Right v)
|
||||||
Left e -> case f e of
|
Left e -> case f e of
|
||||||
Nothing -> throw e
|
Nothing -> throw e
|
||||||
Just b -> return $ Left b
|
Just b -> return $ Left b
|
||||||
{-# INLINABLE tryJust #-}
|
{-# INLINABLE tryJust #-}
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
@ -184,7 +186,7 @@ catchJust ef m bf = catch m handler
|
|||||||
where
|
where
|
||||||
handler e = case ef e of
|
handler e = case ef e of
|
||||||
Nothing -> throw e
|
Nothing -> throw e
|
||||||
Just b -> bf b
|
Just b -> bf b
|
||||||
{-# INLINABLE catchJust #-}
|
{-# INLINABLE catchJust #-}
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
@ -242,14 +244,24 @@ mapError f = interpretH $ \case
|
|||||||
{-# INLINE mapError #-}
|
{-# INLINE mapError #-}
|
||||||
|
|
||||||
|
|
||||||
newtype WrappedExc e = WrappedExc { unwrapExc :: e }
|
data WrappedExc = WrappedExc !Unique Any
|
||||||
deriving (Typeable)
|
|
||||||
|
|
||||||
instance Typeable e => Show (WrappedExc e) where
|
instance Show WrappedExc where
|
||||||
show = mappend "WrappedExc: " . show . typeRep
|
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
|
-- | 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
|
-- @since 1.2.0.0
|
||||||
errorToIOFinal
|
errorToIOFinal
|
||||||
:: ( Typeable e
|
:: forall e r a
|
||||||
, Member (Final IO) r
|
. ( Member (Final IO) r
|
||||||
)
|
)
|
||||||
=> Sem (Error e ': r) a
|
=> Sem (Error e ': r) a
|
||||||
-> Sem r (Either e a)
|
-> Sem r (Either e a)
|
||||||
errorToIOFinal sem = withStrategicToFinal @IO $ do
|
errorToIOFinal sem = withStrategicToFinal @IO $ do
|
||||||
m' <- runS (runErrorAsExcFinal sem)
|
m' <- bindS (`runErrorAsExcFinal` sem)
|
||||||
s <- getInitialStateS
|
s <- getInitialStateS
|
||||||
pure $
|
pure $ do
|
||||||
either
|
uid <- newUnique
|
||||||
((<$ s) . Left . unwrapExc)
|
catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left)
|
||||||
(fmap Right)
|
|
||||||
<$> X.try m'
|
|
||||||
{-# INLINE errorToIOFinal #-}
|
{-# INLINE errorToIOFinal #-}
|
||||||
|
|
||||||
runErrorAsExcFinal
|
runErrorAsExcFinal
|
||||||
:: forall e r a
|
:: 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
|
-> Sem r a
|
||||||
runErrorAsExcFinal = interpretFinal $ \case
|
runErrorAsExcFinal uid = interpretFinal $ \case
|
||||||
Throw e -> pure $ X.throwIO $ WrappedExc e
|
Throw e -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e)
|
||||||
Catch m h -> do
|
Catch m h -> do
|
||||||
m' <- runS m
|
m' <- runS m
|
||||||
h' <- bindS h
|
h' <- bindS h
|
||||||
s <- getInitialStateS
|
s <- getInitialStateS
|
||||||
pure $ X.catch m' $ \(se :: WrappedExc e) ->
|
pure $ catchWithUid uid m' $ \e -> h' (e <$ s)
|
||||||
h' (unwrapExc se <$ s)
|
|
||||||
{-# INLINE runErrorAsExcFinal #-}
|
{-# INLINE runErrorAsExcFinal #-}
|
||||||
|
|
||||||
|
@ -7,4 +7,3 @@ packages:
|
|||||||
extra-deps:
|
extra-deps:
|
||||||
- dump-core-0.1.3.2 # used when the dump-core flag is toggled
|
- 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
|
- 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 qualified Control.Exception as X
|
||||||
import Polysemy
|
import Polysemy
|
||||||
|
import Polysemy.Async
|
||||||
import Polysemy.Error
|
import Polysemy.Error
|
||||||
import Polysemy.Resource
|
import Polysemy.Resource
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
@ -35,4 +36,21 @@ spec = parallel $ do
|
|||||||
pure ()
|
pure ()
|
||||||
) $ pure $ error "this exception shouldn't happen"
|
) $ pure $ error "this exception shouldn't happen"
|
||||||
a `shouldBe` (Left $ MyExc "hello")
|
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