Merge pull request #2 from fused-effects/upgrade-to-0.5

Upgrade to fused-effects 0.5.
main
Rob Rix 2019-07-15 15:03:22 -05:00 committed by GitHub
commit c900f59f8f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 19 additions and 19 deletions

View File

@ -1,16 +1,17 @@
cabal-version: 2.4
name: fused-effects-exceptions name: fused-effects-exceptions
version: 0.1.1.0 version: 0.2.0.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/fused-effects/fused-effects-exceptions#readme
license: BSD3 license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
author: Josh Vera author: Josh Vera
maintainer: patrickt@github.com maintainer: patrickt@github.com
copyright: 2019 Josh Vera and Patrick Thomson copyright: 2019 Josh Vera and Patrick Thomson
category: Control. category: Control
build-type: Simple build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md extra-source-files: README.md
tested-with: GHC == 8.6.4 tested-with: GHC == 8.6.4
@ -19,10 +20,10 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
exposed-modules: Control.Effect.Catch exposed-modules: Control.Effect.Catch
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, fused-effects >= 0.3 && <1 , fused-effects ^>= 0.5
, safe-exceptions >= 0.1 && <1 , safe-exceptions >= 0.1 && <1
, unliftio-core >= 0.1.2 && <1 , unliftio-core >= 0.1.2 && <1
source-repository head source-repository head
type: git type: git

View File

@ -14,7 +14,6 @@ module Control.Effect.Catch
, catch , catch
, catchSync , catchSync
, runCatch , runCatch
, withCatch
, CatchC (..) , CatchC (..)
) where ) where
@ -27,12 +26,12 @@ import Control.Monad.IO.Class
import Control.Monad.IO.Unlift 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 -> m k)
deriving instance Functor (Catch m) deriving instance Functor m => Functor (Catch m)
instance HFunctor Catch where instance HFunctor Catch where
hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) k hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) (f . k)
instance Effect Catch where instance Effect Catch where
handle state handler (CatchIO go cleanup k) handle state handler (CatchIO go cleanup k)
@ -63,15 +62,15 @@ catchSync f g = f `catch` \e ->
else liftIO (Exc.throw e) else liftIO (Exc.throw e)
-- | Evaluate a 'Catch' effect. -- | Evaluate a 'Catch' effect.
runCatch :: (forall x . m x -> IO x) unliftCatch :: (forall x . m x -> IO x)
-> CatchC m a -> CatchC m a
-> m a -> m a
runCatch handler = runReader (Handler handler) . runCatchC unliftCatch handler = runReader (Handler handler) . runCatchC
-- | Evaluate a 'Catch' effect, using 'MonadUnliftIO' to infer a correct -- | Evaluate a 'Catch' effect, using 'MonadUnliftIO' to infer a correct
-- unlifting function. -- unlifting function.
withCatch :: MonadUnliftIO m => CatchC m a -> m a runCatch :: MonadUnliftIO m => CatchC m a -> m a
withCatch c = withRunInIO (\f -> runHandler (Handler f) c) runCatch 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)
@ -83,7 +82,7 @@ newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a }
instance MonadUnliftIO m => MonadUnliftIO (CatchC m) where instance MonadUnliftIO m => MonadUnliftIO (CatchC m) where
askUnliftIO = CatchC . ReaderC $ \(Handler h) -> askUnliftIO = CatchC . ReaderC $ \(Handler h) ->
withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runCatch h r)) withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (unliftCatch 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