Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Free Monad with Trampoline Infrastructure and Computation Builder
// 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.