4 people like it.

Continuation Monad with Call/CC

This is an implementation of the Continuation monad using a type, taking an exception handler, and allowing for Call/CC. This specific implementation is mostly Matt Podwysocki's. I have a similar implementation using a purely functional, exception-handler-less version in FSharp.Monad. Until now, I haven't been able to resolve the callCC operator.

Continuation monad

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 

type Cont<'a,'r> =
  abstract Call : ('a -> 'r) * (exn -> 'r) -> 'r

let private 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<_,_>) cont econt = c.Call(cont, econt)
let throw exn = { new Cont<_,_> with member x.Call (cont,econt) = econt exn }
let callCC f =
  { new Cont<_,_> with
      member x.Call(cont, econt) =
        runCont (f (fun a -> { new Cont<_,_> with member x.Call(_,_) = cont a })) cont econt }
 
type ContinuationBuilder() =
  member this.Return(a) = 
    { new Cont<_,_> with member x.Call(cont, econt) = cont a }
  member this.ReturnFrom(comp:Cont<_,_>) = comp
  member this.Bind(comp1, f) = 
    { new Cont<_,_> with 
        member x.Call (cont, econt) = 
          runCont comp1 (fun a -> protect f a (fun comp2 -> runCont comp2 cont econt) econt) econt }
  member this.Catch(comp:Cont<_,_>) =
    { new Cont<Choice<_, exn>,_> with 
        member x.Call (cont, econt) = 
          runCont comp (fun v -> cont (Choice1Of2 v)) (fun err -> cont (Choice2Of2 err)) }
  member this.Zero() =
    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.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.For(items:seq<_>, body) =
    this.Using(items.GetEnumerator(), (fun enum -> this.While((fun () -> enum.MoveNext()), this.Delay(fun () -> body enum.Current))))
let cont = ContinuationBuilder()

test samples

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 

let c n = cont { return n }
let addSomeNumbers = cont {
  let! x = c 6
  let! y = c 7
  return x + y }

[<Test>]
let ``When adding 6 to 7 and applying a continuation to convert to string and replace 1 with a, it should return a3``() =
  runCont addSomeNumbers (fun x -> x.ToString().Replace('1', 'a')) (sprintf "%A") |> should equal "a3"

(* Test callCC *)
let sum l =
  let rec sum l = cont {
    let! result = callCC (fun exit1 -> cont {
      match l with
      | [] -> return 0
      | h::t when h = 2 -> return! exit1 42
      | h::t -> let! r = sum t
                return h + r })
    return result }
  runCont (sum l) id (fun _ -> -1)

[<Test>]
let ``When summing a list without a 2 via callCC it should return 8``() =
  sum [1;1;3;3] |> should equal 8

[<Test>]
let ``When summing a list containing 2 via callCC it should return 43``() =
  sum [1;2;3] |> should equal 43
type Cont<'a,'r> =
  interface
    abstract member Call : ('a -> 'r) * (exn -> 'r) -> 'r
  end

Full name: Script.Cont<_,_>
abstract member Cont.Call : ('a -> 'r) * (exn -> 'r) -> 'r

Full name: Script.Cont`2.Call
type exn = Exception

Full name: Microsoft.FSharp.Core.exn
val private protect : f:('a -> 'b) -> x:'a -> cont:('b -> 'c) -> econt:(exn -> 'c) -> 'c

Full name: Script.protect
val f : ('a -> 'b)
val x : 'a
val cont : ('b -> 'c)
val econt : (exn -> 'c)
val res : Choice<'b,exn>
union case Choice.Choice1Of2: 'T1 -> Choice<'T1,'T2>
val err : exn
union case Choice.Choice2Of2: 'T2 -> Choice<'T1,'T2>
val v : 'b
val v : exn
val runCont : c:Cont<'a,'b> -> cont:('a -> 'b) -> econt:(exn -> 'b) -> 'b

Full name: Script.runCont
val c : Cont<'a,'b>
val cont : ('a -> 'b)
val econt : (exn -> 'b)
abstract member Cont.Call : ('a -> 'r) * (exn -> 'r) -> 'r
val throw : exn:exn -> Cont<'a,'b>

Full name: Script.throw
Multiple items
val exn : exn

--------------------
type exn = Exception

Full name: Microsoft.FSharp.Core.exn
val x : Cont<'a,'b>
val callCC : f:(('a -> Cont<'b,'c>) -> #Cont<'a,'c>) -> Cont<'a,'c>

Full name: Script.callCC
val f : (('a -> Cont<'b,'c>) -> #Cont<'a,'c>)
val x : Cont<'a,'c>
val cont : ('a -> 'c)
val a : 'a
val x : Cont<'b,'c>
Multiple items
type ContinuationBuilder =
  new : unit -> ContinuationBuilder
  member Bind : comp1:Cont<'a1,'a2> * f:('a1 -> #Cont<'a4,'a2>) -> Cont<'a4,'a2>
  member Catch : comp:Cont<'s,'t> -> Cont<Choice<'s,exn>,'t>
  member Combine : comp1:Cont<unit,'h> * comp2:Cont<'i,'h> -> Cont<'i,'h>
  member Delay : f:(unit -> #Cont<'f,'g>) -> Cont<'f,'g>
  member For : items:seq<'a> * body:('a -> #Cont<unit,'c>) -> Cont<unit,'c>
  member Return : a:'a7 -> Cont<'a7,'a8>
  member ReturnFrom : comp:Cont<'a5,'a6> -> Cont<'a5,'a6>
  member TryFinally : tryBlock:Cont<'n,'o> * finallyBlock:(unit -> unit) -> Cont<'n,'o>
  member TryWith : tryBlock:Cont<'p,'q> * catchBlock:(exn -> Cont<'p,'q>) -> Cont<'p,'q>
  ...

Full name: Script.ContinuationBuilder

--------------------
new : unit -> ContinuationBuilder
val this : ContinuationBuilder
member ContinuationBuilder.Return : a:'a7 -> Cont<'a7,'a8>

Full name: Script.ContinuationBuilder.Return
val a : 'a7
val x : Cont<'a7,'a8>
val cont : ('a7 -> 'a8)
val econt : (exn -> 'a8)
member ContinuationBuilder.ReturnFrom : comp:Cont<'a5,'a6> -> Cont<'a5,'a6>

Full name: Script.ContinuationBuilder.ReturnFrom
val comp : Cont<'a5,'a6>
member ContinuationBuilder.Bind : comp1:Cont<'a1,'a2> * f:('a1 -> #Cont<'a4,'a2>) -> Cont<'a4,'a2>

Full name: Script.ContinuationBuilder.Bind
val comp1 : Cont<'a1,'a2>
val f : ('a1 -> #Cont<'a4,'a2>)
val x : Cont<'a4,'a2>
val cont : ('a4 -> 'a2)
val econt : (exn -> 'a2)
val a : 'a1
val comp2 : #Cont<'a4,'a2>
member ContinuationBuilder.Catch : comp:Cont<'s,'t> -> Cont<Choice<'s,exn>,'t>

Full name: Script.ContinuationBuilder.Catch
val comp : Cont<'s,'t>
Multiple items
type Choice<'T1,'T2> =
  | Choice1Of2 of 'T1
  | Choice2Of2 of 'T2

Full name: Microsoft.FSharp.Core.Choice<_,_>

--------------------
type Choice<'T1,'T2,'T3> =
  | Choice1Of3 of 'T1
  | Choice2Of3 of 'T2
  | Choice3Of3 of 'T3

Full name: Microsoft.FSharp.Core.Choice<_,_,_>

--------------------
type Choice<'T1,'T2,'T3,'T4> =
  | Choice1Of4 of 'T1
  | Choice2Of4 of 'T2
  | Choice3Of4 of 'T3
  | Choice4Of4 of 'T4

Full name: Microsoft.FSharp.Core.Choice<_,_,_,_>

--------------------
type Choice<'T1,'T2,'T3,'T4,'T5> =
  | Choice1Of5 of 'T1
  | Choice2Of5 of 'T2
  | Choice3Of5 of 'T3
  | Choice4Of5 of 'T4
  | Choice5Of5 of 'T5

Full name: Microsoft.FSharp.Core.Choice<_,_,_,_,_>

--------------------
type Choice<'T1,'T2,'T3,'T4,'T5,'T6> =
  | Choice1Of6 of 'T1
  | Choice2Of6 of 'T2
  | Choice3Of6 of 'T3
  | Choice4Of6 of 'T4
  | Choice5Of6 of 'T5
  | Choice6Of6 of 'T6

Full name: Microsoft.FSharp.Core.Choice<_,_,_,_,_,_>

--------------------
type Choice<'T1,'T2,'T3,'T4,'T5,'T6,'T7> =
  | Choice1Of7 of 'T1
  | Choice2Of7 of 'T2
  | Choice3Of7 of 'T3
  | Choice4Of7 of 'T4
  | Choice5Of7 of 'T5
  | Choice6Of7 of 'T6
  | Choice7Of7 of 'T7

Full name: Microsoft.FSharp.Core.Choice<_,_,_,_,_,_,_>
val x : Cont<Choice<'s,exn>,'t>
val cont : (Choice<'s,exn> -> 't)
val econt : (exn -> 't)
val v : 's
member ContinuationBuilder.Zero : unit -> Cont<unit,'r>

Full name: Script.ContinuationBuilder.Zero
member ContinuationBuilder.Return : a:'a7 -> Cont<'a7,'a8>
member ContinuationBuilder.TryWith : tryBlock:Cont<'p,'q> * catchBlock:(exn -> Cont<'p,'q>) -> Cont<'p,'q>

Full name: Script.ContinuationBuilder.TryWith
val tryBlock : Cont<'p,'q>
val catchBlock : (exn -> Cont<'p,'q>)
member ContinuationBuilder.Bind : comp1:Cont<'a1,'a2> * f:('a1 -> #Cont<'a4,'a2>) -> Cont<'a4,'a2>
member ContinuationBuilder.Catch : comp:Cont<'s,'t> -> Cont<Choice<'s,exn>,'t>
val v : 'p
member ContinuationBuilder.TryFinally : tryBlock:Cont<'n,'o> * finallyBlock:(unit -> unit) -> Cont<'n,'o>

Full name: Script.ContinuationBuilder.TryFinally
val tryBlock : Cont<'n,'o>
val finallyBlock : (unit -> unit)
val v : 'n
member ContinuationBuilder.Using : res:'j * body:('j -> #Cont<'l,'m>) -> Cont<'l,'m> (requires 'j :> IDisposable and 'j : null)

Full name: Script.ContinuationBuilder.Using
val res : 'j (requires 'j :> IDisposable and 'j : null)
type IDisposable =
  member Dispose : unit -> unit

Full name: System.IDisposable
val body : ('j -> #Cont<'l,'m>) (requires 'j :> IDisposable and 'j : null)
member ContinuationBuilder.TryFinally : tryBlock:Cont<'n,'o> * finallyBlock:(unit -> unit) -> Cont<'n,'o>
val disp : 'j (requires 'j :> IDisposable and 'j : null)
IDisposable.Dispose() : unit
member ContinuationBuilder.Combine : comp1:Cont<unit,'h> * comp2:Cont<'i,'h> -> Cont<'i,'h>

Full name: Script.ContinuationBuilder.Combine
val comp1 : Cont<unit,'h>
val comp2 : Cont<'i,'h>
member ContinuationBuilder.Delay : f:(unit -> #Cont<'f,'g>) -> Cont<'f,'g>

Full name: Script.ContinuationBuilder.Delay
val f : (unit -> #Cont<'f,'g>)
member ContinuationBuilder.While : pred:(unit -> bool) * body:Cont<unit,'d> -> Cont<unit,'d>

Full name: Script.ContinuationBuilder.While
val pred : (unit -> bool)
val body : Cont<unit,'d>
member ContinuationBuilder.While : pred:(unit -> bool) * body:Cont<unit,'d> -> Cont<unit,'d>
member ContinuationBuilder.For : items:seq<'a> * body:('a -> #Cont<unit,'c>) -> Cont<unit,'c>

Full name: Script.ContinuationBuilder.For
val items : seq<'a>
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
val body : ('a -> #Cont<unit,'c>)
member ContinuationBuilder.Using : res:'j * body:('j -> #Cont<'l,'m>) -> Cont<'l,'m> (requires 'j :> IDisposable and 'j : null)
Collections.Generic.IEnumerable.GetEnumerator() : Collections.Generic.IEnumerator<'a>
val enum : Collections.Generic.IEnumerator<'a>
Collections.IEnumerator.MoveNext() : bool
member ContinuationBuilder.Delay : f:(unit -> #Cont<'f,'g>) -> Cont<'f,'g>
property Collections.Generic.IEnumerator.Current: 'a
val cont : ContinuationBuilder

Full name: Script.cont
val c : n:'a -> Cont<'a,'b>

Full name: Script.c
val n : 'a
val addSomeNumbers : Cont<int,string>

Full name: Script.addSomeNumbers
val x : int
val y : int
val ( When adding 6 to 7 and applying a continuation to convert to string and replace 1 with a, it should return a3 ) : unit -> 'a

Full name: Script.( When adding 6 to 7 and applying a continuation to convert to string and replace 1 with a, it should return a3 )
Int32.ToString() : string
Int32.ToString(provider: IFormatProvider) : string
Int32.ToString(format: string) : string
Int32.ToString(format: string, provider: IFormatProvider) : string
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
val sum : l:int list -> int

Full name: Script.sum
val l : int list
val sum : (int list -> Cont<int,'a>)
val result : int
val exit1 : (int -> Cont<int,'a>)
val h : int
val t : int list
val r : int
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val ( When summing a list without a 2 via callCC it should return 8 ) : unit -> 'a

Full name: Script.( When summing a list without a 2 via callCC it should return 8 )
val ( When summing a list containing 2 via callCC it should return 43 ) : unit -> 'a

Full name: Script.( When summing a list containing 2 via callCC it should return 43 )

More information

Link:http://fssnip.net/7c
Posted:13 years ago
Author:Ryan Riley
Tags: continuation , monad , callcc , call-with-current-continuation

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.