Below is the file 'view.ml' from this revision. You can also download the file.

open Viz_misc
open Viz_types
open Revision_types


let utf8ize =
  let fallback = "<binary data>" in
  let (is_utf8, _) = Glib.Convert.get_charset () in
  if not is_utf8
  then fun s ->
    try Glib.Convert.locale_to_utf8 s
    with Glib.Convert.Error _ -> fallback
  else fun s ->
    (if Glib.Utf8.validate s then s else fallback)

let wrap_in_scroll_window packing =
  let sw = GBin.scrolled_window
      ~hpolicy:`AUTOMATIC
      ~vpolicy:`AUTOMATIC ~packing () in
  sw#add

let error_notice ~parent message =
  let parent = GWindow.toplevel parent in
  let d = GWindow.message_dialog
      ~message ~message_type:`ERROR
      ~buttons:GWindow.Buttons.close
      ?parent ~destroy_with_parent:true ~show:true () in
  ignore (d#connect#response (fun _ -> d#destroy ()))

let error_notice_f ~parent fmt =
  Printf.kprintf (error_notice ~parent) fmt




type info_display = {
    revision_label  : GMisc.label ;
    empty_label     : string ;

    revision_c_type : GtkStock.id GTree.column ;
    revision_c_file : string GTree.column ;
    revision_model  : GTree.tree_store ;
    revision_view   : GTree.view ;

    cert_c_name     : string GTree.column ;
    cert_c_value    : string GTree.column ;
    cert_c_signer   : string GTree.column ;
    cert_c_sig      : sig_verif GTree.column ;
    cert_model      : GTree.list_store ;
    cert_view       : GTree.view ;
  }

type branch_selector = {
    combo : GEdit.combo_box GEdit.text_combo ;
    mutable combo_signal : GtkSignal.id option ;
    mutable branches : string array ;
    select_signal : Viz_types.query Signal.t ;
  }

type event = [
    `CLEAR
  | `OPEN_DB
  | `CLOSE_DB
  | `UPDATE_BEGIN
  | `UPDATE_END
  | `NODE_SELECT of string
  | `NODE_POPUP of string * int
  | `NODE_SWITCH_BRANCH of string]

type canvas = {
    w : GnoCanvas.canvas ;
    mutable ppu : float ;
    mutable branch_items : GnoCanvas.group option ;
    mutable text_items : GnoCanvas.text list ;
    selected_marker : GnoCanvas.rect ;
    mutable background_rendering : Glib.Idle.id option ;
  }

type keyboard_nav = {
    mutable previous_selected_node : string option ;
    mutable keyboard_nav_siblings : (string * Viz_types.c_node) list ;
  }

type find = {
    mutable last_find : string * (string * Viz_types.c_node) list ;
    find_signal : string Signal.t ;
    find_entry  : GEdit.entry ;
  }

type t = {
    info : info_display ;
    selector : branch_selector ;
    canvas : canvas ;
    keyboard_nav : keyboard_nav ;
    find : find ;
    mutable prefs : Viz_style.prefs ;
    mutable db    : Database.t option ;
    mutable agraph : Agraph.t option ;
    event_signal : event Signal.t ;
    mutable selected_node : string option ;
    status_reporter : Status.reporter Lazy.t ;
  }

let get_cnodes v =
  (Agraph.get_layout (some v.agraph)).c_nodes

let get_cnode v id =
  NodeMap.find id (get_cnodes v)








module Info_Display = struct
  let sig_verif_conv =
    let warning = GtkStock.convert_id `DIALOG_WARNING in
    let error = GtkStock.convert_id `DIALOG_ERROR in
    { Gobject.kind = `STRING ;
      Gobject.proj = (fun _ -> assert false) ;
      Gobject.inj = (function
	| SIG_OK      -> `STRING None
	| SIG_UNKNOWN -> `STRING (Some warning)
	| SIG_BAD     -> `STRING (Some error) )
    }

  let initial_height = 175

  let make ~packing =
    let pane = GPack.paned `HORIZONTAL ~packing () in

    let box = GPack.vbox ~spacing:4 ~height:initial_height
	~packing:(pane#pack1 ~resize:true ~shrink:true) () in
    let label = GMisc.label ~xalign:0. ~packing:box#pack () in
    label#set_use_markup true ;
    label#set_selectable true ;
    let empty_label = Printf.sprintf "<tt>%50s</tt>" " " in
    label#set_label empty_label ;


    let rev_columns = new GTree.column_list in
    let c_type = rev_columns#add GtkStock.conv in
    let c_file = rev_columns#add Gobject.Data.string in

    let revision_model = GTree.tree_store rev_columns in

    let revision_view =
      let view = GTree.view
	  ~width:250 ~height:initial_height
	  ~model:revision_model
	  ~headers_visible:false
	  ~packing:(wrap_in_scroll_window (pane#pack2 ~shrink:true)) () in
      let column = GTree.view_column () in
      let r = GTree.cell_renderer_pixbuf [ `STOCK_SIZE `MENU ] in
      column#pack r ;
      column#add_attribute r "stock-id" c_type ;
      ignore (view#append_column column) ;
      let column = GTree.view_column () in
      let r = GTree.cell_renderer_text [] in
      column#pack r ;
      column#add_attribute r "text" c_file ;
      ignore (view#append_column column) ;
      view#set_expander_column (Some column) ;
      view in

    let cert_columns = new GTree.column_list in
    let c_name  = cert_columns#add Gobject.Data.string in
    let c_value = cert_columns#add Gobject.Data.string in
    let c_signer = cert_columns#add Gobject.Data.string in
    let c_sig = cert_columns#add sig_verif_conv in

    let cert_model = GTree.list_store cert_columns in
    cert_model#set_sort_func 0
      (fun model row_a row_b ->
	let a = model#get ~row:row_a ~column:c_name in
	let b = model#get ~row:row_b ~column:c_name in
	let c_a = a = "Changelog:" in
	let c_b = b = "Changelog:" in
	if c_a && c_b then 0 else
	if c_a then 1 else
	if c_b then -1 else
	compare a b) ;
    cert_model#set_sort_column_id 0 `ASCENDING ;

    let cert_view =
      let view = GTree.view ~packing:(wrap_in_scroll_window (box#pack ~expand:true)) () in
      begin
	let column = GTree.view_column ~title:"S" () in
	let r = GTree.cell_renderer_pixbuf [ `STOCK_SIZE `MENU ; `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "stock-id" c_sig ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Cert Name" () in
	let r = GTree.cell_renderer_text [ `WEIGHT `BOLD ; `XALIGN 1.; `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "markup" c_name ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Cert Value" () in
	let r = GTree.cell_renderer_text [] in
	column#pack r ;
	column#add_attribute r "text" c_value ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Signed by" () in
	let r = GTree.cell_renderer_text [ `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "text" c_signer ;
	ignore (view#append_column column)
      end ;
      view in
    {
     revision_label  = label ;
     empty_label     = empty_label ;
     revision_c_type = c_type ;
     revision_c_file = c_file ;
     revision_model  = revision_model ;
     revision_view   = revision_view ;
     cert_c_name     = c_name ;
     cert_c_value    = c_value ;
     cert_c_signer   = c_signer ;
     cert_c_sig      = c_sig ;
     cert_model      = cert_model ;
     cert_view       = cert_view ;
    }

  let clear_info { info = i } =
    i.revision_label#set_label i.empty_label ;
    i.revision_model#clear () ;
    i.cert_model#clear ()

  let stock_of_delta_type = function
    | PATCH _ -> None
    | ADD_FILE _ -> Some `ADD
    | DELETE_FILE _
    | DELETE_DIR _ -> Some `REMOVE
    | RENAME_FILE _
    | RENAME_DIR _ -> Some `CONVERT

  let text_of_delta_type = function
    | PATCH (f, "", _)
    | PATCH (f, _, "") -> ""
    | PATCH (f, _, _) -> f
    | ADD_FILE f
    | DELETE_FILE f -> f
    | DELETE_DIR f -> f ^ "/"
    | RENAME_FILE (o, n) -> Printf.sprintf "%s -> %s"   o n
    | RENAME_DIR  (o, n) -> Printf.sprintf "%s/ -> %s/" o n

  let display_info i data =
    (* Set the revision id and manifest id labels *)
    i.revision_label#set_label
      (Printf.sprintf "<tt><b>Revision:</b> %s\n<b>Manifest:</b> %s</tt>"
	 data.revision_id data.manifest_id) ;

    (* Fill the revision set view *)
    begin
      i.revision_view#set_model None ;
      let m = i.revision_model in
      m#clear () ;
      List.iter
	(fun (old_revision, change_set) ->
	  let parent as row = m#append () in
	  m#set ~row ~column:i.revision_c_file ("on " ^ old_revision) ;
	  List.iter
	    (fun change ->
	      let text = text_of_delta_type change in
	      if text <> "" then
		let row = m#append ~parent () in
		may
		  (m#set ~row ~column:i.revision_c_type)
		  (stock_of_delta_type change) ;
		m#set ~row ~column:i.revision_c_file (utf8ize text))
	    change_set)
	data.revision_set ;
      i.revision_view#set_model (Some i.revision_model#coerce) ;
      i.revision_view#expand_all ()
    end ;

    (* Fill the certs view *)
    begin
      i.cert_view#set_model None ;
      let m = i.cert_model in
      m#clear () ;
      List.iter
	(fun c ->
	  let row = m#append () in
	  let c_disp = String.capitalize c.c_name ^ ":" in
	  m#set ~row ~column:i.cert_c_name c_disp ;
	  m#set ~row ~column:i.cert_c_value (utf8ize c.c_value) ;
	  m#set ~row ~column:i.cert_c_signer c.c_signer_id ;
	  m#set ~row ~column:i.cert_c_sig c.c_signature)
	data.certs ;
      i.cert_view#set_model (Some i.cert_model#coerce)
    end

  let failed_node_data = {
    revision_id = "???" ;
    manifest_id = "???" ;
    revision_set = [] ;
    certs = [] ;
  }

  let fetch_and_display_data v id =
    display_info v.info
      begin
	try Database.fetch_certs_and_revision (some v.db) id
	with Viz_types.Error msg ->
	  error_notice ~parent:v.info.revision_label msg ;
	  failed_node_data
      end
end




module Branch_selector = struct
  let select_branch s =
    let (combo, _) = s.combo in
    try
      Signal.emit s.select_signal
	begin
	  match combo#active with
	  | -1 -> raise Exit
	  | 0 -> ALL
	  | i -> BRANCH s.branches.(i - 1)
	end
    with Exit -> ()

  let with_inactive_combo ({ combo = (combo, _) } as s) f =
    let id = some s.combo_signal in
    GtkSignal.handler_block combo#as_widget id ;
    f s.combo ;
    GtkSignal.handler_unblock combo#as_widget id

  let make ~packing =
    let hb = GPack.hbox ~border_width:4 ~packing () in
    let combo =
      ignore (GMisc.label ~text:"Branch: " ~packing:hb#pack ()) ;
      let (model, column) as store = GTree.store_of_list Gobject.Data.string [] in
      let combo = GEdit.combo_box ~model ~packing:hb#pack () in
      let r = GTree.cell_renderer_text [] in
      combo#pack r ;
      combo#add_attribute r "markup" column ;
      (combo, store) in
    let entry = GEdit.entry ~packing:(hb#pack ~from:`END) () in
    begin
      let tooltips = GData.tooltips () in
      tooltips#set_tip
	~text:"Find a node by its revision id or tag"
	entry#coerce
    end ;
    let lbl = GMisc.label ~text:"Find:" ~packing:(hb#pack ~from:`END) () in
    let c =
      { combo = combo ; combo_signal = None ;
	branches = [||] ;
	select_signal = Signal.make () } in
    begin
      let callback () = select_branch c in
      let (combo, _) = combo in
      c.combo_signal <- Some (combo#connect#changed ~callback)
    end ;
    let f = { last_find = "", [] ; find_signal = Signal.make () ; find_entry = entry } in
    ignore (entry#connect#activate (fun () ->
      Signal.emit f.find_signal entry#text)) ;
    (c, f)

  let connect v f =
    Signal.connect v.selector.select_signal f

  let clear { selector = s } =
    s.branches <- [||] ;
    with_inactive_combo s
      (fun (_, (model, _)) -> model#clear ())

  let populate { selector = s } br =
    with_inactive_combo s
      (fun (combo, (model, column)) ->
	s.branches <- Array.of_list br ;
	begin
	  let row = model#append () in
	  model#set ~row ~column "<i>HEAD</i>"
	end ;
	List.iter
	  (fun b ->
	    let row = model#append () in
	    model#set ~row ~column (Glib.Markup.escape_text (utf8ize b)))
	  br)

  let set_branch { selector = s } b =
    let (combo, _) = s.combo in
    combo#set_active
      begin
	match b with
	| None -> 0
	| Some b ->
	    try 1 + array_index s.branches b
	    with Not_found ->
	      error_notice_f ~parent:(fst s.combo) "Could not find the branch '%s'" b ;
	      -1
      end

  let get_branch { selector = s } =
    let (combo, _) = s.combo in
    match combo#active with
    | i when i > 0 -> Some s.branches.(i - 1)
    | _ -> None
end



module KeyNav = struct

  let top_down_dir =
    [ GdkKeysyms._Up,    `PARENT ;
      GdkKeysyms._Down,  `CHILD ;
      GdkKeysyms._Left,  `PREV ;
      GdkKeysyms._Right, `NEXT ;
      GdkKeysyms._BackSpace, `LAST ; ]

  let left_right_dir =
    [ GdkKeysyms._Up,    `NEXT ;
      GdkKeysyms._Down,  `PREV ;
      GdkKeysyms._Left,  `PARENT ;
      GdkKeysyms._Right, `CHILD ;
      GdkKeysyms._BackSpace, `LAST ; ]

  let nav_dir lr_layout k =
    List.assoc
      (GdkEvent.Key.keyval k)
      (if lr_layout then left_right_dir else top_down_dir)

  let navigate_is_sibling k id =
    List.exists (fun (i, _) -> i = id) k.keyboard_nav_siblings

  let navigate_choose k current_id direction =
    match k.keyboard_nav_siblings with
    | [] -> None
    | [ n ] -> Some n
    | sx ->
	let rec locate = function
	  | (id, x) :: ((_, y) as n) :: _ when id = current_id && x != y -> Some n
	  | _ :: tl -> locate tl
	  | [] -> None in
	match direction with
	| `NEXT -> locate sx
	| `PREV -> locate (List.rev sx)
	| `PARENT | `CHILD ->
	    match k.previous_selected_node with
	    | None -> Some (List.hd sx)
	    | Some p_id ->
		try Some (List.find (fun (id, _) -> id = p_id) sx)
		with Not_found -> Some (List.hd sx)

  let navigate v key =
    let id = some v.selected_node in
    let graph = some v.agraph in
    let k = v.keyboard_nav in
    match nav_dir v.prefs.Viz_style.lr_layout key with
    | `LAST ->
	maybe
	  (fun id ->
	    if not (navigate_is_sibling k id)
	    then k.keyboard_nav_siblings <- [] ;
	    id, NodeMap.find id (Agraph.get_layout graph).c_nodes)
	  k.previous_selected_node
    | (`NEXT | `PREV) as d when k.keyboard_nav_siblings <> [] ->
	navigate_choose k id d
    | #Viz_types.direction as d ->
	let cnodes =
	  match d with
	  | `PARENT ->
	      Agraph.get_parents  graph id
	  | `CHILD ->
	      Agraph.get_children graph id
	  | `NEXT | `PREV ->
	      Agraph.get_siblings graph id in
	k.keyboard_nav_siblings <- cnodes ;
	navigate_choose k id d

  let select { keyboard_nav = k } id =
    if not (navigate_is_sibling k id)
    then k.keyboard_nav_siblings <- []

  let clear { keyboard_nav = k } =
    k.previous_selected_node <- None ;
    k.keyboard_nav_siblings <- []

end


module Canvas = struct

  external pango_fix : unit -> unit = "ml_fix_libgnomecanvas_pango"
  let _ = pango_fix ()

  let set_busy_cursor =
    let busy_cursor = Gdk.Cursor.create `WATCH in
    let normal_cursor = Gdk.Cursor.create `LEFT_PTR in
    fun canvas busy ->
      Gdk.Window.set_cursor canvas.w#misc#window
	(if busy then busy_cursor else normal_cursor)

  let make ~aa ~packing =
    let sw = GBin.scrolled_window ~width:700 ~height:400 ~packing () in
    let canvas = GnoCanvas.canvas ~aa ~packing:sw#add () in
    let selection_rect = GnoCanvas.rect ~fill_color:"tomato" canvas#root in
    selection_rect#hide () ;
    { w = canvas ;
      ppu = 1. ;
      branch_items = None ;
      text_items = [] ;
      selected_marker = selection_rect ;
      background_rendering = None ;
    }

  let get_string_font_descr v =
    v.prefs.Viz_style.font

  let get_pango_font_descr v =
    Pango.Font.from_string (get_string_font_descr v)

  let get_font_size font =
    let s = float (Pango.Font.get_size (Pango.Font.from_string font)) /. float Pango.scale in
    if Viz_misc.debug "font"
    then Printf.eprintf "### font: '%s' font_size: %f\n%!" font s ;
    s

  let get_font_metrics v =
    let desc = get_pango_font_descr v in
    v.canvas.w#misc#pango_context#get_metrics ~desc ()

  let zoom ({ canvas = canv } as v) dir () =
      let old_ppu = canv.ppu in
      begin
	match dir with
	| `IN  -> canv.ppu <- canv.ppu *. sqrt 2.
	| `OUT -> canv.ppu <- canv.ppu /. sqrt 2.
      end ;
      canv.w#set_pixels_per_unit canv.ppu ;
      let font_size = get_font_size (get_string_font_descr v) in
      if debug "zoom"
      then Printf.eprintf "### zoom: ppu = %f, font_size = %f\n%!" canv.ppu (canv.ppu *. font_size) ;
      let new_size = canv.ppu *. font_size in
      List.iter
	(fun t ->
	  if new_size >= 3.0
	  then begin
	    t#set [ `SIZE_POINTS new_size ] ;
	    t#show () end
	  else
	    (* disable label when zooming out a lot: it's unreadable anyway *)
	    t#hide ())
	canv.text_items

  let display_selection_marker v id =
    let node_data = get_cnode v id in
    begin
      let sel = Some id in
      if v.selected_node <> sel then begin
	v.keyboard_nav.previous_selected_node <- v.selected_node ;
	v.selected_node <- sel end
    end ;
    let x1 = node_data.n_x -. node_data.n_w /. 2. -. 5. in
    let y1 = node_data.n_y -. node_data.n_h /. 2. -. 5. in
    let x2 = node_data.n_x +. node_data.n_w /. 2. +. 5. in
    let y2 = node_data.n_y +. node_data.n_h /. 2. +. 5. in
    let marker = v.canvas.selected_marker in
    marker#set [ `X1 x1; `X2 x2; `Y1 y1; `Y2 y2 ] ;
    marker#lower_to_bottom () ;
    marker#show ()

  let clear ({ canvas = c } as v) =
    may (fun g -> g#destroy ()) c.branch_items ;
    c.branch_items <- None ;
    c.text_items <- [] ;
    c.selected_marker#hide () ;
    may
      (fun id ->
	Glib.Idle.remove id ;
	c.background_rendering <- None ;
	(Lazy.force v.status_reporter)#progress_end () ;
	set_busy_cursor c false)
      c.background_rendering ;
    Signal.emit v.event_signal `CLEAR

  let id_width = 8

  let id_size c =
    let metrics = get_font_metrics c in
    let char_width = GPango.to_pixels metrics#approx_char_width in
    let ascent = GPango.to_pixels metrics#ascent in
    let descent = GPango.to_pixels metrics#descent in
    let (w, h) as s =
      ((id_width + 4) * char_width,
       (ascent + descent) * 2) in
    if Viz_misc.debug "font"
    then Printf.eprintf "### font: width = %d, height = %d\n%!" w h ;
    s

  let scroll view view_width target target_width =
    let a = target -. target_width /. 2. -. 10. in
    let b = target +. target_width /. 2. +. 10. in
    int_of_float begin
      if a < view then a (* scroll *) else
      if b < view +. view_width then view (* don't move *) else
      b -. view_width (* scroll in other direction *)
    end

  (* it does not really "center", it just brings the node into the view *)
  let center_on ({ canvas = c } as v) (id, n) =
    let c_x, c_y = c.w#w2c ~wx:n.n_x ~wy:n.n_y in
    let x =
      let a = c.w#hadjustment in
      scroll a#value a#page_size (float c_x) n.n_w in
    let y =
      let a = c.w#vadjustment in
      scroll a#value a#page_size (float c_y) n.n_h in
    c.w#scroll_to ~x ~y ;
    Signal.emit v.event_signal (`NODE_SELECT id)

  module PQueue = Heap.Imperative (struct
                                     type t = float * (unit -> unit)
                                     let compare ((x, _) : t) (y, _) = compare x y
                                   end)

  let default_node_props =
    [ `OUTLINE_COLOR "black" ; `WIDTH_PIXELS 2 ],
    [ `FILL_COLOR "black" ]

  let border = 10.

  let update_graph v =
    let canvas = v.canvas.w in
    let graph = some v.agraph in
    let layout = Agraph.get_layout graph in
    let db = some v.db in
    let lr_layout = v.prefs.Viz_style.lr_layout in

    begin
      (* setup the canvas coordinates and initial position *)

      canvas#set_pixels_per_unit v.canvas.ppu ;
      let (x1, y1, x2, y2) = layout.bb in
      canvas#set_scroll_region
	~x1:(x1 -. border) ~y1:(y1 -. border)
	~x2:(x2 +. border) ~y2:(y2 +. border) ;
      if lr_layout
      then
	begin
	  (* scroll to the right of the graph (most recent revision) *)
	  let page_size = canvas#vadjustment#page_size in
	  let x = int_of_float x2 in
	  let y = int_of_float ((y1 +. y2 -. page_size) /. 2.) in
	  canvas#scroll_to ~x ~y
	end
      else
	begin
	  (* scroll to the bottom of the graph (most recent revision) *)
	  let page_size = canvas#hadjustment#page_size in
	  let x = int_of_float ((x1 +. x2 -. page_size) /. 2.) in
	  let y = int_of_float y2 in
	  canvas#scroll_to ~x ~y
	end
    end ;
    begin
      (* work around a bug in libgnomecanvas (?) where the arrows of the
	 scrollbars don't do anything. *)
      let set_page_incr (adj : GData.adjustment) =
	adj#set_bounds ~step_incr:(adj#page_increment /. 8.) () in

      set_page_incr canvas#hadjustment ;
      set_page_incr canvas#vadjustment
    end ;

    let main_group = GnoCanvas.group ~x:0. ~y:0. canvas#root in
    let edges_group  = GnoCanvas.group ~x:0. ~y:0. main_group in
    let nodes_group  = GnoCanvas.group ~x:0. ~y:0. main_group in

    let pr = Lazy.force v.status_reporter in

    let font = get_string_font_descr v in
    let font_size = get_font_size font in
    let font_desc = get_pango_font_descr v in

    let match_style = Viz_style.match_style v.prefs graph in

    let node_item id node () =
      let g = GnoCanvas.group ~x:node.n_x ~y:node.n_y nodes_group in
      let (rect_props, text_props) = match_style id default_node_props in
      let rect =
	let x = node.n_w /. 2. in
	let y = node.n_h /. 2. in
	let props =
	  if node.c_kind = NEIGHBOUR
	  then `DASH (0., [| 5.; 5. |]) :: rect_props
	  else rect_props in
	if node.c_kind = MERGE
	then
	  (* annoyingly, dot outputs circle-shaped nodes with different width and height *)
	  let r = max x y in
	  GnoCanvas.ellipse ~x1:(~-. r) ~y1:(~-. r) ~x2:r ~y2:r ~props g
	else
	  GnoCanvas.rect ~x1:(~-. x) ~y1:(~-. y) ~x2:x ~y2:y ~props g in
      if node.c_kind = DISAPPROVE
      then rect#affine_relative [| 0.5 ; 0.5 ; 0.5 ; -0.5 ; 0. ; 0. |] ;
      if node.c_kind = REGULAR || node.c_kind = NEIGHBOUR then
	begin
	  let scaled_font_size = font_size *. v.canvas.ppu in
	  let text = String.sub id 0 id_width in
          let t = GnoCanvas.text
              ~text ~font
              ~props:([ `SIZE_POINTS scaled_font_size ] @ text_props) g in
	  if scaled_font_size <= 3. then t#hide () ;
	  v.canvas.text_items <- t :: v.canvas.text_items
	end ;
      ignore
	(g#connect#event
	   (function
	     | `BUTTON_PRESS b ->
		 begin match GdkEvent.Button.button b with
		 | 1 ->
		     KeyNav.select v id ;
		     Signal.emit v.event_signal (`NODE_SELECT id) ;
		     true
		 | 3 ->
		     Signal.emit v.event_signal (`NODE_POPUP (id, 3)) ;
		     true
		 | _ ->
		     false end
	     | `TWO_BUTTON_PRESS b when node.c_kind = NEIGHBOUR ->
		 if GdkEvent.Button.button b = 1 then begin
		   match Database.fetch_cert_value db id "branch" with
		   | other_branch :: _ ->
		       Signal.emit v.event_signal (`NODE_SWITCH_BRANCH other_branch)
		   | [] -> ()
		 end ; true
	     | _ -> false)) ;
      pr#progress 1
    in

    let edge_item edge s () =
      let color =
	match s.edge_kind with
	  SAME_BRANCH -> "black"
	| BRANCHING -> "orange"
	| DISAPPROVED -> "red" in
      let bpath = GnomeCanvas.PathDef.new_path () in
      begin
	GnomeCanvas.PathDef.moveto bpath s.controlp.(0) s.controlp.(1) ;
	let i = ref 2 in
	while !i < Array.length s.controlp do
	  GnomeCanvas.PathDef.curveto bpath
	    s.controlp.(!i  ) s.controlp.(!i+1)
	    s.controlp.(!i+2) s.controlp.(!i+3)
	    s.controlp.(!i+4) s.controlp.(!i+5) ;
	  i := !i+6
	done ;
	let last_x = s.controlp.(!i-2) in
	let last_y = s.controlp.(!i-1) in
	let vx = (s.endp.(0) -. last_x) /. (2. *. sqrt 3.) in
	let vy = (s.endp.(1) -. last_y) /. (2. *. sqrt 3.) in
	GnomeCanvas.PathDef.moveto bpath
	  s.endp.(0) s.endp.(1) ;
	GnomeCanvas.PathDef.lineto bpath
	  (last_x -. vy) (last_y +. vx) ;
	GnomeCanvas.PathDef.lineto bpath
	  (last_x +. vy) (last_y -. vx) ;
	GnomeCanvas.PathDef.closepath bpath
      end ;
      ignore
	(GnoCanvas.bpath ~bpath
	   ~props:[ `OUTLINE_COLOR color ; `FILL_COLOR color ; `WIDTH_PIXELS 2 ]
	   edges_group) ;
      pr#progress 1
    in

    main_group#grab_focus () ;
    ignore (main_group#connect#event (function
      | `KEY_PRESS k when v.selected_node <> None ->
	  begin
	    try may (center_on v) (KeyNav.navigate v k) ; true
	    with Not_found -> false
	  end
      | _ -> false)) ;

    v.canvas.branch_items <- Some main_group ;
    let q = PQueue.create 256 in
    let count = ref 0 in
    NodeMap.iter
      (fun id n ->
	incr count ;
	let p = if lr_layout then n.n_x else n.n_y in
	PQueue.add q (p, node_item id n))
      layout.c_nodes ;
    EdgeMap.iter
      (fun edge spl ->
	incr count ;
	let p =
	  let len = Array.length spl.controlp in
	  spl.controlp.(if lr_layout then len - 2 else len - 1) in
	PQueue.add q (p, edge_item edge spl))
      layout.c_edges ;

    let id =
      Glib.Idle.add (fun () ->
	try
	  for i = 1 to 10 do
	    snd (PQueue.pop_maximum q) ()
	  done ; true
	with Heap.EmptyHeap ->
	  v.canvas.background_rendering <- None ;
	  pr#progress_end () ;
	  set_busy_cursor v.canvas false ;
	  Signal.emit v.event_signal `UPDATE_END ;
	  false
	| exn ->
	    Printf.eprintf "Uncaught exception: '%s'\n%!" (Printexc.to_string exn) ;
	    true) in
    v.canvas.background_rendering <- Some id ;
    pr#progress_start "Drawing ancestry graph ..." !count ;
    set_busy_cursor v.canvas true ;
    Signal.emit v.event_signal `UPDATE_BEGIN

end



module Find = struct
  let clear v =
    v.find.find_entry#set_text "" ;
    v.find.last_find <- "", []

  let connect v f =
    Signal.connect v.find.find_signal f

  let is_id =
    let re = Str.regexp "^[0-9a-fA-f]*$" in
    fun id -> Str.string_match re id 0

  let locate_id v id =
    let id = String.lowercase id in
    let nodes = get_cnodes v in
    if String.length id < 2
    then []
    else
      NodeMap.fold (fun k n acc ->
	if string_is_prefix id k
	then (k, n) :: acc
	else acc) nodes []

  let is_date =
    let re = Str.regexp "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$" in
    fun id -> Str.string_partial_match re id 0

  let locate_with_db v f =
    let g = some v.agraph in
    List.map
      (fun (id, _) -> id, get_cnode v id)
      (List.sort
	 (fun (_,a) (_,b) -> compare a b)
	 (List.filter
	    (fun (id, _) -> Agraph.mem g id)
	    (f (Agraph.get_db g))))

  let locate_date v date_prefix =
    locate_with_db v
      (fun db -> Database.get_matching_dates db date_prefix)

  let locate_tag v re =
    locate_with_db v
      (fun db ->
	Database.get_matching_tags db
	  (fun t -> Str.string_match re t 0))

  let locate v q =
    match v.find.last_find with
    | (last_q, n :: t) when last_q = q ->
	v.find.last_find <- (last_q, t) ;
	Canvas.center_on v n
    | _ ->
	let candidates =
	  try
	    if is_id q
	    then locate_id v q
	    else if is_date q
	    then locate_date v q
	    else locate_tag v (Str.regexp q)
	  with Failure _ | Invalid_argument _ -> [] in
	match candidates with
 	| [] ->
	    v.find.last_find <- (q, [])
	| n :: t ->
	    v.find.last_find <- (q, t) ;
	    Canvas.center_on v n

  let focus_find_entry v =
    v.find.find_entry#misc#grab_focus ()
end




let layout_params v =
  let (w, h) = Canvas.id_size v in
  { Agraph.box_w = float w ;
    Agraph.box_h = float h ;
    Agraph.lr_layout = v.prefs.Viz_style.lr_layout }

let connect_event v f =
  Signal.connect v.event_signal f



let handle_query v query =
  may
    (fun db ->
      may Agraph.abort_layout v.agraph ;
      Canvas.clear v ;
      v.agraph <- Some (
	Agraph.make db query (layout_params v) (function
	  | `LAYOUT_ERROR msg ->
	      error_notice ~parent:v.canvas.w msg
	  | `LAYOUT_DONE ->
	      Canvas.update_graph v)))
    v.db


let make ~aa ~prefs ~packing =
  let b = GPack.vbox ~packing () in

  (* Branches selection *)
  let (selector, find_box) = Branch_selector.make ~packing:b#pack in

  let view_pane = GPack.paned `VERTICAL ~packing:(b#pack ~expand:true) () in

  (* Canvas *)
  let canvas =
    Canvas.make ~aa
      ~packing:(view_pane#pack1 ~resize:true ~shrink:true) in

  (* Info pane *)
  let info_display = Info_Display.make ~packing:(view_pane#pack2 ~shrink:true) in

  let v = {
    info = info_display ;
    selector = selector ;
    canvas = canvas ;
    keyboard_nav = { previous_selected_node = None ; keyboard_nav_siblings = [] } ;
    find = find_box ;
    prefs = prefs ;
    db = None ;
    agraph = None ;
    event_signal = Signal.make () ;
    selected_node = None ;
    status_reporter = lazy (Status.new_reporter "monotone")
  } in

  Branch_selector.connect v (handle_query v) ;

  begin
    let clipboard = GData.clipboard Gdk.Atom.primary in
    ignore
      (v.canvas.w#event#connect#button_press
	 (function
	   | b when GdkEvent.Button.button b = 2 ->
	       may
		 (Signal.emit v.find.find_signal)
		 clipboard#text ;
	       true
	   | _ -> false))
  end ;

  connect_event v (function
    | `NODE_SELECT id ->
	Canvas.display_selection_marker v id ;
	Info_Display.fetch_and_display_data v id
    | `CLEAR ->
	Info_Display.clear_info v ;
	KeyNav.clear v ;
	Find.clear v ;
	v.selected_node <- None ;
    | _ -> ()) ;

  Find.connect v (Find.locate v) ;

  v


let close v =
  Branch_selector.clear v ;
  may Agraph.abort_layout v.agraph ;
  Canvas.clear v ;
  v.agraph <- None ;
  may Database.close_db v.db ;
  v.db <- None ;
  Signal.emit v.event_signal `CLOSE_DB


let finalize v =
  may Database.close_db v.db


let open_db v fname branch =
  close v ;
  try
    let db = Database.open_db fname in
    v.db <- Some db ;
    Branch_selector.populate v (Database.fetch_branches db) ;
    Branch_selector.set_branch v branch ;
    Signal.emit v.event_signal `OPEN_DB
  with Viz_types.Error msg ->
    error_notice ~parent:v.canvas.w msg


let reload v =
  may (fun db ->
    let branch = Branch_selector.get_branch v in
    let fname = Database.get_filename db in
    open_db v fname branch)
    v.db


let zoom = Canvas.zoom

let display_certs v id =
  Canvas.display_selection_marker v id ;
  Info_Display.fetch_and_display_data
    v id


type prefs = Viz_style.prefs = {
    font          : string ;
    autocolor     : autocolor ;
    lr_layout     : bool ;
    monotone_path : string ;
    style         : Viz_style.style ;
  }

let set_prefs v p =
  let old_prefs = v.prefs in
  let need_layout = ref false in
  let need_redraw = ref false in
  if old_prefs.font <> p.font
  then begin
    v.prefs <- { v.prefs with font = p.font } ;
    need_layout := true
  end ;
  if old_prefs.autocolor <> p.autocolor
  then begin
    v.prefs <- { v.prefs with autocolor = p.autocolor } ;
    need_redraw := true
  end ;
  if old_prefs.lr_layout <> p.lr_layout
  then begin
    v.prefs <- { v.prefs with lr_layout = p.lr_layout } ;
    need_layout := true
  end ;
  if old_prefs.monotone_path <> p.monotone_path
  then begin
    v.prefs <- { v.prefs with monotone_path = p.monotone_path }
  end ;
  if old_prefs.style <> p.style
  then begin
    v.prefs <- { v.prefs with style = p.style } ;
    need_redraw := true
  end ;
  match v.agraph with
  | Some g when !need_layout ->
      handle_query v (Agraph.get_query g)
  | Some g when !need_redraw ->
      Canvas.clear v ;
      Canvas.update_graph v
  | _ -> ()

let get_ancestors v id =
  Agraph.get_ancestors (some v.agraph) id

let view_diff v old_id new_id =
  let parent = v.canvas.w in
  try
    Database.run_monotone_diff
      (some v.db) v.prefs.Viz_style.monotone_path (old_id, new_id)
      (Lazy.force v.status_reporter)
      (fun res ->
	match res with
	| `DIFF d ->
	    Unidiff.view ~parent d
	| `SUB_PROC_ERROR msg ->
	    error_notice ~parent msg)
  with Viz_types.Error msg ->
    error_notice ~parent msg

let get_toplevel v =
  GWindow.toplevel v.canvas.w