Merge pull request #29 from talex5/minibuffer

Allow setting viewport values explicitly

Author: talex5

README.md

@@ -113,6 +113,14 @@ In the above trace, the upper domain performed GC while suspended
 (the dark "minor" region in the top right, inside the "suspend-domain" region).
 This is possible because each domain has a "backup" thread that handles GC while the domain is suspended.
 
+## Controls
+
+- F5 : reload the trace file
+- s : start-time (elapsed time at left edge of window since trace start)
+- d : duration (duration to show in the currently visible area of the window)
+
+`d` is useful for getting two windows to use the same scale, so that they can be compared easily.
+
 ## Limitations
 
 - OCaml 5.1 can [deadlock when tracing multiple domains](https://github.com/ocaml/ocaml/issues/12897). This should be fixed in OCaml 5.2.

gtk/gtk_ui.ml

@@ -7,12 +7,13 @@ let create ~title tracefile =
   let window = GWindow.window () in
   window#set_title title;
   window#event#connect#delete ==> (fun _ -> GMain.quit (); true);
-  let table = GPack.table ~rows:2 ~columns:2 ~homogeneous:false ~packing:window#add () in
+  let table = GPack.table ~rows:3 ~columns:2 ~homogeneous:false ~packing:window#add () in
   let hadjustment = GData.adjustment () in
   let vadjustment = GData.adjustment () in
   let area = GMisc.drawing_area ~packing:(table#attach ~left:0 ~top:0 ~expand:`BOTH ~fill:`BOTH) () in
   let _hscroll = GRange.scrollbar `HORIZONTAL ~adjustment:hadjustment ~packing:(table#attach ~left:0 ~top:1 ~expand:`X ~fill:`BOTH) () in
   let _vscroll = GRange.scrollbar `VERTICAL ~adjustment:vadjustment ~packing:(table#attach ~left:1 ~top:0 ~expand:`Y ~fill:`BOTH) () in
+  let minibuffer = Minibuffer.create ~packing:(table#attach ~left:0 ~top:2 ~right:2 ~fill:`BOTH) () in
   let v =
     let layout = Layout.load tracefile in
     View.of_layout layout ~width:1000. ~height:1000.
@@ -49,6 +50,52 @@ let create ~title tracefile =
     );
   area#misc#set_app_paintable true;
 
+  let show_start () =
+    let current = View.time_of_x v 0. /. 1e9 in 
+    Minibuffer.show minibuffer
+      ~label:"Viewport start: "
+      ~value:(Time.to_string current)
+      (fun s ->
+         match Time.of_string s with
+         | Ok time ->
+           set_start_time (time *. 1e9);
+           redraw ();
+           Minibuffer.hide minibuffer
+         | Error message ->
+           let box =
+             GWindow.message_dialog ()
+               ~message
+               ~parent:window
+               ~buttons:GWindow.Buttons.close
+           in
+           box#connect#response ==> (fun _ -> box#destroy ());
+           box#show ()
+      )
+  in
+
+  let show_duration () =
+    let current = View.get_duration v /. 1e9 in
+    Minibuffer.show minibuffer
+      ~label:"Viewport duration: "
+      ~value:(Time.to_string current)
+      (fun s ->
+         match Time.of_string s with
+         | Ok d ->
+           View.set_duration v (d *. 1e9);
+           redraw ();
+           Minibuffer.hide minibuffer
+         | Error message ->
+           let box =
+             GWindow.message_dialog ()
+               ~message
+               ~parent:window
+               ~buttons:GWindow.Buttons.close
+           in
+           box#connect#response ==> (fun _ -> box#destroy ());
+           box#show ()
+      )
+  in
+
   window#event#connect#key_press ==> (fun ev ->
       let keyval = GdkEvent.Key.keyval ev in
       if keyval = GdkKeysyms._F5 then (
@@ -57,7 +104,20 @@ let create ~title tracefile =
         set_scollbars ();
         redraw ();
         true
-      ) else false
+      ) else if Minibuffer.is_open minibuffer then (
+        if keyval = GdkKeysyms._Escape then (
+          Minibuffer.hide minibuffer;
+          true
+        ) else false
+      ) else (
+        if keyval = GdkKeysyms._s then (
+          show_start ();
+          true
+        ) else if keyval = GdkKeysyms._d then (
+          show_duration ();
+          true
+        ) else false
+      )
     );
 
   area#event#add [`SMOOTH_SCROLL; `BUTTON1_MOTION; `BUTTON_PRESS];
@@ -113,7 +173,7 @@ let create ~title tracefile =
       set_scroll_y vadjustment#value;
       redraw ();
     );
-  
+
   let height =
     int_of_float @@ min
       (float (Gdk.Screen.height ()) *. 0.8)

gtk/minibuffer.ml

@@ -0,0 +1,35 @@
+let ( ==> ) signal callback =
+  ignore (signal ~callback : GtkSignal.id)
+
+type t = {
+  widget : GPack.box;
+  label : GMisc.label;
+  entry : GEdit.entry;
+  mutable action : (string -> unit);
+}
+
+let create ~packing () =
+  let widget = GPack.hbox ()
+      ~packing
+      ~border_width:4
+      ~show:false
+  in
+  let label = GMisc.label ~packing:widget#pack ~text:"?" () in
+  let entry = GEdit.entry ~packing:(widget#pack ~expand:true) () in
+  let t = { widget; label; entry; action = ignore } in
+  entry#connect#activate ==> (fun () -> t.action entry#text);
+  t
+
+let show t ~label ~value action =
+  t.action <- action;
+  t.label#set_text label;
+  t.entry#set_text value;
+  t.widget#misc#show ();
+  t.entry#misc#grab_focus ()
+
+let hide t =
+  t.action <- ignore;
+  t.widget#misc#hide ()
+
+let is_open t =
+  t.widget#misc#visible

gtk/minibuffer.mli

@@ -0,0 +1,11 @@
+type t
+
+val create : packing:(GObj.widget -> unit) -> unit -> t
+
+val show : t -> label:string -> value:string -> (string -> unit) -> unit
+(** [show t ~label ~value action] shows the mini-buffer with the given label and initial value.
+    When the user presses return, [action] is called with the new value. *)
+
+val hide : t -> unit
+
+val is_open : t -> bool

lib/time.ml

@@ -0,0 +1,22 @@
+let of_string s =
+  match
+    Scanf.sscanf_opt s "%f %s" @@ fun v units ->
+    match units with
+    | ""
+    | "s" -> Ok v
+    | "m" -> Ok (v *. 60.)
+    | "ms" -> Ok (v /. 1e3)
+    | "us" -> Ok (v /. 1e6)
+    | "ns" -> Ok (v /. 1e9)
+    | x -> Fmt.error "Unknown time unit %S" x
+  with
+  | None -> Fmt.error "Invalid duration %S" s
+  | Some x -> x
+
+let pp f x =
+  if x >= 1.0 then Fmt.pf f "%gs" x
+  else if x >= 1e-3 then Fmt.pf f "%gms" (x *. 1e3)
+  else if x >= 1e-6 then Fmt.pf f "%gus" (x *. 1e6)
+  else Fmt.pf f "%gns" (x *. 1e9)
+
+let to_string = Fmt.to_to_string pp

lib/view.ml

@@ -42,11 +42,17 @@ let zoom_to t z =
 let zoom t delta =
   zoom_to t (t.zoom +. delta)
 
+let set_duration t duration =
+  let ppns = (t.width -. 2. *. h_margin) /. duration in
+  zoom_to t (log ppns /. log 10.)
+
+let get_duration t =
+  (t.width -. 2. *. h_margin) /. t.pixels_per_ns
+
 let zoom_to_fit ?(start_time=0.0) ?duration t =
   let start_time = min start_time t.layout.duration in
   let duration = Option.value duration ~default:(t.layout.duration -. start_time) in
-  let ppns = (t.width -. 2. *. h_margin) /. duration in
-  zoom_to t (log ppns /. log 10.);
+  set_duration t duration;
   t.start_time <- start_time -. timespan_of_width t h_margin
 
 let max_x_scroll t =

src/main.ml

@@ -4,20 +4,7 @@ let ( $ ) = Term.app
 let ( $$ ) f x = Term.const f $ x
 
 let time =
-  let parse s =
-    Scanf.sscanf_opt s "%f %s" @@ fun v units ->
-    match units with
-    | ""
-    | "s" -> Ok v
-    | "m" -> Ok (v *. 60.)
-    | "ms" -> Ok (v /. 1e3)
-    | "us" -> Ok (v /. 1e6)
-    | "ns" -> Ok (v /. 1e9)
-    | x -> Fmt.error "Unknown time unit %S" x
-  in
-  let parse s = Option.value (parse s) ~default:(Fmt.error "Invalid duration %S" s) in
-  let print f x = Fmt.pf f "%fns" x in
-  Arg.conv' (parse, print)
+  Arg.conv' (Eio_trace.Time.of_string, Eio_trace.Time.pp)
 
 let tracefile =
   let doc = "The path of the trace file." in