Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
open System
type Cont<'T> =
abstract Call<'R> : ('T -> 'R) * (exn -> 'R) -> 'R
let protect f x cont econt =
let res = try Choice1Of2 (f x) with err -> Choice2Of2 err
match res with
| Choice1Of2 v -> cont v
| Choice2Of2 v -> econt v
let runCont (c:Cont<'T>) cont econt = c.Call (cont,econt)
let throw exn = { new Cont<'T> with member x.Call (cont,econt) = econt exn }
//let callCC f = Cont (fun c -> runCont (f (fun a -> Cont (fun _ -> c a))) c)
type ContinuationBuilder() =
member this.Return(a) =
{ new Cont<'T> with member x.Call (cont,econt) = cont a }
member this.ReturnFrom( comp:Cont<'R> ) = comp
member this.Bind(comp1, compNext) =
{ new Cont<'T> with
member x.Call (cont,econt) =
runCont comp1 (fun a -> protect compNext a (fun comp2 -> runCont comp2 cont econt) econt) econt }
member this.Catch(comp:Cont<'T>) =
{ new Cont<Choice<'T,exn>> with
member x.Call (cont,econt) =
runCont comp (fun v -> cont (Choice1Of2 v)) (fun err -> cont (Choice2Of2 err)) }
member this.Combine(comp1, comp2) =
this.Bind(comp1, (fun () -> comp2))
member this.Delay(f) =
this.Bind(this.Return (), f)
member this.While(pred, body) =
if pred() then this.Bind(body, (fun () -> this.While(pred,body))) else this.Return ()
member this.TryWith(tryBlock, catchBlock) =
this.Bind(this.Catch tryBlock,(function Choice1Of2 v -> this.Return v
| Choice2Of2 exn -> catchBlock exn))
member this.TryFinally(tryBlock, finallyBlock) =
this.Bind(this.Catch tryBlock,(function Choice1Of2 v -> finallyBlock(); this.Return v
| Choice2Of2 exn -> finallyBlock(); throw exn))
member this.Using(res:#IDisposable, body) =
this.TryFinally(body res, (fun () -> match res with null -> () | disp -> disp.Dispose()))
member this.For(items:seq<_>, body) =
this.Using(items.GetEnumerator(), (fun enum -> this.While((fun () -> enum.MoveNext()), this.Delay(fun () -> body enum.Current))))
member this.Zero() =
this.Return ()
let K = new ContinuationBuilder()
let run c = runCont c (printfn "res = %A") (fun err -> printfn "err sent to continuation: %A" err.Message)
K { return 1 } |> run
K { let! x = K { return 2 } in return x + 1 } |> run
K { printfn "hello"; return 1 } |> run
K { for x in 1 .. 4 do
printfn "x = %d" x;
return 1 } |> run
K { printfn "hello";
failwith "fail"
return 1 } |> run
K { try
printfn "hello";
finally
failwith "fail" } |> run
K { try
printfn "hello";
return 2
with e ->
return 1 } |> run
K { try
failwith "hello";
return 2
with e ->
return 1 } |> run
K { while (failwith "fail") do
() } |> run
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment