♻️ Integrate Report_box into Recorder API & move to bin/native

Zeta611 · Dec 2, 2024 · 39cc643 · 39cc643
1 parent e549ec8
commit 39cc643
Show file tree

Hide file tree

Showing 8 changed files with 153 additions and 107 deletions.
diff --git a/bin/native/dune b/bin/native/dune
@@ -3,4 +3,12 @@
  (name main)
  (preprocess
   (pps ppx_jane))
- (libraries react_trace base logs logs.fmt fmt fmt.tty))
+ (libraries
+  react_trace
+  base
+  logs
+  logs.fmt
+  fmt
+  fmt.tty
+  printbox
+  printbox-text))
diff --git a/bin/native/main.ml b/bin/native/main.ml
@@ -74,10 +74,26 @@ let () =
     if !opt_pp then
       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
-          ~recorder:(module Default_recorder)
-          prog
+      let steps =
+        if !opt_report then (
+          let { Interp.steps; recording; _ } =
+            Interp.run ?fuel:!opt_fuel
+              ~recorder:(module Report_box_recorder)
+              prog
+          in
+          recording |> List.rev
+          |> List.iter ~f:(fun (msg, box) ->
+                 Logs.info (fun m -> m "%s\n" msg);
+                 PrintBox_text.output Stdio.stdout box);
+          steps)
+        else
+          let { Interp.steps; _ } =
+            Interp.run ?fuel:!opt_fuel ~recorder:(module Default_recorder) prog
+          in
+          steps
       in
-      printf "\nSteps: %d\n" steps;
+      Out_channel.(
+        output_char stdout '\n';
+        flush stdout);
+      printf "Steps: %d\n" steps;
       Stdlib.exit (if Logs.err_count () > 0 then 1 else 0))
diff --git a/bin/native/report_box_recorder.ml b/bin/native/report_box_recorder.ml
@@ -0,0 +1,91 @@
+open! Base
+open Stdlib.Effect
+open Stdlib.Effect.Deep
+open React_trace
+open Interp_effects
+open Concrete_domains
+include Recorder_intf
+module B = PrintBox
+
+type recording = (string * B.t) list
+
+let align ?(h = `Center) ?(v = `Center) = B.align ~h ~v
+let bold_text = B.(text_with_style Style.bold)
+
+let trunc ?(max_len = 10) s =
+  if String.length s > max_len then String.prefix s max_len ^ "…" else s
+
+let value (v : value) : B.t =
+  sexp_of_value v |> Sexp.to_string |> trunc |> B.text
+
+let clos ({ param; _ } : clos) : B.t = "λ" ^ param ^ ".<body>" |> B.text
+let leaf_null () : B.t = B.text "()"
+let leaf_int (i : int) : B.t = B.int i
+
+let rec tree : tree -> B.t = function
+  | Leaf_null -> leaf_null ()
+  | Leaf_int i -> leaf_int i
+  | Path p -> path p
+
+and path (pt : Path.t) : B.t =
+  let { part_view; children } = perform (Lookup_ent pt) in
+  let part_view_box =
+    match part_view with
+    | Root -> bold_text "•" |> align
+    | Node { comp_spec = { comp; arg; _ }; dec; st_store; eff_q } ->
+        let comp_spec_box =
+          B.(
+            hlist ~bars:false
+              [ bold_text (trunc comp.name); text " "; value arg ])
+          |> align
+        in
+        let dec_box =
+          let dec = sexp_of_decision dec |> Sexp.to_string in
+          B.(hlist_map text [ "dec"; dec ])
+        in
+        let stt_box =
+          let st_trees =
+            let st_store = St_store.to_alist st_store in
+            List.map st_store ~f:(fun (lbl, (value, job_q)) ->
+                let lbl = Int.to_string lbl in
+                let value = Sexp.to_string (sexp_of_value value) in
+                let job_q = Job_q.to_list job_q |> List.map ~f:clos in
+
+                B.(tree (text (lbl ^ " ↦ " ^ value)) job_q))
+            |> B.vlist
+          in
+          B.(hlist [ text "stt"; st_trees ])
+        in
+        let eff_box =
+          let eff_q = Job_q.to_list eff_q |> List.map ~f:clos in
+          B.(hlist [ text "eff"; vlist eff_q ])
+        in
+        B.vlist [ comp_spec_box; dec_box; stt_box; eff_box ]
+  in
+  let children =
+    Snoc_list.to_list children |> B.hlist_map (fun t -> tree t |> align)
+  in
+  B.(vlist [ part_view_box; children ] |> frame)
+
+let get_path_from_checkpoint = function
+  | Retry_start (_, pt) | Render_check pt | Render_finish pt | Effects_finish pt
+    ->
+      pt
+
+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);
+  }
diff --git a/bin/native/report_box_recorder.mli b/bin/native/report_box_recorder.mli
@@ -0,0 +1,2 @@
+open React_trace
+include Recorder_intf.Intf with type recording = (string * PrintBox.t) list
diff --git a/lib/default_recorder.ml b/lib/default_recorder.ml
@@ -34,5 +34,9 @@ let event_h =
               (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);
   }
diff --git a/lib/dune b/lib/dune
@@ -2,7 +2,7 @@
  (name react_trace)
  (preprocess
   (pps ppx_jane))
- (libraries base logs flow_parser ppx_jane printbox printbox-text))
+ (libraries base logs flow_parser ppx_jane))
 
 (ocamllex lexer)
 

diff --git a/lib/interp.ml b/lib/interp.ml
@@ -168,94 +168,6 @@ module Env = struct
   let lookup_exn env ~id = lookup env ~id |> value_exn (Unbound_var id)
 end
 
-module Report_box : sig
-  type _ Stdlib.Effect.t += Log : { msg : string; path : Path.t } -> unit t
-
-  val log_h : bool -> _ effect_handler
-end = struct
-  module B = PrintBox
-
-  (* For reporting *)
-  type _ Stdlib.Effect.t += Log : { msg : string; path : Path.t } -> unit t
-
-  let align ?(h = `Center) ?(v = `Center) = B.align ~h ~v
-  let bold_text = B.(text_with_style Style.bold)
-
-  let trunc ?(max_len = 10) s =
-    if String.length s > max_len then String.prefix s max_len ^ "…" else s
-
-  let value (v : value) : B.t =
-    sexp_of_value v |> Sexp.to_string |> trunc |> B.text
-
-  let clos ({ param; _ } : clos) : B.t = "λ" ^ param ^ ".<body>" |> B.text
-  let leaf_null () : B.t = B.text "()"
-  let leaf_int (i : int) : B.t = B.int i
-
-  let rec tree : tree -> B.t = function
-    | Leaf_null -> leaf_null ()
-    | Leaf_int i -> leaf_int i
-    | Path p -> path p
-
-  and path (pt : Path.t) : B.t =
-    let { part_view; children } = perform (Lookup_ent pt) in
-    let part_view_box =
-      match part_view with
-      | Root -> bold_text "•" |> align
-      | Node { comp_spec = { comp; arg; _ }; dec; st_store; eff_q } ->
-          let comp_spec_box =
-            B.(
-              hlist ~bars:false
-                [ bold_text (trunc comp.name); text " "; value arg ])
-            |> align
-          in
-          let dec_box =
-            let dec = sexp_of_decision dec |> Sexp.to_string in
-            B.(hlist_map text [ "dec"; dec ])
-          in
-          let stt_box =
-            let st_trees =
-              let st_store = St_store.to_alist st_store in
-              List.map st_store ~f:(fun (lbl, (value, job_q)) ->
-                  let lbl = Int.to_string lbl in
-                  let value = Sexp.to_string (sexp_of_value value) in
-                  let job_q = Job_q.to_list job_q |> List.map ~f:clos in
-
-                  B.(tree (text (lbl ^ " ↦ " ^ value)) job_q))
-              |> B.vlist
-            in
-            B.(hlist [ text "stt"; st_trees ])
-          in
-          let eff_box =
-            let eff_q = Job_q.to_list eff_q |> List.map ~f:clos in
-            B.(hlist [ text "eff"; vlist eff_q ])
-          in
-          B.vlist [ comp_spec_box; dec_box; stt_box; eff_box ]
-    in
-    let children =
-      Snoc_list.to_list children |> B.hlist_map (fun t -> tree t |> align)
-    in
-    B.(vlist [ part_view_box; children ] |> frame)
-
-  let log ?(msg : string option) (pt : Path.t) : unit =
-    (match msg with Some msg -> Logs.info (fun m -> m "%s" msg) | None -> ());
-    PrintBox_text.output Stdio.stdout (path pt);
-    Out_channel.(
-      output_char stdout '\n';
-      flush stdout)
-
-  let log_h (report : bool) =
-    {
-      effc =
-        (fun (type a) (eff : a t) ->
-          match eff with
-          | Log { msg; path } ->
-              Some
-                (fun (k : (a, _) continuation) ->
-                  continue k (if report then log ~msg path else ()))
-          | _ -> None);
-    }
-end
-
 let rec eval : type a. a Expr.t -> value =
  fun expr ->
   Logger.eval expr;
@@ -398,10 +310,11 @@ let rec eval_mult : type a. ?re_render:int -> a Expr.t -> value =
   let path = perform Rd_pt in
   match perform (Get_dec path) with
   | Retry ->
-      perform (Report_box.Log { msg = "Will retry"; path });
-      match_with
-        (eval_mult ~re_render:(re_render + 1))
-        expr ptph_h ~ptph:(path, P_retry)
+      let re_render = re_render + 1 in
+      perform
+        (Checkpoint
+           { msg = "Will retry"; checkpoint = Retry_start (re_render, path) });
+      match_with (eval_mult ~re_render) expr ptph_h ~ptph:(path, P_retry)
   | Idle | Update -> v
 
 let rec render (path : Path.t) (vss : view_spec list) : unit =
@@ -554,21 +467,27 @@ let step_prog (prog : Prog.t) : Path.t =
   let vss = match_with eval_top prog env_h ~env:Env.empty in
   let path = perform Alloc_pt in
   perform (Update_ent (path, { part_view = Root; children = [] }));
+
+  perform (Checkpoint { msg = "Render"; checkpoint = Render_check path });
   render path vss;
+  perform (Checkpoint { msg = "Rendered"; checkpoint = Render_finish path });
 
-  perform (Report_box.Log { msg = "Rendered"; path });
   commit_effs path;
-  perform (Report_box.Log { msg = "After effects"; path });
+  perform
+    (Checkpoint { msg = "After effects"; checkpoint = Effects_finish path });
   path
 
 let step_path (path : Path.t) : bool =
   Logger.step_path path;
+
+  perform (Checkpoint { msg = "Render"; checkpoint = Render_check path });
   let has_updates = update path None in
 
   if has_updates then (
-    perform (Report_box.Log { msg = "Rendered"; path });
+    perform (Checkpoint { msg = "Rendered"; checkpoint = Render_finish path });
     commit_effs path;
-    perform (Report_box.Log { msg = "After effects"; path }));
+    perform
+      (Checkpoint { msg = "After effects"; checkpoint = Effects_finish path }));
 
   has_updates
 
@@ -579,7 +498,7 @@ type 'recording run_info = {
   recording : 'recording;
 }
 
-let run (type recording) ?(fuel : int option) ?(report : bool = false)
+let run (type recording) ?(fuel : int option)
     ~(recorder : (module Recorder_intf.Intf with type recording = recording))
     (prog : Prog.t) : recording run_info =
   Logger.run prog;
@@ -603,9 +522,6 @@ let run (type recording) ?(fuel : int option) ?(report : bool = false)
     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, recording), treemem), mem = driver () in

diff --git a/lib/interp_effects.ml b/lib/interp_effects.ml
@@ -35,6 +35,15 @@ type _ Stdlib.Effect.t +=
   | Lookup_ent : Path.t -> entry t
   | Update_ent : Path.t * entry -> unit t
 
+type checkpoint =
+  | Retry_start of (int * Path.t)
+  | Render_check of Path.t
+  | Render_finish of Path.t
+  | Effects_finish of Path.t
+
+type _ Stdlib.Effect.t +=
+  | Checkpoint : { msg : string; checkpoint : checkpoint } -> unit t
+
 (* For testing nontermination *)
 type _ Stdlib.Effect.t += Re_render_limit : int t
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1,2 @@
		open React_trace
		include Recorder_intf.Intf with type recording = (string * PrintBox.t) list