♻️ The effect syntax strikes back

bin/js/dune

@@ -2,5 +2,5 @@
  (name main)
  (modes js)
  (preprocess
-  (pps ppx_jane js_of_ocaml-ppx))
- (libraries react_trace base logs logs.fmt fmt fmt.tty js_of_ocaml))
+  (pps js_of_ocaml-ppx))
+ (libraries react_trace string_recorder base logs.fmt fmt.tty js_of_ocaml))

bin/js/main.ml

@@ -28,8 +28,8 @@ let () =
   Js.export_all
     (object%js
        method run (fuel : int) program_str =
-         (let open Result.Let_syntax in
-          let%bind prog = parse_program_str program_str in
+         (let ( let* ) x f = Result.bind x ~f in
+          let* prog = parse_program_str program_str in
           let Interp.{ recording; _ } =
             Interp.run
               ?fuel:(if fuel < 1 then None else Some fuel)

bin/js/string_recorder/dune

@@ -0,0 +1,3 @@
+(library
+ (name string_recorder)
+ (libraries react_trace base))

bin/js/string_recorder/string_recorder.ml

@@ -0,0 +1,57 @@
+open! Base
+open Stdlib.Effect
+open Stdlib.Effect.Deep
+open React_trace
+open Lib_domains
+open Concrete_domains
+open Interp_effects
+include Recorder_intf
+
+type recording = string
+
+let emp_recording = "= Recording =\n"
+
+let event_h (type a b) (f : a -> b) (x : a) :
+    recording:recording -> b * recording =
+  match f x with
+  | v -> fun ~recording -> (v, recording)
+  | effect Update_st (path, label, (v, q)), k ->
+      fun ~recording ->
+        let () = perform (Update_st (path, label, (v, q))) in
+        let recording =
+          recording
+          ^ Printf.sprintf "[path %s] Update state %d -> %s\n"
+              (Sexp.to_string (Path.sexp_of_t path))
+              label
+              (Sexp.to_string (sexp_of_value v))
+        in
+        continue k () ~recording
+  | effect Set_dec (path, dec), k ->
+      fun ~recording ->
+        let () = perform (Set_dec (path, dec)) in
+        let recording =
+          recording
+          ^ Printf.sprintf "[path %s] Set decision %s\n"
+              (Sexp.to_string (Path.sexp_of_t path))
+              (Sexp.to_string (sexp_of_decision dec))
+        in
+        continue k () ~recording
+  | effect Enq_eff (path, clos), k ->
+      fun ~recording ->
+        let () = perform (Enq_eff (path, clos)) in
+        let recording =
+          recording
+          ^ Printf.sprintf "[path %s] Enqueue effect\n"
+              (Sexp.to_string (Path.sexp_of_t path))
+        in
+        continue k () ~recording
+  | effect Alloc_pt, k ->
+      fun ~recording ->
+        let path = perform Alloc_pt in
+        let recording =
+          recording
+          ^ Printf.sprintf "Allocate path %s\n"
+              (Sexp.to_string (Path.sexp_of_t path))
+        in
+        continue k path ~recording
+  | effect Checkpoint _, k -> fun ~recording -> continue k () ~recording

bin/native/dune

@@ -1,14 +1,10 @@
 (executable
  (public_name react_trace)
  (name main)
- (preprocess
-  (pps ppx_jane))
  (libraries
   react_trace
+  report_box_recorder
   base
-  logs
   logs.fmt
-  fmt
   fmt.tty
-  printbox
   printbox-text))

bin/native/report_box_recorder/dune

@@ -0,0 +1,3 @@
+(library
+ (name report_box_recorder)
+ (libraries react_trace base printbox))

bin/native/report_box_recorder.ml → bin/native/report_box_recorder/report_box_recorder.ml

@@ -75,18 +75,12 @@ let get_path_from_checkpoint = function
 
 let emp_recording = []
 
-let event_h =
-  {
-    retc = (fun v ~recording -> (v, recording));
-    exnc = raise;
-    effc =
-      (fun (type a) (eff : a t) ->
-        match eff with
-        | Checkpoint { msg; checkpoint } ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                let pt = get_path_from_checkpoint checkpoint in
-                let box = path pt in
-                continue k () ~recording:((msg, box) :: recording))
-        | _ -> None);
-  }
+let event_h (type a b) (f : a -> b) (x : a) :
+    recording:recording -> b * recording =
+  match f x with
+  | v -> fun ~recording -> (v, recording)
+  | effect Checkpoint { msg; checkpoint }, k ->
+      fun ~recording ->
+        let pt = get_path_from_checkpoint checkpoint in
+        let box = path pt in
+        continue k () ~recording:((msg, box) :: recording)

lib/default_recorder.ml

@@ -7,36 +7,24 @@ type recording = unit
 
 let emp_recording = ()
 
-let event_h =
-  {
-    retc = (fun v ~recording -> (v, recording));
-    exnc = raise;
-    effc =
-      (fun (type a) (eff : a t) ->
-        match eff with
-        | Update_st (path, label, (v, q)) ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                let () = perform (Update_st (path, label, (v, q))) in
-                continue k () ~recording)
-        | Set_dec (path, dec) ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                let () = perform (Set_dec (path, dec)) in
-                continue k () ~recording)
-        | Enq_eff (path, clos) ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                let () = perform (Enq_eff (path, clos)) in
-                continue k () ~recording)
-        | Alloc_pt ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                let path = perform Alloc_pt in
-                continue k path ~recording)
-        | Checkpoint _ ->
-            Some
-              (fun (k : (a, _) continuation) ~(recording : recording) ->
-                continue k () ~recording)
-        | _ -> None);
-  }
+let event_h (type a b) (f : a -> b) (x : a) :
+    recording:recording -> b * recording =
+  match f x with
+  | v -> fun ~recording -> (v, recording)
+  | effect Update_st (path, label, (v, q)), k ->
+      fun ~recording ->
+        let () = perform (Update_st (path, label, (v, q))) in
+        continue k () ~recording
+  | effect Set_dec (path, dec), k ->
+      fun ~recording ->
+        let () = perform (Set_dec (path, dec)) in
+        continue k () ~recording
+  | effect Enq_eff (path, clos), k ->
+      fun ~recording ->
+        let () = perform (Enq_eff (path, clos)) in
+        continue k () ~recording
+  | effect Alloc_pt, k ->
+      fun ~recording ->
+        let path = perform Alloc_pt in
+        continue k path ~recording
+  | effect Checkpoint _, k -> fun ~recording -> continue k () ~recording