🚧 Pluggable recorder module for the interpreter

Author: Zeta611

bin/js/dune

@@ -0,0 +1,6 @@
+(executable
+ (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))

bin/js/main.ml

@@ -0,0 +1,39 @@
+open! Core
+open React_trace
+
+let position (lexbuf : Lexing.lexbuf) : string =
+  let open Lexing in
+  let pos = lexbuf.lex_curr_p in
+  sprintf "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
+
+let parse_with_error (lexbuf : Lexing.lexbuf) : Syntax.Prog.t =
+  Parser.prog Lexer.read lexbuf
+
+let parse_program_str (program_str : string) : (Syntax.Prog.t, string) result =
+  let lexbuf = Lexing.from_string program_str in
+  match parse_with_error lexbuf with
+  | prog -> Ok prog
+  | exception Parser.Error ->
+      Error (sprintf "%s: syntax error" (position lexbuf))
+
+let () =
+  Fmt_tty.setup_std_outputs ();
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Logs.set_level (Some Logs.Info);
+
+  let open Js_of_ocaml in
+  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 Interp.{ recording; _ } =
+            Interp.run
+              ?fuel:(if fuel < 1 then None else Some fuel)
+              ~recorder:(module Recorder)
+              prog
+          in
+          if Logs.err_count () > 0 then Error "error" else Ok recording)
+         |> (function Ok s -> s | Error s -> s)
+         |> Js.string
+    end)

bin/js/recorder.ml

@@ -0,0 +1,39 @@
+open Stdlib.Effect
+open Stdlib.Effect.Deep
+open React_trace
+include Recorder_intf
+
+(* TODO: Replace the dummy string with an actual recording type *)
+type recording = string
+
+let emp_recording = "empty recording"
+
+let event_h =
+  {
+    retc = (fun v ~recording -> (v, recording));
+    exnc = raise;
+    effc =
+      (fun (type a) (eff : a t) ->
+        match eff with
+        | Evt_update_st (path, label, (v, q)) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, label, v, q);
+                continue k () ~recording)
+        | Evt_set_dec (path, dec) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, dec);
+                continue k () ~recording)
+        | Evt_enq_eff (path, clos) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, clos);
+                continue k () ~recording)
+        | Evt_alloc_pt path ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore path;
+                continue k () ~recording)
+        | _ -> None);
+  }

bin/js/recorder.mli

@@ -0,0 +1 @@
+include React_trace.Recorder_intf.Intf with type recording = string

bin/dune renamed to bin/native/dune

@@ -1,7 +1,6 @@
 (executable
  (public_name react_trace)
  (name main)
- (modes exe js)
  (preprocess
   (pps ppx_jane))
  (libraries react_trace base logs logs.fmt fmt fmt.tty))

bin/main.ml renamed to bin/native/main.ml

@@ -74,7 +74,9 @@ let () =
       Sexp.pp_hum Stdlib.Format.std_formatter (Syntax.Prog.sexp_of_t prog)
     else
       let { Interp.steps; _ } =
-        Interp.run ?fuel:!opt_fuel ~report:!opt_report prog
+        Interp.run ?fuel:!opt_fuel ~report:!opt_report
+          ~recorder:(module Default_recorder)
+          prog
       in
       printf "\nSteps: %d\n" steps;
       Stdlib.exit (if Logs.err_count () > 0 then 1 else 0))

dune-project

@@ -27,7 +27,8 @@
   (ocaml-base-compiler
    (= 5.2.0))
   core
-  js_of_ocaml-compiler
+  js_of_ocaml
+  js_of_ocaml-ppx
   flow_parser
   fmt
   logs

lib/default_recorder.ml

@@ -0,0 +1,37 @@
+open Stdlib.Effect
+open Stdlib.Effect.Deep
+include Recorder_intf
+
+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
+        | Evt_update_st (path, label, (v, q)) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, label, v, q);
+                continue k () ~recording)
+        | Evt_set_dec (path, dec) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, dec);
+                continue k () ~recording)
+        | Evt_enq_eff (path, clos) ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore (path, clos);
+                continue k () ~recording)
+        | Evt_alloc_pt path ->
+            Some
+              (fun (k : (a, _) continuation) ~(recording : recording) ->
+                ignore path;
+                continue k () ~recording)
+        | _ -> None);
+  }

lib/default_recorder.mli

@@ -0,0 +1 @@
+include Recorder_intf.Intf

lib/interp.ml

@@ -572,10 +572,16 @@ let step_path (path : Path.t) : bool =
 
   has_updates
 
-type run_info = { steps : int; mem : Memory.t; treemem : Tree_mem.t }
-
-let run ?(fuel : int option) ?(report : bool = false) (prog : Prog.t) : run_info
-    =
+type 'recording run_info = {
+  steps : int;
+  mem : Memory.t;
+  treemem : Tree_mem.t;
+  recording : 'recording;
+}
+
+let run (type recording) ?(fuel : int option) ?(report : bool = false)
+    ~(recorder : (module Recorder_intf.Intf with type recording = recording))
+    (prog : Prog.t) : recording run_info =
   Logger.run prog;
 
   let driver () =
@@ -592,9 +598,15 @@ let run ?(fuel : int option) ?(report : bool = false) (prog : Prog.t) : run_info
     loop ();
     !cnt
   in
+
+  let driver () =
+    let open (val recorder) in
+    match_with driver () event_h ~recording:emp_recording
+  in
   (* TODO: Integrate Report_box with (WIP) Recorder API *)
   let driver () = try_with driver () (Report_box.log_h report) in
+
   let driver () = match_with driver () treemem_h ~treemem:Tree_mem.empty in
   let driver () = match_with driver () mem_h ~mem:Memory.empty in
-  let (steps, treemem), mem = driver () in
-  { steps; mem; treemem }
+  let ((steps, recording), treemem), mem = driver () in
+  { steps; mem; treemem; recording }