Add withCatch.

main
Patrick Thomson 2019-05-15 18:09:01 -04:00
parent bfffc12e67
commit afa25d5562
2 changed files with 21 additions and 4 deletions

View File

@ -1,5 +1,5 @@
name: fused-effects-exceptions name: fused-effects-exceptions
version: 0.1.0.0 version: 0.1.1.0
synopsis: Handle exceptions thrown in IO with fused-effects. synopsis: Handle exceptions thrown in IO with fused-effects.
description: Provides an effect that enables catching exceptions thrown from impure computations such as 'IO'. description: Provides an effect that enables catching exceptions thrown from impure computations such as 'IO'.
homepage: https://github.com/patrickt/fused-effects-exceptions#readme homepage: https://github.com/patrickt/fused-effects-exceptions#readme
@ -13,6 +13,8 @@ build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
extra-source-files: README.md extra-source-files: README.md
tested-with: GHC == 8.6.4
library library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -20,3 +22,8 @@ library
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, fused-effects >= 0.3 && <1 , fused-effects >= 0.3 && <1
, safe-exceptions >= 0.1 && <1 , safe-exceptions >= 0.1 && <1
, unliftio-core >= 0.1.2 && <1
source-repository head
type: git
location: https://github.com/fused-effects/fused-effects-exceptions

View File

@ -4,7 +4,7 @@
-- | An effect that enables catching exceptions thrown from -- | An effect that enables catching exceptions thrown from
-- impure computations such as 'IO'. -- impure computations such as 'IO'.
-- --
-- Use of the 'Error' effect from 'Control.Effect.Error' may lead to -- Use of the 'Control.Effect.Error' effect from @Control.Effect.Error@ may lead to
-- simpler code, as well as avoiding the dynamically-typed nature of -- simpler code, as well as avoiding the dynamically-typed nature of
-- 'Control.Exception'. This is best used when integrating with third-party -- 'Control.Exception'. This is best used when integrating with third-party
-- libraries that operate in 'IO'. If you are using 'catch' for resource -- libraries that operate in 'IO'. If you are using 'catch' for resource
@ -23,6 +23,7 @@ import Control.Effect.Sum
import qualified Control.Exception as Exc import qualified Control.Exception as Exc
import Control.Exception.Safe (isSyncException) import Control.Exception.Safe (isSyncException)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
data Catch m k data Catch m k
= forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> k) = forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> k)
@ -39,7 +40,7 @@ instance Effect Catch where
-- | Like 'Control.Effect.Error.catchError', but delegating to -- | Like 'Control.Effect.Error.catchError', but delegating to
-- 'Control.Exception.catch' under the hood, which allows catching -- 'Control.Exception.catch' under the hood, which allows catching
-- errors that might occur when lifting 'IO' computations. -- errors that might occur when lifting 'IO' computations.
-- Unhandled errors are rethrown. Use 'SomeException' if you want -- Unhandled errors are rethrown. Use 'Exc.SomeException' if you want
-- to catch all errors. -- to catch all errors.
catch :: (Member Catch sig, Carrier sig m, Exc.Exception e) catch :: (Member Catch sig, Carrier sig m, Exc.Exception e)
=> m a => m a
@ -60,12 +61,17 @@ catchSync f g = f `catch` \e ->
-- since we want to preserve async behavior -- since we want to preserve async behavior
else liftIO (Exc.throw e) else liftIO (Exc.throw e)
-- | Evaulate a 'Catch' effect. -- | Evaluate a 'Catch' effect.
runCatch :: (forall x . m x -> IO x) runCatch :: (forall x . m x -> IO x)
-> CatchC m a -> CatchC m a
-> m a -> m a
runCatch handler = runReader (Handler handler) . runCatchC runCatch handler = runReader (Handler handler) . runCatchC
-- | Evaluate a 'Catch' effect, using 'MonadUnliftIO' to infer a correct
-- unlifting function.
withCatch :: MonadUnliftIO m => CatchC m a -> m a
withCatch c = withRunInIO (\f -> runHandler (Handler f) c)
newtype Handler m = Handler (forall x . m x -> IO x) newtype Handler m = Handler (forall x . m x -> IO x)
runHandler :: Handler m -> CatchC m a -> IO a runHandler :: Handler m -> CatchC m a -> IO a
@ -74,6 +80,10 @@ runHandler h@(Handler handler) = handler . runReader h . runCatchC
newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a } newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a }
deriving (Functor, Applicative, Monad, MonadIO) deriving (Functor, Applicative, Monad, MonadIO)
instance MonadUnliftIO m => MonadUnliftIO (CatchC m) where
askUnliftIO = CatchC . ReaderC $ \(Handler h) ->
withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runCatch h r))
instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where
eff (L (CatchIO act cleanup k)) = do eff (L (CatchIO act cleanup k)) = do
handler <- CatchC ask handler <- CatchC ask