(How) can I make this monadic bind tail-recursive?

Question

I have this monad called Desync -

[<AutoOpen>]
module DesyncModule =

    /// The Desync monad. Allows the user to define in a sequential style an operation that spans
    /// across a bounded number of events. Span is bounded because I've yet to figure out how to
    /// make Desync implementation tail-recursive (see note about unbounded recursion in bind). And
    /// frankly, I'm not sure if there is a tail-recursive implementation of it...
    type [<NoComparison; NoEquality>] Desync<'e, 's, 'a> =
        Desync of ('s -> 's * Either<'e -> Desync<'e, 's, 'a>, 'a>)

    /// Monadic return for the Desync monad.
    let internal returnM (a : 'a) : Desync<'e, 's, 'a> =
        Desync (fun s -> (s, Right a))

    /// Monadic bind for the Desync monad.
    let rec internal bind (m : Desync<'e, 's, 'a>) (cont : 'a -> Desync<'e, 's, 'b>) : Desync<'e, 's, 'b> =
        Desync (fun s ->
            match (match m with Desync f -> f s) with
            //                              ^--- NOTE: unbounded recursion here
            | (s', Left m') -> (s', Left (fun e -> bind (m' e) cont))
            | (s', Right v) -> match cont v with Desync f -> f s')

    /// Builds the Desync monad.
    type DesyncBuilder () =
        member this.Return op = returnM op
        member this.Bind (m, cont) = bind m cont

    /// The Desync builder.
    let desync = DesyncBuilder ()

It allows the implementation of game logic that executes across several game ticks to written in a seemingly sequential style using computation expressions.

Unfortunately, when used for tasks that last for an unbounded number of game ticks, it crashes with StackOverflowException. And even when it's not crashing, it's ending up with unwieldy stack traces like this -

InfinityRpg.exe!InfinityRpg.GameplayDispatcherModule.desync@525-20.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> _arg10) Line 530   F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>>.Invoke(Nu.SimulationModule.World s) Line 24    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.DesyncModule.bind@20<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>.Invoke(Nu.SimulationModule.World s) Line 21    F#
Prime.exe!Prime.Desync.step<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>(Prime.DesyncModule.Desync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit> m, Nu.SimulationModule.World s) Line 71 F#
Prime.exe!Prime.Desync.advanceDesync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>(Microsoft.FSharp.Core.FSharpFunc<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Prime.DesyncModule.Desync<Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>,Nu.SimulationModule.World,Microsoft.FSharp.Core.Unit>> m, Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> e, Nu.SimulationModule.World s) Line 75 F#
Nu.exe!Nu.Desync.advance@98<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> event, Nu.SimulationModule.World world) Line 100 F#
Nu.exe!Nu.Desync.subscription@104-16<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(Nu.SimulationModule.Event<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen> event, Nu.SimulationModule.World world) Line 105    F#
Nu.exe!Nu.World.boxableSubscription@165<Prime.EitherModule.Either<Microsoft.FSharp.Core.Unit,Microsoft.FSharp.Core.Unit>,Nu.SimulationModule.Screen>.Invoke(object event, Nu.SimulationModule.World world) Line 166 F#

I am hoping to solve the problem by making the Left case of the bind function tail-recursive. However, I'm not sure of two things -

1) if it can be done at all, and 2) how it would actually be done.

If it's impossible to make bind tail-recursive here, is there some way to restructure my monad to allow it to become tail-recursive?

EDIT 3 (subsumes previous edits): Here is additional code that implements the desync combinators I will use to demonstrate the stack overflow -

module Desync =

    /// Get the state.
    let get : Desync<'e, 's, 's> =
        Desync (fun s -> (s, Right s))

    /// Set the state.
    let set s : Desync<'e, 's, unit> =
        Desync (fun _ -> (s, Right ()))

    /// Loop in a desynchronous context while 'pred' evaluate to true.
    let rec loop (i : 'i) (next : 'i -> 'i) (pred : 'i -> 's -> bool) (m : 'i -> Desync<'e, 's, unit>) =
        desync {
            let! s = get
            do! if pred i s then
                    desync {
                        do! m i
                        let i = next i
                        do! loop i next pred m }
                else returnM () }

    /// Loop in a desynchronous context while 'pred' evaluates to true.
    let during (pred : 's -> bool) (m : Desync<'e, 's, unit>) =
        loop () id (fun _ -> pred) (fun _ -> m)

    /// Step once into a desync.
    let step (m : Desync<'e, 's, 'a>) (s : 's) : 's * Either<'e -> Desync<'e, 's, 'a>, 'a> =
    match m with Desync f -> f s

    /// Run a desync to its end, providing e for all its steps.
    let rec runDesync (m : Desync<'e, 's, 'a>) (e : 'e) (s : 's) : ('s * 'a) =
        match step m s with
        | (s', Left m') -> runDesync (m' e) e s'
        | (s', Right v) -> (s', v)

Here is the Either implementation -

[<AutoOpen>]
module EitherModule =

    /// Haskell-style Either type.
    type Either<'l, 'r> =
        | Right of 'r
        | Left of 'l

And finally, here's simple a line of code that will yield a stack overflow -

open Desync
ignore <| runDesync (desync { do! during (fun _ -> true) (returnM ()) }) () ()

Perhaps you should take a look at how F#'s builtin `Async<_>` is implemented? I imagine it would have the same problem. — MisterMetaphor, Jan 03 '15 at 13:55
It doesn't solve the issue but you can avoid those nested matchs by changing `bind (m : Desync<'e, 's, 'a>) .. ` to `bind (Desync f : Desync<'e, 's, 'a>) ..` then you can do directly `match f s with` — Gus, Jan 03 '15 at 14:21
@MauricioScheffer, interesting. Could you elaborate how that might be used here? — Bryan Edds, Jan 03 '15 at 17:05
I think @MauricioScheffer may be recalling a similar problem we faced with a State monad, it was a very interesting discussion but in the end the solution was to use a Monad Transformer version (StateT) with a Cont Monad. Here's the [discussion](https://github.com/gmpl/FsControl/issues/22) — Gus, Jan 03 '15 at 18:00
The code you posted doesn't compile. Can you post a small sample usage that reproduces the error? — Gus, Jan 04 '15 at 08:16
@Gustavo, I can't verify that a previous version of the code didn't compile, but I can verify what's currently posted does in F# 3.0. I doubt there were any breaking changes to later versions, so could you try compiling what's currently on this page? — Bryan Edds, Jan 04 '15 at 11:36
I tried the code in the link. The code in this page doesn't break since there is no sample usage to reproduce the issue. May be if you add a short one it will be easier for others to suggest a solution. — Gus, Jan 04 '15 at 14:31
Sorry, that code was decidedly incomplete and over-complex. I have made a substantial edit to the question in order to provide you what I hope is all the context you're asking for :) Please have another look :) — Bryan Edds, Jan 04 '15 at 15:45
I just had another look. Still missing Either and step but I figured out the code and yes, it's definitely the same issue. I added a simplified code as an answer, have a look and try to adapt your code the same way, if you think it worths using a Cont in your monad. — Gus, Jan 05 '15 at 00:07
Added step and Either. Sorry, I often overlook things when trying to reduce a question to its essentials. — Bryan Edds, Jan 05 '15 at 13:05

Gus · Answer 1 · 2020-09-20T05:42:04.100

It seems to me your monad is a State with error handling.

It's basically ErrorT< State<'s,Either<'e,'a>>> but the error branch binds again which is not very clear to me why.

Anyway I was able to reproduce your Stack Overflow with a basic State monad:

type State<'S,'A> = State of ('S->('A * 'S))

module State =
    let run (State x) = x :'s->_
    let get() = State (fun s -> (s , s))  :State<'s,_>
    let put x = State (fun _ -> ((), x))  :State<'s,_>
    let result a = State(fun s -> (a, s))
    let bind (State m) k = State(fun s -> 
                                    let (a, s') = m s
                                    let (State u) = (k a) 
                                    u s')     :State<'s,'b>

    type StateBuilder() =
        member this.Return op = result op
        member this.Bind (m, cont) = bind m cont

    let state = StateBuilder()

    let rec loop (i: 'i) (next: 'i -> 'i) (pred: 'i -> 's -> bool) (m: 'i -> State<'s, unit>) =
        state {
            let! s = get()
            do! if pred i s then
                    state {
                        do! m i
                        let i = next i
                        do! loop i next pred m }
                else result () }

    let during (pred : 's -> bool) (m : State<'s, unit>) =
        loop () id (fun _ -> pred) (fun _ -> m)

// test
open State
ignore <| run (state { do! during (fun c -> true) (result ()) })  () // boom

As stated in the comments one way to solve this is to use a StateT<'s,Cont<'r,'a>>.

Here's an example of the solution. At the end there is a test with the zipIndex function which blows the stack as well when defined with a normal State monad.

Note you don't need to use the Monad Transformers from FsControl (now FSharpPlus), I use them because it's easier for me since I write less code but you can always create your transformed monad by hand.

BTW, Either is not used for error-handling, but to represent whether the computation is complete (with the answer) or not (with the remains of the computation). It allows for building a computation that pauses each step until more context (here, another 'e') is available. Given this, is your answer still as applicable? — Bryan Edds, Jan 05 '15 at 13:09
@BryanEdds OK, it's not error handling at all, good to know. Anyway I think the solution still would apply, because as you can see even if you take out the Either and leave it as a regular State monad the problem is already there. Sorry I can't give you an exact solution at the moment but I hope this will guide you through this method of solving the Stack Overflow. — Gus, Jan 05 '15 at 18:32
Hi, the link you posted has gone dead. Do you still have the code for it? — dain, Sep 19 '20 at 14:26
Thanks! Since it isn't so long, you might want to just edit it into your answer, since github gists seem prone to having their links breaking. — dain, Sep 20 '20 at 15:42

(How) can I make this monadic bind tail-recursive?

1 Answers1

Linked