4

注意：我认为这里的问题不在于 Polysemy本身。

目标：

我正在尝试编写多方同步通信的单线程模拟。更具体地说，目标是编写一个方将在某个效果系统中运行*的程序**，并具有一个纯函数，可以模拟多方一起运行他们的程序。该模拟的输出应该是各方发送（或接收）的所有消息的表示***。

*所有各方将运行相同的程序。
**多义词是我所知道的。
***以及每一方各自的返回值，尽管这并不重要。

设置：

我们可以稍微简化一下，假设只有两方。对于这种情况，我写了一个简单的Pair仿函数；对于实际系统，我希望使用固定长度的向量。

我们感兴趣的特定效果是Input和Output。
output $ Pair a1 a2表示“相关方”发送a1给方#1 和a2方#2。
Pair b1 b2 <- input表示“相关方”b1从方#1 和b2方#2 接收。
这些总是必须成对出现，output首先是。在实际系统中，我们会通过处理和处理的Communicate效果来保证这一点，但现在我们只是将其作为假设。 InputOutput

我认为不可能完全在 Polysemy 处理程序（也称为解释器或运行器）的结构中进行我想要的那种并行同步模拟。我很确定我需要的是一个像

parallelEvaluation :: forall x a r.
                     (Sem r ([Pair x], a) -> Sem '[] ([Pair x], a)) ->
                     Pair (Sem (Output (Pair x) ': Input (Pair x) ': r) a) ->
                     Pair ([Pair x], a)
parallelEvaluation handleRest sems = ...

第一个参数parallelEvaluation只是一个垫片；我可能不需要它。

理念：

如果我们想象两方并行运行，我们可以清楚地收集output他们发送的 s；Polysemy 已经为此内置了处理程序。这将为我们提供我们想要的东西：所有已发送消息的列表。
问题是向他们input的 s 提供什么。

这个想法是使用parallelEvaluation递归的结果作为处理程序的输入磁带Input。output如果整个函数是“足够”惰性的，并且我们上面关于和总是一起出现的假设input是合理的，那么这应该是可计算的。

多义词有必要的懒惰！
具体看这里。doRealRecursion 工作正常；我为使它工作所做的唯一特别的事情是使用runLazyOutputList处理程序（出于空间效率的原因，这不是 Polysemy 的默认设置）。

编码：

测试纯并行模拟：

import Polysemy (Members, Sem, reinterpret, run)
import Polysemy.Input (Input(Input), input)
import Polysemy.Output (Output, output, runLazyOutputList)
import Polysemy.State (get, put, runState)

import Pair (Pair(Pair),universe, (!))

runUnsafeInputList :: [i] -> Sem (Input i ': r) a -> Sem r a
-- Just like the normal PolySemy.Input.runInputList, except if there aren't enough inputs that's a runtime error!
runUnsafeInputList is = fmap snd . runState is . reinterpret (\case
    Input -> do ~(s : ss) <- get
                put ss
                pure s
    )

parallelEvaluation :: forall x a r.
                      (Sem r ([Pair x], a) -> Sem '[] ([Pair x], a)) ->
                      Pair (Sem (Output (Pair x) ': Input (Pair x) ': r) a) ->
                      Pair ([Pair x], a)
parallelEvaluation handleRest sems = run . handleRest <$> (runUnsafeInputList <$> os <*> (runLazyOutputList <$> sems))
  where os :: Pair [Pair x]
        os = fst <$> (parallelEvaluation handleRest sems)


testProgram :: forall r.
               Members '[Input (Pair String), Output (Pair String)] r =>
               Bool -> Sem r String
testProgram self = do output $ ((ownName ++ " says hi to ") ++) <$> parties
                      Pair m11 m12 <- input
                      let c1 = show $ (length m11) + (length m12)
                      output $ (++ ("; " ++ ownName ++ " got " ++ c1 ++ " characters last turn!")) <$> parties
                      Pair m21 m22 <- input
                      let c2 = show $ (length m21) + (length m22)
                      return $ ownName ++ "successfully got " ++ c2 ++ " characters in second round!"
  where parties = Pair "Party1" "Party2"
        ownName = parties ! self

doParallelRecursion :: IO ()
doParallelRecursion = do print "Attempting..."
                         let results = parallelEvaluation id $ testProgram <$> universe
                         print $ "Results: " ++ (show results)

Pair帮手：_

data Pair a where
  Pair :: a -> a -> Pair a
  deriving (Read, Show, Eq)
instance Functor Pair where
  fmap f (Pair a1 a2) = Pair (f a1) (f a2)
instance Applicative Pair where
  pure a = Pair a a
  (Pair f1 f2) <*> (Pair a1 a2) = Pair (f1 a1) (f2 a2)

(!) :: Pair a -> Bool -> a
(Pair a1 a2) ! b = if b then a2 else a1

universe :: Pair Bool
universe = Pair False True

问题：

作为可执行文件，doParallelRecursion打印"Attempting..."（使用换行符），然后挂起（似乎永远）。

从 GHCI，它打印

"Attempting..."
"Results:

然后在那条线上挂了几秒才*** Exception: stack overflow。

我尝试使用 GHCI 中的调试器来缩小问题范围。假设我正确使用它，runUnsafeInputList并且testProgram从未被评估过。runUnsafeInputList <$> os评估os，立即递归。

我试过交换效果/处理程序的顺序，这根本不影响行为。（我认为这无关紧要，但这里呈现的顺序可能更直观。）

4

0 回答 0