From d672693b27512bbe7fc3202e71b8c015d11d7242 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 12:27:02 -0400 Subject: [PATCH] Excise basically the whole project in favor of Control.Effect.Exc. --- fused-effects-exceptions.cabal | 13 ++--- src/Control/Carrier/Catch.hs | 45 ---------------- src/Control/Carrier/Resource.hs | 66 ----------------------- src/Control/Carrier/State/IORef.hs | 36 +++++-------- src/Control/Effect/Catch.hs | 62 --------------------- src/Control/Effect/Resource.hs | 87 ------------------------------ 6 files changed, 17 insertions(+), 292 deletions(-) delete mode 100644 src/Control/Carrier/Catch.hs delete mode 100644 src/Control/Carrier/Resource.hs delete mode 100644 src/Control/Effect/Catch.hs delete mode 100644 src/Control/Effect/Resource.hs diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 045d765..d12e9bb 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -19,16 +19,11 @@ tested-with: GHC == 8.6.4 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 + exposed-modules: Control.Carrier.State.IORef + Control.Effect.Exception build-depends: base >= 4.7 && < 5 - , fused-effects - , safe-exceptions >= 0.1 && <1 - , transformers - , unliftio-core >= 0.1.2 && <1 + , fused-effects >= 1.0.0.0 + , 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..adc3d08 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 -, evalState -, execState -, StateC(..) - -- * Re-exports -, Carrier -, run -) where + ( -- * Strict state carrier + runState + , evalState + , execState + , StateC(..) + -- * 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 06da8af..0000000 --- a/src/Control/Effect/Catch.hs +++ /dev/null @@ -1,62 +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 - , catchSync - ) 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 0.1.0.0 -catch :: (Member Catch sig, Carrier sig m, Exc.Exception e) - => m a - -> (e -> m a) - -> m a -catch go cleanup = send (CatchIO go cleanup pure) - --- | Like 'catch', but the handler only engages on synchronous exceptions. Async exceptions are rethrown. --- --- | @since 0.1.0.0 -catchSync :: (Member Catch sig, Carrier sig m, Exc.Exception e, MonadIO m) - => m a - -> (e -> m a) - -> m a -catchSync 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/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)