✨ view tree logging feature (#2)

* ✨ Basic view tree logging feature * ✨ Visualize dec/stt/eff * ✨ Visualize arguments to components * ✨ Match the report timings * ♻️ Refactor Report_box.log * ✨ Visualize retry * 🚸 Truncate long strings * 📌 printbox without overflowing frames * 🔥 No more hpad necessary as printbox got patched * 🍱 Add samples from react.dev * ♻️ Move logging effect & handler inside Report_box
React-Analysis · Sep 13, 2024 · ffb6300 · ffb6300
1 parent f31c512
commit ffb6300
Show file tree

Hide file tree

Showing 12 changed files with 163 additions and 8 deletions.
diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore
@@ -1 +1 @@
-samples/*
+samples/**
diff --git a/bin/main.ml b/bin/main.ml
@@ -35,6 +35,7 @@ let () =
   let opt_pp = ref false in
   let opt_parse_js = ref false in
   let opt_fuel = ref None in
+  let opt_report = ref false in
   let opt_verbosity = ref Logs.Info in
 
   let usage_msg =
@@ -49,6 +50,9 @@ let () =
       ( "-verbose",
         Arg.Unit (fun _ -> opt_verbosity := Logs.Debug),
         "Verbose mode" );
+      ( "-report",
+        Arg.Unit (fun _ -> opt_report := true),
+        "Report the view trees" );
       ("-fuel", Arg.Int (fun n -> opt_fuel := Some n), "[fuel] Run with fuel");
     ]
   in
@@ -67,6 +71,8 @@ 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 prog in
+      let { Interp.steps; _ } =
+        Interp.run ?fuel:!opt_fuel ~report:!opt_report prog
+      in
       printf "\nSteps: %d\n" steps;
       Stdlib.exit (if Logs.err_count () > 0 then 1 else 0))
diff --git a/dune-project b/dune-project
@@ -32,6 +32,8 @@
   logs
   menhir
   ppx_jane
+  printbox
+  printbox-text
   stdio
   (alcotest :with-test))
  (tags

diff --git a/lib/concrete_domains.ml b/lib/concrete_domains.ml
@@ -71,6 +71,7 @@ module M : Domains.S = struct
     let empty = Label.Map.empty
     let lookup store ~label = Map.find_exn store label
     let update store ~label ~value = Map.set store ~key:label ~data:value
+    let to_alist store = Map.to_alist ~key_order:`Increasing store
   end
 
   and Job_q : (Domains.Job_q with type elt := T.clos and type t = T.job_q) =

diff --git a/lib/domains.ml b/lib/domains.ml
@@ -80,6 +80,7 @@ module type St_store = sig
   val empty : t
   val lookup : t -> label:Label.t -> value * job_q
   val update : t -> label:Label.t -> value:value * job_q -> t
+  val to_alist : t -> (Label.t * (value * job_q)) list
   val sexp_of_t : t -> Sexp.t
 end
 

diff --git a/lib/dune b/lib/dune
@@ -2,7 +2,7 @@
  (name react_trace)
  (preprocess
   (pps ppx_jane))
- (libraries core logs flow_parser ppx_jane))
+ (libraries core logs flow_parser ppx_jane printbox printbox-text))
 
 (ocamllex lexer)
 

diff --git a/lib/interp.ml b/lib/interp.ml
@@ -165,6 +165,90 @@ module Env = struct
   let lookup_exn env ~id = lookup env ~id |> value_exn (Unbound_var id)
 end
 
+module Report_box = 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 = string_of_int 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 stdout (path pt);
+    Out_channel.(
+      newline stdout;
+      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;
@@ -290,6 +374,7 @@ 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)
@@ -446,31 +531,47 @@ let step_prog (prog : Prog.t) : Path.t =
   let path = perform Alloc_pt in
   perform (Update_ent (path, { part_view = Root; children = [] }));
   render path vss;
+
+  perform (Report_box.Log { msg = "Rendered"; path });
   commit_effs path;
+  perform (Report_box.Log { msg = "After effects"; path });
   path
 
 let step_path (path : Path.t) : bool =
   Logger.step_path path;
   let has_updates = update path None in
-  if has_updates then commit_effs path;
+
+  if has_updates then (
+    perform (Report_box.Log { msg = "Rendered"; path });
+    commit_effs path;
+    perform (Report_box.Log { msg = "After effects"; path }));
+
   has_updates
 
 type run_info = { steps : int; mem : Tree_mem.t }
 
-let run ?(fuel : int option) (prog : Prog.t) : run_info =
+let run ?(fuel : int option) ?(report : bool = false) (prog : Prog.t) : run_info
+    =
   Logger.run prog;
+
   let driver () =
     let cnt = ref 1 in
     Logs.info (fun m -> m "Step prog %d" !cnt);
-    let path = step_prog prog in
+    let root_path = step_prog prog in
+
     let rec loop () =
       Logs.info (fun m -> m "Step path %d" (!cnt + 1));
-      if step_path path then (
+      if step_path root_path then (
         Int.incr cnt;
         match fuel with Some n when !cnt >= n -> () | _ -> loop ())
     in
     loop ();
     !cnt
   in
-  let steps, mem = match_with driver () mem_h ~mem:Tree_mem.empty in
+
+  let steps, mem =
+    match_with
+      (fun () -> try_with driver () (Report_box.log_h report))
+      () mem_h ~mem:Tree_mem.empty
+  in
   { steps; mem }
diff --git a/react_trace.opam b/react_trace.opam
@@ -18,6 +18,8 @@ depends: [
   "logs"
   "menhir"
   "ppx_jane"
+  "printbox"
+  "printbox-text"
   "stdio"
   "alcotest" {with-test}
   "odoc" {with-doc}
@@ -39,4 +41,6 @@ build: [
 dev-repo: "git+https://github.com/React-Analysis/ReacttRace.git"
 pin-depends: [
   [ "flow_parser.0.239.1" "git+https://github.com/facebook/flow#5d1b246a1ac8a8fc4e431b835ab8fb7f6f5ebd30" ]
+  [ "printbox.0.11" "git+https://github.com/c-cube/printbox#d49d9520e7d9e96121c13643cd3eaf8876389205" ]
+  [ "printbox-text.0.11" "git+https://github.com/c-cube/printbox#d49d9520e7d9e96121c13643cd3eaf8876389205" ]
 ]
diff --git a/react_trace.opam.template b/react_trace.opam.template
@@ -1,3 +1,5 @@
 pin-depends: [
   [ "flow_parser.0.239.1" "git+https://github.com/facebook/flow#5d1b246a1ac8a8fc4e431b835ab8fb7f6f5ebd30" ]
+  [ "printbox.0.11" "git+https://github.com/c-cube/printbox#d49d9520e7d9e96121c13643cd3eaf8876389205" ]
+  [ "printbox-text.0.11" "git+https://github.com/c-cube/printbox#d49d9520e7d9e96121c13643cd3eaf8876389205" ]
 ]
diff --git a/samples/learn-react/conditional_rendering.ml b/samples/learn-react/conditional_rendering.ml
@@ -0,0 +1,10 @@
+let Item isPacked =
+  if isPacked then
+    view [1]
+  else
+    view [0]
+;;
+let PackingList _ =
+  view [Item true, Item true, Item false]
+;;
+view [PackingList ()]
diff --git a/samples/learn-react/queueing_a_series_of_state_updates.ml b/samples/learn-react/queueing_a_series_of_state_updates.ml
@@ -0,0 +1,10 @@
+let Counter _ =
+  let (number, setNumber) = useState 0 in
+  if number = 0 then (
+    setNumber (fun _ -> number + 5);
+    setNumber (fun n -> n + 1);
+    setNumber (fun _ -> 42)
+  );
+  view [number]
+;;
+view [Counter ()]
diff --git a/samples/learn-react/your_ui_as_a_tree.ml b/samples/learn-react/your_ui_as_a_tree.ml
@@ -0,0 +1,18 @@
+let FancyText x =
+  if x = 0 then
+    view [0]
+  else
+    view [1]
+;;
+let InspirationGenerator children =
+  let (index, setIndex) = useState 0 in
+  # need to have indexing
+  children
+;;
+let Copyright year =
+  view [year]
+;;
+let App _ =
+  view [FancyText 42, InspirationGenerator (view [Copyright 2004])]
+;;
+view [App ()]