From 0e837cdf3f0dedf8b9789b79221f0698089c99a1 Mon Sep 17 00:00:00 2001 From: rjones Date: Wed, 25 Mar 2009 23:54:20 +0000 Subject: [PATCH] Tooltips. --- rpmdepsize.ml | 131 +++++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 112 insertions(+), 19 deletions(-) diff --git a/rpmdepsize.ml b/rpmdepsize.ml index 4bc2a42..1fb9458 100644 --- a/rpmdepsize.ml +++ b/rpmdepsize.ml @@ -282,6 +282,25 @@ let () = 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 = @@ -293,6 +312,46 @@ let () = 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"); @@ -307,27 +366,28 @@ let () = 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 @@ -335,7 +395,9 @@ let () = 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 @@ -378,6 +440,7 @@ let () = * 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 ( @@ -500,24 +563,54 @@ Tot: %.1f%% %s" pkg.name | `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 () -- 1.8.3.1