Merge pull request #42 from avsm/effect-syntax

Use effect syntax for OCaml 5.3

.github/workflows/ci.yml

@@ -15,7 +15,7 @@ jobs:
           - ubuntu-latest
           - macos-latest
         ocaml-compiler:
-          - ocaml-base-compiler.5.1.0
+          - ocaml-base-compiler.5.3.0+trunk
 
     runs-on: ${{ matrix.os }}
 

.ocamlformat

@@ -1,2 +1,2 @@
 profile = default
-version = 0.26.0
+version = 0.26.2

Makefile

@@ -1,7 +1,7 @@
 EXE := concurrent.exe ref.exe transaction.exe echo.exe \
 	dyn_wind.exe generator.exe promises.exe reify_reflect.exe \
 	MVar_test.exe chameneos.exe eratosthenes.exe pipes.exe loop.exe \
-	fringe.exe algorithmic_differentiation.exe
+	fringe.exe algorithmic_differentiation.exe dynamic_state.exe
 
 all: $(EXE)
 

README.md

@@ -38,17 +38,15 @@ The original implementation of Multicore OCaml allowed a user to `Obj.clone_cont
 
 ## Running the examples
 
-To run the examples with Multicore OCaml, be sure to install [Opam with these instructions](https://opam.ocaml.org/doc/Install.html). If your version of Opam (`opam --version`) is greater than or equal to `2.1` then the following instructions will work:
+To run the examples with OCaml, be sure to install [Opam with these instructions](https://opam.ocaml.org/doc/Install.html).
 
 ```bash
-# After cloning this repository, create a 5.1.0 switch
+# After cloning this repository, create a 5.1 switch
 opam update
-# Add the alpha repository to get unreleased 5.1.0 compatible libraries
-opam switch create 5.1.0
+opam switch create 5.1.1
 opam install . --deps-only
 ```
 
-
 Running `make` will build all of the examples. If you want to run a single executable that is built with `dune` you can run:
 
 ```

algorithmic_differentiation.ml

@@ -17,39 +17,24 @@ end = struct
 
   let mk v = { v; d = 0.0 }
 
-  type _ Effect.t += Add : t * t -> t Effect.t
-  type _ Effect.t += Mult : t * t -> t Effect.t
+  type _ eff += Add : t * t -> t eff
+  type _ eff += Mult : t * t -> t eff
 
   let run f =
-    ignore
-      (match_with f ()
-         {
-           retc =
-             (fun r ->
-               r.d <- 1.0;
-               r);
-           exnc = raise;
-           effc =
-             (fun (type a) (e : a Effect.t) ->
-               match e with
-               | Add (a, b) ->
-                   Some
-                     (fun (k : (a, _) continuation) ->
-                       let x = { v = a.v +. b.v; d = 0.0 } in
-                       ignore (continue k x);
-                       a.d <- a.d +. x.d;
-                       b.d <- b.d +. x.d;
-                       x)
-               | Mult (a, b) ->
-                   Some
-                     (fun k ->
-                       let x = { v = a.v *. b.v; d = 0.0 } in
-                       ignore (continue k x);
-                       a.d <- a.d +. (b.v *. x.d);
-                       b.d <- b.d +. (a.v *. x.d);
-                       x)
-               | _ -> None);
-         })
+    ignore (match f () with
+      | r -> r.d <- 1.0; r;
+      | effect (Add(a,b)), k ->
+          let x = {v = a.v +. b.v; d = 0.0} in
+          ignore (continue k x);
+          a.d <- a.d +. x.d;
+          b.d <- b.d +. x.d;
+          x
+      | effect (Mult(a,b)), k ->
+          let x = {v = a.v *. b.v; d = 0.0} in
+          ignore (continue k x);
+          a.d <- a.d +. (b.v *. x.d);
+          b.d <- b.d +. (a.v *. x.d);
+          x)
 
   let grad f x =
     let x = mk x in

dune

@@ -19,6 +19,10 @@
  (names dyn_wind)
  (modules dyn_wind))
 
+(executables
+ (names dynamic_state)
+ (modules dynamic_state))
+
 (executables
  (names generator)
  (modules generator))

dyn_wind.ml

@@ -6,47 +6,27 @@ open Effect.Deep
 let dynamic_wind before_thunk thunk after_thunk =
   before_thunk ();
   let res =
-    match_with thunk ()
-      {
-        retc = Fun.id;
-        exnc =
-          (fun e ->
-            after_thunk ();
-            raise e);
-        effc =
-          (fun (type a) (e : a Effect.t) ->
-            Some
-              (fun (k : (a, _) continuation) ->
-                after_thunk ();
-                let res' = perform e in
-                before_thunk ();
-                continue k res'));
-      }
+    match thunk () with
+    | v -> v
+    | exception e -> after_thunk (); raise e
+    | effect e, k ->
+        after_thunk ();
+        let res' = perform e in
+        before_thunk ();
+        continue k res'
   in
   after_thunk ();
   res
 
-type _ Effect.t += E : unit Effect.t
+type _ eff += E : unit eff
 
 let () =
   let bt () = Printf.printf "IN\n" in
   let at () = Printf.printf "OUT\n" in
   let foo () =
-    Printf.printf "peform E\n";
-    perform E;
-    Printf.printf "peform E\n";
-    perform E;
+    Printf.printf "perform E\n"; perform E;
+    Printf.printf "perform E\n"; perform E;
     Printf.printf "done\n"
   in
-  try_with (dynamic_wind bt foo) at
-    {
-      effc =
-        (fun (type a) (e : a Effect.t) ->
-          match e with
-          | E ->
-              Some
-                (fun (k : (a, _) continuation) ->
-                  Printf.printf "handled E\n";
-                  continue k ())
-          | _ -> None);
-    }
+  try dynamic_wind bt foo at with
+  | effect E, k -> Printf.printf "handled E\n"; continue k ()

dynamic_state.ml

@@ -0,0 +1,181 @@
+open Effect
+open Effect.Deep
+
+(* This file contains a collection of attempts at replicating ML-style
+   references using algebraic effects and handlers. The difficult thing
+   to do is the dynamic creation of new reference cells at arbitrary
+   types, without needing some kind of universal type or dynamic type
+   checking. *)
+
+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
+  type _ eff += New : int -> R.t eff
+  type _ eff += Get : R.t -> int eff
+  type _ eff += Put : R.t * int -> unit eff
+end
+
+module type StateOps = sig
+  type reff
+  type _ eff += New : int -> reff eff
+  type _ eff += Get : reff -> int eff
+  type _ eff += Put : reff * int -> unit eff
+end
+
+(**********************************************************************)
+(* version 1 : doesn't work, because declaration of new effect names
+   is generative, so the handler and the client get different versions of
+   the 'New', 'Get' and 'Put' effects. *)
+
+let run main =
+  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
+  in
+  comp IM.empty
+
+let main (module T : Type) =
+  let module S = LocalState(T) in
+  let x = perform (S.New 1) in
+  perform (S.Put (x, 5));
+  perform (S.Get x)
+
+(**********************************************************************)
+(* 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
+  in
+  comp IM.empty
+
+let main2 (module S : StateOps) =
+  let open S in
+  let x = perform (New 1) in
+  perform (Put (x, 5));
+  perform (Get x)
+
+(**********************************************************************)
+(* version 3, static creation of new state cells, requiring nested
+   handlers. Similar to the example in "state.ml". *)
+module type GetPutOps = sig
+  type t
+  type _ eff += Get : t eff
+  type _ eff += Put : t -> unit eff
+end
+
+module MakeGetPut (T : sig type t end) () = struct
+  type t = T.t
+  type _ eff += Get : t eff
+  type _ eff += Put : t -> unit eff
+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
+  in
+  comp s
+
+module S1 = MakeGetPut (struct type t = int end) ()
+module S2 = MakeGetPut (struct type t = string end) ()
+
+let test3 () =
+  perform (S1.Put 5);
+  let x = perform (S1.Get) in
+  perform (S2.Put (string_of_int x ^ "xx"));
+  perform S2.Get
+
+(* XXX avsm: disabled pending port to multicont (uses clone_continuation)
+
+(**********************************************************************)
+(* version 4. Uses dynamic creation of new effect names to simulate
+   the creation of new reference cells. Initially, there is only one
+   effect 'New', which can be used to dynamically create new effect
+   names. The handler for 'New' wraps the continuation in a new
+   handler that handles the freshly generated effect names. This setup
+   yields the same interface as ML refs, except that there is no way
+   to compare references for equality. This is because cells are
+   represeted as objects with a pair of a 'write' method and a 'read'
+   method, so it is possible to create new references that reference
+   the same underlying data without the access objects being
+   equal. This is similar to the situation in Idealised Algol, where
+   variables are ways to affect the state, but have no independent
+   existence of their own.
+
+   Compared to the example in "ref.ml", this implementation does not
+   require a universal type, nor does it have "impossible" cases.
+
+   This example also includes an unneccessary extra 'Choice' effect to
+   demonstrate the combination of other effects with state in the same
+   handler. This uses the experimental Obj.clone_continuation function to clone
+   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
+
+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
+  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
+
+let newref i = perform (New i)
+
+let (:=) r x = r#put x
+
+let (!) r = r#get
+
+let test4 () =
+  let a = newref 0 in
+  let b = newref "str" in
+  if perform Choice then
+    begin a := String.length !b;
+          b := string_of_int !a;
+          print_endline !b
+    end
+  else
+    print_endline !b
+*)