Lazy mutual recursive evaluation of Polysemy expressions - haskell

Question

NB: I don't think the problem here is with Polysemy per se.
The Goal:
I'm trying to write a single-thread simulation of multiple parties communicating synchronously. More specifically, the goal is to write the program that one party will run* in some effect system** and have a pure function that will simulate the multiple parties all running their programs together. The output of this simulation should be a representation of all the messages sent (or received) by each party***.
*All parties will run the same program.
**Polysemy is what I know.
***And each party's respective return value, although that's not really important.
Setup:
We can simplify a little and suppose there are only two parties. For this context I wrote a simple Pair functor; for the real system I expect to use fixed-length vectors.
The particular effects we're interested in are Input and Output.
output $ Pair a1 a2 means that "the party in question" sends a1 to party #1 and a2 to party #2.
Pair b1 b2 <- input means that "the party in question" receives b1 from party #1 and b2 from party #2.
These always have to come in pairs, with output first. In the real system we'd guarantee that by having a Communicate effect that got handled into Input and Output, but for now we'll just take it as an assumption.
I don't think it's possible to do the kind of parallel synchronous simulation I want entirely within the structure of a Polysemy handler (aka interpreter or runner). I'm pretty sure what I need is a function like
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 = ...
The first argument to parallelEvaluation is just a shim; I may not need it.
The Idea:
If we imagine the two parties running in parallel, we can clearly gather up their outputs as they send them; Polysemy has builtin handler just for that. That will give us exactly what we want: a list of all the messages sent.
The issue is what to feed into their inputs.
The idea is the use the results of parallelEvaluation recursively as the input-tape to the Input handler. If the whole function is "sufficiently" lazy, and our above assumption that output and input always appear together is sound, then this should be computable.
Polysemy is capable of the necessary laziness!
Specifically see here. doRealRecursion works fine; the only special thing I did to make it work was use the runLazyOutputList handler (which isn't Polysemy's default for space-efficiency reasons).
The Code:
Testing the pure-parallel-simulation:
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)
The Pair helper:
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
The Problem:
As an executable, doParallelRecursion prints "Attempting..." (with a newline), and then hangs (seemingly forever).
From GHCI, it prints
"Attempting..."
"Results:
and then hangs on that line for several seconds before *** Exception: stack overflow.
I've attempted to use the debugger in GHCI to narrow down the problem. Assuming I'm using it correctly, the bodies of runUnsafeInputList and testProgram aren't ever being evaluated. runUnsafeInputList <$> os evaluates os, which immediately recurses.
I've tried swapping the order of the effects/handlers, this didn't affect the behavior at all. (I don't think it ought to matter, but the order presented here may be more intuitive.)