(* rpmdepsize - visualize the size of RPM dependencies
 * (C) Copyright 2009 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * Written by Richard W.M. Jones <rjones@redhat.com>
 * Python script modified from a version by Seth Vidal.
 *)

(* Rename the extlib Std module so it doesn't clash with the
 * sexplib Std module.
 *)
module Extlib_Std = Std

open Sexplib
open Sexplib.Conv
(*TYPE_CONV_PATH "."*)

open ExtList
open Unix
open Printf

(* This corresponds to the sexpr that we write out from the
 * Python code.  OCaml will type-check it.
 *)
type root_packages = nevra * packages
and packages = pkg list
and pkg = {
  nevra : nevra;
  name : string;
  epoch : int;
  version : string;
  release : string;
  arch : string;
  size : int64;				(* installed size, excl. dirs *)
  deps : nevra list;
}
and nevra = string			(* Name-[Epoch:]Version-Release.Arch *)
 with sexp

(* Full dependency representation.  This is actually a graph because
 * it contains dependency loops.  The only difference from the pkg
 * structure is that we have resolved the nevra strings into direct
 * links, so we can quickly recurse over the tree.
 *
 * Parents/deps are mutable only because we want to modify these
 * lists when creating this graph in 'create_deps'.
 *)
type deps = {
  pkg : pkg;			(* the package *)
  mutable children : deps list;	(* dependencies of this package (below) *)
  mutable parents : deps list;	(* parents of this package (above) *)
}

(* Final tree representation, loops removed, and everything we want to
 * display stored in the nodes.
 *)
type tree = Tree of pkg * int64 * int64 * GDraw.color * tree list

(* Helpful modules, operators and functions. *)
module StringMap = Map.Make (String)
let (+^) = Int64.add
let sum = List.fold_left (+^) 0L
let spaces n = String.make n ' '
let failwithf = ksprintf failwith

(* Debugging support (--debug on the command line). *)
let debug_flag = ref false
let debug format =
  (* ifprintf consumes the arguments, but produces no output *)
  (if !debug_flag then eprintf else ifprintf Pervasives.stderr) format

(* Python has privileged access to the yum repodata, so we have to use
 * this Python snippet to pull the data that we need out.  This is the
 * part of the program that takes ages to run, because Python is as
 * slow as a fat snake that's just eaten a huge lunch.  We can't help
 * that.
 * 
 * This function takes a string (package name) and returns a
 * root_packages type.
 *)
let repoquery pkgstr =
  let py = "
import yum
import yum.misc
import sys

yb = yum.YumBase ()

basepkg = yb.pkgSack.returnPackages (patterns=[sys.argv[1]])[0]
deps = dict ({basepkg:False})

# Recursively find all the dependencies.
stable = False
while not stable:
    stable = True
    for pkg in deps.keys():
        if deps[pkg] == False:
            deps[pkg] = []
            stable = False
            for r in pkg.requires:
                ps = yb.whatProvides (r[0], r[1], r[2])
                best = yb._bestPackageFromList (ps.returnPackages ())
                if best.name != pkg.name:
                    deps[pkg].append (best)
                    if not deps.has_key (best):
                        deps[best] = False
            deps[pkg] = yum.misc.unique (deps[pkg])

# Get the data out of python as fast as possible so we can
# use a serious language for analysis of the tree.
print \"(%s (\" % basepkg
for pkg in deps.keys():
    print \"((nevra %s) (name %s) (epoch %s) (version %s) (release %s) (arch %s) (size %s)\" % (pkg, pkg.name, pkg.epoch, pkg.version, pkg.release, pkg.arch, pkg.installedsize)
    print \"(deps (\"
    for p in deps[pkg]:
        print \"%s \" % p,
    print \")))\"
sys.stdout.write (\"))\")  # suppress trailing newline" in

  (* Run the Python program and read in the generated sexpr. *)
  let cmd =
    sprintf "python -c %s %s" (Filename.quote py) (Filename.quote pkgstr) in
  let chan = open_process_in cmd in
  ignore (input_line chan); (* Drop "Loaded plugins" line. *)
  let root, pkgs =
    root_packages_of_sexp (Sexp.of_string (Extlib_Std.input_all chan)) in
  (match close_process_in chan with
   | WEXITED 0 -> ()
   | WEXITED i -> failwithf "python command exited with status %d" i
   | WSIGNALED i | WSTOPPED i ->
       failwithf "python command stopped with signal %d" i
  );

  (root, pkgs)

(* Create the dependency graph from the raw package data.  Probably
 * contains loops so beware.
 *
 * Takes the list of packages (from Python code) and returns a
 * StringMap of nevra -> deps.
 *)
let create_deps pkgs =
  let deps =
    List.map (fun pkg -> { pkg = pkg; children = []; parents = [] }) pkgs in
  let depsmap =
    List.fold_left (
      fun map ({pkg = pkg} as deps) -> StringMap.add pkg.nevra deps map
    ) StringMap.empty deps in
  List.iter (
    fun dep ->
      List.iter (
	fun nevra ->
	  let dep' = StringMap.find nevra depsmap in
	  (* dep.pkg is parent of dep'.pkg *)
	  dep.children <- dep' :: dep.children;
	  dep'.parents <- dep :: dep'.parents
      ) dep.pkg.deps;
  ) deps;
  depsmap

(* For each package, calculate the total installed size of the package,
 * which includes all subpackages pulled in.  So it's what would be
 * installed if you did 'yum install foo'.
 *
 * Takes the list of packages and the dependency map (see 'create_deps')
 * and returns a StringMap of nevra -> total.
 *)
let create_totals pkgs depsmap =
  let total pkg =
    let seen = ref StringMap.empty in
    let rec _total = function
      | { pkg = pkg } when StringMap.mem pkg.nevra !seen -> 0L
      | { pkg = pkg; children = children } ->
	  seen := StringMap.add pkg.nevra true !seen;
	  pkg.size +^ sum (List.map _total children)
    in
    _total (StringMap.find pkg.nevra depsmap)
  in
  let totalsmap =
    List.fold_left (
      fun map pkg -> StringMap.add pkg.nevra (total pkg) map
    ) StringMap.empty pkgs in
  totalsmap

(* Create the final display tree.  Each node is sorted so that
 * children with the largest contribution come first (on the left).
 * We remove packages which are already installed by earlier
 * (leftward) packages.  At each node we also store total size and
 * size of the additional packages.
 *
 * Takes the nevra of the root package, the depsmap (see 'create_deps')
 * and the totalsmap (see 'create_totals'), and returns the display
 * tree and the depth of the tree.
 *)
let create_tree root depsmap totalsmap =
  let tree =
    let seen = StringMap.empty in
    let seen = StringMap.add root true seen in
    let seen = ref seen in
    let mark_seen { pkg = pkg } = seen := StringMap.add pkg.nevra true !seen in
    let not_seen { pkg = pkg } = not (StringMap.mem pkg.nevra !seen) in
    let rec build_tree = function
      | { pkg = pkg; children = children } ->
	  (* Sort children by reverse total size. *)
	  let cmp { pkg = p1 } { pkg = p2 } =
	    let t1 = StringMap.find p1.nevra totalsmap in
	    let t2 = StringMap.find p2.nevra totalsmap in
	    compare t2 t1
	  in
	  let children = List.sort ~cmp children in
	  let children = List.filter not_seen children in
	  List.iter mark_seen children;
	  let children = List.map build_tree children in
	  let total = StringMap.find pkg.nevra totalsmap in
	  let increm =
	    let rec sum_child_sizes = function
	      | Tree (pkg, _, _, _, children) ->
		  List.fold_left (
		    fun size child -> size +^ sum_child_sizes child
		  ) pkg.size children
	    in
	    sum_child_sizes (Tree (pkg, 0L, 0L, `WHITE, children)) in
	  Tree (pkg, total, increm, `WHITE, children)
    in
    build_tree (StringMap.find root depsmap) in

  (* Max depth of the tree. *)
  let depth =
    let rec depth = function
      | Tree (pkg, _, _, _, children) ->
	  List.fold_left (fun d c -> max d (1 + depth c)) 1 children
    in
    depth tree in

  (* Allocate a colour to each node in the tree based on its parent.  The
   * single top node is always light grey.  The second level nodes are
   * primary colours.
   *)
  let tree =
    let Tree (pkg, total, increm, _, level2) = tree in
    let level2 =
      let pcols = [
	`RGB (55000, 0, 0);
	`RGB (0, 55000, 0);
	`RGB (0, 0, 55000);
	`RGB (55000, 55000, 0);
	`RGB (0, 55000, 55000);
      ] in
      let rec colour_level2 cols = function
	| [] -> []
	| Tree (pkg, total, increm, _, level3) :: level2 ->
	    let col, cols = match cols with
	      | [] -> List.hd pcols, List.tl pcols
	      | col :: cols -> col, cols in
	    let level3 = colour_level3 col (List.length level3) 0 level3 in
	    Tree (pkg, total, increm, col, level3)
	    :: colour_level2 cols level2
      and colour_level3 col n i = function
	| [] -> []
	| Tree (pkg, total, increm, _, leveln) :: level3 ->
	    let col = scale_colour col n i in
	    let leveln = colour_level3 col (List.length leveln) 0 leveln in
	    Tree (pkg, total, increm, col, leveln)
	    :: colour_level3 col n (i+1) level3
      and scale_colour col n i =
	let r, g, b = match col with
	  | `RGB (r, g, b) -> float r, float g, float b
	  | _ -> assert false in
	let i = float i and n = float n in
	let scale = 0.8 +. i/.(5.*.n) in
	let r = r *. scale in
	let g = g *. scale in
	let b = b *. scale in
	`RGB (int_of_float r, int_of_float g, int_of_float b)
      in
      colour_level2 pcols level2 in
    Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in

  tree, depth

(* Debugging functions.  These only produce any output if debugging
 * was enabled on the command line.
 *)
let debug_pkgs root pkgs =
  if !debug_flag then (
    List.iter (
      fun pkg ->
	eprintf "%s -> [%s]\n" pkg.nevra (String.concat ", " pkg.deps)
    ) pkgs;
    eprintf "root package is %s\n" root;
    eprintf "===\n%!"
  )

let debug_deps root depsmap =
  if !debug_flag then (
    let seen = ref StringMap.empty in
    let rec display ?(indent=0) = function
      | { pkg = pkg; children = children; parents = parents } ->
	  if StringMap.mem pkg.nevra !seen then
	    eprintf "%s%s -> ...\n" (spaces indent) pkg.nevra
	  else (
	    eprintf "%s%s ->\n%sparents:[%s]\n"
	      (spaces indent) pkg.nevra (spaces (indent+2)) (
		String.concat ", "
		  (List.map (fun { pkg = pkg } -> pkg.nevra) parents)
	      );
	    seen := StringMap.add pkg.nevra true !seen;
	    List.iter (display ~indent:(indent+2)) children
	  )
    in
    display (StringMap.find root depsmap);
    eprintf "===\n%!"
  )

let debug_tree tree =
  if !debug_flag then (
    let rec display ?(indent=0) = function
      | Tree (pkg, total, increm, _, children) ->
	  eprintf "%s%s %Ld/%Ld/%Ld\n%!"
	    (spaces indent) pkg.nevra pkg.size increm total;
	  List.iter (display ~indent:(indent+2)) children
    in
    display tree;
  )

(* Useful display functions. *)
let display_percent bytes top_total =
  100. *. Int64.to_float bytes /. Int64.to_float top_total

let 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

(* Defer a function callback until Gtk rendering has been done. *)
let defer ?(ms=10) f = 
  ignore (GMain.Timeout.add ~ms ~callback:(fun () -> f (); false))

(* Open the toplevel window.  The 'pkgstr' parameter is the optional
 * name of the package to open.  If None then we open a blank window.
 *)
let open_window pkgstr =
  (* Open the window. *)
  let base_title = "Fedora RPM dependency size viewer" in
  let window =
    GWindow.window ~width:800 ~height:600
      ~title:base_title ~allow_shrink:true () in

  let vbox = GPack.vbox ~packing:window#add () in

  (* Menu bar. *)
  let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  let factory = new GMenu.factory menubar in
  let accel_group = factory#accel_group in
  let package_menu = factory#add_submenu "_Package" in
  let help_menu = factory#add_submenu "_Help" in

  let factory = new GMenu.factory package_menu ~accel_group in
  let open_item = factory#add_item "_Open package ..." ~key:GdkKeysyms._O in
  let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in

  let factory = new GMenu.factory help_menu ~accel_group in
  let about_item = factory#add_item "About" in

  (* Events for the menu bar. *)
  ignore (window#connect#destroy ~callback:GMain.quit);
  ignore (quit_item#connect#activate ~callback:GMain.quit);

  ignore (about_item#connect#activate ~callback:Rpmdepsize_about.callback);

  let da = GMisc.drawing_area
    ~packing:(vbox#pack ~expand:true ~fill:true) () in
  da#misc#realize ();
  let draw = new GDraw.drawable da#misc#window in

  window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);

  (* Force a repaint of the drawing area. *)
  let drawing_area_repaint () =
    GtkBase.Widget.queue_draw da#as_widget
  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");
  let pango_small_context = da#misc#create_pango_context in
  pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");

  (* This is the currently open package, or None if nothing has
   * opened by the user yet.
   *)
  let opened = ref None in

  (* If we are moused-over a particular package, then this is != None. *)
  let current = ref None in
  let set_current new_current =
    let old_current = !current in
    current := new_current;
    (* Because this structure contains loops, we can't use
     * structural comparisons like: = <> compare.
     *)
    let do_repaint =
      match old_current, new_current with
      | None, Some _ -> true
      | Some _, None -> true
      | Some { pkg = { nevra = n1 } }, Some { pkg = { nevra = n2 } } ->
	  n1 <> n2
      | _ -> false in
    if do_repaint then drawing_area_repaint ()
  in

  (* Called from the "Open package" menu entry and other places. *)
  let open_package pkgstr =
    debug "open_package %s\n%!" pkgstr;

    (* XXX Can't be bothered to do this "properly" (ie with threads etc)
     * so just put a loading message in the middle of the drawing area.
     *)
    let width, height = draw#size in
    let txt = pango_large_context#create_layout in
    Pango.Layout.set_text txt (sprintf "Loading %s ..." pkgstr);
    let { Pango.width = txtwidth; Pango.height = txtheight } =
      Pango.Layout.get_pixel_extent txt in
    let x = (width - txtwidth) / 2 and y = (height - txtheight) / 2 in
    draw#set_foreground (`RGB (0, 0, 65535));
    draw#rectangle ~x:(x-4) ~y:(y-2)
      ~width:(txtwidth+8) ~height:(txtheight+8) ~filled:true ();
    draw#put_layout ~x ~y ~fore:`WHITE txt;

    defer (
      fun () ->
	let root, pkgs = repoquery pkgstr in
	debug_pkgs root pkgs;
	let depsmap = create_deps pkgs in
	debug_deps root depsmap;
	let totalsmap = create_totals pkgs depsmap in
	let tree, depth = create_tree root depsmap totalsmap in
	debug_tree tree;

	(* 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);

	opened :=
	  Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total);
	set_current None;

	(* Update the window title. *)
	window#set_title (pkgstr ^ " - " ^ base_title);

	drawing_area_repaint ()
    )
  in

  (* If the user selected something on the command line (pkgstr !=
   * None) then set up an idle event to populate 'opened' as soon as
   * the window gets drawn on the screen.
   *)
  (match pkgstr with
   | None -> ()
   | Some pkgstr ->
       defer ~ms:50 (fun () -> open_package pkgstr)
  );

  let callback _ =
    let dlg =
      GWindow.dialog ~parent:window ~modal:true
	~position:`CENTER_ON_PARENT ~title:"Open package" () in
    dlg#add_button "Open package" `OPEN;
    dlg#add_button "Cancel" `CANCEL;
    let vbox = dlg#vbox in
    let hbox = GPack.hbox ~packing:vbox#pack () in
    ignore (GMisc.label ~text:"Package:" ~packing:hbox#pack ());
    let entry = GEdit.entry
      ~width_chars:40 ~packing:(hbox#pack ~expand:true ~fill:true) () in
    ignore (GMisc.label ~text:"Enter a package name, wildcard or path."
	      ~packing:vbox#pack ());
    dlg#show ();
    match dlg#run () with
    | `CANCEL | `DELETE_EVENT ->
	dlg#destroy ()
    | `OPEN ->
	let pkgstr = entry#text in
	dlg#destroy ();
	if pkgstr <> "" then
	  defer (fun () -> open_package pkgstr)
  in
  ignore (open_item#connect#activate ~callback);

  (* 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

  let rec real_repaint root pkgs depsmap totalsmap tree depth top_total =
    (* Get the canvas size and fill the background with white. *)
    let width, height = draw#size in
    draw#set_background `WHITE;
    draw#set_foreground `WHITE;
    draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();

    (* Calculate the scales so we can fit everything into the window. *)
    let rowheight = float height /. float depth in
    let scale = float width /. Int64.to_float top_total in

    reset_locns rowheight depth;

    (* Now draw the tree. *)
    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 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 yi = yi + 1 in
	  let rec loop x = function
	    | [] -> ()
	    | child :: children ->
		draw_tree x yi child;
		let Tree (_, _, increm, _, _) = child in
		let childwidth = scale *. Int64.to_float increm in
		loop (x +. childwidth) children
	  in
	  loop x children

    (* Draw a single package. *)
    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
      let pkgsizewidth = int_of_float pkgsizewidth in
      let height = int_of_float height in

      if width > 8 then (
	draw_pkg_outline x y width pkgsizewidth height colour pkg;
	draw_pkg_label x y width height colour pkg total increm
      )
      else if width >= 4 then
	draw_pkg_narrow x y width height colour pkg
	  (* else
	     XXX This doesn't work.  We need to coalesce small packages
	     in the tree.
	     draw_pkg_narrow x y 1 height colour *)

    and draw_pkg_outline x y width pkgsizewidth height colour pkg =
      let body_colour = choose_colour colour pkg in
      draw#set_foreground body_colour;
      draw#rectangle ~x:(x+2) ~y:(y+2)
	~width:(width-4) ~height:(height-4)
	~filled:true ();
      if pkgsizewidth > 2 then (
	draw#set_foreground (darken body_colour);
	draw#rectangle ~x:(x+2) ~y:(y+2)
	  ~width:(pkgsizewidth-2) ~height:(height-4)
	  ~filled:true ();
	draw#set_foreground (choose_contrasting_colour body_colour);
	draw#set_line_attributes ~style:`ON_OFF_DASH ();
	draw#line (x+pkgsizewidth) (y+2) (x+pkgsizewidth) (y+height-2);
	draw#set_line_attributes ~style:`SOLID ()
      );
      draw#set_foreground `BLACK;
      draw#rectangle ~x:(x+2) ~y:(y+2)
	~width:(width-4) ~height:(height-4)
	~filled:false ()

    and draw_pkg_label x y width height colour pkg total increm =
      (* How to write text in a drawing area, in case it's not
       * 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 (
	  sprintf "%s
Package: %.1f%% %s (%Ld bytes)
Incremental: %.1f%% %s (%Ld bytes)
Total: %.1f%% %s (%Ld bytes)" pkg.nevra
	    (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
	    (display_percent increm top_total) (display_size increm) increm
	    (display_percent total top_total) (display_size total) total
	);
	txt
      )
      and txt2 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s
Package: %.1f%% %s (%Ld bytes)
Incremental: %.1f%% %s (%Ld bytes)
Total: %.1f%% %s (%Ld bytes)" pkg.nevra
	    (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
	    (display_percent increm top_total) (display_size increm) increm
	    (display_percent total top_total) (display_size total) total
	);
	txt
      )
      and txt3 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s
Pkg: %.1f%% %s (%Ld bytes)
Incr: %.1f%% %s (%Ld bytes)
Tot: %.1f%% %s (%Ld bytes)" pkg.name
	    (display_percent pkg.size top_total) (display_size pkg.size) pkg.size
	    (display_percent increm top_total) (display_size increm) increm
	    (display_percent total top_total) (display_size total) total
	);
	txt
      )
      and txt4 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s
Pkg: %.1f%% %s
Incr: %.1f%% %s
Tot: %.1f%% %s" pkg.name
	    (display_percent pkg.size top_total) (display_size pkg.size)
	    (display_percent increm top_total) (display_size increm)
	    (display_percent total top_total) (display_size total)
	);
	txt
      )
      and txt5 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%"
	    pkg.name
	    (display_percent pkg.size top_total)
	    (display_percent increm top_total)
	    (display_percent total top_total)
	);
	txt
      )
      and txt6 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name
	    (display_percent pkg.size top_total) (display_size pkg.size)
	    (display_percent increm top_total) (display_size increm)
	    (display_percent total top_total) (display_size total)
	);
	txt
      )
      and txt7 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name
	    (display_percent pkg.size top_total)
	    (display_percent increm top_total)
	    (display_percent total top_total)
	);
	txt
      )
      and txt8 = lazy (
	let txt = pango_small_context#create_layout in
	Pango.Layout.set_text txt (
	  sprintf "%s" pkg.name
	);
	txt
      ) in
      let txts = [ txt1; txt2; txt3; txt4; txt5; txt6; txt7; txt8 ] in

      let fore = choose_contrasting_colour colour in

      let rec loop = function
	| [] -> ()
	| txt :: txts ->
	    let txt = Lazy.force txt in
	    let { Pango.width = txtwidth;
		  Pango.height = txtheight } =
	      Pango.Layout.get_pixel_extent txt in
	    (* Now with added fudge-factor. *)
	    if width >= txtwidth + 8 && height >= txtheight + 8 then
	      draw#put_layout ~x:(x+4) ~y:(y+4) ~fore txt
	    else loop txts
      in
      loop txts

    and draw_pkg_narrow x y width height colour pkg =
      draw#set_foreground (choose_colour colour pkg);
      draw#rectangle ~x:(x+2) ~y:(y+2)
	~width:(width-4) ~height:(height-4) ~filled:true ()

    and choose_contrasting_colour = function
      | `RGB (r, g, b) ->
	  if r + g + b > 98304 then `BLACK else `WHITE
      | _ -> `WHITE

    and choose_colour colour pkg =
      match !current with
      | None -> colour
      | Some current ->
	  let nevra = pkg.nevra in
	  let is_parent =
	    List.exists
	      (fun { pkg = { nevra = n } } -> n = nevra) current.parents in
	  let is_child =
	    List.exists
	      (fun { pkg = { nevra = n } } -> n = nevra) current.children in
	  if is_parent && is_child then `RGB (63000, 63000, 0) (* yellow *)
	  else if is_parent then `RGB (0, 63000, 63000) (* cyan *)
	  else if is_child then `RGB (0, 63000, 0) (* green *)
	  else colour

    and darken = function
      | `RGB (r, g, b) ->
	  `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
      | _ -> `WHITE
    in
    draw_tree 0. 0 tree

  and repaint _ =
    (match !opened with
     | None -> ()
     | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
	 real_repaint root pkgs depsmap totalsmap tree depth top_total
    );

    (* Return false because this is a Gtk event handler. *)
    false
  in
  ignore (da#event#connect#expose ~callback:repaint);

  let rec real_motion root pkgs depsmap totalsmap tree depth top_total 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

    (match get_locn x y with
     | None ->
	 set_current None;
	 kill_tooltip ()
     | Some (colour, pkg, total, increm) ->
	 (* Update 'current' which points to the currently moused package. *)
	 let dep = StringMap.find pkg.nevra depsmap in
	 set_current (Some dep);

	 let deps_of_string deps =
	   String.concat "\n  "
	     (List.sort (List.map (fun d -> d.pkg.nevra) deps))
	 in

	 (* 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 + extra. *)
	 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 top_total) (display_size pkg.size) pkg.size
           (display_percent increm top_total) (display_size increm) increm
           (display_percent total top_total) (display_size total) total in
	 let text = if dep.parents = [] then text else text ^ sprintf "
Required by (blue):
  %s"
           (deps_of_string dep.parents) in
	 let text = if dep.children = [] then text else text ^ sprintf "
Requires (green):
  %s"
           (deps_of_string dep.children) in
	 tt#set_tip ~text (da :> GObj.widget);
	 tt#enable ();
	 tooltips := Some tt
    )

  and motion ev =
    (match !opened with
     | None -> ()
     | Some (root, pkgs, depsmap, totalsmap, tree, depth, top_total) ->
	 real_motion root pkgs depsmap totalsmap tree depth top_total ev
    );

    (* Return false because this is a Gtk event handler. *)
    false
  in
  ignore (da#event#connect#motion_notify ~callback:motion);

  window#add_accel_group accel_group;
  window#show ();
  GMain.main ()

(* Main program. *)
let () =
  (* Parse the command line arguments. *)
  let anon_args = ref [] in

  let argspec = Arg.align [
    "--debug", Arg.Set debug_flag,
    " " ^ "Enable debugging messages on stderr";
  ] in
  let anon_fun str = anon_args := str :: !anon_args in
  let usage_msg =
    "rpmdepsize [package] : visualize the size of RPM dependencies" in

  Arg.parse argspec anon_fun usage_msg;

  (* Should be at most one anonymous argument. *)
  let pkgstr =
    match !anon_args with
    | [] -> None
    | [p] -> Some p
    | _ ->
	eprintf "rpmdepsize: too many command line arguments";
	exit 1 in

  (* Open the main window. *)
  open_window pkgstr