Trampolining following http://days2012.scala-lang.org/sites/days2012/files/bjarnason_trampolines.pdf

trampoline.fs

open System
open System.Diagnostics

type InteractionF<'f> =
    | Get of (string -> 'f)
    | Put of string * 'f
    with
    static member map f = function
        | Get g -> Get (f << g)
        | Put (s, g) -> Put (s, f g)

module Trampoline =

    type Trampoline<'a> =
        private
        | Step of Step<'a>
        | Bind of IBind<'a>
        // existential, should not be used to wrap Bound directly
        // - the .bind function must be used to re-associate

        with
        member this.resume () : Step<'a> =
            match this with
            | Step s -> s
            | Bind b -> b.Bound()

        member this.bind (f : 'a -> Trampoline<'b>) =
            // rewrite binds to be right-associative
            match this with
            | Bind b -> b.Rebind(f)
            | Step s -> Bind(Bound(s, f))


    and Intermediate<'a> = InteractionF<Trampoline<'a>>
    and Step<'a> = Yield of 'a | Suspend of (unit -> Intermediate<'a>)

    and IBind<'a> =
        abstract member Bound : unit -> Step<'a>
        abstract member Rebind<'r> : ('a -> Trampoline<'r>) -> Trampoline<'r>

    and Bound<'a, 'b> (a : Step<'a>, f : ('a -> Trampoline<'b>)) =
        interface IBind<'b> with
            member this.Bound () =
                match a with
                | Yield v -> f(v).resume()
                | Suspend k -> Suspend (fun () -> Intermediate<'b>.map (fun (x : Trampoline<'a>) -> x.bind(f)) (k()))

            member this.Rebind (f') = Bind(Bound(a, fun x -> f(x).bind(f')))

    // This isn't strictly necessary but here as an optimization,
    // (it's a specialized version of Bound).
    and Delay<'a> (f : unit -> Trampoline<'a>) =
        interface IBind<'a> with
            member this.Bound () = f().resume()
            member this.Rebind(f') = Bind(Delay(fun () -> f().bind(f')))

    let rec run (x : Trampoline<'a>) (interpreter : Intermediate<'a> -> Trampoline<'a>) =
        let rec go (x : Trampoline<'a>) =
            match x.resume() with
            | Yield a -> a
            | Suspend k -> go (interpreter (k()))
        go x

    let result x = Step (Yield x)
    let delay f = Bind(Delay(f))
    let define (k : InteractionF<'a>) : Trampoline<'a> = Step (Suspend (fun () -> Intermediate<_>.map (Step << Yield) k))

open Trampoline

type TrampolineBuilder() =
    member this.Return x = result x
    member this.ReturnFrom x = x
    // without Delay type, you can use 'Bind(Bound(Done (), f)))'
    member this.Delay f =  delay f
    member this.Bind(x : Trampoline<_>, f) = x.bind(f)

let trampoline = TrampolineBuilder()

let get : Trampoline<string> = define (Get id)
let put (s : string) : Trampoline<unit> = define (Put(s, ()))

let rec ex = trampoline {
    do! put "Hi, everybody! What's your name?"
    let! name = get
    do! put ("Hello, " + name)
    return name
    }

let rec inc a = trampoline {
        if a = 1 then return 1
        else
            let! x = inc (a - 1)
            return x + 1
    }

let interpret (f : Intermediate<'a>) : Trampoline<'a> =
    match f with
    | Get cont -> Console.ReadLine() |> cont
    | Put (str, cont) -> Console.WriteLine(str); cont

[<EntryPoint>]
let main _ =
    let sw = Stopwatch.StartNew()
    printfn "%A" (run (inc 10000) interpret)
    printfn "%A" sw.Elapsed
    0