Port examples to use the effect handler syntax.

examples/README.md

@@ -10,7 +10,8 @@ $ dune build
 
 After successfully building the suite you can run each example via
 `dune`, which will run either the native or bytecode version of an
-example depending on which suffix you supply, e.g. to run the native version type
+example depending on which suffix you supply, e.g. to run the native
+version type
 
 ```shell
 $ dune exec ./nqueens.exe

examples/async.ml

@@ -81,31 +81,27 @@ end = struct
       if Queue.is_empty st.suspended then ()
       else Queue.take st.suspended ()
 
-    let hsched : unit -> (unit, unit) Effect.Deep.handler
-      = fun () ->
+    let run : (unit -> unit) -> unit
+      = fun f ->
       let state = { suspended = Queue.create () } in
-      let open Effect.Deep in
-      { retc = (fun () -> run_next state)
-      ; exnc = (fun e ->
-        match e with
-        | End_of_strand -> run_next state
-        | e -> raise e)
-      ; effc = (fun (type a) (eff : a Effect.t) ->
-        match eff with
-        | Await pr -> Some (fun (k : (a, unit) continuation) ->
-          (if Promise.is_done pr
-           then continue k (Promise.value pr)
-           else Promise.wait pr (fun v -> continue k v));
-          run_next state)
-        | Fork -> Some (fun (k : (bool, unit) continuation) ->
-          let open Multicont.Deep in
-          let r = promote k in
-          enqueue state (fun () -> resume r false);
-          resume r true)
-        | Yield -> Some (fun (k : (unit, unit) continuation) ->
-          enqueue state (fun () -> continue k ());
-          run_next state)
-        | _ -> None) }
+      match f () with
+      | () -> ()
+      | exception End_of_strand -> run_next state
+      | effect Await pr, k ->
+         let open Effect.Deep in
+         (if Promise.is_done pr
+          then continue k (Promise.value pr)
+          else Promise.wait pr (fun v -> continue k v));
+         run_next state
+      | effect Fork, k ->
+         let open Multicont.Deep in
+         let r = promote k in
+         enqueue state (fun () -> resume r false);
+         resume r true
+      | effect Yield, k ->
+         let open Effect.Deep in
+         enqueue state (fun () -> continue k ());
+         run_next state
   end
 
   let run : (unit -> 'a) -> 'a
@@ -115,7 +111,7 @@ end = struct
       let v = f () in
       result := (fun () -> v)
     in
-    let () = Effect.Deep.match_with f' () (Scheduler.hsched ()) in
+    Scheduler.run f';
     !result ()
 end
 
@@ -128,17 +124,9 @@ module Env = struct
 
   let bind : int -> (unit -> 'b) -> 'b
     = fun v f ->
-    let open Effect.Deep in
-    let hdynbind : ('b, 'b) Effect.Deep.handler =
-      { retc = (fun x -> x)
-      ; exnc = (fun e -> raise e)
-      ; effc = (fun (type a) (eff : a Effect.t) ->
-        match eff with
-        | Ask -> Some (fun (k : (a, _) continuation) ->
-          continue k v)
-        | _ -> None) }
-    in
-    match_with f () hdynbind
+    match f () with
+    | ans -> ans
+    | effect Ask, k -> Effect.Deep.continue k v
 end
 
 (* The `well-behaveness' of this implementation can be illustrated by

examples/choice.ml

@@ -2,8 +2,6 @@
   * McCarthy's locally angelic choice
   *)
 
-open Effect.Deep
-
 type 'a Effect.t += Choose : (unit -> 'a) list -> 'a Effect.t
 
 let amb : (unit -> 'a) list -> 'a
@@ -27,20 +25,12 @@ let handle : (unit -> 'a) -> 'a
   = fun m ->
   (* McCarthy's locally angelic choice operator (angelic modulo
      nontermination). *)
-  let hamb =
-    { retc = (fun x -> x)
-    ; exnc = (fun e -> raise e)
-    ; effc = (fun (type b) (eff : b Effect.t) ->
-      match eff with
-      | Choose xs ->
-         Some
-           (fun (k : (b, _) continuation) ->
-             let open Multicont.Deep in
-             let r = promote k in
-             first_success (resume r) xs)
-      | _ -> None) }
-  in
-  match_with m () hamb
+  match m () with
+  | ans -> ans
+  | effect Choose xs, k ->
+     let open Multicont.Deep in
+     let r = promote k in
+     first_success (resume r) xs
 
 (* The following examples are adapted from Oleg Kiselyov
    "Non-deterministic choice amb"

examples/generic_count.ml

@@ -1,7 +1,5 @@
 (* Generic counting example based on Hillerström et al. (2020) https://arxiv.org/abs/2007.00605 *)
 
-open Effect.Deep
-
 type _ Effect.t += Branch : bool Effect.t
 
 type point = int -> bool
@@ -16,21 +14,18 @@ let xor_predicate : int -> predicate
   | [] -> false
   | v :: vs -> List.fold_left xor v vs
 
-let generic_count : (bool, int) handler =
-  { retc = (fun x -> if x then 1 else 0)
-  ; exnc = (fun e -> raise e)
-  ; effc = (fun (type a) (eff : a Effect.t) ->
-    match eff with
-    | Branch ->
-       Some (fun (k : (a, _) continuation) ->
-           let open Multicont.Deep in
-           let r = promote k in
-           let tt = resume r true in
-           let ff = resume r false in
-           tt + ff)
-    | _ -> None) }
+let generic_count : ((int -> bool) -> bool) -> int
+  = fun f ->
+  match f (fun _ -> Effect.perform Branch) with
+  | ans -> if ans then 1 else 0
+  | effect Branch, k ->
+     let open Multicont.Deep in
+     let r = promote k in
+     let tt = resume r true in
+     let ff = resume r false in
+     tt + ff
 
 let _ =
   let n = try int_of_string Sys.argv.(1) with _ -> 8 in
-  let solutions = match_with (xor_predicate n) (fun _ -> Effect.perform Branch) generic_count in
+  let solutions = generic_count (xor_predicate n) in
   Printf.printf "%d\n" solutions

examples/legacy/README.md

@@ -0,0 +1,25 @@
+# Compiling and running the legacy examples
+
+The legacy examples do not make use of the effect handler syntax added
+in OCaml 5.3. To compile and run the examples suite you must first
+have installed the library via OPAM. In order to build the suite
+simply invoke `dune`, i.e.
+
+```shell
+$ dune build
+```
+
+After successfully building the suite you can run each example via
+`dune`, which will run either the native or bytecode version of an
+example depending on which suffix you supply, e.g. to run the native
+version type
+
+```shell
+$ dune exec ./nqueens.exe
+```
+
+and for the bytecode version type
+
+```shell
+$ dune exec ./nqueens.bc.exe
+```

examples/legacy/async.ml

@@ -0,0 +1,187 @@
+(* An algebraically well-behaved implementation of async/await with
+   multi-shot continuations. *)
+
+module Async: sig
+  module Promise: sig
+    type 'a t
+    exception Circular_await
+  end
+
+  val await : 'a Promise.t -> 'a
+  val async : (unit -> 'a) -> 'a Promise.t
+  val yield : unit -> unit
+  val run : (unit -> 'a) -> 'a
+end = struct
+
+  module Promise = struct
+    type 'a promise = Done of 'a
+                    | Pending of ('a -> unit) list
+    type 'a t = 'a promise ref
+
+    exception Circular_await
+
+    let is_done : 'a t -> bool
+      = fun pr -> match !pr with
+                  | Done _ -> true
+                  | _ -> false
+
+    let wait : 'a t -> ('a -> unit) -> unit
+      = fun pr r -> match !pr with
+                    | Done _ -> assert false
+                    | Pending rs -> pr := Pending (r :: rs)
+
+    let value : 'a t -> 'a
+      = fun pr -> match !pr with
+                  | Done v -> v
+                  | Pending _ -> assert false
+
+    let make_empty : unit -> 'a t
+      = fun () -> ref (Pending [])
+  end
+
+  type _ Effect.t += Await : 'a Promise.t -> 'a Effect.t
+                   | Fork : bool Effect.t
+                   | Yield : unit Effect.t
+
+
+  exception End_of_strand
+
+  let await : 'a Promise.t -> 'a
+    = fun pr -> Effect.perform (Await pr)
+
+  let fork : unit -> bool
+    = fun () -> Effect.perform Fork
+
+  let yield : unit -> unit
+    = fun () -> Effect.perform Yield
+
+  let async : (unit -> 'a) -> 'a Promise.t
+    = fun f ->
+    let pr = Promise.make_empty () in
+    if fork () (* returns twice *)
+    then pr
+    else let v = f () in
+         (match !pr with
+          | Done _ -> assert false
+          | Pending rs ->
+             pr := Done v;
+             List.iter (fun r -> r v) rs);
+         raise End_of_strand
+
+  module Scheduler = struct
+
+    type state = { suspended: (unit -> unit) Queue.t }
+
+    let enqueue :  state -> (unit -> unit) -> unit
+      = fun st r ->
+      Queue.add r st.suspended
+
+    let run_next : state -> unit
+      = fun st ->
+      if Queue.is_empty st.suspended then ()
+      else Queue.take st.suspended ()
+
+    let hsched : unit -> (unit, unit) Effect.Deep.handler
+      = fun () ->
+      let state = { suspended = Queue.create () } in
+      let open Effect.Deep in
+      { retc = (fun () -> run_next state)
+      ; exnc = (fun e ->
+        match e with
+        | End_of_strand -> run_next state
+        | e -> raise e)
+      ; effc = (fun (type a) (eff : a Effect.t) ->
+        match eff with
+        | Await pr -> Some (fun (k : (a, unit) continuation) ->
+          (if Promise.is_done pr
+           then continue k (Promise.value pr)
+           else Promise.wait pr (fun v -> continue k v));
+          run_next state)
+        | Fork -> Some (fun (k : (bool, unit) continuation) ->
+          let open Multicont.Deep in
+          let r = promote k in
+          enqueue state (fun () -> resume r false);
+          resume r true)
+        | Yield -> Some (fun (k : (unit, unit) continuation) ->
+          enqueue state (fun () -> continue k ());
+          run_next state)
+        | _ -> None) }
+  end
+
+  let run : (unit -> 'a) -> 'a
+    = fun f ->
+    let result = ref (fun () -> raise Promise.Circular_await) in
+    let f' () =
+      let v = f () in
+      result := (fun () -> v)
+    in
+    let () = Effect.Deep.match_with f' () (Scheduler.hsched ()) in
+    !result ()
+end
+
+(* Another effect: dynamic binding *)
+module Env = struct
+  type _ Effect.t += Ask : int Effect.t
+
+  let ask : unit -> int
+    = fun () -> Effect.perform Ask
+
+  let bind : int -> (unit -> 'b) -> 'b
+    = fun v f ->
+    let open Effect.Deep in
+    let hdynbind : ('b, 'b) Effect.Deep.handler =
+      { retc = (fun x -> x)
+      ; exnc = (fun e -> raise e)
+      ; effc = (fun (type a) (eff : a Effect.t) ->
+        match eff with
+        | Ask -> Some (fun (k : (a, _) continuation) ->
+          continue k v)
+        | _ -> None) }
+    in
+    match_with f () hdynbind
+end
+
+(* The `well-behaveness' of this implementation can be illustrated by
+   using it in conjunction with another effect. In each async strand
+   any occurrence of `Ask' is correctly bound by an ambient
+   `Env.bind'. *)
+let main () =
+  let task name () =
+    Printf.printf "starting %s\n%!" name;
+    let v = Env.ask () in
+    Printf.printf "yielding %s\n%!" name;
+    Async.yield ();
+    Printf.printf "ending %s with %d\n%!" name v;
+    v
+  in
+  let pa =
+    Env.bind 40
+      (fun () -> Async.async (task "a"))
+  in
+  let pb =
+    Env.bind 2
+      (fun () -> Async.async (task "b"))
+  in
+  let pc =
+    Async.async
+      (fun () -> Async.await pa + Async.await pb)
+  in
+  Printf.printf "Sum is %d\n" (Async.await pc);
+  assert Async.(await pa + await pb = await pc)
+
+let _ = Async.run main
+
+(* The following program would deadlock if cyclic
+   promise resolution was allowed *)
+(* let try_deadlock () =
+ *   let pr = ref (fun () -> assert false) in
+ *   let task () =
+ *     Async.await (!pr ())
+ *   in
+ *   print_endline "Fork task";
+ *   let pr' = Async.async task in
+ *   pr := (fun () -> pr');
+ *   print_endline "Await";
+ *   Async.await (!pr ())
+ *
+ * let _ = Async.run try_deadlock *)