Below is the file 'view.ml' from this revision. You can also download the file.
open Viz_misc open Viz_types open Revision_types open Ui let ( ++ ) x f = f x module Info_Display = struct type t = { 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 ; mutable current_row : Gtk.tree_path option ; } 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 proper_id_select label ev = if GdkEvent.Button.button ev = 1 && GdkEvent.get_type ev = `TWO_BUTTON_PRESS then begin let txt = label#text in let nl = try String.index txt '\n' with Not_found -> 0 in if string_is_prefix "Revision: " txt && string_is_prefix "Manifest: " ~offset:(nl+1) txt then begin if label#cursor_position <= nl then label#select_region 10 nl else label#select_region (nl + 1 + 10) (-1) ; true end else false end else false 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 ; ignore (GtkSignal.connect ~sgn:GtkBase.Widget.Signals.Event.button_press ~callback:(proper_id_select label) label#as_widget) ; 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 ; column#set_resizable true ; 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 ; column#set_resizable true ; 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 ; current_row = None ; } let setup info ctrl = (* setup the signal for the popup menu *) ignore (info.cert_view#event#connect#button_press (fun ev -> let button = GdkEvent.Button.button ev in if button = 3 then begin begin let x = int_of_float (GdkEvent.Button.x ev) in let y = int_of_float (GdkEvent.Button.y ev) in match info.cert_view#get_path_at_pos ~x ~y with | Some (path, _, _, _) -> info.current_row <- Some path | None -> info.current_row <- None end ; ctrl#cert_popup button end ; false)) let clear i = i.current_row <- None ; 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 _ | ADD_DIR _ -> Some `ADD | DELETE_FILE _ | DELETE_DIR _ -> Some `REMOVE | RENAME_FILE _ | RENAME_DIR _ -> Some `CONVERT | ATTR_SET _ -> Some `PROPERTIES | ATTR_CLEAR _ -> Some `CLEAR let text_of_delta_type = function | PATCH (f, "", _) | PATCH (f, _, "") -> "" | PATCH (f, _, _) | ADD_FILE (f, _) | DELETE_FILE f -> f | ADD_DIR 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 | ATTR_CLEAR (attr, f) | ATTR_SET (attr, f, _) -> Printf.sprintf "%s on %s" attr f 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 (* monotone uses UTF-8 internaly *) if valid_utf8 text && 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 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 ; (* cert values are either binary or valid utf8 *) let c_value_disp = if valid_utf8 c.c_value then c.c_value else "<binary data>" in m#set ~row ~column:i.cert_c_value c_value_disp ; 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 filter_certs ignored_certs data = { data with certs = List.filter (fun c -> not (List.mem c.c_name ignored_certs)) data.certs } let fetch_and_display_data info ctrl id = match ctrl#get_db with | None -> () | Some db -> let data = try Database.fetch_certs_and_revision db id with | Sqlite3.Error ((Sqlite3.BUSY | Sqlite3.LOCKED), _) -> failed_node_data | Viz_types.Error msg -> ctrl#error_notice msg ; failed_node_data in display_info info (filter_certs ctrl#get_prefs.Viz_style.ignored_certs data) let get_current_cert_value info = maybe (fun path -> info.cert_model#get ~row:(info.cert_model#get_iter path) ~column:info.cert_c_value) info.current_row end module Complete = struct let is_id = let re = Str.regexp "^[0-9a-fA-F]+$" in fun id -> Str.string_match re id 0 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 complete_with_db ctrl f = match ctrl#get_db with | None -> [] | Some db -> f db let complete_id ctrl query_domain q = complete_with_db ctrl (fun db -> let data = Database.get_matching_ids db q in match query_domain with | QUERY_ALL -> data | QUERY_BRANCHES allowed_branches -> List.filter (fun (_, branch_name) -> List.mem branch_name allowed_branches) data) let complete_tag ctrl q = complete_with_db ctrl (fun db -> let re = Str.regexp q in Database.get_matching_tags db (fun t -> Str.string_match re t 0)) let get_id_and_uniquify data = data ++ List.map fst ++ List.sort compare ++ Viz_misc.list_uniq let several_completions parent (t, ids) = let txt = Buffer.create 128 in Printf.bprintf txt "<b>Several possible completions for %s :</b>\n<tt>\n" (Glib.Markup.escape_text t) ; List.iter (fun id -> Printf.bprintf txt " %s\n" id) ids ; Printf.bprintf txt "</tt>" ; let m = GWindow.message_dialog ~message:(Buffer.contents txt) ~use_markup:true ~message_type:`INFO ~buttons:GWindow.Buttons.close ~parent ~destroy_with_parent:true ~title:"Monotone-viz - Date completion" () in ignore (m#connect#response (fun _ -> m#destroy ())) ; m#show () exception None exception Many of (string * string list) let complete_date ctrl domain t = if is_date t then t else let match_data = if is_id t then complete_id ctrl domain t else complete_tag ctrl t in match get_id_and_uniquify match_data with | [] -> raise None | [ id ] -> begin match Database.fetch_cert_value (some ctrl#get_db) id "date" with | t :: _ -> t | [] -> raise None end | ids -> raise (Many (t, ids)) end module Branch_selector = struct type t = { store : GTree.tree_store ; branch_column : string GTree.column ; count_column : int GTree.column ; in_view_column : bool GTree.column ; vis_column : bool GTree.column ; w : [`CANCEL|`DELETE_EVENT|`VIEW] GWindow.dialog ; view : GTree.view ; select_buttons : GButton.button * GButton.button ; toggle_renderer : GTree.cell_renderer_toggle ; radio_buttons : GButton.radio_button array ; entries : GEdit.entry array ; propagate_checkb : GButton.toggle_button ; mutable selected_b : int ; mutable limit_kind : int ; } let make parent = (* The model containing branch names *) let cl = new GTree.column_list in let branch_column = cl#add Gobject.Data.string in let count_column = cl#add Gobject.Data.int in let in_view_column = cl#add Gobject.Data.boolean in let vis_column = cl#add Gobject.Data.boolean in let model = GTree.tree_store cl in (* The dialog, created now, only shown when one presses the button *) let w = GWindow.dialog ~parent ~destroy_with_parent:true ~border_width:8 ~no_separator:true ~title:"Ancestry graph view specification" () in w#add_button_stock `CANCEL `CANCEL ; w#add_button_stock (`STOCK "mviz-view") `VIEW ; w#set_response_sensitive `VIEW false ; let packing = w#vbox#pack in (* The treeview of branches *) let view, select_buttons = let packing = Ui.category "Branches" (packing ~expand:true) in let select_buttons = let al = GBin.alignment ~xalign:1. ~xscale:0.333 ~packing () in let hb = GPack.hbox ~homogeneous:true ~packing:al#add () in let add_button label = GButton.button ~packing:(hb#pack ~from:`END) ~label () in let b1 = add_button "select none" in let b2 = add_button "select all" in (b1, b2) in let view = GTree.view ~model ~height:200 ~packing:(Ui.wrap_in_scroll_window (packing ~expand:true)) () in view, select_buttons in view#selection#set_mode `NONE ; let toggle_renderer = let vc = GTree.view_column ~title:"view" () in let r = GTree.cell_renderer_toggle [] in vc#pack r ; vc#add_attribute r "active" in_view_column ; vc#add_attribute r "visible" vis_column ; ignore (view#append_column vc) ; r in begin let vc = GTree.view_column ~title:"Branch" () in let r = GTree.cell_renderer_text [] in vc#pack r ; vc#add_attribute r "text" branch_column ; ignore (view#append_column vc) ; view#set_expander_column (Some vc) end ; begin let vc = GTree.view_column ~title:"Count" () in let r = GTree.cell_renderer_text [`XALIGN 1.] in vc#pack r ; vc#add_attribute r "text" count_column ; vc#add_attribute r "visible" vis_column ; ignore (view#append_column vc) end ; (* The radio buttons for the date limit *) let b1, b2, entry_from, entry_to = let packing = Ui.category "Date limit" packing in let tooltips = GData.tooltips () in let date_entry_tooltip_text = "Specify a date (YYYY-MM-DD), a tag or a revision id" in let tbl = GPack.table ~columns:2 ~rows:3 ~row_spacings:2 ~col_spacings:4 ~packing () in let b1 = let packing = tbl#attach ~left:0 ~top:0 in GButton.radio_button ~label:"_No limit" ~use_mnemonic:true ~active:true ~packing () in let group = b1#group in let button = GButton.radio_button ~group ~label:"_Interval limit" ~use_mnemonic:true ~packing:(tbl#attach ~left:0 ~top:1) () in let hb = GPack.hbox ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in let packing = hb#pack ~padding:4 in ignore (button#connect#toggled (fun () -> hb#misc#set_sensitive button#active)) ; hb#misc#set_sensitive false ; Ui.add_label "from " packing ; let e1 = GEdit.entry ~packing () in tooltips#set_tip ~text:date_entry_tooltip_text e1#coerce ; Ui.add_label " to " packing ; let e2 = GEdit.entry ~packing ~activates_default:true () in tooltips#set_tip ~text:date_entry_tooltip_text e2#coerce ; ignore (e1#connect#activate (fun () -> e2#misc#grab_focus ())) ; (b1, button, e1, e2) in (* The check button to select all propagate nodes or not *) let checkb = let packing = Ui.category "Options" packing in GButton.check_button ~label:"Display all propagate nodes" ~active:false ~packing () in { store = model ; branch_column = branch_column ; count_column = count_column ; in_view_column = in_view_column ; vis_column = vis_column ; view = view ; select_buttons = select_buttons ; toggle_renderer = toggle_renderer ; w = w ; radio_buttons = [| b1 ; b2 |] ; entries = [| entry_from ; entry_to |] ; propagate_checkb = checkb ; selected_b = 0 ; limit_kind = 0 } let expand_rows s = (* expand some rows a bit *) let rec loop depth parent = if depth <= 2 then begin let n = s.store#iter_n_children parent in for i = 0 to n - 1 do let child = s.store#iter_children ~nth:i parent in let path = s.store#get_path child in s.view#expand_row path ; loop (depth + 1) (Some child) done end in loop 0 None ; s.store#foreach (fun path row -> let v = s.store#get ~row ~column:s.in_view_column in if v then Viz_gmisc.tree_view_expand_to_path (Gobject.try_cast s.view#as_widget s.view#misc#get_type) path ; false) let scroll s = (* make sure that a selected row is visible *) match let v_path = ref None in s.store#foreach (fun path row -> let v = s.store#get ~row ~column:s.in_view_column in if v then v_path := Some path ; v) ; !v_path with | None -> () | Some path -> s.view#scroll_to_cell path (s.view#get_column 0) let get_query_domain s = let all = ref true in let acc = ref [] in s.store#foreach (fun path row -> let v = s.store#get ~row ~column:s.in_view_column in all := !all && v ; if v then begin let b = s.store#get ~row ~column:s.branch_column in acc := b :: !acc end ; false) ; if !all then QUERY_ALL else QUERY_BRANCHES !acc let future = "9999-12" let past = "0001-01" let make_query_limit_interval ctrl domain s_from s_to = let t_from = Complete.complete_date ctrl domain (if s_from = "" then past else s_from) in let t_to = Complete.complete_date ctrl domain (if s_to = "" then future else s_to) in QUERY_BETWEEN (t_from, t_to) let make_query ctrl ?id s = try let query_domain = get_query_domain s in let query_limit = match s.limit_kind with | 0 -> QUERY_NO_LIMIT | _ -> make_query_limit_interval ctrl query_domain s.entries.(0)#text s.entries.(1)#text in let query_propagate = s.propagate_checkb#active in Some { query = { dom = query_domain ; lim = query_limit ; all_propagates = query_propagate }; preselect = id } with | Complete.None -> None | Complete.Many compl -> Complete.several_completions s.w compl ; None let adjust_view_button_sensitivity s = s.w#set_response_sensitive `VIEW (s.selected_b > 0) let setup s ctrl = Array.iteri (fun i (b : GButton.radio_button) -> ignore (b#connect#toggled (fun () -> if b#active then s.limit_kind <- i))) s.radio_buttons ; begin let sel_none_b, sel_all_b = s.select_buttons in ignore (sel_none_b#connect#clicked (fun () -> s.selected_b <- 0 ; s.store#foreach (fun path row -> s.store#set ~row ~column:s.in_view_column false ; false) ; adjust_view_button_sensitivity s)) ; ignore (sel_all_b#connect#clicked (fun () -> let nb_b = ref 0 in s.store#foreach (fun path row -> s.store#set ~row ~column:s.in_view_column true ; incr nb_b ; false) ; s.selected_b <- !nb_b ; adjust_view_button_sensitivity s)) ; end ; ignore (s.toggle_renderer#connect#toggled (fun path -> let column = s.in_view_column in let row = s.store#get_iter path in let v = s.store#get ~row ~column in if v then s.selected_b <- s.selected_b - 1 else s.selected_b <- s.selected_b + 1 ; s.store#set ~row ~column (not v) ; if s.selected_b <= 1 then adjust_view_button_sensitivity s)) ; ignore (s.w#connect#after#close s.w#misc#hide) ; ignore (s.w#event#connect#delete (fun _ -> s.w#misc#hide () ; true)) ; ignore (s.w#connect#response (function | `CANCEL | `DELETE_EVENT -> s.w#misc#hide () | `VIEW -> may (fun q -> s.w#misc#hide () ; ctrl#query q) (make_query ctrl s))) module Trie = struct type 'a t = | N of 'a * 'a t StringMap.t | B of 'a t StringMap.t let empty = B StringMap.empty let rec insert t k v = match k, t with | [], N (_, m) | [], B m -> N (v, m) | h :: tl, B m -> let st = try StringMap.find h m with Not_found -> empty in B (StringMap.add h (insert st tl v) m) | h :: tl, N (x, m) -> let st = try StringMap.find h m with Not_found -> empty in N (x, StringMap.add h (insert st tl v) m) end let at_least_two m = try ignore (StringMap.fold (fun _ _ n -> if n >= 1 then raise Exit ; n + 1) m 0) ; false with Exit -> true let fill_store_from_trie s t = let rec loop kl parent t = let m, parent = match t with | Trie.N ((v, n), m) -> let row = s.store#append ?parent () in s.store#set ~row ~column:s.branch_column v ; s.store#set ~row ~column:s.count_column n ; s.store#set ~row ~column:s.vis_column true ; m, Some row | Trie.B m when kl <> [] && at_least_two m -> let row = s.store#append ?parent () in let v = String.concat "." (List.rev ("" :: kl)) in s.store#set ~row ~column:s.branch_column v ; m, Some row | Trie.B m -> m, parent in StringMap.iter (fun k st -> loop (k :: kl) parent st) m in loop [] None t let tree_of_branches s br = assert (s.store#get_iter_first = None) ; (* branch names are theoretically unstructured but in practice . is used as delimiter. (NDQF) *) List.map (fun ((b, _) as v) -> string_split '.' b, v) br ++ List.fold_left (fun acc (bl, v) -> Trie.insert acc bl v) Trie.empty ++ fill_store_from_trie s let populate = tree_of_branches let clear s = s.w#misc#hide () ; s.store#clear () ; s.selected_b <- 0 ; adjust_view_button_sensitivity s ; s.radio_buttons.(0)#set_active true ; (* should update s.limit_kind *) Array.iter (fun e -> e#set_text "") s.entries type state = Viz_types.query_domain * int * string array let get_state s = let domain = get_query_domain s in let limit_kind = s.limit_kind in let entries_text = Array.map (fun e -> e#text) s.entries in (domain, limit_kind, entries_text) let set_state s ctrl ?id state = s.w#misc#hide () ; let (domain, limit_kind, entries_text) = state in let in_domain v = match domain with | QUERY_ALL -> true | QUERY_BRANCHES b -> List.mem v b in s.selected_b <- 0 ; s.store#foreach (fun path row -> let b = s.store#get ~row ~column:s.branch_column in let v = s.store#get ~row ~column:s.in_view_column in let n = in_domain b in if n <> v then s.store#set ~row ~column:s.in_view_column n ; if n then s.selected_b <- s.selected_b + 1 ; false) ; adjust_view_button_sensitivity s ; s.radio_buttons.(limit_kind)#set_active true ; Array.iteri (fun i e -> e#set_text entries_text.(i)) s.entries ; may ctrl#query (make_query ctrl ?id s) let string_of_date d = let b = String.create 10 in let l = Viz_gmisc.Date.strftime d "%Y-%m-%d" b in assert (l = 10) ; b let two_months_ago () = let d = Viz_gmisc.Date.current_time () in Viz_gmisc.Date.subtract_months d 2 ; string_of_date d let set_branch s ctrl ?id br = s.selected_b <- 0 ; s.store#foreach (fun path row -> let b = s.store#get ~row ~column:s.branch_column in let v = s.store#get ~row ~column:s.in_view_column in let sel = b = br in if v <> sel then s.store#set ~row ~column:s.in_view_column sel ; if sel then s.selected_b <- 1 ; false) ; adjust_view_button_sensitivity s ; begin match id with | None -> s.radio_buttons.(1)#set_active true ; s.entries.(0)#set_text (two_months_ago ()) ; s.entries.(1)#set_text "" | Some id -> match Database.fetch_cert_value (some ctrl#get_db) id "date" with | [] -> s.radio_buttons.(0)#set_active true | d :: _ -> s.radio_buttons.(1)#set_active true ; let p o l = int_of_string (String.sub d o l) in let d = p 8 2 in let m = p 5 2 in let y = p 0 4 in let d_from = let date = Viz_gmisc.Date.make_dmy d m y in Viz_gmisc.Date.subtract_months date 2 ; string_of_date date in let d_to = let date = Viz_gmisc.Date.make_dmy d m y in Viz_gmisc.Date.add_months date 2 ; string_of_date date in s.entries.(0)#set_text d_from ; s.entries.(1)#set_text d_to end ; may ctrl#query (make_query ctrl ?id s) let present_dialog s = expand_rows s ; scroll s ; s.w#set_default_response `VIEW ; s.w#present () end module KeyNav = struct type t = { mutable previous_selected_node : (string * Viz_types.c_node) option ; mutable keyboard_nav_siblings : (string * Viz_types.c_node) list ; } let make () = { previous_selected_node = None ; keyboard_nav_siblings = [] } 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 = try List.assoc (GdkEvent.Key.keyval k) (if lr_layout then left_right_dir else top_down_dir) with Not_found -> `NONE let navigate_is_sibling k id = List.exists (fun (i, _) -> i = id) k.keyboard_nav_siblings let on_same_branch db id = let b_target = Database.fetch_cert_value db id "branch" in fun (id, _) -> let b_node = Database.fetch_cert_value db id "branch" in List.exists (fun b -> List.mem b b_target) b_node let navigate_choose k ctrl 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 List.filter (on_same_branch (some ctrl#get_db) current_id) sx with | [] -> Some (List.hd sx) | h :: _ -> Some h let navigate k ctrl key = match ctrl#get_selected_node with | None -> None | Some id -> match nav_dir ctrl#get_prefs.Viz_style.lr_layout key with | `NONE -> None | `LAST -> may (fun (id, _) -> if not (navigate_is_sibling k id) then k.keyboard_nav_siblings <- []) k.previous_selected_node ; k.previous_selected_node | (`NEXT | `PREV) as d when k.keyboard_nav_siblings <> [] -> navigate_choose k ctrl id d | #Viz_types.direction as d -> match ctrl#get_agraph with | None -> None | Some graph -> 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 ctrl id d let select k id previous_id = k.previous_selected_node <- previous_id ; if not (navigate_is_sibling k id) then k.keyboard_nav_siblings <- [] let clear k = k.previous_selected_node <- None ; k.keyboard_nav_siblings <- [] end let is_neighbor n = match n.c_kind with | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true | _ -> false module Canvas = struct external pango_fix : unit -> unit = "ml_fix_libgnomecanvas_pango" let _ = pango_fix () type t = { canvas : 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 ; mutable drag_active : bool ; mutable selected_node : (string * Viz_types.c_node) option ; keynav : KeyNav.t } 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 () ; { canvas = canvas ; ppu = 1. ; branch_items = None ; text_items = [] ; selected_marker = selection_rect ; background_rendering = None ; drag_active = false ; selected_node = None ; keynav = KeyNav.make () } let dnd_targets = [| { Gtk.target = "text/uri-list" ; Gtk.flags = [] ; Gtk.info = 0 } ; { Gtk.target = "text/plain" ; Gtk.flags = [] ; Gtk.info = 1 } ; |] let file_of_drop_data data = try let f = List.find (fun f -> Viz_misc.string_is_prefix "file://" f) (Str.split (Str.regexp "\r\n") data) in Some (Viz_misc.string_slice ~s:7 f) with Not_found -> None let drag_setup c ctrl = let canvas = c.canvas in canvas#drag#dest_set ~actions:[`COPY] [ dnd_targets.(0) ] ; ignore (canvas#drag#connect#data_received (fun ctx ~x ~y sel ~info ~time -> if info = 0 then (* a file dropped from a file manager *) may (ctrl#open_db ?id:None ?branch:None) (file_of_drop_data sel#data))) ; let setup_drag () = canvas#drag#source_set ~modi:[`BUTTON1] ~actions:[`COPY] [ dnd_targets.(1) ] in setup_drag () ; (* OK, this is a bit complicated: GTK+ supports DnD at the widget level but here I want DnD for a GnomeCanvasItem (a node in the ancestry graph). So the GnomeCanvas is set up as a DragSource. In the button press event handler of the canvas item, the drag_active field is set to true. In a event handler of the canvas widget for button press (connected with after so that it runs after the canvas item ones), I check drag_active: if false, that means the click was outside a node and I call gtk_drag_source_unset(). In the button release handler, I reset drag_active to false and re-setup the canvas as a drag source. *) ignore (canvas#event#connect#after#button_press (fun ev -> if GdkEvent.Button.button ev = 1 && not c.drag_active then canvas#drag#source_unset () ; false)) ; ignore (canvas#event#connect#button_release (fun ev -> if GdkEvent.Button.button ev = 1 then begin if c.drag_active then c.drag_active <- false else setup_drag () end ; false)) ; ignore (canvas#drag#connect#data_get (fun ctx sel_ctx ~info ~time -> match c.selected_node with | Some (id, _) when info = 1 -> sel_ctx#return id | _ -> ())) let setup c ctrl = drag_setup c ctrl ; let clipboard = GData.clipboard Gdk.Atom.primary in ignore (c.canvas#event#connect#button_press (fun ev -> (* Grab the focus when one clicks on the canvas *) c.canvas#misc#grab_focus () ; if GdkEvent.Button.button ev = 2 then may ctrl#find clipboard#text ; false)) let get_string_font_descr ctrl = ctrl#get_prefs.Viz_style.font let get_pango_font_descr ctrl = Pango.Font.from_string (get_string_font_descr ctrl) 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 c ctrl = let desc = get_pango_font_descr ctrl in c.canvas#misc#pango_context#get_metrics ~desc () let zoom c ctrl dir () = begin match dir with | `IN -> c.ppu <- c.ppu *. sqrt 2. | `OUT -> c.ppu <- c.ppu /. sqrt 2. end ; c.canvas#set_pixels_per_unit c.ppu ; let font_size = get_font_size (get_string_font_descr ctrl) in if debug "zoom" then Printf.eprintf "### zoom: ppu = %f, font_size = %f\n%!" c.ppu (c.ppu *. font_size) ; let new_size = c.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 ()) c.text_items let display_selection_marker c ctrl sel = let (id, node_data) = sel in KeyNav.select c.keynav id c.selected_node ; c.selected_node <- Some sel ; 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 = c.selected_marker in marker#set [ `X1 x1; `X2 x2; `Y1 y1; `Y2 y2 ] ; marker#lower_to_bottom () ; marker#show () ; ctrl#display_certs id let clear c ctrl = may (fun g -> g#destroy ()) c.branch_items ; c.branch_items <- None ; c.text_items <- [] ; c.selected_marker#hide () ; c.selected_node <- None ; KeyNav.clear c.keynav ; may (fun id -> Glib.Idle.remove id ; c.background_rendering <- None ; (ctrl#status "canvas")#progress_end ()) c.background_rendering let id_width = 8 let id_size c ctrl = let metrics = get_font_metrics c ctrl 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, cw) as s = ((id_width + 4) * char_width, (ascent + descent) * 2, char_width) in if Viz_misc.debug "font" then Printf.eprintf "### font: width = %d, height = %d, char_width = %d\n%!" w h cw ; 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 c ctrl ((_, n) as sel) = let c_x, c_y = c.canvas#w2c ~wx:n.n_x ~wy:n.n_y in let x = let a = c.canvas#hadjustment in scroll a#value a#page_size (float c_x) n.n_w in let y = let a = c.canvas#vadjustment in scroll a#value a#page_size (float c_y) n.n_h in c.canvas#scroll_to ~x ~y ; display_selection_marker c ctrl sel let default_node_props = [ `OUTLINE_COLOR "black" ; `WIDTH_PIXELS 2 ], [ `FILL_COLOR "black" ] let border = 10. let update_graph c ctrl preselect_id = let canvas = c.canvas in let graph = some ctrl#get_agraph in let layout = Agraph.get_layout graph in let db = some ctrl#get_db in let pr = ctrl#status "canvas" in let prefs = ctrl#get_prefs in let lr_layout = prefs.Viz_style.lr_layout in begin (* setup the canvas coordinates and initial position *) canvas#set_pixels_per_unit c.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 font = prefs.Viz_style.font in let font_size = get_font_size font in let match_style = Viz_style.match_style prefs graph db 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 is_neighbor node 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. |] ; let text = match node.c_kind with | TAGGED t -> t | REGULAR -> String.sub id 0 id_width | _ when is_neighbor node -> String.sub id 0 id_width | _ -> "" in if text <> "" then begin let scaled_font_size = font_size *. c.ppu 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 () ; c.text_items <- t :: c.text_items end ; ignore (g#connect#event (function | `BUTTON_PRESS b -> begin match GdkEvent.Button.button b with | 1 -> display_selection_marker c ctrl (id, node) ; c.drag_active <- true ; true | 3 -> ctrl#view_popup (id, 3) ; true | _ -> false end | `TWO_BUTTON_PRESS b when is_neighbor node && GdkEvent.Button.button b = 1 -> begin match Database.fetch_cert_value db id "branch" with | other_branch :: _ -> ctrl#switch_branch (other_branch, id) | [] -> () end ; true | _ -> false)) ; pr#progress 1 in let edge_item edge s () = let color = match s.edge_kind with SAME_BRANCH -> "black" | BRANCHING | BRANCHING_NEIGH -> "orange" | DISAPPROVED -> "red" | SPANNING -> "darkgrey" 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 c.selected_node <> None -> may (center_on c ctrl) (KeyNav.navigate c.keynav ctrl k) ; true | _ -> false)) ; c.branch_items <- Some main_group ; let q, count = let presel_node = maybe (Agraph.get_node graph) preselect_id in let enqueue v (q, count) = (v :: q, count + 1) in let acc = ([], 0) in let acc = let prio n = match presel_node with | None when lr_layout -> n.n_x | None -> n.n_y | Some (_, p) when lr_layout -> ~-. (abs_float (n.n_x -. p.n_x)) | Some (_, p) -> ~-. (abs_float (n.n_y -. p.n_y)) in NodeMap.fold (fun id n acc -> enqueue (prio n, node_item id n) acc) layout.c_nodes acc in let q, count = let prio spl = let len = Array.length spl.controlp in match presel_node with | None when lr_layout -> spl.controlp.(len - 2) | None -> spl.controlp.(len - 1) | Some (_, p) when lr_layout -> ~-. (abs_float (spl.controlp.(len - 2) -. p.n_x)) | Some (_, p) -> ~-. (abs_float (spl.controlp.(len - 1) -. p.n_y)) in EdgeMap.fold (fun edge spl acc -> enqueue (prio spl, edge_item edge spl) acc