Create a graphical ui representing for an tezos store

src/irmin-pack-tools/README.md

@@ -4,7 +4,8 @@ This folder contains several tools meant to provide usefull ways to debug and du
 Currently, there are the following tools:
 - [`ppcf`](#ppcf), a json printer for control files
 - [`ppidx`](#ppidx), a json printer for index folders
-- [`tezos-explorer`](#tezos-explorer), a gui for a fast exploration of tezos stores
+- [`tezos-explorer`](#tezos-explorer), a notty ui for a fast exploration of tezos stores
+- [`tezos-explorer-gui`](#tezos-explorer-gui), a graphical ui for a fast exploration of tezos stores
 
 ## ppcf
 This tool prints a control file in a human readable manner (json), allowing to fetch important informations easily.
@@ -101,3 +102,25 @@ $ jq -s 'sort_by(.off)' -- index
 
 ## tezos-explorer
 TODO
+
+## tezos-explorer-gui
+This tool is a graphical UI, meant to allow the user to figure out rapidly the shape of a commit, giving them informations on its content.
+In order to launch it, uncomment the `dune` file under the path `src/irmin-pack-tools/tezos_explorer_gui` and install the deps `tsdl` and `tsdl-ttf`.
+You will also need to pin the package `prettree` with `git+https://github.com/art-w/prettree.git#568de08442f02dd87acc84ca6a91cc661b7e77bf`.
+It can be launched using the following command:
+```shell
+$ dune exec -- irmin-tezos-explorer-gui <path-to-store> <path-to-ttf-font> <commit>
+```
+
+The first argument is the path to the root of the store (e.g. `output/root/`).
+
+The second argument is the path to a `.ttf` file, necessary to know which font to use when printing strings.
+
+The third argument is an int, the `nth` commit stored in the index of the store that will be shown first.
+
+Once the program is launched, you can:
+- Navigate through the indexed commits using the left and right arrows.
+- Zoom in and out using the mouse wheel.
+- Drag the tree around when pressing the left mouse click and moving it around.
+
+Be aware that some commit are too big to be shown, and will take ages to compute for very little informations: You can shut the program down using the `alt-f4`` command.

src/irmin-pack-tools/tezos_explorer_gui/context.ml

@@ -0,0 +1,58 @@
+open Tsdl
+open Tsdl_ttf
+open Optint
+open Sdl_util
+
+type ctx = {
+  r : Sdl.renderer;
+  w : Sdl.window;
+  wr : Sdl.rect;
+  f : Ttf.font;
+  indexes : (string * Int63.t) list;
+  store_path : string;
+  mutable drag : (int * int) option;
+  mutable current : int;
+  mutable last_refresh : float;
+  mutable updated : bool;
+}
+
+let get_window_rect () =
+  let open Sdl.Rect in
+  let bounds = get @@ Sdl.get_display_bounds 0 in
+  let usable_bounds = get @@ Sdl.get_display_usable_bounds 0 in
+  let uw = w usable_bounds in
+  let uh = h usable_bounds in
+  create ~x:(w bounds - uw) ~y:(Sdl.Rect.h bounds - uh) ~w:uw ~h:uh
+
+let init_context store_path font_path i =
+  let wr = get_window_rect () in
+  let w =
+    let open Sdl.Rect in
+    get
+    @@ Sdl.create_window ~x:(x wr) ~y:(y wr) ~w:(w wr) ~h:(h wr)
+         "Tezos store explorer" Sdl.Window.opengl
+  in
+  let r =
+    get @@ Sdl.create_renderer ~index:(-1) ~flags:Sdl.Renderer.accelerated w
+  in
+  let f = get @@ Ttf.open_font font_path 12 in
+  let last_refresh = Unix.gettimeofday () in
+  let indexes = Load_tree.load_index store_path in
+  let current = i in
+  {
+    r;
+    w;
+    wr;
+    f;
+    store_path;
+    indexes;
+    current;
+    drag = None;
+    last_refresh;
+    updated = false;
+  }
+
+let delete_context ctx =
+  Ttf.close_font ctx.f;
+  Sdl.destroy_renderer ctx.r;
+  Sdl.destroy_window ctx.w

src/irmin-pack-tools/tezos_explorer_gui/dune

@@ -0,0 +1,8 @@
+; (executable
+;  (public_name irmin-tezos-explorer-gui)
+;  (package irmin-pack-tools)
+;  (name main)
+;  (modules main context load_tree tree sdl_util layout loading)
+;  (libraries prettree tsdl tsdl-ttf fmt irmin_pack irmin_tezos cmdliner)
+;  (preprocess
+;   (pps ppx_repr)))

src/irmin-pack-tools/tezos_explorer_gui/layout.ml

@@ -0,0 +1,184 @@
+open Tree
+open Sdl_util
+open Context
+
+type texture_data = {
+  min_w : float;
+  max_w : float;
+  min_h : float;
+  max_h : float;
+  scale_w : float;
+  scale_h : float;
+  zoom : float;
+}
+
+let must_be_shown (x, y) (size_w, size_h) t =
+  x +. size_w >= t.min_w
+  && x <= t.max_w +. (t.zoom /. t.zoom)
+  && y +. size_h >= t.min_h
+  && y <= t.max_h +. (t.zoom /. t.zoom)
+
+let scale_text_rect ttx_r (scale_w, scale_h) =
+  let open Tsdl in
+  let text_w = float (Sdl.Rect.w ttx_r) in
+  let text_h = float (Sdl.Rect.h ttx_r) in
+  let corrected_w = min scale_w text_w in
+  let corrected_h = min scale_h text_h in
+  Sdl.Rect.(
+    create
+      ~x:(x ttx_r + (int @@ ((text_w -. corrected_w) /. 2.)))
+      ~y:(y ttx_r) ~w:(int corrected_w) ~h:(int corrected_h))
+
+let render_rect renderer color size (ttx_t, ttx_r, ttx_width) current (x, y) t =
+  let scale_w, scale_h =
+    (t.scale_w *. t.zoom *. size, t.scale_h *. t.zoom *. size)
+  in
+  let x', y' = ((x -. t.min_w) *. scale_w, (y -. t.min_h) *. scale_h) in
+  let scale_w = scale_w *. ttx_width in
+  let must_be_shown = must_be_shown (x, y) (size *. ttx_width, size) t in
+  if must_be_shown then
+    if min scale_w scale_h < 1. then draw_point renderer color (x', y')
+    else (
+      if not current then
+        fill_rect renderer light_grey (x', y') (scale_w, scale_h);
+      draw_rect renderer color (x', y') (scale_w, scale_h);
+      let center = (x' +. (scale_w /. 2.), y' +. (scale_h /. 2.)) in
+      let ttx_r = scale_text_rect (ttx_r center) (scale_w, scale_h) in
+      render_text renderer ttx_t ttx_r);
+  ( ( must_be_shown,
+      (x' +. (scale_w /. 2.), y'),
+      (x' +. (scale_w /. 2.), y' +. scale_h) ),
+    t )
+
+let render_link renderer ((b1, _, bottom), _) ((b2, top, _), _) =
+  if b1 || b2 then draw_line renderer bottom top
+
+let get_text_texture ctx text =
+  let open Tsdl in
+  let open Tsdl_ttf in
+  let s = get @@ Ttf.render_text_solid ctx.f text black in
+  let ttf_w, ttf_h = Sdl.get_surface_size s in
+  let text_texture = get @@ Sdl.create_texture_from_surface ctx.r s in
+  Sdl.free_surface s;
+  let text_rect (c_x, c_y) =
+    Sdl.Rect.create
+      ~x:(int @@ (c_x -. (float ttf_w /. 2.)))
+      ~y:(int @@ (c_y -. (float ttf_h /. 2.)))
+      ~w:ttf_w ~h:ttf_h
+  in
+  (text_texture, text_rect, float ttf_w /. 10.)
+
+let layout ctx loading =
+  let rec layout_rec { depth = _; path; obj; current } =
+    let open Prettree in
+    Loading.update loading;
+    let size = 1. in
+    match obj with
+    | Leaf ->
+        loading.current.entries <- loading.current.entries + 1;
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
+        Prettree.make
+          (size *. text_width, size)
+          (fun pos t ->
+            render_rect ctx.r blue size
+              (text_texture, text_rect, text_width)
+              current pos t)
+    | Commit None ->
+        loading.current.commits <- loading.current.commits + 1;
+        let text_texture, text_rect, text_width = get_text_texture ctx path in
+        Prettree.make
+          (size *. text_width, size)
+          (fun pos t ->
+            render_rect ctx.r red size
+              (text_texture, text_rect, text_width)
+              current pos t)
+    | Commit (Some child) ->
+        loading.current.commits <- loading.current.commits + 1;
+        Prettree.vert
+        @@
+        let open Prettree.Syntax in
+        let+ parent =
+          let text_texture, text_rect, text_width = get_text_texture ctx path in
+          Prettree.make
+            (size *. text_width, size)
+            (fun pos t ->
+              render_rect ctx.r red size
+                (text_texture, text_rect, text_width)
+                current pos t)
+        and+ () = Prettree.padding 1.
+        and+ child = layout_rec child in
+        fun t ->
+          let parent_info = parent t in
+          let child_info = child t in
+          render_link ctx.r parent_info child_info;
+          parent_info
+    | Inode i -> (
+        loading.current.inodes <- loading.current.inodes + 1;
+        match i with
+        | Values None ->
+            let text_texture, text_rect, text_width =
+              get_text_texture ctx path
+            in
+            Prettree.make
+              (size *. text_width, size)
+              (fun pos t ->
+                render_rect ctx.r green size
+                  (text_texture, text_rect, text_width)
+                  current pos t)
+        | Values (Some l) ->
+            Prettree.vert
+            @@
+            let open Prettree.Syntax in
+            let+ parent =
+              let text_texture, text_rect, text_width =
+                get_text_texture ctx path
+              in
+              Prettree.make
+                (size *. text_width, size)
+                (fun pos t ->
+                  render_rect ctx.r green size
+                    (text_texture, text_rect, text_width)
+                    current pos t)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                l;
+              parent_pos
+        | Tree None ->
+            let text_texture, text_rect, text_width =
+              get_text_texture ctx path
+            in
+            Prettree.make
+              (size *. text_width, size)
+              (fun pos t ->
+                render_rect ctx.r purple size
+                  (text_texture, text_rect, text_width)
+                  current pos t)
+        | Tree (Some l) ->
+            Prettree.vert
+            @@
+            let open Prettree.Syntax in
+            let+ parent =
+              let text_texture, text_rect, text_width =
+                get_text_texture ctx path
+              in
+              Prettree.make
+                (size *. text_width, size)
+                (fun pos t ->
+                  render_rect ctx.r purple size
+                    (text_texture, text_rect, text_width)
+                    current pos t)
+            and+ () = Prettree.padding 1.
+            and+ l = horz (list ~padding:size (List.map layout_rec l)) in
+            fun scale ->
+              let parent_pos = parent scale in
+              List.iter
+                (fun child -> render_link ctx.r parent_pos (child scale))
+                l;
+              parent_pos)
+  in
+  Loading.set_state loading Gen_layout;
+  layout_rec