ContinuationMonad.fs

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