add missing MonadCatch instance to conduit

snoyberg · Feb 16, 2023 · 3aa5b68 · 3aa5b68
1 parent 325c3f5
commit 3aa5b68
Show file tree

Hide file tree

Showing 2 changed files with 13 additions and 1 deletion.
diff --git 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/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 #-}