diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 0000000..84adab5 --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,36 @@ +name: Haskell CI + +on: [pull_request] + +jobs: + build: + name: ghc ${{ matrix.ghc }} + runs-on: ubuntu-16.04 + strategy: + matrix: + ghc: ["8.2.2", "8.4.4", "8.6.5", "8.8.1"] + cabal: ["3.0"] + + steps: + - uses: actions/checkout@master + if: github.event.action == 'opened' || github.event.action == 'synchronize' + + - uses: actions/setup-haskell@v1 + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Install dependencies + run: | + cabal v2-update + cabal v2-configure --write-ghc-environment-files=always -j2 + cabal v2-build --only-dependencies + + - name: Build & test + run: | + cabal v2-build + cabal v2-run examples + cabal v2-haddock + cabal v2-sdist + cabal check diff --git a/ChangeLog.md b/ChangeLog.md index ac3261f..0344e38 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,9 @@ # 1.0.0.0 * Port to fused-effects 1.0. -* Add `Control.Effect.Resource` and `Control.Carrier.Resource`, as ported from fused-effects 0.5. -* Add `Control.Carrier.State.IORef` to help people migrating from other state carriers. -* Move `Control.Effect.Catch.CatchC` to `Control.Carrier.Catch` and simplify its internals. -* Rename `catch` to `catchAsync` and `catchSync` to `catch`. +* Add `Control.Effect.Exception`, which wraps the entirety of `base`'s `Control.Exception`. +* Add `Control.Carrier.State.IORef`, a state carrier that does not drop writes. +* Remove `Catch` effect in favor of `Control.Effect.Exception`. # 0.2.0.0 diff --git a/README.md b/README.md index a6140e4..0b43da2 100644 --- a/README.md +++ b/README.md @@ -2,15 +2,11 @@ [![Hackage](https://img.shields.io/hackage/v/fused-effects-exceptions.svg)](https://hackage.haskell.org/package/fused-effects-exceptions) [![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) -[![Build status](https://secure.travis-ci.org/patrickt/fused-effects-exceptions.svg)](https://travis-ci.org/patrickt/fused-effects-exceptions) +[![Build Status](https://action-badges.now.sh/fused-effects/fused-effects-exceptions)](https://github.com/fused-effects/fused-effects-exceptions/actions) -This package provides two useful effects for handling exceptions thrown from pure code or IO with GHC's `Control.Exception.throw` function. +This package provides `Control.Effect.Exception`, a module that wraps the [`Control.Exception`](http://hackage.haskell.org/package/base/docs/Control-Exception.html) API from `base` with the vocabulary provided by the [`fused-effects`](http://hackage.haskell.org/package/fused-effects) library. These functions interact with GHC's support for dynamic exceptions, including functions like `catch` for exception handling and `bracket` for resource management. -## Control.Effect.Resource - -This effect provides `bracket`, `finally`, and `onException` functions capable of allocating and freeing scarce resources in the presence of GHC's exceptions. It is similar in functionality to the [`resourcet`](http://hackage.haskell.org/package/resourcet) package. - -This effect was included in prior versions of `fused-effects`, but has been moved to this package due to the surprising interactions it can have with the `Control.Carrier.State` carriers provided by `fused-effects`. If you use the `ResourceC` and `StateC` effects in conjunction, writes inside a `finally` block may be discarded, since `finally` discards the result of its cleanup handler: +Please be aware that injudicious use of these functions may provoke surprising interactions with carriers that thread a monadic state as a parameter, à la the `Control.Carrier.State` types provided by `fused-effects`. For example, a function like `finally`, which does not thread any state from its body to its handler block, may discard state writes in cleanup handlers: ```haskell λ runM (runResource (runState 'a' (modify (succ @Char) `finally` modify (succ . succ @Char)))) @@ -19,8 +15,4 @@ This effect was included in prior versions of `fused-effects`, but has been move If this behavior is a concern, a `Control.Carrier.State.IORef` carrier is provided, which fixes this issue given access to a `MonadIO` constraint. If it is not a concern (such as if the cleanup block is only run for its effects in `IO`), then the `StateC` carriers from `fused-effects` will suffice. For more information about the issues associated with this approach, consult Alexis King's excellent [Demystifying `MonadBaseControl`](https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/). -## Control.Effect.State - -This effect is similar to the `MonadCatch` and `MonadThrow` classes provided by the `exceptions` package. It delegates to `catch` from `Control.Exception`. An additional `catchSync` primitive is provided to handle the common case of catching only synchronous exceptions. Its implementation was extracted from one originally written by Josh Vera. - -This effect displays the same behavior associated with `Resource` in that carriers like `Control.Carrier.State.Strict` which rely on return types to propagate state may drop state information. +Prior versions of this package provided a `Catch` effect; this has been excised in favor of the more-general `Control.Effect.Exception`, which provides more functionality without requiring any additional carriers beyond a `Lift IO` effect. diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..724efbd --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/fused-effects/fused-effects.git + tag: 0c7d9c19b638f7fe21ac77903894308ad15b0e80 diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 045d765..0a17efd 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -12,23 +12,26 @@ maintainer: patrickt@github.com copyright: 2019 Josh Vera, Patrick Thomson, and Rob Rix category: Control build-type: Simple -extra-source-files: README.md +extra-source-files: + README.md + ChangeLog.md -tested-with: GHC == 8.6.4 +tested-with: + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.1 library hs-source-dirs: src - default-language: Haskell2010 - exposed-modules: Control.Carrier.Catch - Control.Carrier.Resource - Control.Carrier.State.IORef - Control.Effect.Catch - Control.Effect.Resource - build-depends: base >= 4.7 && < 5 - , fused-effects - , safe-exceptions >= 0.1 && <1 - , transformers - , unliftio-core >= 0.1.2 && <1 + default-language: Haskell2010 + exposed-modules: + Control.Carrier.State.IORef + Control.Effect.Exception + build-depends: + base >= 4.7 && < 5 + , fused-effects >= 1 + , transformers >= 0.4 && < 0.6 source-repository head type: git diff --git a/src/Control/Carrier/Catch.hs b/src/Control/Carrier/Catch.hs deleted file mode 100644 index bc9b983..0000000 --- a/src/Control/Carrier/Catch.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-} - --- | A carrier for a 'Catch' effect. -module Control.Carrier.Catch - ( -- * Catch effect - module Control.Effect.Catch - -- * Catch carrier - , runCatch - , CatchC (..) - -- * Re-exports - , Carrier - , run - ) where - -import Control.Applicative (Alternative(..)) -import Control.Carrier -import Control.Effect.Catch -import qualified Control.Exception as Exc -import Control.Monad (MonadPlus(..)) -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift -import Control.Monad.Trans.Class - --- | Evaluate a 'Catch' effect, using 'MonadUnliftIO' to infer a correct unlifting function. --- --- | @since 1.0.0.0 -runCatch :: MonadUnliftIO m => CatchC m a -> m a -runCatch = runCatchC - -newtype CatchC m a = CatchC { runCatchC :: m a } - deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus) - -instance MonadTrans CatchC where - lift = CatchC - -instance MonadUnliftIO m => MonadUnliftIO (CatchC m) where - withRunInIO f = CatchC (withRunInIO (\ runInIO -> f (runInIO . runCatchC))) - -instance (Carrier sig m, MonadUnliftIO m) => Carrier (Catch :+: sig) (CatchC m) where - eff (L (CatchIO act cleanup k)) = do - handler <- askUnliftIO - liftIO (Exc.catch (unliftIO handler act) (unliftIO handler . cleanup)) >>= k - eff (R other) = CatchC (eff (handleCoercible other)) diff --git a/src/Control/Carrier/Resource.hs b/src/Control/Carrier/Resource.hs deleted file mode 100644 index 51b5152..0000000 --- a/src/Control/Carrier/Resource.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-} - --- | Provides a carrier for a 'Resource' effect. This carrier is implemented atop 'Control.Exception.catch' from "Control.Exception" and is thus safe in the presence of asynchronous exceptions. -module Control.Carrier.Resource -( -- * Resource effect - module Control.Effect.Resource - -- * Resource carrier -, runResource -, ResourceC(..) - -- * Re-exports -, Carrier -, run -) where - -import Control.Applicative (Alternative(..)) -import Control.Carrier -import Control.Effect.Resource -import qualified Control.Exception as Exc -import Control.Monad (MonadPlus(..)) -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift -import Control.Monad.Trans.Class - --- | Executes a 'Resource' effect. Because this runs using 'MonadUnliftIO', --- invocations of 'runResource' must happen at the "bottom" of a stack of --- effect invocations, i.e. before the use of any monads that lack such --- instances, such as 'StateC': --- --- @ --- runM --- . runResource --- . runState @Int 1 --- $ myComputation --- @ --- --- @since 1.0.0.0 -runResource :: ResourceC m a -> m a -runResource = runResourceC - -newtype ResourceC m a = ResourceC { runResourceC :: m a } - deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus) - -instance MonadTrans ResourceC where - lift = ResourceC - -instance MonadUnliftIO m => MonadUnliftIO (ResourceC m) where - withRunInIO f = ResourceC (withRunInIO (\ runInIO -> f (runInIO . runResourceC))) - -instance (Carrier sig m, MonadUnliftIO m) => Carrier (Resource :+: sig) (ResourceC m) where - eff (L (Resource acquire release use k)) = do - handler <- askUnliftIO - a <- liftIO (Exc.bracket - (unliftIO handler acquire) - (unliftIO handler . release) - (unliftIO handler . use)) - k a - eff (L (OnError acquire release use k)) = do - handler <- askUnliftIO - a <- liftIO (Exc.bracketOnError - (unliftIO handler acquire) - (unliftIO handler . release) - (unliftIO handler . use)) - k a - eff (R other) = ResourceC (eff (handleCoercible other)) diff --git a/src/Control/Carrier/State/IORef.hs b/src/Control/Carrier/State/IORef.hs index 9fca6be..661308e 100644 --- a/src/Control/Carrier/State/IORef.hs +++ b/src/Control/Carrier/State/IORef.hs @@ -5,27 +5,23 @@ Note that the parameter order in 'runState', 'evalState', and 'execState' is reversed compared the equivalent functions provided by @transformers@. This is an intentional decision made to enable the composition of effect handlers with '.' without invoking 'flip'. -} module Control.Carrier.State.IORef -( -- * State effect - module Control.Effect.State - -- * Strict state carrier -, runState +( -- * Strict state carrier + runState , evalState , execState , StateC(..) - -- * Re-exports -, Carrier -, run +-- * State effect +, module Control.Effect.State ) where import Control.Applicative (Alternative (..)) -import Control.Carrier +import Control.Algebra import Control.Carrier.Reader import Control.Effect.State import Control.Monad (MonadPlus (..)) import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class -import Control.Monad.IO.Unlift import Control.Monad.Trans.Class import Data.IORef @@ -66,17 +62,11 @@ execState s = fmap fst . runState s newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a } deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus) -instance MonadUnliftIO m => MonadUnliftIO (StateC s m) where - askUnliftIO = StateC . ReaderC $ \r -> withUnliftIO $ \u -> pure (UnliftIO (\(StateC (ReaderC x)) -> unliftIO u (x r))) - {-# INLINE askUnliftIO #-} - withRunInIO inner = StateC . ReaderC $ \r -> withRunInIO $ \go -> inner (go . runReader r . runStateC) - {-# INLINE withRunInIO #-} - -instance (MonadIO m, Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where - eff (L act) = do +instance (MonadIO m, Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where + alg (L act) = do ref <- StateC ask case act of Put s k -> liftIO (writeIORef ref s) *> k Get k -> liftIO (readIORef ref) >>= k - eff (R other) = StateC (eff (R (handleCoercible other))) - {-# INLINE eff #-} + alg (R other) = StateC (handleCoercible other) + {-# INLINE alg #-} diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs deleted file mode 100644 index ca5b382..0000000 --- a/src/Control/Effect/Catch.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} - --- | An effect that enables catching exceptions thrown from --- impure computations such as 'IO'. --- --- 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 --- 'Control.Exception'. This is best used when integrating with third-party --- libraries that operate in 'IO'. If you are using 'catch' for resource --- management, consider using 'Control.Effect.Resource' instead. -module Control.Effect.Catch - ( Catch (..) - , catch - , catchAsync - ) where - -import Control.Carrier -import Control.Effect.Reader -import Control.Effect.Sum -import qualified Control.Exception as Exc -import Control.Exception.Safe (isSyncException) -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift - --- | @since 0.1.0.0 -data Catch m k - = forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> m k) - -deriving instance Functor m => Functor (Catch m) - -instance HFunctor Catch where - hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) (f . k) - -instance Effect Catch where - handle state handler (CatchIO go cleanup k) - = CatchIO (handler (go <$ state)) (\se -> handler (cleanup se <$ state)) (handler . fmap k) - --- | Like 'Control.Effect.Error.catchError', but delegating to 'Control.Exception.catch' under the hood, which allows catching errors that might occur when lifting 'IO' computations. --- --- Unhandled errors are rethrown. Use 'Exc.SomeException' if you want to catch all errors. --- --- | @since 1.0.0.0 -catchAsync :: (Member Catch sig, Carrier sig m, Exc.Exception e) - => m a - -> (e -> m a) - -> m a -catchAsync go cleanup = send (CatchIO go cleanup pure) - --- | Like 'Control.Effect.Error.catchError', but delegating to 'Control.Exception.catch' under the hood, which allows catching errors that might occur when lifting 'IO' computations. Asynchronous exceptions are rethrown by this function. Use 'catchAsync' to catch them as well. --- --- Unhandled errors are rethrown. Use 'Exc.SomeException' if you want to catch all errors. --- --- | @since 0.1.0.0 -catch :: (Member Catch sig, Carrier sig m, Exc.Exception e, MonadIO m) - => m a - -> (e -> m a) - -> m a -catch f g = f `catch` \e -> - if isSyncException e - then g e - -- intentionally rethrowing an async exception synchronously, - -- since we want to preserve async behavior - else liftIO (Exc.throw e) diff --git a/src/Control/Effect/Exception.hs b/src/Control/Effect/Exception.hs new file mode 100644 index 0000000..05e571e --- /dev/null +++ b/src/Control/Effect/Exception.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DeriveFunctor, ExistentialQuantification, RankNTypes, StandaloneDeriving #-} +-- | Operations from "Control.Exception" lifted into effectful contexts using 'Control.Effect.Lift.Lift'. +-- +-- @since 1.0.0.0 +module Control.Effect.Exception +( -- * Lifted "Control.Exception" operations + throwIO +, ioError +, throwTo +, catch +, catches +, Handler(..) +, catchJust +, handle +, handleJust +, try +, tryJust +, evaluate +, mask +, mask_ +, uninterruptibleMask +, uninterruptibleMask_ +, getMaskingState +, interruptible +, allowInterrupt +, bracket +, bracket_ +, bracketOnError +, finally +, onException +, module Control.Exception + -- * Lift effect +, Lift(..) +, sendM +, liftWith + -- * Re-exports +, Algebra +, Has +, run +) where + +import Control.Concurrent (ThreadId) +import Control.Effect.Lift +import Control.Exception hiding + ( throwIO + , ioError + , throwTo + , catch + , catches + , Handler + , catchJust + , handle + , handleJust + , try + , tryJust + , evaluate + , mask + , mask_ + , uninterruptibleMask + , uninterruptibleMask_ + , getMaskingState + , interruptible + , allowInterrupt + , bracket + , bracket_ + , bracketOnError + , finally + , onException + ) +import qualified Control.Exception as Exc +import Prelude hiding (ioError) + +-- | See @"Control.Exception".'Exc.throwIO'@. +-- +-- @since 1.0.0.0 +throwIO :: (Exc.Exception e, Has (Lift IO) sig m) => e -> m a +throwIO = sendM . Exc.throwIO + +-- | See @"Control.Exception".'Exc.ioError'@. +-- +-- @since 1.0.0.0 +ioError :: Has (Lift IO) sig m => IOError -> m a +ioError = sendM . Exc.ioError + +-- | See @"Control.Exception".'Exc.throwTo'@. +-- +-- @since 1.0.0.0 +throwTo :: (Exc.Exception e, Has (Lift IO) sig m) => ThreadId -> e -> m () +throwTo thread = sendM . Exc.throwTo thread + +-- | See @"Control.Exception".'Exc.catch'@. +-- +-- @since 1.0.0.0 +catch :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a +catch m h = liftWith $ \ ctx run -> run (m <$ ctx) `Exc.catch` (run . (<$ ctx) . h) + +-- | See @"Control.Exception".'Exc.catches'@. +-- +-- @since 1.0.0.0 +catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a +catches m hs = liftWith $ \ ctx run -> + Exc.catches (run (m <$ ctx)) (map (\ (Handler h) -> Exc.Handler (run . (<$ ctx) . h)) hs) + +-- | See @"Control.Exception".'Exc.Handler'@. +-- +-- @since 1.0.0.0 +data Handler m a + = forall e . Exc.Exception e => Handler (e -> m a) + +deriving instance Functor m => Functor (Handler m) + +-- | See @"Control.Exception".'Exc.catchJust'@. +-- +-- @since 1.0.0.0 +catchJust + :: (Exc.Exception e, Has (Lift IO) sig m) + => (e -> Maybe b) + -> m a + -> (b -> m a) + -> m a +catchJust p m h = liftWith $ \ ctx run -> Exc.catchJust p (run (m <$ ctx)) (run . (<$ ctx) . h) + +-- | See @"Control.Exception".'Exc.handle'@. +-- +-- @since 1.0.0.0 +handle :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a +handle = flip catch + +-- | See @"Control.Exception".'Exc.handleJust'@. +-- +-- @since 1.0.0.0 +handleJust + :: (Exc.Exception e, Has (Lift IO) sig m) + => (e -> Maybe b) + -> (b -> m a) + -> m a + -> m a +handleJust p = flip (catchJust p) + +-- | See @"Control.Exception".'Exc.try'@. +-- +-- @since 1.0.0.0 +try :: (Exc.Exception e, Has (Lift IO) sig m) => m a -> m (Either e a) +try m = (Right <$> m) `catch` (pure . Left) + +-- | See @"Control.Exception".'Exc.tryJust'@. +-- +-- @since 1.0.0.0 +tryJust :: (Exc.Exception e, Has (Lift IO) sig m) => (e -> Maybe b) -> m a -> m (Either b a) +tryJust p m = catchJust p (Right <$> m) (pure . Left) + +-- | See @"Control.Exception".'Exc.evaluate'@. +-- +-- @since 1.0.0.0 +evaluate :: Has (Lift IO) sig m => a -> m a +evaluate = sendM . Exc.evaluate + +-- | See @"Control.Exception".'Exc.mask'@. +-- +-- @since 1.0.0.0 +mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b +mask with = liftWith $ \ ctx run -> Exc.mask $ \ restore -> + run (with (\ m -> liftWith $ \ ctx' run' -> restore (run' (m <$ ctx'))) <$ ctx) + +-- | See @"Control.Exception".'Exc.mask_'@. +-- +-- @since 1.0.0.0 +mask_ :: Has (Lift IO) sig m => m a -> m a +mask_ m = mask $ const m + +-- | See @"Control.Exception".'Exc.uninterruptibleMask'@. +-- +-- @since 1.0.0.0 +uninterruptibleMask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b +uninterruptibleMask with = liftWith $ \ ctx run -> Exc.uninterruptibleMask $ \ restore -> + run (with (\ m -> liftWith $ \ ctx' run' -> restore (run' (m <$ ctx'))) <$ ctx) + +-- | See @"Control.Exception".'Exc.uninterruptibleMask_'@. +-- +-- @since 1.0.0.0 +uninterruptibleMask_ :: Has (Lift IO) sig m => m a -> m a +uninterruptibleMask_ m = uninterruptibleMask $ const m + +-- | See @"Control.Exception".'Exc.getMaskingState'@. +-- +-- @since 1.0.0.0 +getMaskingState :: Has (Lift IO) sig m => m Exc.MaskingState +getMaskingState = sendM Exc.getMaskingState + +-- | See @"Control.Exception".'Exc.interruptible'@. +-- +-- @since 1.0.0.0 +interruptible :: Has (Lift IO) sig m => m a -> m a +interruptible m = liftWith $ \ ctx run -> Exc.interruptible (run (m <$ ctx)) + +-- | See @"Control.Exception".'Exc.allowInterrupt'@. +-- +-- @since 1.0.0.0 +allowInterrupt :: Has (Lift IO) sig m => m () +allowInterrupt = sendM Exc.allowInterrupt + +-- | See @"Control.Exception".'Exc.bracket'@. +-- +-- @since 1.0.0.0 +bracket + :: Has (Lift IO) sig m + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracket acquire release m = mask $ \ restore -> do + a <- acquire + r <- restore (m a) `onException` release a + r <$ release a + +-- | See @"Control.Exception".'Exc.bracket_'@. +-- +-- @since 1.0.0.0 +bracket_ + :: Has (Lift IO) sig m + => m a + -> m b + -> m c + -> m c +bracket_ before after thing = bracket before (const after) (const thing) + +-- | See @"Control.Exception".'Exc.bracketOnError'@. +-- +-- @since 1.0.0.0 +bracketOnError + :: Has (Lift IO) sig m + => m a + -> (a -> m b) + -> (a -> m c) + -> m c +bracketOnError acquire release m = mask $ \ restore -> do + a <- acquire + restore (m a) `onException` release a + +-- | See @"Control.Exception".'Exc.finally'@. +-- +-- @since 1.0.0.0 +finally + :: Has (Lift IO) sig m + => m a + -> m b + -> m a +finally m sequel = mask $ \ restore -> (restore m `onException` sequel) <* sequel + +-- | See @"Control.Exception".'Exc.onException'@. +-- +-- @since 1.0.0.0 +onException :: Has (Lift IO) sig m => m a -> m b -> m a +onException io what = io `catch` \e -> what >> throwIO (e :: Exc.SomeException) diff --git a/src/Control/Effect/Resource.hs b/src/Control/Effect/Resource.hs deleted file mode 100644 index 649afa0..0000000 --- a/src/Control/Effect/Resource.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, StandaloneDeriving #-} - -{- | An effect that provides a "bracket"-style function to acquire, use, and automatically release resources, in the manner of the @resourcet@ package. The 'Control.Carrier.Resource.ResourceC' carrier ensures that resources are properly released in the presence of asynchronous exceptions. - -Predefined carriers: - -* "Control.Carrier.Resource". --} - -module Control.Effect.Resource -( -- * Resource effect - Resource(..) -, bracket -, bracketOnError -, finally -, onException - -- * Re-exports -, Carrier -, Has -, run -) where - -import Control.Carrier - --- | @since 1.0.0.0 -data Resource m k - = forall resource any output . Resource (m resource) (resource -> m any) (resource -> m output) (output -> m k) - | forall resource any output . OnError (m resource) (resource -> m any) (resource -> m output) (output -> m k) - -deriving instance Functor m => Functor (Resource m) - -instance HFunctor Resource where - hmap f (Resource acquire release use k) = Resource (f acquire) (f . release) (f . use) (f . k) - hmap f (OnError acquire release use k) = OnError (f acquire) (f . release) (f . use) (f . k) - -instance Effect Resource where - handle state handler (Resource acquire release use k) = Resource (handler (acquire <$ state)) (handler . fmap release) (handler . fmap use) (handler . fmap k) - handle state handler (OnError acquire release use k) = OnError (handler (acquire <$ state)) (handler . fmap release) (handler . fmap use) (handler . fmap k) - --- | Provides a safe idiom to acquire and release resources safely. --- --- When acquiring and operating on a resource (such as opening and --- reading file handle with 'openFile' or writing to a blob of memory --- with 'malloc'), any exception thrown during the operation may mean --- that the resource is not properly released. @bracket acquire release op@ --- ensures that @release@ is run on the value returned from @acquire@ even --- if @op@ throws an exception. --- --- Carriers for 'bracket' must ensure that it is safe in the presence of --- asynchronous exceptions. --- --- @since 1.0.0.0 -bracket :: Has Resource sig m - => m resource -- ^ computation to run first ("acquire resource") - -> (resource -> m any) -- ^ computation to run last ("release resource") - -> (resource -> m a) -- ^ computation to run in-between - -> m a -bracket acquire release use = send (Resource acquire release use pure) - --- | Like 'bracket', but only performs the final action if there was an --- exception raised by the in-between computation. --- --- @since 1.0.0.0 -bracketOnError :: Has Resource sig m - => m resource -- ^ computation to run first ("acquire resource") - -> (resource -> m any) -- ^ computation to run last ("release resource") - -> (resource -> m a) -- ^ computation to run in-between - -> m a -bracketOnError acquire release use = send (OnError acquire release use pure) - --- | Like 'bracket', but for the simple case of one computation to run afterward. --- --- @since 1.0.0.0 -finally :: Has Resource sig m - => m a -- ^ computation to run first - -> m b -- ^ computation to run afterward (even if an exception was raised) - -> m a -finally act end = bracket (pure ()) (const end) (const act) - --- | Like 'bracketOnError', but for the simple case of one computation to run afterward. --- --- @since 1.0.0.0 -onException :: Has Resource sig m - => m a -- ^ computation to run first - -> m b -- ^ computation to run afterward if an exception was raised - -> m a -onException act end = bracketOnError (pure ()) (const end) (const act)