module Data.Conduit.Extra.ZipConduit
( ZipConduit (..)
, sequenceConduits
) where
import Data.Conduit
import Data.Conduit.Internal (Pipe (..), ConduitM (..), injectLeftovers)
import Data.Void (absurd)
import Control.Monad (liftM)
import Control.Applicative (Applicative (..))
import Data.Traversable (Traversable, sequenceA)
#if !MIN_VERSION_conduit(1,0,17)
zipConduit :: Monad m
=> ConduitM i o m (x -> y)
-> ConduitM i o m x
-> ConduitM i o m y
zipConduit (ConduitM left0) (ConduitM right0) =
ConduitM $ go (return ()) (return ()) (injectLeftovers left0) (injectLeftovers right0)
where
go _ _ (Done f) (Done x) = Done (f x)
go _ finalY (HaveOutput x finalX o) y = HaveOutput
(go finalX finalY x y)
(finalX >> finalY)
o
go finalX _ x (HaveOutput y finalY o) = HaveOutput
(go finalX finalY x y)
(finalX >> finalY)
o
go _ _ (Leftover _ i) _ = absurd i
go _ _ _ (Leftover _ i) = absurd i
go finalX finalY (PipeM mx) y = PipeM (flip (go finalX finalY) y `liftM` mx)
go finalX finalY x (PipeM my) = PipeM (go finalX finalY x `liftM` my)
go finalX finalY (NeedInput px cx) (NeedInput py cy) = NeedInput
(\i -> go finalX finalY (px i) (py i))
(\u -> go finalX finalY (cx u) (cy u))
go finalX finalY (NeedInput px cx) (Done y) = NeedInput
(\i -> go finalX finalY (px i) (Done y))
(\u -> go finalX finalY (cx u) (Done y))
go finalX finalY (Done x) (NeedInput py cy) = NeedInput
(\i -> go finalX finalY (Done x) (py i))
(\u -> go finalX finalY (Done x) (cy u))
newtype ZipConduit i o m r = ZipConduit { getZipConduit :: ConduitM i o m r }
deriving Functor
instance Monad m => Applicative (ZipConduit i o m) where
pure = ZipConduit . pure
ZipConduit left <*> ZipConduit right = ZipConduit (zipConduit left right)
sequenceConduits :: (Traversable f, Monad m) => f (ConduitM i o m r) -> ConduitM i o m (f r)
sequenceConduits = getZipConduit . sequenceA . fmap ZipConduit
#endif