Fix dynamic_state to use new Effect syntax

multishot/dune

@@ -27,3 +27,8 @@
  (names delimcc)
  (modules delimcc)
  (libraries multicont))
+
+(executables
+ (names dynamic_state)
+ (modules dynamic_state)
+ (libraries multicont))

dynamic_state.ml → multishot/dynamic_state.ml

@@ -4,21 +4,24 @@
    types, without needing some kind of universal type or dynamic type
    checking. *)
 
+open Effect
+open Effect.Deep
+
 module type Type = sig type t end
 module Int = struct type t = int let compare = compare end
 
 module LocalState (R : sig type t end) = struct
   type reff = R.t
-  effect New : int -> R.t
-  effect Get : R.t -> int
-  effect Put : R.t * int -> unit
+  type _ Effect.t += New : int -> R.t Effect.t
+  type _ Effect.t += Get : R.t -> int Effect.t
+  type _ Effect.t += Put : R.t * int -> unit Effect.t
 end
 
 module type StateOps = sig
-  type rEffect.t
-  effect New : int -> rEffect.t
-  effect Get : reff -> int
-  effect Put : reff * int -> unit
+  type reff
+  type _ Effect.t += New : int -> reff Effect.t
+  type _ Effect.t += Get : reff -> int Effect.t
+  type _ Effect.t += Put : reff * int -> unit Effect.t
 end
 
 (**********************************************************************)
@@ -27,18 +30,25 @@ end
    the 'New', 'Get' and 'Put' effects. *)
 
 let run main =
-  let module S = LocalState (Int) in 
+  let module S = LocalState (Int) in
   let module IM = Map.Make (Int) in
   let comp =
-    match main (module Int : Type) with
-      | effect (S.New i) k ->
-          fun s -> let r = fst (IM.max_binding s) + 1
-                   in continue k r (IM.add r i s) 
-      | effect (S.Get r) k ->
-          fun s -> continue k (IM.find r s) s
-      | effect (S.Put (r, i)) k ->
-          fun s -> continue k () (IM.add r i s)
-      | x -> fun s -> x
+    match_with main (module Int : Type)
+      {
+        retc = (fun s _ -> s);
+        exnc = (fun e -> raise e);
+        effc = (fun (type a) (e: a Effect.t) ->
+          match e with
+          | S.Put (r, i) -> Some (fun (k : (a,_) continuation) -> (fun s ->
+                                    continue k () (IM.add r i s)))
+          | S.Get r -> Some (fun (k: (a,_) continuation) -> (fun s -> continue k (IM.find r s) s))
+          | S.New i -> Some (fun (k: (a, _) continuation) -> (fun s ->
+                               let r = fst (IM.max_binding s) + 1
+                               in continue k r (IM.add r i s)
+                         ))
+          | _ -> None
+        )
+      }
   in
   comp IM.empty
 
@@ -51,21 +61,26 @@ let main (module T : Type) =
 (**********************************************************************)
 (* version 2 : working creation of freshly generated state cells, but
    only an int type. *)
-
 let run2 main =
   let module S  = LocalState (Int) in
   let module IM = Map.Make (Int) in
   let comp =
-    match main (module S : StateOps) with
-      | effect (S.New i) k ->
-          fun s ->
-            let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1
-            in continue k r (IM.add r i s) 
-      | effect (S.Get r) k ->
-          fun s -> continue k (IM.find r s) s
-      | effect (S.Put (r, i)) k ->
-          fun s -> continue k () (IM.add r i s)
-      | x -> fun s -> x
+    match_with main (module S : StateOps)
+      {
+        retc = (fun s _ -> s);
+        exnc = (fun e -> raise e);
+        effc = (fun (type a) (e: a Effect.t) ->
+          match e with
+          | S.Put (r, i) -> Some (fun (k : (a,_) continuation) -> (fun s ->
+                                    continue k () (IM.add r i s)))
+          | S.Get r -> Some (fun (k: (a,_) continuation) -> (fun s -> continue k (IM.find r s) s))
+          | S.New i -> Some (fun (k: (a,_) continuation) -> (fun s ->
+                               let r = if IM.is_empty s then 0 else fst (IM.max_binding s) + 1
+                               in continue k r (IM.add r i s)
+                         ))
+          | _ -> None
+        )
+      }
   in
   comp IM.empty
 
@@ -80,38 +95,42 @@ let main2 (module S : StateOps) =
    handlers. Similar to the example in "state.ml". *)
 module type GetPutOps = sig
   type t
-  effect Get : t
-  effect Put : t -> unit
+  type _ Effect.t += Get : t Effect.t
+  type _ Effect.t += Put : t -> unit Effect.t
 end
 
 module MakeGetPut (T : sig type t end) () = struct
   type t = T.t
-  effect Get : t
-  effect Put : t -> unit
+  type _ Effect.t += Get : t Effect.t
+  type _ Effect.t += Put : t -> unit Effect.t
 end
 
 let run3 (type a) (module S : GetPutOps with type t = a) (s : a) main =
   let module IM = Map.Make (Int) in
   let comp =
-    match main () with
-      | effect S.Get k ->
-          fun (s : S.t) -> continue k s s
-      | effect (S.Put i) k ->
-          fun s -> continue k () i
-      | x -> fun s -> x
+    match_with main ()
+      {
+        retc = (fun s _ -> s);
+        exnc = (fun e -> raise e);
+        effc = (fun (type a) (e: a Effect.t) ->
+          match e with
+          | S.Get -> Some (fun (k : (a,_) continuation) -> (fun (s : S.t) -> continue k s s))
+          | S.Put i -> Some (fun (k : (a,_) continuation) -> (fun s -> continue k () i))
+          | _ -> None
+        )
+      }
   in
   comp s
 
 module S1 = MakeGetPut (struct type t = int end) ()
 module S2 = MakeGetPut (struct type t = string end) ()
 
-let test3 () =
+let test3 () : string =
   perform (S1.Put 5);
   let x = perform (S1.Get) in
   perform (S2.Put (string_of_int x ^ "xx"));
   perform S2.Get
 
-
 (**********************************************************************)
 (* version 4. Uses dynamic creation of new effect names to simulate
    the creation of new reference cells. Initially, there is only one
@@ -136,27 +155,41 @@ let test3 () =
    continuations. *)
 type 'a reff = < get : 'a; put : 'a -> unit; internals : (module GetPutOps with type t = 'a) >
 
-effect New : 'a -> 'a rEffect.t
-effect Choice : bool
+type _ Effect.t += New : 'a -> 'a reff t
+type _ Effect.t += Choice : bool t
 
 let run4 main =
   let donew : type a b. (a reff, b) continuation -> a -> b = fun k ->
-      let module Ops = MakeGetPut (struct type t = a end) () in
-      let cell = object
-                   method get   = perform Ops.Get
-                   method put x = perform (Ops.Put x)
-                   method internals = (module Ops : GetPutOps with type t = a)
-                 end
-      in
-      match continue k cell with
-        | effect Ops.Get      k -> fun s -> continue k s s
-        | effect (Ops.Put v)  k -> fun s -> continue k () v
-        | x                     -> fun s -> x
+    let module Ops = MakeGetPut (struct type t = a end) () in
+    let cell = object
+        method get   = perform Ops.Get
+        method put x = perform (Ops.Put x)
+        method internals = (module Ops : GetPutOps with type t = a)
+      end
+    in
+    match_with (continue k) cell
+      {
+        retc = (fun s _ -> s);
+        exnc = (fun e -> raise e);
+        effc = (fun (type c) (e: c t) ->
+          match e with
+          | Ops.Put v -> Some (fun (k : (c,_) continuation) -> (fun _ -> continue k () v))
+          | Ops.Get -> Some (fun (k : (c,_) continuation) -> (fun (s : a) -> continue k s s))
+          | _ -> None
+        )
+      }
   in
-  match main () with
-    | effect (New v) k -> donew k v
-    | effect (Choice) k -> let k' = Obj.clone_continuation k in continue k true; continue k' false
-    | x                -> x
+  try_with main () {
+      effc = (fun (type a) (e: a t) ->
+        match e with
+        | New v -> Some (fun (k : (a,_) continuation) -> donew k v)
+        | Choice -> Some (fun (k : (a,_) continuation) ->
+                            let k' = Multicont.Deep.clone_continuation k in
+                            continue k true;
+                            continue k' false)
+        | _ -> None
+      )
+    }
 
 let newref i = perform (New i)