[Haskell-cafe] Corecursive folds viewed as coroutines?

[Viktor Dukhovni]

> On 17 Sep 2021, at 3:19 am, Tom Ellis <tom-lists-haskell-cafe-2017 at jaguarpaw.co.uk> wrote:
> 
> On Fri, Sep 17, 2021 at 01:57:58AM -0400, Viktor Dukhovni wrote:
>> Laziness makes it it possible to use folds as coroutines that lazily
>> yield a sequence of values.  This is not possible in strict languages,
>> where you'd need explicit support for coroutines (generators) via
>> something like a "yield" primitive.
> 
> Wouldn't an explicit thunk datatype (that takes a lambda as a
> "constructor") be sufficient?  I can't see why going all the way to
> coroutines would be required.

Yes, sure, coroutines are but one model.  Indeed explicit thunks
can simulate laziness in a strict language.

But then there's the mind bending recent challenge on r/haskell to
implement (in Haskell) a general `foldr` using nothing from the
underlying Foldable except its `foldl'` (otherwise, any and all
Haskell tools are fine).

The implementation needs to be no less lazy than the real `foldr`,
forcing no more of the structures spine or elements than `foldr`
would.

It turns out that pretty much the only solutions reported all use
coroutines (unsafePerformIO and forkIO) in order to synchronise
demand-driven yields of the structure elements by a strict left
fold.

This tells me that `foldr` as coroutine is one version of the truth,
even if there are alternative valid mental models.

    {-# LANGUAGE LambdaCase #-}
    import Control.Concurrent
    import qualified Data.Foldable as F
    import System.IO.Unsafe
    
    foldr :: Foldable f => (a -> b -> b) -> b -> f a -> b
    foldr f z xs = unsafeDupablePerformIO $ do
        next <- newEmptyMVar
        lock <- newEmptyMVar
        let yield k a = seq (unsafeDupablePerformIO $ putMVar next (Just a) >> takeMVar lock) k
            loop      = takeMVar next >>= \case
                Nothing -> return z
                Just  a -> unsafeInterleaveIO (putMVar lock () >> loop) >>= pure . f a
        forkIO $ F.foldl' yield (pure ()) xs >> putMVar next Nothing
        loop

-- 
	Viktor.