Add Resource effect and port to fused-effects 1.0.

README.md

@@ -1,5 +1,26 @@
 # 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.

fused-effects-exceptions.cabal

@@ -1,15 +1,15 @@
 cabal-version:       2.4
 
 name:                fused-effects-exceptions
-version:             0.2.0.0
+version:             1.0.0.0
 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
 license:             BSD-3-Clause
 license-file:        LICENSE
-author:              Josh Vera
+author:              Josh Vera, Patrick Thomson, and Rob Rix
 maintainer:          patrickt@github.com
-copyright:           2019 Josh Vera and Patrick Thomson
+copyright:           2019 Josh Vera, Patrick Thomson, and Rob Rix
 category:            Control
 build-type:          Simple
 extra-source-files:  README.md
@@ -19,10 +19,15 @@ tested-with:         GHC == 8.6.4
 library
   hs-source-dirs:      src
   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
-                     , fused-effects   ^>= 0.5
+                     , fused-effects
                      , safe-exceptions  >= 0.1 && <1
+                     , transformers
                      , unliftio-core    >= 0.1.2 && <1
 
 source-repository head

src/Control/Carrier/Catch.hs

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

src/Control/Carrier/Resource.hs

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

src/Control/Carrier/State/IORef.hs

@@ -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 #-}

src/Control/Effect/Catch.hs

@@ -13,12 +13,9 @@ module Control.Effect.Catch
   ( Catch (..)
   , catch
   , catchSync
-  , runCatch
-  , withCatch
-  , CatchC (..)
   ) where
 
-import           Control.Effect.Carrier
+import           Control.Carrier
 import           Control.Effect.Reader
 import           Control.Effect.Sum
 import qualified Control.Exception as Exc
@@ -61,32 +58,3 @@ catchSync f g = f `catch` \e ->
       -- intentionally rethrowing an async exception synchronously,
       -- since we want to preserve async behavior
       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)))

src/Control/Effect/Resource.hs

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