Refactored treemap visualization into separate binary + Cmdliner CLI interface

bin/visualizations/builder_viz.ml

@@ -0,0 +1,110 @@
+let src = Logs.Src.create "builder-viz" ~doc:"Builder_viz"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+open Rresult
+
+(* open Lwt.Syntax
+ * open Lwt_result.Infix *)
+
+let print_treemap_html elf_path elf_size =
+  let open Modulectomy in
+  let infos = 
+    elf_path
+    |> Elf.get
+    |> Result.map_error (fun _ -> R.msg "Invalid ELF file")
+    |> R.failwith_error_msg
+  in
+  let info, excluded_minors =
+    let size, info =
+      infos
+      |> Info.import
+      |> Info.diff_size_tree
+    in
+    (*> Note: this heuristic fails if one has all subtrees of equal size*)
+    let node_big_enough subtree =
+      match Info.(subtree.T.value.size) with
+      | None -> true
+      | Some subtree_size ->
+        let pct = Int64.(to_float subtree_size /. to_float size) in
+        pct > 0.004
+    in
+    info
+    |> Info.prefix_filename
+    |> Info.cut 2
+    |> Info.partition_subtrees node_big_enough
+  in
+  let scale_chunks =
+    let excluded_minors_size =
+      excluded_minors
+      |> List.map Info.compute_area
+      |> List.fold_left Int64.add 0L
+    in
+    [ 
+      "Smaller excluded entries", excluded_minors_size
+    ]
+  in
+  info
+  |> Treemap.of_tree
+  |> Treemap.to_html_with_scale ~binary_size:elf_size ~scale_chunks
+  |> Fmt.to_to_string (Tyxml.Html.pp ())
+(* |> Treemap.svg
+ * |> Fmt.to_to_string (Tyxml.Svg.pp ()) *)
+
+
+module Cmd = struct 
+
+  module Arg = struct
+  
+    let elf_path =
+      let doc = "The file-path of the debug-ELF to be analyzed" in
+      Cmdliner.Arg.(
+        required &
+        pos 0 (some file) None &
+        info ~doc ~docv:"DEBUG_ELF_PATH" []
+      )
+
+    let elf_size =
+      let doc = "The file-size of the stripped ELF file in bytes" in
+      Cmdliner.Arg.(
+        required &
+        pos 1 (some int) None &
+        info ~doc ~docv:"STRIPPED_ELF_SIZE" []
+      )
+
+  end
+
+  module Aux = struct
+
+    let help man_format cmds = function
+      | None -> `Help (man_format, None)
+      | Some cmd ->
+        if List.mem cmd cmds
+        then `Help (man_format, Some cmd)
+        else `Error (true, "Unknown command: " ^ cmd)
+
+  end
+  
+  let treemap =
+    let doc = "Dump treemap SVG and CSS wrapped in HTML" in
+    Cmdliner.Term.(pure print_treemap_html $ Arg.elf_path $ Arg.elf_size),
+    Cmdliner.Term.info ~doc "treemap"
+
+  let help =
+    let topic =
+      let doc = "Command to get help on" in
+      Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"COMMAND" [])
+    in
+    let doc = "Builder database help" in
+    Cmdliner.Term.(ret (const Aux.help $ man_format $ choice_names $ topic)),
+    Cmdliner.Term.info ~doc "help"
+
+  let default =
+    let doc = "Builder database command" in
+    Cmdliner.Term.(ret (const Aux.help $ man_format $ choice_names $ const None)),
+    Cmdliner.Term.info ~doc "builder-viz"
+
+end
+
+let () =
+  Cmdliner.Term.eval_choice Cmd.default [ Cmd.help; Cmd.treemap ]
+  |> Cmdliner.Term.exit

bin/visualizations/dune

@@ -0,0 +1,12 @@
+(executable
+ (name builder_viz) 
+ (public_name builder-viz)
+ (libraries
+  tyxml bos caqti-lwt cmdliner rresult
+  builder_db
+  modulectomy
+  opam-graph
+  )
+ (flags (:standard (-w -27-26)))
+ )
+