diff --git a/conduit/src/Conduit.hs b/conduit/src/Conduit.hs index 6f612b610..a257d5996 100644 --- a/conduit/src/Conduit.hs +++ b/conduit/src/Conduit.hs @@ -20,6 +20,7 @@ module Conduit , MonadIO (..) , MonadTrans (..) , MonadThrow (..) + , MonadCatch (..) , MonadUnliftIO (..) , PrimMonad (..) -- * ResourceT @@ -39,5 +40,5 @@ import Control.Monad.Primitive (PrimMonad (..), PrimState) import Data.Conduit.Lift import Data.Conduit.Combinators.Unqualified import Data.Functor.Identity (Identity (..)) -import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), runResourceT, ResourceT) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), MonadCatch (..), runResourceT, ResourceT) import Data.Acquire hiding (with) diff --git a/conduit/src/Data/Conduit.hs b/conduit/src/Data/Conduit.hs index b1d4d7dcc..2dd0e646a 100644 --- a/conduit/src/Data/Conduit.hs +++ b/conduit/src/Data/Conduit.hs @@ -7,7 +7,8 @@ module Data.Conduit ( -- * Core interface -- ** Types - ConduitT + ConduitT(..) + , Pipe(..) -- *** Deprecated , Source , Conduit @@ -101,6 +102,7 @@ module Data.Conduit ) where import Data.Conduit.Internal.Conduit +import Data.Conduit.Internal.Pipe (Pipe(..)) import Data.Void (Void) import Data.Functor.Identity (Identity, runIdentity) import Control.Monad.Trans.Resource (ResourceT, runResourceT) diff --git a/conduit/src/Data/Conduit/Internal/Conduit.hs b/conduit/src/Data/Conduit/Internal/Conduit.hs index 9139fa353..5f708463e 100644 --- a/conduit/src/Data/Conduit/Internal/Conduit.hs +++ b/conduit/src/Data/Conduit/Internal/Conduit.hs @@ -162,6 +162,17 @@ instance MonadFail m => MonadFail (ConduitT i o m) where instance MonadThrow m => MonadThrow (ConduitT i o m) where throwM = lift . throwM +instance MonadCatch m => MonadCatch (ConduitT i o m) where + catch (ConduitT c0) f = ConduitT $ \rest -> + let go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (\i -> go (p i)) (\u -> go (c u)) + go (Done x) = rest x + go (PipeM mp) = + PipeM $ catch (liftM go mp) $ \e -> do + return $ unConduitT (f e) rest + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + instance MonadIO m => MonadIO (ConduitT i o m) where liftIO = lift . liftIO {-# INLINE liftIO #-} diff --git a/resourcet/Control/Monad/Trans/Resource.hs b/resourcet/Control/Monad/Trans/Resource.hs index eba2139ed..90d3c38e0 100644 --- a/resourcet/Control/Monad/Trans/Resource.hs +++ b/resourcet/Control/Monad/Trans/Resource.hs @@ -54,6 +54,7 @@ module Control.Monad.Trans.Resource , closeInternalState -- * Reexport , MonadThrow (..) + , MonadCatch (..) ) where import qualified Data.IntMap as IntMap @@ -65,7 +66,7 @@ import Control.Monad.Trans.Resource.Internal import Control.Concurrent (ThreadId, forkIO) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (MonadThrow (..), MonadCatch (..)) import Data.Acquire.Internal (ReleaseType (..))