colour_level2 pcols level2 in
Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in
+ (* top_total is the total size in bytes of everything. Used for
+ * relative display of percentages, widths, etc.
+ *)
+ let Tree (_, top_total, top_increm, _, _) = tree in
+ assert (top_total = top_increm);
+
+ (* Useful display functions. *)
+ let display_percent bytes =
+ 100. *. Int64.to_float bytes /. Int64.to_float top_total
+
+ and display_size bytes =
+ if bytes > 104_857L then
+ sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.)
+ else if bytes > 102L then
+ sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.)
+ else
+ sprintf "%Ld" bytes
+ in
+
(* Open the window. *)
let title = root ^ " - Fedora RPM dependency size viewer" in
let window =
da#misc#realize ();
let draw = new GDraw.drawable da#misc#window in
+ (* Need to enable these mouse events so we can do tooltips. *)
+ GtkBase.Widget.add_events da#as_widget
+ [`ENTER_NOTIFY; `LEAVE_NOTIFY; `POINTER_MOTION];
+
+ let tooltips = ref None in
+
+ (* To track tooltips, the 'repaint' function records the location of
+ * each box (ie. package) in the drawing area in this private data
+ * structure, and the 'motion' function looks them up in order to
+ * display the right tooltip over each box.
+ *)
+ let add_locn, reset_locns, get_locn =
+ let rows = ref [||] in
+ let rowheight = ref 0. in
+
+ let reset_locns rowheight' depth =
+ (* This data structure sucks because we just do a linear search
+ * over each row when looking up the 'x'. Should use some sort
+ * of self-balancing tree instead. XXX
+ *)
+ rows := Array.init depth (fun _ -> ref []);
+ rowheight := rowheight'
+ and add_locn x yi width thing =
+ let row = (!rows).(yi) in
+ row := ((x, x +. width), thing) :: !row
+ and get_locn x y =
+ let yi = int_of_float (y /. !rowheight) in
+ if yi >= 0 && yi < Array.length !rows then (
+ let row = !((!rows).(yi)) in
+ try Some
+ (snd (List.find (fun ((xlow, xhi), thing) ->
+ xlow <= x && x < xhi)
+ row))
+ with Not_found -> None
+ )
+ else None
+ in
+ add_locn, reset_locns, get_locn
+ in
+
(* Pango contexts used to draw large and small text. *)
let pango_large_context = da#misc#create_pango_context in
pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
(* Calculate the scales so we can fit everything into the window. *)
- let Tree (_, top_total, top_increm, _, _) = tree in
- assert (top_total = top_increm);
let rowheight = float height /. float depth in
- let scale = float width /. Int64.to_float top_increm in
+ let scale = float width /. Int64.to_float top_total in
+
+ reset_locns rowheight depth;
(* Now draw the tree. *)
- let rec draw_tree y x = function
+ let rec draw_tree x yi = function
| Tree (pkg, total, increm, colour, children) ->
(* Draw pkg at (x, y). *)
+ let y = float yi *. rowheight in
let width = scale *. Int64.to_float increm in
let pkgsizewidth = scale *. Int64.to_float pkg.size in
- draw_pkg x y width pkgsizewidth rowheight colour pkg total increm;
+ draw_pkg x yi y width pkgsizewidth rowheight colour pkg total increm;
(* Draw the children of pkg at (i, y + rowheight), where
* i starts as x and increments for each child.
*)
- let y = y +. rowheight in
+ let yi = yi + 1 in
let rec loop x = function
| [] -> ()
| child :: children ->
- draw_tree y x child;
+ draw_tree x yi child;
let Tree (_, _, increm, _, _) = child in
let childwidth = scale *. Int64.to_float increm in
loop (x +. childwidth) children
loop x children
(* Draw a single package. *)
- and draw_pkg x y width pkgsizewidth height colour pkg total increm =
+ and draw_pkg x yi y width pkgsizewidth height colour pkg total increm =
+ add_locn x yi width (colour, pkg, total, increm);
+
let x = int_of_float x in
let y = int_of_float y in
let width = int_of_float width in
* obvious, which it certainly is not:
* http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/120.txt
*)
+ (* txt1 is the same as the tooltip. *)
let txt1 = lazy (
let txt = pango_large_context#create_layout in
Pango.Layout.set_text txt (
| `RGB (r, g, b) ->
`RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
| _ -> `WHITE
+ in
+ draw_tree 0. 0 tree;
- and display_percent bytes =
- 100. *. Int64.to_float bytes /. Int64.to_float top_total
+ (* Return false because this is a Gtk event handler. *)
+ false
+ in
+ ignore (da#event#connect#expose ~callback:repaint);
- and display_size bytes =
- if bytes > 104_857L then
- sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.)
- else if bytes > 102L then
- sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.)
- else
- sprintf "%Ld" bytes
+ let motion ev =
+ let x, y = GdkEvent.Motion.x ev, GdkEvent.Motion.y ev in
+
+ let kill_tooltip () =
+ (match !tooltips with
+ | None -> ()
+ | Some (tt : GData.tooltips) ->
+ tt#set_tip ~text:"" (da :> GObj.widget);
+ tt#disable ()
+ );
+ tooltips := None
in
- draw_tree 0. 0. tree;
+
+ (match get_locn x y with
+ | None ->
+ kill_tooltip ()
+ | Some (colour, pkg, total, increm) ->
+ (* The only way to make the tooltip follow the mouse is to
+ * kill the whole tooltips object and recreate it each time ...
+ *)
+ kill_tooltip ();
+ let tt = GData.tooltips ~delay:100 () in
+ (* Tooltip text is the same as txt1. *)
+ let text = sprintf "%s
+Package: %.1f%% %s (%Ld bytes)
+Incremental: %.1f%% %s (%Ld bytes)
+Total: %.1f%% %s (%Ld bytes)" pkg.nevra
+(display_percent pkg.size) (display_size pkg.size) pkg.size
+(display_percent increm) (display_size increm) increm
+(display_percent total) (display_size total) total in
+ tt#set_tip ~text (da :> GObj.widget);
+ tt#enable ();
+ tooltips := Some tt
+ );
(* Return false because this is a Gtk event handler. *)
false
in
- ignore (da#event#connect#expose ~callback:repaint);
+
+ ignore (da#event#connect#motion_notify ~callback:motion);
window#show ();
GMain.main ()
git.annexia.org / rpmdepsize.git / commitdiff