From ffb63001a53fb18c109a9202d7c8c5da92c13ca0 Mon Sep 17 00:00:00 2001 From: Jay Lee Date: Fri, 13 Sep 2024 12:51:41 +0900 Subject: [PATCH] :sparkles: view tree logging feature (#2) * :sparkles: Basic view tree logging feature * :sparkles: Visualize dec/stt/eff * :sparkles: Visualize arguments to components * :sparkles: Match the report timings * :recycle: Refactor Report_box.log * :sparkles: Visualize retry * :children_crossing: Truncate long strings * :pushpin: printbox without overflowing frames * :fire: No more hpad necessary as printbox got patched * :bento: Add samples from react.dev * :recycle: Move logging effect & handler inside Report_box --- .ocamlformat-ignore | 2 +- bin/main.ml | 8 +- dune-project | 2 + lib/concrete_domains.ml | 1 + lib/domains.ml | 1 + lib/dune | 2 +- lib/interp.ml | 111 +++++++++++++++++- react_trace.opam | 4 + react_trace.opam.template | 2 + samples/learn-react/conditional_rendering.ml | 10 ++ .../queueing_a_series_of_state_updates.ml | 10 ++ samples/learn-react/your_ui_as_a_tree.ml | 18 +++ 12 files changed, 163 insertions(+), 8 deletions(-) create mode 100644 samples/learn-react/conditional_rendering.ml create mode 100644 samples/learn-react/queueing_a_series_of_state_updates.ml create mode 100644 samples/learn-react/your_ui_as_a_tree.ml diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore index 781fb73..fd6fa8d 100644 --- a/.ocamlformat-ignore +++ b/.ocamlformat-ignore @@ -1 +1 @@ -samples/* +samples/** diff --git a/bin/main.ml b/bin/main.ml index cf7b5ae..bab69cc 100644 --- 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 index 0e7094e..501a7b7 100644 --- 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 index 30bed20..e31dd6f 100644 --- 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 index 7037797..f528d09 100644 --- 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 index 7b03e03..9dd1a76 100644 --- 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 index bdfb508..59a4b99 100644 --- 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 ^ "." |> 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 index 30857f4..bfccabe 100644 --- 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 index 8bafeff..4822aa9 100644 --- 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 new file mode 100644 index 0000000..9942de0 --- /dev/null +++ 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 new file mode 100644 index 0000000..03f1bb9 --- /dev/null +++ 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 new file mode 100644 index 0000000..fd26a96 --- /dev/null +++ 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 ()]