Merge pull request #8 from fused-effects/new-glorious-exceptions

Remove Resource and Catch and introduce Control.Effect.Exception.

.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

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.Effect.Exception`, which wraps the entirety of `base`'s `Control.Exception`.
-* Add `Control.Carrier.State.IORef` to help people migrating from other state carriers.
+* Add `Control.Carrier.State.IORef`, a state carrier that does not drop writes.
-* Move `Control.Effect.Catch.CatchC` to `Control.Carrier.Catch` and simplify its internals.
+* Remove `Catch` effect in favor of `Control.Effect.Exception`.
-* Rename `catch` to `catchAsync` and `catchSync` to `catch`.
 
 # 0.2.0.0
 

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
+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:
-
-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:
 
 ```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
+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.
-
-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.

cabal.project

@@ -0,0 +1,6 @@
+packages: .
+
+source-repository-package
+  type: git
+  location: https://github.com/fused-effects/fused-effects.git
+  tag: 0c7d9c19b638f7fe21ac77903894308ad15b0e80

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
+  default-language: Haskell2010
-  exposed-modules:     Control.Carrier.Catch
+  exposed-modules:
-                       Control.Carrier.Resource
+    Control.Carrier.State.IORef
-                       Control.Carrier.State.IORef
+    Control.Effect.Exception
-                       Control.Effect.Catch
+  build-depends:
-                       Control.Effect.Resource
+      base             >= 4.7 && < 5
-  build-depends:       base             >= 4.7 && < 5
+    , fused-effects    >= 1
-                     , fused-effects
+    , transformers     >= 0.4 && < 0.6
-                     , safe-exceptions  >= 0.1 && <1
-                     , transformers
-                     , unliftio-core    >= 0.1.2 && <1
 
 source-repository head
   type:     git

src/Control/Carrier/Catch.hs

@@ -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))

src/Control/Carrier/Resource.hs

@@ -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))

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
+( -- * Strict state carrier
-  module Control.Effect.State
+  runState
-  -- * Strict state carrier
-, runState
 , evalState
 , execState
 , StateC(..)
-  -- * Re-exports
+-- * State effect
-, Carrier
+, module Control.Effect.State
-, run
 ) 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
+instance (MonadIO m, Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where
-  askUnliftIO = StateC . ReaderC $ \r -> withUnliftIO $ \u -> pure (UnliftIO (\(StateC (ReaderC x)) -> unliftIO u (x r)))
+  alg (L act) = do
-  {-# 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
     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)))
+  alg (R other) = StateC (handleCoercible other)
-  {-# INLINE eff #-}
+  {-# INLINE alg #-}

src/Control/Effect/Catch.hs

@@ -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)

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)

src/Control/Effect/Resource.hs

@@ -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)