Extract from parent project.

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.

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

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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

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

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