管道:将两个来源合二为一

时间:2016-10-31 11:26:14

标签: haskell conduit

我有两个导管来源A和B,我想将它们合并为一个导致:

data Result = Left Int | Value Int | Right Int

merge :: Monad m => Source m Int -> Source m Int -> Source Result
merge a b = undefined

如:

  • 消费ab
  • 的值
  • 执行一些计算以生成Value Int
  • 作为计算的结果,ab可能有leftover
  • 当其中一个序列用尽时,结果源应始终生成LeftRight值(取决于哪个原始源仍具有值),直到两个源都耗尽

我尝试使用ZipSource实现它,例如:

getZipSource (ZipSource (a =$= CL.map Left) <* ZipSource (b =$= CL.map Right))

但我无法弄清楚如何让它在源之间交替(当我做两个await时)以及如何以我上面描述的方式处理剩余物。

我也看了sequenceSources,但似乎也没有帮助。

可以用Conduit构建类似的东西吗?

一个具体的例子是:

  • 有两个(假设排序的)Int来源
  • 从两者中获取值并进行比较
  • 产生min值,从最大值中减去并将剩余的值放回其流中
  • 重复。

预期输出为:

runConduit $ merge (CL.sourceList [10, 20, 30]) (CL.sourceList [6, 4, 20]) $$ CL.take 10

Value 6    -- 10-6  = 4,  6 yielded, 4 goes back to "a"
Value 4    -- 4-4   = 0,  both values are fully consumed
Value 20   -- 20-20 = 0,  both values are fully consumed
Left 30    -- "b" has no values, but "a" still yielding

[UPDATE] 到目前为止我发现的最好的方法是写一些类似于zipSources调整其内部结构的东西:

go (Done ()) (HaveOutput src close y) = HaveOutput (go (Done ()) src) close (Nothing, Just y)
go (HaveOutput src close x) (Done ()) = HaveOutput (go src (Done ())) close (Just x, Nothing)

这是正确的方法吗?

1 个答案:

答案 0 :(得分:0)

我最终这样做了:

data MergedValue a v b = BackL a v | MergedValue v | BackR v b
data JoinResult a v b = LeftoverL a | JoinValue v | LeftoverR b

joinSources :: Monad m
            => (a -> b -> MergedValue a v b)
            -> Source m a
            -> Source m b
            -> Source m (JoinResult a v b)
joinSources f as bs =
  go (newResumableSource as) (newResumableSource bs)
  where
    go ras rbs = do
      (ras', ma) <- lift $ ras $$++ await
      (rbs', mb) <- lift $ rbs $$++ await
      case (ma, mb) of
        (Nothing, Nothing) -> pure ()
        (Nothing, Just b)  -> yield (LeftoverR b) >> go ras' rbs'
        (Just a,  Nothing) -> yield (LeftoverL a) >> go ras' rbs'
        (Just a,  Just b)  -> case f a b of
          BackL x v -> do
            yield (JoinValue v)
            (nxt, _) <- lift $ ras' $$++ leftover x
            go nxt rbs'
          BackR v x -> do
            yield (JoinValue v)
            (nxt, _) <- lift $ rbs' $$++ leftover x
            go ras' nxt
          MergedValue v -> yield (JoinValue v) >> go ras' rbs'