Free Monad with Trampoline Infrastructure and Computation Builder

free.fs

// F<'a> is any type with member 'map' of type ('a -> 'b) -> F<'a> -> F<'b>

type F<'a> = QIL<'a> 
and S<'a> = F<Q<'a>>
and Q<'a> =        
    private
    | Step of Step<'a>
    | Bind of IBind<'a>
    with
        static member lift (k : F<'a>) : Q<'a> = Step (Suspend (fun () -> S<_>.map (Yield >> Step) k))
        member internal this.resume () : Step<'a> =
            match this with
            | Step s -> s
            | Bind b -> b.Bound()

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

        member this.run (interpreter : S<'a> -> Q<'a>) =
            let rec go (x : Q<'a>) =
                match x.resume() with
                | Yield a -> a
                | Suspend k -> go (interpreter (k()))
            go this

and internal Step<'a> = 
    | Yield of 'a
    | Suspend of (unit -> S<'a>)

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

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

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

and private Delay<'a> (f : unit -> Q<'a>) =
    interface IBind<'a> with
        member this.Bound () = f().resume()
        member this.Rebind(f') = Bind(Delay(fun () -> f().bind(f')))

type QComputationBuilder() = class
    let Done x = (Yield >> Step) x
    let (>>=) (mv : Q<'t>) (f : 't -> Q<'r>) : Q<'r> = mv.bind(f)

    // https://www.haskell.org/hoogle/?hoogle=sequence
    let sequenceList programList = 
        let folder c r = 
            r >>= (fun l -> c >>= (fun e -> Done (e :: l)))
        let initState = Done []
        List.foldBack folder programList initState

    member this.Return (x : 'a) : Q<'a> = Done x
    member this.ReturnFrom (x : 'a) : 'a = x
    member this.Delay (f : unit -> Q<_>) : Q<_> = Bind(Delay f)
    member this.Bind(mv : Q<_>, f) = mv >>= f
   
    member this.Zero() : Q<_> = this.Return ()

    member this.While(guard : unit -> bool, body : unit -> Q<_>) : Q<_> =
        if not (guard()) then 
            this.Zero() 
        else
            this.Bind(body(), fun () -> this.While(guard, body))  

    member this.TryWith(body, handler) =
        try this.ReturnFrom(body())
        with e -> handler e

    member this.TryFinally(body, compensation) =
        try this.ReturnFrom(body())
        finally compensation() 

    member this.Using(disposable:#System.IDisposable, body) =
        let body' = fun () -> body disposable
        this.TryFinally(body', fun () -> 
            match disposable with 
                | null -> () 
                | disp -> disp.Dispose())

    member this.For(sequence:seq<'a>, body : 'a -> Q<_>) : Q<_> =
        this.Using(
            sequence.GetEnumerator(), 
            fun enum -> 
                this.While(
                    enum.MoveNext, (fun () -> body enum.Current)))

    member this.Combine (a : Q<unit>, b: Q<_>) : Q<_> = 
        a >>= (fun () -> b)

    member this.SequenceList ps = sequenceList ps

    // https://www.haskell.org/hoogle/?hoogle=mapM
    member this.MapList (f: 'a -> Q<'b>) (xs : 'a list) : Q<'b list> = 
        xs |> (List.map f >> sequenceList)

    member this.FoldList (folder: 'r -> Q<'a> -> 'r) (state : 'r) (xs : Q<'a> list) : Q<'r> =
        let folder curr resultM =
            resultM >>= (fun result -> this.Return (folder result curr))
        let initState = this.Return state
        List.foldBack folder xs initState
end