From 610116e9ba7c8b4c93fbacbad911604be9e3ee0f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 19 Mar 2019 10:24:57 -0400 Subject: [PATCH] Extract from parent project. --- LICENSE | 30 +++++++++++++ README.md | 5 +++ Setup.hs | 2 + fused-effects-exceptions.cabal | 23 ++++++++++ src/Control/Effect/Catch.hs | 81 ++++++++++++++++++++++++++++++++++ stack.yaml | 8 ++++ 6 files changed, 149 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 fused-effects-exceptions.cabal create mode 100644 src/Control/Effect/Catch.hs create mode 100644 stack.yaml diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..05c8413 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Josh Vera (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Patrick Thomson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..21d309b --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# 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. + +This implementation was extracted from one originally written by Josh Vera. Please be aware that as of the time of this writing it depends on the current git `HEAD` of [fused-effects](https://github.com/robrix/higher-order-effects). diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal new file mode 100644 index 0000000..b03ff0d --- /dev/null +++ b/fused-effects-exceptions.cabal @@ -0,0 +1,23 @@ +name: fused-effects-exceptions +version: 0.1.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'. +homepage: https://github.com/patrickt/fused-effects-exceptions#readme +license: BSD3 +license-file: LICENSE +author: Josh Vera +maintainer: patrickt@github.com +copyright: 2019 Josh Vera +category: Control. +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Control.Effect.Catch + build-depends: base >= 4.7 && < 5 + -- A proper version constraint will be provided when fused-effects hits 0.3 + , fused-effects + , safe-exceptions >= 0.1 && <1 diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs new file mode 100644 index 0000000..0aab1a6 --- /dev/null +++ b/src/Control/Effect/Catch.hs @@ -0,0 +1,81 @@ +{-# 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 '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 + , runCatch + , CatchC (..) + ) where + +import Control.Effect.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 + +data Catch m k + = forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> k) + +deriving instance Functor (Catch m) + +instance HFunctor Catch where + hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) 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 'SomeException' if you want +-- to catch all errors. +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. +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) + +-- | Evaulate a 'Catch' effect. +runCatch :: (forall x . m x -> IO x) + -> CatchC m a + -> m a +runCatch handler = runReader (Handler handler) . runCatchC + +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 (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))) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..e26390d --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-13.13 + +packages: +- . +- location: + git: https://github.com/fused-effects/fused-effects + commit: 13b3c5f5871b6a637f5de7128865bcd305ba744e + extra-dep: true