Add Resource effect and port to fused-effects 1.0.

main
Patrick Thomson 2019-10-14 13:22:38 -04:00
parent 57b1dc8b5d
commit 8a3c6e3baf
7 changed files with 315 additions and 44 deletions

View File

@ -1,5 +1,26 @@
# fused-effects-exceptions # fused-effects-exceptions
This package provides functionality to handle exceptions thrown in the `IO` monad. It delegates to `catch` from `Control.Exception`. An additional `catchSync` primitive is provided to handle the common case of catching only synchronous exceptions. [![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)
This implementation was extracted from one originally written by Josh Vera. It requires a version of `fused-effects` later than 0.3. This package provides two useful effects for handling exceptions thrown from pure code or IO with GHC's `Control.Exception.throw` function.
## 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:
```haskell
λ runM (runResource (runState 'a' (modify (succ @Char) `finally` modify (succ . succ @Char))))
('b', ())
```
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.

View File

@ -1,15 +1,15 @@
cabal-version: 2.4 cabal-version: 2.4
name: fused-effects-exceptions name: fused-effects-exceptions
version: 0.2.0.0 version: 1.0.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 Resource and Catch effects capable of reacting to and catching GHC's dynamic exceptions
homepage: https://github.com/patrickt/fused-effects-exceptions#readme homepage: https://github.com/patrickt/fused-effects-exceptions#readme
license: BSD-3-Clause license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
author: Josh Vera author: Josh Vera, Patrick Thomson, and Rob Rix
maintainer: patrickt@github.com maintainer: patrickt@github.com
copyright: 2019 Josh Vera and Patrick Thomson copyright: 2019 Josh Vera, Patrick Thomson, and Rob Rix
category: Control category: Control
build-type: Simple build-type: Simple
extra-source-files: README.md extra-source-files: README.md
@ -19,10 +19,15 @@ tested-with: GHC == 8.6.4
library library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
exposed-modules: Control.Effect.Catch exposed-modules: Control.Carrier.Catch
Control.Carrier.Resource
Control.Carrier.State.IORef
Control.Effect.Catch
Control.Effect.Resource
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, fused-effects ^>= 0.5 , fused-effects
, safe-exceptions >= 0.1 && <1 , safe-exceptions >= 0.1 && <1
, transformers
, unliftio-core >= 0.1.2 && <1 , unliftio-core >= 0.1.2 && <1
source-repository head source-repository head

View File

@ -0,0 +1,44 @@
{-# 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.
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))

View File

@ -0,0 +1,66 @@
{-# 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 'Control.Carrier.State.IORef.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))

View File

@ -0,0 +1,82 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
{- | A carrier for the 'State' effect. It uses an 'IORef' internally to handle its state, and thus is safe to use with "Control.Carrier.Resource". Underlying 'IORef' operations are performed with 'readIORef' and 'writeIORef'.
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
, evalState
, execState
, StateC(..)
-- * Re-exports
, Carrier
, run
) where
import Control.Applicative (Alternative (..))
import Control.Carrier
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
-- | Run a 'State' effect starting from the passed value.
--
-- prop> run (runState a (pure b)) === (a, b)
--
-- @since 1.0.0.0
runState :: MonadIO m => s -> StateC s m a -> m (s, a)
runState s x = do
ref <- liftIO $ newIORef s
result <- runReader ref . runStateC $ x
final <- liftIO . readIORef $ ref
pure (final, result)
{-# INLINE[3] runState #-}
-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
-- prop> run (evalState a (pure b)) === b
--
-- @since 1.0.0.0
evalState :: forall s m a . MonadIO m => s -> StateC s m a -> m a
evalState s x = do
ref <- liftIO $ newIORef s
runReader ref . runStateC $ x
{-# INLINE[3] evalState #-}
-- | Run a 'State' effect, yielding the final state and discarding the return value.
--
-- prop> run (execState a (pure b)) === a
--
-- @since 1.0.0.0
execState :: forall s m a . MonadIO m => s -> StateC s m a -> m s
execState s = fmap fst . runState s
{-# INLINE[3] execState #-}
-- | @since 1.0.0.0
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
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 #-}

View File

@ -13,12 +13,9 @@ module Control.Effect.Catch
( Catch (..) ( Catch (..)
, catch , catch
, catchSync , catchSync
, runCatch
, withCatch
, CatchC (..)
) where ) where
import Control.Effect.Carrier import Control.Carrier
import Control.Effect.Reader import Control.Effect.Reader
import Control.Effect.Sum import Control.Effect.Sum
import qualified Control.Exception as Exc import qualified Control.Exception as Exc
@ -61,32 +58,3 @@ catchSync f g = f `catch` \e ->
-- intentionally rethrowing an async exception synchronously, -- intentionally rethrowing an async exception synchronously,
-- since we want to preserve async behavior -- since we want to preserve async behavior
else liftIO (Exc.throw e) else liftIO (Exc.throw e)
-- | Evaluate a 'Catch' effect.
runCatch :: (forall x . m x -> IO x)
-> CatchC m a
-> m a
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)
runHandler :: Handler m -> CatchC m a -> IO a
runHandler h@(Handler handler) = handler . runReader h . runCatchC
newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a }
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
eff (L (CatchIO act cleanup k)) = do
handler <- CatchC ask
liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k
eff (R other) = CatchC (eff (R (handleCoercible other)))

View File

@ -0,0 +1,85 @@
{-# 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
, Has
) where
import Control.Carrier
-- | @since 0.1.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 0.1.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 0.2.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 0.2.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 0.2.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)