Haskell 具有下游状态且无损耗的惯用双向管道

假设我有一个简单的生产者/消费者模型，消费者希望将一些状态传递给生产者。例如，让下游流动对象是我们想要写入文件的对象，而上游对象是表示对象在文件中写入位置的某个标记（例如偏移量）

这两个过程可能看起来像这样（使用

pipes-4.0

）

{-#语言泛化newtypederiving}
导入管道
导入管道。核心
进口管制.单子.跨州
进口管制
newtype Object=Obj Int
派生（显示）
newtype ObjectId=ObjId Int
派生（Show，Num）
writeObjects:：Proxy ObjectId Object（）X IO r
writeObjects=evalStateT（永久运行）（对象0）
其中go=do i使用哪种成分取决于哪种成分应启动整个过程。如果您希望下游管道启动流程，则您希望使用基于拉动的合成（即
（>++>）
/
（++>）
），但如果您希望上游管道启动流程，则应使用基于推送的合成（即
（>~）
/
（>~）
（>~）

）。您得到的类型错误实际上是在警告您代码中存在逻辑错误：您没有明确确定哪个组件首先启动流程

从您的描述中，很明显您希望控制流从

produceObjects

开始，因此您希望使用基于推送的合成。一旦您使用了基于推的合成，合成操作符的类型将告诉您关于如何修复代码所需要知道的一切。我将选择它的类型，并将其专门化为您的合成链：

-- Here I'm using the `Server` and `Client` type synonyms to simplify the types
(>>~) :: Server ObjectId Object IO ()
      -> (Object -> Client ObjectId Object IO ())
      -> Effect IO ()

正如您已经注意到的，尝试使用

（>>~）

时出现的类型错误告诉您，

writeObjects

函数缺少类型为

Object

的参数。这静态地强制您在接收第一个

对象之前（通过初始参数），不能在
writeObjects
中运行任何代码

解决方案是重写
writeObjects
函数，如下所示：

writeObjects :: Object -> Proxy ObjectId Object () X IO r
writeObjects obj0 = evalStateT (go obj0) (ObjId 0)
  where go obj = do i <- get
                    lift $ lift $ putStrLn $ "Wrote "++ show obj
                    modify (+1)
                    obj' <- lift $ request i
                    go obj'

您可能想知道，为什么要求两个管道中的一个管道接受初始参数是有意义的，而不是类别法所要求的抽象理由。简单的英语解释是，另一种选择是，在
writeObjects
到达其第一个
请求
语句之前，您需要在两个管道之间“缓冲”第一个传输的
对象。这种方法会产生很多有问题的行为和错误的角落情况，但最重要的问题可能是管道组合将不再是关联的，效果的顺序将根据您的组合顺序而改变

双向管道组合操作符的好处在于，类型能够正常工作，因此您始终可以通过研究类型来推断组件是“主动”（即启动控制）还是“被动”（即等待输入）。如果组合表示某个管道（如
writeObjects
）必须接受一个参数，那么它是被动的。如果它不带参数（如
produceObjects
），则它处于活动状态并启动控件。因此，合成强制您在管道中最多有一个活动管道（不带初始参数的管道），这就是开始控制的管道。
常量是您要丢弃数据的地方。为了获取所有数据，您可能需要执行以下基于推送的工作流：

writeObjects :: Object -> Proxy ObjectId Object () X IO r
writeObjects obj = go 0 obj
  where
    go objid obj = do
        lift $ putStrLn $ "Wrote "++show obj
        obj' <- request objid
        go (objid + 1) obj'

-- produceObjects as before

main = void $ run $ produceObjects objects >>~ writeObjects

writeObjects:：Object->Proxy ObjectId Object（）X IO r
WriteObject对象=go 0对象
哪里
go objid obj=do
提升$putStrLn$“写入”++显示对象
我们在邮件列表上讨论过这个问题，但我想我也会在这里为那些感兴趣的人提出来

您的问题是，您有两个协程，它们都准备好相互吐出值。任何一方都不需要另一方的投入才能产生价值。那么谁先去呢？你自己说的：

writeObjects
首先在请求时阻塞，并向上游发送初始的
ObjId 0

好吧，那就意味着我们需要延迟
produceObjects
，这样它在吐出相应的对象之前就要等待一个
ObjId
信号（即使它显然不需要所说的ID）

深入到代理的内部，这里有一个神奇的咒语，在这个时候我不会费心去仔细解释。基本思想是在需要输入之前获取输入，然后在需要时应用输入，然后假装需要新的输入（即使您现在还不需要该输入）：

现在，您可以在
produceObjects对象
而不是
const
上使用此选项，并且您的第二次尝试可以根据需要工作：

delayD (produceObjects objects) +>> writeObjects

我们正在讨论邮件列表中的
delayD
，看看它是否值得列入标准管道曲目

writeObjects :: Object -> Proxy ObjectId Object () X IO r
writeObjects obj0 = evalStateT (go obj0) (ObjId 0)
  where go obj = do i <- get
                    lift $ lift $ putStrLn $ "Wrote "++ show obj
                    modify (+1)
                    obj' <- lift $ request i
                    go obj'

>>> run $ produceObjects objects >>~ writeObjects
Producing Obj 0
Wrote Obj 0
Object Obj 0 has ID ObjId 0
Producing Obj 1
Wrote Obj 1
Object Obj 1 has ID ObjId 1
Producing Obj 2
Wrote Obj 2
Object Obj 2 has ID ObjId 2
Producing Obj 3
Wrote Obj 3
Object Obj 3 has ID ObjId 3
Producing Obj 4
Wrote Obj 4
Object Obj 4 has ID ObjId 4
Producing Obj 5
Wrote Obj 5
Object Obj 5 has ID ObjId 5
Producing Obj 6
Wrote Obj 6
Object Obj 6 has ID ObjId 6
Producing Obj 7
Wrote Obj 7
Object Obj 7 has ID ObjId 7
Producing Obj 8
Wrote Obj 8
Object Obj 8 has ID ObjId 8
Producing Obj 9
Wrote Obj 9
Object Obj 9 has ID ObjId 9
Producing Obj 10
Wrote Obj 10
Object Obj 10 has ID ObjId 10

writeObjects :: Object -> Proxy ObjectId Object () X IO r
writeObjects obj = go 0 obj
  where
    go objid obj = do
        lift $ putStrLn $ "Wrote "++show obj
        obj' <- request objid
        go (objid + 1) obj'

-- produceObjects as before

main = void $ run $ produceObjects objects >>~ writeObjects

delayD :: (Monad m) => Proxy a' a b' b m r -> b' -> Proxy a' a b' b m r
delayD p0 b' = case p0 of
    Request a' f -> Request a' (go . f)
    Respond b  g -> Respond b  (delayD (g b'))
    M m          -> M (liftM go m)
    Pure r       -> Pure r
  where
    go p = delayD p b'

delayD (produceObjects objects) +>> writeObjects