# # delete_file "status.ml" # # add_file "app.ml" # # add_file "app.mli" # # add_file "query.mli" # # add_file "ui.mli" # # patch "Makefile" # from [014069772d0984ac2b7c258cbf9078a370e3357a] # to [a6a4476838ce1258815d403a108049fa43bc3540] # # patch "agraph.ml" # from [112863631f39bca61cfc4c43ff3d69062491c14e] # to [f12739a60a31028c6bc1bcf4b48df6196d09becd] # # patch "agraph.mli" # from [88bee9cb508728a7e7510152a4443bf78c98f970] # to [08e41b7cf67369cbf32876a38add40bfd2c09ba8] # # patch "app.ml" # from [] # to [11821edcec8d05f1be39698f5b37e5c2f26ac765] # # patch "app.mli" # from [] # to [2e5bf23cbb20daae7194c707c757764bb768917f] # # patch "database.mli" # from [16ab65994da34c28262d423624e154ff3652cae5] # to [92a7d49361cafc56f963f7d5188f9705f3f53705] # # patch "main.ml" # from [8159bc944a1ff286d7ca279944691d7e19a13177] # to [76d695d2ec4c7849db39b9f51b390c4931aabcb3] # # patch "query.ml" # from [0774985cb60091adbc66de0375801b89eb3dd7af] # to [4fd07dbfdaf0d7269f249ccc1df6acf01fd6368c] # # patch "query.mli" # from [] # to [26219a504510f931da07f22a48af22f59b1eba47] # # patch "ui.ml" # from [9f04b2665f883b08f4d714b5e311a958e9ad50b6] # to [b6c845fc9089553842dde375c4047bc7c05b5658] # # patch "ui.mli" # from [] # to [08c8f50676d3c3b1e5f2f2e479b6b343b3ca7012] # # patch "unidiff.ml" # from [8364675a96bfe736ac395bc7f4924ddfa2755928] # to [c91173ccdf199cfe6a93689b234f7864c7353110] # # patch "unidiff.mli" # from [d31d60a0f12c3a892bf4a12581dc1d8cf7aee0ee] # to [a99a05e08d5504eb5e064d5120d50d64b204def2] # # patch "view.ml" # from [6ee2e4a63701af0bdeed8b77a544f91ef9b96c93] # to [6302ab124e672800f67cf9fc3288bc83b16c3345] # # patch "view.mli" # from [01d6087db6831d53ec35e1da6c9eb63ecc523804] # to [5d2ee84a233b89a239b459c0e2ac4cfb1c37aee9] # # patch "viz_types.ml" # from [ac47415114692a19bdf32928c5d78f2402e1fa47] # to [2348af90556459bd15ea99ce8d5b45b2f2dbe82c] # # patch "viz_types.mli" # from [292b0505def1f086f2705c3bcc7d10f780bca15a] # to [c3524724d488bbf3da18ba9de56ab98d9a08599f] # ======================================================================== --- Makefile 014069772d0984ac2b7c258cbf9078a370e3357a +++ Makefile a6a4476838ce1258815d403a108049fa43bc3540 @@ -19,11 +19,11 @@ dot_lexer.ml dot_parser.ml dot_parser.mli \ revision_types.mli revision_lexer.ml revision_parser.ml revision_parser.mli \ subprocess.ml subprocess.mli \ - status.ml components.ml \ + components.ml \ database.ml database.mli agraph.ml agraph.mli \ autocolor.ml autocolor.mli viz_style.ml viz_style.mli \ - icon.ml unidiff.ml unidiff.mli \ - view.ml view.mli query.ml ui.ml version.ml main.ml + icon.ml ui.ml ui.mli unidiff.ml unidiff.mli \ + view.ml view.mli query.ml query.mli app.ml app.mli version.ml main.ml C_OBJ = mlsqlite/ocaml-sqlite3.o \ glib/ocaml-gspawn.o glib/ocaml-giochannel.o \ ======================================================================== --- agraph.ml 112863631f39bca61cfc4c43ff3d69062491c14e +++ agraph.ml f12739a60a31028c6bc1bcf4b48df6196d09becd @@ -254,7 +254,7 @@ type done_cb = [`LAYOUT_DONE | `LAYOUT_ERROR of string] -> unit -let make agraph query layout_params (done_cb : done_cb) = +let make agraph query layout_params status (done_cb : done_cb) = let graph = { query = query ; agraph = agraph ; @@ -265,7 +265,7 @@ dot_subproc = None ; } in (* Spawn the dot process *) - graph.dot_subproc <- Some (spawn_dot graph (Status.new_reporter "dot") done_cb) ; + graph.dot_subproc <- Some (spawn_dot graph status done_cb) ; (* immediately return an (incomplete) value *) graph ======================================================================== --- agraph.mli 88bee9cb508728a7e7510152a4443bf78c98f970 +++ agraph.mli 08e41b7cf67369cbf32876a38add40bfd2c09ba8 @@ -10,7 +10,10 @@ type t type done_cb = [`LAYOUT_DONE | `LAYOUT_ERROR of string] -> unit -val make : agraph -> query -> layout_params -> done_cb -> t +val make : + agraph -> query -> layout_params -> + unit; pop : unit -> unit; ..> -> + done_cb -> t (* spawn dot *) exception Not_yet ======================================================================== --- app.ml +++ app.ml 11821edcec8d05f1be39698f5b37e5c2f26ac765 @@ -0,0 +1,261 @@ +class type status = + object + method push : string -> unit + method pop : unit -> unit + method progress_start : string -> int -> unit + method progress : int -> unit + method progress_end : unit -> unit + method with_status : string -> (unit -> 'a) -> 'a + end + +class type t = + object + method get_db : Database.t option + method get_agraph : Agraph.t option + method get_prefs : Viz_style.prefs + method get_toplevel : GWindow.window + + method set_prefs : Viz_style.prefs -> unit + + method open_db : ?id:string -> ?branch:string -> string -> unit + method close_db : unit -> unit + method finalize : unit -> unit + method display_certs : string -> unit + method focus_find_entry : unit -> unit + method get_current_cert_value : string option + method reload : unit -> unit + method zoom_in : unit -> unit + method zoom_out : unit -> unit + method re_layout : unit -> unit + method redraw : unit -> unit + method query : Viz_types.select_info -> unit + method get_selected_node : string option + method find : string -> unit + method switch_branch : string * string -> unit + method update_begin : unit + method update_end : unit + method center_on :string * Viz_types.c_node -> unit + method center_on_by_id : string -> unit + method view_popup : string * int -> unit + method cert_popup : int -> unit + + method show_open : unit -> unit + method show_search : unit -> unit + method show_prefs : unit -> unit + method show_diff : string -> string -> unit + + method status : string -> status + + method error_notice : string -> unit + end + + +open Viz_misc + +class ctrl w ~prefs ~manager ~status ~view : t = + object (self) + val mutable db = None + val mutable agraph = None + val mutable prefs = prefs + val mutable query = None + val mutable open_d = None + + method private get_query = + match query with + | Some q -> q + | None -> + let q = Query.make self in + query <- Some q ; + q + + method private get_open_d = + match open_d with + | Some d -> d + | None -> + let d = Ui.Open.make self in + open_d <- Some d ; + d + + method get_db = db + method get_agraph = agraph + method get_prefs = prefs + + method get_toplevel = w + + method set_prefs new_prefs = + let old_prefs = prefs in + prefs <- new_prefs ; + Ui.Prefs.update_prefs self old_prefs new_prefs + + method open_db ?id ?branch fname = + self#close_db () ; + let m_db = Database.open_db fname in + db <- Some m_db ; + View.open_db view self ; + Ui.open_db manager self ; + may + (View.Branch_selector.set_branch + view.View.selector self ?id) + branch + + method close_db () = + may Database.close_db db ; + db <- None ; + may Agraph.abort_layout agraph ; + agraph <- None ; + View.close_db view self ; + Ui.close_db manager self + + method finalize () = + may Database.close_db db + + method display_certs id = + View.Info_Display.fetch_and_display_data + view.View.info self id + + method focus_find_entry () = + View.Find.focus_find_entry view.View.find + + method get_current_cert_value = + View.Info_Display.get_current_cert_value + view.View.info + + method reload () = + let fname = maybe Database.get_filename db in + self#close_db () ; + may + (self#open_db + ?id:self#get_selected_node + ?branch:(View.Branch_selector.get_branch view.View.selector)) + fname + + method zoom_in = + View.Canvas.zoom view.View.canvas self `IN + method zoom_out = + View.Canvas.zoom view.View.canvas self `OUT + + method re_layout () = + may + (fun g -> + self#query + { Viz_types.query = Agraph.get_query g ; + Viz_types.preselect = self#get_selected_node }) + agraph + + method private clear = + View.clear view self ; + Ui.clear manager ; + may Query.clear query + + + method redraw () = + self#clear ; + View.update view self None + + method query query = + may Agraph.abort_layout agraph ; + agraph <- None ; + self#clear ; + may + (fun db -> + let g1 = + (self#status "agraph")#with_status + "Building ancestry graph" + (fun () -> + Ui.nice_fetch + (fun db -> Database.fetch_ancestry_graph db query.Viz_types.query) + db) in + let g2 = + Agraph.make + g1 + query.Viz_types.query + self#layout_params + (self#status "dot") + (function + | `LAYOUT_ERROR msg -> + self#error_notice msg + | `LAYOUT_DONE -> + View.update + view self + query.Viz_types.preselect) in + agraph <- Some g2) + db + + method private layout_params = + let (w, h) = View.Canvas.id_size view.View.canvas self in + { Agraph.box_w = float w ; + Agraph.box_h = float h ; + Agraph.lr_layout = prefs.Viz_style.lr_layout ; + Agraph.dot_program = prefs.Viz_style.dot_path } + + method get_selected_node = + View.get_selected_node view + + method find id = + View.Find.locate view.View.find self id + + method switch_branch (branch, id) = + View.Branch_selector.set_branch + view.View.selector self ~id branch + + method update_begin = + Ui.update_begin manager ; + may Query.activate query ; + + method update_end = () + + method center_on n = + View.Canvas.center_on view.View.canvas self n + + method center_on_by_id id = + match agraph with + | None -> () + | Some g -> + self#center_on (Agraph.get_node g id) + + method view_popup (popup_id, button) = + Ui.popup manager self + ~popup_id + button + + method cert_popup button = + Ui.popup_cert manager button + + method show_open () = + may + self#open_db + (Ui.Open.show self#get_open_d) + + method show_search () = + Query.show self#get_query + + method show_prefs = + Ui.Prefs.show self + + method show_diff id1 id2 = + Unidiff.show self id1 id2 + + method status = status + + method error_notice msg = + Ui.error_notice + ~parent:w + msg + + initializer + View.setup view self ; + Ui.setup manager self + end + + + + + +let make w ~aa ~prefs = + let b = GPack.vbox ~packing:w#add () in + let manager = Ui.make ~packing:b#pack in + let status = new Ui.status_bar ~packing:(b#pack ~from:`END) in + let status = Viz_misc.make_cache status in + let view = View.make ~aa ~packing:b#pack in + new ctrl w ~prefs ~manager ~status ~view + ======================================================================== --- app.mli +++ app.mli 2e5bf23cbb20daae7194c707c757764bb768917f @@ -0,0 +1,52 @@ +class type status = + object + method push : string -> unit + method pop : unit -> unit + method progress_start : string -> int -> unit + method progress : int -> unit + method progress_end : unit -> unit + method with_status : string -> (unit -> 'a) -> 'a + end + +class type t = + object + method get_db : Database.t option + method get_agraph : Agraph.t option + method get_prefs : Viz_style.prefs + method get_toplevel : GWindow.window + + method set_prefs : Viz_style.prefs -> unit + + method open_db : ?id:string -> ?branch:string -> string -> unit + method close_db : unit -> unit + method finalize : unit -> unit + method display_certs : string -> unit + method focus_find_entry : unit -> unit + method get_current_cert_value : string option + method reload : unit -> unit + method zoom_in : unit -> unit + method zoom_out : unit -> unit + method re_layout : unit -> unit + method redraw : unit -> unit + method query : Viz_types.select_info -> unit + method get_selected_node : string option + method find : string -> unit + method switch_branch : string * string -> unit + method update_begin : unit + method update_end : unit + method center_on :string * Viz_types.c_node -> unit + method center_on_by_id : string -> unit + method view_popup : string * int -> unit + method cert_popup : int -> unit + + method show_open : unit -> unit + method show_search : unit -> unit + method show_prefs : unit -> unit + method show_diff : string -> string -> unit + + method status : string -> status + + method error_notice : string -> unit + end + +val make : GWindow.window -> aa:bool -> prefs:Viz_style.prefs -> t ======================================================================== --- database.mli 16ab65994da34c28262d423624e154ff3652cae5 +++ database.mli 92a7d49361cafc56f963f7d5188f9705f3f53705 @@ -25,12 +25,12 @@ val run_monotone_diff : t -> string -> - Status.reporter -> + unit; pop : unit -> unit; ..> -> ([>`SUB_PROC_ERROR of string | `OUTPUT of string] -> unit) -> string * string -> unit val run_monotone_select : t -> string -> - Status.reporter -> + unit; pop : unit -> unit; ..> -> ([>`SUB_PROC_ERROR of string | `IDS of string list] -> unit) -> string list -> Subprocess.t ======================================================================== --- main.ml 8159bc944a1ff286d7ca279944691d7e19a13177 +++ main.ml 76d695d2ec4c7849db39b9f51b390c4931aabcb3 @@ -100,11 +100,12 @@ (!aa, parse_options (Q.to_list !anons)) -let exn_handler w exn = - View.error_notice ~parent:w +let exn_handler parent exn = + Ui.error_notice ~parent (match exn with | Viz_types.Error msg -> msg - | exn -> Printexc.to_string exn) + | exn -> + Printf.sprintf "Uncaught exception: %s" (Printexc.to_string exn)) let main = let w = GWindow.window @@ -118,7 +119,7 @@ let prefs = Viz_style.load () in - let v = Ui.get_view (Ui.make w ~aa ~prefs) in + let ctrl = App.make w ~aa ~prefs in ignore (Glib.Idle.add @@ -128,13 +129,13 @@ match mt_options with | MTopt_none -> () | MTopt_db fname -> - View.open_db v fname + ctrl#open_db fname | MTopt_branch (fname, branch) -> - View.open_db v ~branch fname + ctrl#open_db ~branch fname | MTopt_full (fname, branch, id) -> - View.open_db v ~id ~branch fname + ctrl#open_db ~id ~branch fname with Viz_types.Error msg -> - View.error_notice ~parent:w msg + ctrl#error_notice msg end ; false)) ; @@ -142,4 +143,4 @@ GMain.main () ; (* just close the db, without updating the widgets *) + ctrl#finalize () - View.finalize v ======================================================================== --- query.ml 0774985cb60091adbc66de0375801b89eb3dd7af +++ query.ml 4fd07dbfdaf0d7269f249ccc1df6acf01fd6368c @@ -37,12 +37,12 @@ | _ -> () - let select v status db g sel cont = + let select ctrl db g sel cont = let id = Database.run_monotone_select db - v.View.prefs.Viz_style.monotone_path - status + ctrl#get_prefs.Viz_style.monotone_path + (ctrl#status "search") (fun r -> running_select := None ; cont r) @@ -69,9 +69,10 @@ (* return false for merges *) false -let filter_by_revision_content status db revision_content ids = - Status.with_status - status +let filter_by_revision_content + (ctrl : (unit -> 'a) -> 'a; ..>; ..>) + db revision_content ids = + (ctrl#status "search")#with_status "Searching the monotone database ..." (fun () -> let pat = Gpattern.make revision_content in @@ -83,10 +84,9 @@ else acc) [] ids) - -let select_by_revision_content status db revision_content g = - filter_by_revision_content - status db revision_content +let select_by_revision_content ctrl db revision_content g = + filter_by_revision_content + ctrl db revision_content (Agraph.get_ids g) @@ -104,21 +104,21 @@ ids -let do_query status ~selector ~revision_content v results_cb = +let do_query ~selector ~revision_content ctrl results_cb = let no_results () = results_cb (`IDS []) in let results_ids db ids = results_cb (`IDS (expand_results db ids)) in - match v.View.db, v.View.agraph with + match ctrl#get_db, ctrl#get_agraph with | Some db, Some g when selector <> "" -> - Selector.select - v status db g selector + Selector.select + ctrl db g selector (function | `IDS ids when revision_content <> "" -> results_ids db (filter_by_revision_content - status db revision_content ids) + ctrl db revision_content ids) | `IDS ids -> results_ids db ids | `SUB_PROC_ERROR _ as err -> @@ -126,7 +126,7 @@ | Some db, Some g when revision_content <> "" -> results_ids db (select_by_revision_content - status db revision_content g) + ctrl db revision_content g) | _ -> no_results () @@ -190,7 +190,7 @@ let setup_results_view vbox = let (packing, set_label) = category "Results" ~expand:true vbox in let { model = model } as m = make_model () in - let packing = View.wrap_in_scroll_window packing in + let packing = Ui.wrap_in_scroll_window packing in let v = GTree.view ~model ~packing ~height:100 () in let add_string_renderer ?(props=[]) title col = let vc = GTree.view_column ~title () in @@ -217,24 +217,28 @@ m.model#set_sort_column_id m.col_date.GTree.index `DESCENDING +type t = { + window : [`CLOSE|`CLEAR|`DELETE_EVENT|`QUERY] GWindow.dialog ; + id_store : model ; + entries : GEdit.entry list ; + set_label : int -> unit ; + } -let make v = +let make ctrl = let w = GWindow.dialog ~title:"Monotone-viz Query" - ?parent:(View.get_toplevel v) - ~destroy_with_parent:true - ~border_width:8 - ~type_hint:`NORMAL () in + ~screen:ctrl#get_toplevel#screen + ~type_hint:`NORMAL + ~border_width:8 () in let (e1, e2) = setup_query_builder w#vbox in let (m, rv, set_label) = setup_results_view w#vbox in - let status = Status.new_reporter "query" in w#add_button_stock `CLOSE `CLOSE ; w#add_button_stock `CLEAR `CLEAR ; w#add_button_stock (`STOCK "mviz-query") `QUERY ; w#set_default_response `QUERY ; - ignore (w#connect#close w#misc#hide) ; + ignore (w#connect#after#close w#misc#hide) ; ignore (w#event#connect#delete (fun _ -> w#misc#hide () ; true)) ; ignore (e1#connect#activate (fun () -> @@ -250,12 +254,11 @@ set_label 0 | `QUERY -> w#set_response_sensitive `QUERY false ; - View.set_busy_cursor w true ; + Ui.set_busy_cursor w true ; do_query - status ~selector:e1#text ~revision_content:e2#text - v + ctrl (fun r -> begin match r with @@ -263,32 +266,31 @@ update_results m results ; set_label (List.length results) | `SUB_PROC_ERROR msg -> - View.error_notice ~parent:w msg + Ui.error_notice ~parent:w msg end ; - View.set_busy_cursor w false ; + Ui.set_busy_cursor w false ; w#set_response_sensitive `QUERY true))) ; ignore (rv#connect#row_activated (fun path view_col -> let id = let row = m.model#get_iter path in m.model#get ~row ~column:m.col_id in - View.Canvas.center_on_by_id v id)) ; + ctrl#center_on_by_id id)) ; - View.connect_event v - (function - | `CLEAR -> - Selector.abort () ; - clear_model m ; - set_label 0 ; - e1#set_text "" ; - e2#set_text "" ; - w#set_response_sensitive `QUERY false - | `UPDATE_BEGIN -> - w#set_response_sensitive `QUERY true - | _ -> ()) ; + { window = w ; + id_store = m ; + entries = [ e1 ; e2 ] ; + set_label = set_label } - w +let clear q = + Selector.abort () ; + clear_model q.id_store ; + q.set_label 0 ; + List.iter (fun e -> e#set_text "") q.entries ; + q.window#set_response_sensitive `QUERY false +let activate q = + q.window#set_response_sensitive `QUERY true + +let show q = + q.window#present () -let show v = - let p = lazy (make v) in - fun () -> (Lazy.force p)#present () ======================================================================== --- query.mli +++ query.mli 26219a504510f931da07f22a48af22f59b1eba47 @@ -0,0 +1,6 @@ +type t +val make : #App.t -> t + +val clear : t -> unit +val activate : t -> unit +val show : t -> unit ======================================================================== --- ui.ml 9f04b2665f883b08f4d714b5e311a958e9ad50b6 +++ ui.ml b6c845fc9089553842dde375c4047bc7c05b5658 @@ -1,6 +1,234 @@ open Viz_misc open Viz_types +let valid_utf8 = Glib.Utf8.validate + +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 d = GWindow.message_dialog + ~message ~message_type:`ERROR + ~buttons:GWindow.Buttons.close + ~parent ~destroy_with_parent:true ~show:true () in + ignore (d#connect#after#close d#destroy) ; + ignore (d#connect#response (fun _ -> d#destroy ())) + +let error_notice_f ~parent fmt = + Printf.kprintf (error_notice ~parent) fmt + +let with_grab f = + let w = Viz_gmisc.invisible_new () in + GtkMain.Grab.add w ; + try + let r = f () in + GtkMain.Grab.remove w ; GtkBase.Object.destroy w ; r + with exn -> + GtkMain.Grab.remove w ; GtkBase.Object.destroy w ; raise exn + +let nice_fetch f db = + with_grab (fun () -> + Database.with_progress + (fun () -> + while Glib.Main.iteration false do () done) + f + db) + +let add_label ~text ~packing = + ignore (GMisc.label ~text ~packing ()) + +let busy_cursor = lazy (Gdk.Cursor.create `WATCH) +let normal_cursor = lazy (Gdk.Cursor.create `LEFT_PTR) +let set_busy_cursor w busy = + Gdk.Window.set_cursor w#misc#window + (Lazy.force + (if busy then busy_cursor else normal_cursor)) + + + + +class status_bar ~packing = + let status = GMisc.statusbar ~packing () in + let progress = GRange.progress_bar () in + let _ = + (* work around some limitations in the GtkStatusBar mapping *) + let status_w = status#as_widget in + let b = GtkPack.Box.cast status_w in + GtkPack.Box.pack_end b progress#as_widget false false 0 ; + Gobject.Property.set_dyn status_w "has-resize-grip" (`BOOL false) in + fun description -> + object (self) + val ctx = status#new_context description + + method push msg = + ignore (ctx#push msg) + + method pop = + ctx#pop + + val mutable total = 0. + val mutable count = 0 + val mutable last_fraction = 0. + + method progress_start msg tot = + progress#set_fraction 0. ; + total <- float tot ; + count <- 0 ; + last_fraction <- 0. ; + ignore (ctx#push msg) + + method progress nb = + count <- count + nb ; + let f = float count /. total in + if f -. last_fraction >= 0.02 then begin + last_fraction <- f ; + progress#set_fraction f + end + + method progress_end () = + progress#set_fraction 0. ; + ctx#pop () + + method with_status : 'a. string -> (unit -> 'a) -> 'a = + fun msg f -> + self#push msg ; + try let res = f () in self#pop () ; res + with exn -> self#pop () ; raise exn + end + + + + +module Prefs = struct + let prefs_category title packing = + let _ = + GMisc.label + ~markup:(Printf.sprintf "%s" (Glib.Markup.escape_text title)) + ~xalign:0. + ~packing () in + let al = GBin.alignment ~border_width:8 ~packing () in + al#misc#set_property "left-padding" (`INT 16) ; + (GPack.vbox ~packing:al#add ())#pack + + let make ctrl = + let prefs = ref ctrl#get_prefs in + let w = GWindow.dialog + ~title:"Monotone-viz Preferences" + ~parent:ctrl#get_toplevel + ~destroy_with_parent:true + ~border_width:8 () in + begin + let packing = prefs_category "Ancestry Graph Layout" w#vbox#pack in + let button = + GButton.check_button + ~label:"left-to-right _layout" + ~use_mnemonic:true + ~active:!prefs.Viz_style.lr_layout + ~packing () in + ignore (button#connect#toggled (fun () -> + prefs := { !prefs with Viz_style.lr_layout = not !prefs.Viz_style.lr_layout })) + end ; + begin + let packing = prefs_category "Autocolouring" w#vbox#pack in + ignore + (List.fold_left + (fun group (label, autocolor_style) -> + let b = GButton.radio_button + ?group ~label + ~active:(!prefs.Viz_style.autocolor = autocolor_style) + ~packing () in + ignore (b#connect#toggled (fun () -> + if b#active then + prefs := { !prefs with Viz_style.autocolor = autocolor_style })) ; + if group = None then Some b#group else group) + None + [ "no automatic coloring", NONE ; + "color by key_id", BY_KEYID ; + "color by author", BY_AUTHOR_HASH ; + "color by branch", BY_BRANCH_HASH ] ) + end ; + begin + let packing = prefs_category "External Programs" w#vbox#pack in + let tb = GPack.table ~columns:2 ~rows:2 ~packing () in + begin + let _ = GMisc.label ~text:"monotone: " ~xalign:1. + ~packing:(tb#attach ~left:1 ~top:1) () in + let e = GEdit.entry ~text:(!prefs.Viz_style.monotone_path) + ~packing:(tb#attach ~left:2 ~top:1 ~expand:`X) () in + ignore (e#connect#changed (fun () -> + prefs := { !prefs with Viz_style.monotone_path = e#text })) + end ; + begin + let _ = GMisc.label ~text:"dot: " ~xalign:1. + ~packing:(tb#attach ~left:1 ~top:2) () in + let e = GEdit.entry ~text:(!prefs.Viz_style.dot_path) + ~packing:(tb#attach ~left:2 ~top:2 ~expand:`X) () in + ignore (e#connect#changed (fun () -> + prefs := { !prefs with Viz_style.dot_path = e#text })) + end ; + end ; + + w#add_button_stock `CLOSE `CLOSE ; + w#add_button_stock `SAVE `SAVE ; + w#add_button_stock `APPLY `APPLY ; + ignore (w#connect#after#close w#misc#hide) ; + ignore (w#event#connect#delete (fun _ -> w#misc#hide () ; true)) ; + ignore (w#connect#response (function + | `APPLY -> + ctrl#set_prefs !prefs + | `SAVE -> + Viz_style.save !prefs + | `CLOSE | `DELETE_EVENT -> + w#misc#hide ())) ; + w + + let update_prefs ctrl old_prefs p = + let need_layout = + old_prefs.Viz_style.font <> p.Viz_style.font || + old_prefs.Viz_style.lr_layout <> p.Viz_style.lr_layout in + let need_redraw = + old_prefs.Viz_style.autocolor <> p.Viz_style.autocolor || + old_prefs.Viz_style.style <> p.Viz_style.style in + if need_layout + then ctrl#re_layout () + else if need_redraw + then ctrl#redraw () + + let show ctrl = + let p = lazy (make ctrl) in + fun () -> (Lazy.force p)#present () + +end + + + +module Open = struct + type t = [`OPEN|`CLOSE|`DELETE_EVENT] GWindow.file_chooser_dialog + let make ctrl = + let dialog = GWindow.file_chooser_dialog + ~action:`OPEN ~parent:ctrl#get_toplevel + ~destroy_with_parent:true + ~title:"Open a Monotone database" () in + dialog#add_button_stock `CLOSE `CLOSE ; + dialog#add_select_button_stock `OPEN `OPEN ; + ignore (dialog#connect#after#close (fun () -> dialog#response `CLOSE)) ; + dialog + + let show dialog = + let resp = + match dialog#run () with + | `CLOSE | `DELETE_EVENT -> None + | `OPEN -> dialog#filename in + dialog#misc#hide () ; + resp +end + + + + let ui_info = "\ \ \ @@ -105,13 +333,15 @@ clipboard2 = GData.clipboard Gdk.Atom.primary } -let make_manager () = +let make ~packing = let m = GAction.ui_manager () in let (g_main, g_popup, g_view) = make_groups () in m#insert_action_group g_main 1 ; m#insert_action_group g_popup 2 ; m#insert_action_group g_view 3 ; ignore (m#add_ui_from_string ui_info) ; + packing (m#get_widget "/menubar") ; + packing (m#get_widget "/toolbar") ; { manager = m ; main_group = g_main; view_group = g_view ; popup_data = lazy (make_popup_data m g_popup) @@ -133,8 +363,13 @@ p.menu_cert#popup ~button ~time -let popup m v ~selected_id ~popup_id button = +let set_clipboard m data = let p = get_popup_data m in + p.clipboard1#set_text data ; + p.clipboard2#set_text data + +let popup m ctrl ~popup_id button = + let p = get_popup_data m in reset_popup_menu p popup_id ; let remember_signal o callback = p.signals <- (Gobject.coerce o#as_action, o#connect#activate ~callback) :: p.signals in @@ -143,25 +378,21 @@ begin let copy_revision = p.group#get_action "Copy_revision" in let copy_manifest = p.group#get_action "Copy_manifest" in - let data = Database.fetch_revision (some v.View.db) popup_id in + let data = Database.fetch_revision (some ctrl#get_db) popup_id in remember_signal copy_revision - (fun () -> - p.clipboard1#set_text data.revision_id ; - p.clipboard2#set_text data.revision_id) ; + (fun () -> set_clipboard m data.revision_id) ; remember_signal copy_manifest - (fun () -> - p.clipboard1#set_text data.manifest_id ; - p.clipboard2#set_text data.manifest_id) + (fun () -> set_clipboard m data.manifest_id) end ; (* Setup the "diff with other entry" *) begin let diff_other = p.group#get_action "Diff_other" in - match selected_id with + match ctrl#get_selected_node with | Some id when id <> popup_id -> diff_other#set_sensitive true ; remember_signal diff_other - (fun () -> View.view_diff v id popup_id) + (fun () -> ctrl#show_diff id popup_id) | _ -> diff_other#set_sensitive false end ; @@ -169,7 +400,7 @@ (* Setup the "diff with ancestor(s)" entry *) begin let diff_one = p.group#get_action "Diff_one" in - match View.get_ancestors v popup_id with + match Agraph.get_ancestors (some ctrl#get_agraph) popup_id with | [] -> p.diff_many#misc#hide () ; diff_one#set_visible true; @@ -177,7 +408,7 @@ | [ ancestor_id ] -> p.diff_many#misc#hide () ; remember_signal diff_one - (fun () -> View.view_diff v ancestor_id popup_id) ; + (fun () -> ctrl#show_diff ancestor_id popup_id) ; diff_one#set_visible true ; diff_one#set_sensitive true | a -> @@ -187,7 +418,7 @@ (fun (ancestor_id as label) -> let i = GMenu.menu_item ~label ~packing:submenu#append () in ignore (i#connect#activate - (fun () -> View.view_diff v ancestor_id popup_id))) + (fun () -> ctrl#show_diff ancestor_id popup_id))) a ; p.diff_many#misc#show () end ; @@ -197,253 +428,54 @@ p.menu#popup ~button ~time -class status_bar ~packing = - let status = GMisc.statusbar ~packing () in - let progress = GRange.progress_bar () in - let _ = - (* work around some limitations in the GtkStatusBar mapping *) - let status_w = status#as_widget in - let b = GtkPack.Box.cast status_w in - GtkPack.Box.pack_end b progress#as_widget false false 0 ; - Gobject.Property.set_dyn status_w "has-resize-grip" (`BOOL false) in - fun description -> - object - val ctx = status#new_context description - method push msg = - ignore (ctx#push msg) - method pop = - ctx#pop - val mutable total = 0. - val mutable count = 0 - val mutable last_fraction = 0. - - method progress_start msg tot = - progress#set_fraction 0. ; - total <- float tot ; - count <- 0 ; - last_fraction <- 0. ; - ignore (ctx#push msg) - method progress nb = - count <- count + nb ; - let f = float count /. total in - if f -. last_fraction >= 0.02 then begin - last_fraction <- f ; - progress#set_fraction f - end - method progress_end () = - progress#set_fraction 0. ; - ctx#pop () - end -module Prefs = struct - let prefs_category title packing = - let _ = - GMisc.label - ~markup:(Printf.sprintf "%s" (Glib.Markup.escape_text title)) - ~xalign:0. - ~packing () in - let al = GBin.alignment ~border_width:8 ~packing () in - al#misc#set_property "left-padding" (`INT 16) ; - (GPack.vbox ~packing:al#add ())#pack - let make v = - let prefs = ref v.View.prefs in - let w = GWindow.dialog - ~title:"Monotone-viz Preferences" - ?parent:(View.get_toplevel v) - ~destroy_with_parent:true - ~border_width:8 () in - begin - let packing = prefs_category "Ancestry Graph Layout" w#vbox#pack in - let button = - GButton.check_button - ~label:"left-to-right _layout" - ~use_mnemonic:true - ~active:!prefs.Viz_style.lr_layout - ~packing () in - ignore (button#connect#toggled (fun () -> - prefs := { !prefs with Viz_style.lr_layout = not !prefs.Viz_style.lr_layout })) - end ; - begin - let packing = prefs_category "Autocolouring" w#vbox#pack in - ignore - (List.fold_left - (fun group (label, autocolor_style) -> - let b = GButton.radio_button - ?group ~label - ~active:(!prefs.Viz_style.autocolor = autocolor_style) - ~packing () in - ignore (b#connect#toggled (fun () -> - if b#active then - prefs := { !prefs with Viz_style.autocolor = autocolor_style })) ; - if group = None then Some b#group else group) - None - [ "no automatic coloring", NONE ; - "color by key_id", BY_KEYID ; - "color by author", BY_AUTHOR_HASH ; - "color by branch", BY_BRANCH_HASH ] ) - end ; - begin - let packing = prefs_category "External Programs" w#vbox#pack in - let tb = GPack.table ~columns:2 ~rows:2 ~packing () in - begin - let _ = GMisc.label ~text:"monotone: " ~xalign:1. - ~packing:(tb#attach ~left:1 ~top:1) () in - let e = GEdit.entry ~text:(!prefs.Viz_style.monotone_path) - ~packing:(tb#attach ~left:2 ~top:1 ~expand:`X) () in - ignore (e#connect#changed (fun () -> - prefs := { !prefs with Viz_style.monotone_path = e#text })) - end ; - begin - let _ = GMisc.label ~text:"dot: " ~xalign:1. - ~packing:(tb#attach ~left:1 ~top:2) () in - let e = GEdit.entry ~text:(!prefs.Viz_style.dot_path) - ~packing:(tb#attach ~left:2 ~top:2 ~expand:`X) () in - ignore (e#connect#changed (fun () -> - prefs := { !prefs with Viz_style.dot_path = e#text })) - end ; - end ; - w#add_button_stock `CLOSE `CLOSE ; - w#add_button_stock `SAVE `SAVE ; - w#add_button_stock `APPLY `APPLY ; - ignore (w#connect#close w#misc#hide) ; - ignore (w#event#connect#delete (fun _ -> w#misc#hide () ; true)) ; - ignore (w#connect#response (function - | `APPLY -> - View.set_prefs v !prefs - | `SAVE -> - Viz_style.save !prefs - | `CLOSE | `DELETE_EVENT -> - w#misc#hide ())) ; - w - let show v = - let p = lazy (make v) in - fun () -> (Lazy.force p)#present () -end -type t = { - ui_manager : manager ; - open_dialog : [`OPEN|`CLOSE|`DELETE_EVENT] GWindow.file_chooser_dialog Lazy.t ; - view : View.t ; - } -let get_view { view = v } = v -let show_open_dialog d = - let dialog = Lazy.force d in - let resp = - match dialog#run () with - | `CLOSE | `DELETE_EVENT -> None - | `OPEN -> dialog#filename in - dialog#misc#hide () ; - resp +let setup ({ manager = ui } as m) ctrl = + ctrl#get_toplevel#add_accel_group + m.manager#get_accel_group ; -let make w ~aa ~prefs = - let b = GPack.vbox ~packing:w#add () in + let action_connect name callback = + ignore ((ui#get_action name)#connect#activate ~callback) in - let { manager = ui } as manager = make_manager () in - w#add_accel_group ui#get_accel_group ; + action_connect "/toolbar/Close" ctrl#close_db ; + action_connect "/toolbar/Open" ctrl#show_open ; + action_connect "/toolbar/Quit" GMain.quit ; + action_connect "/toolbar/Zoom_in" ctrl#zoom_in ; + action_connect "/toolbar/Zoom_out" ctrl#zoom_out ; + action_connect "/toolbar/Refresh" ctrl#reload ; + action_connect "/toolbar/Prefs" ctrl#show_prefs ; + action_connect "/toolbar/Query" ctrl#show_search ; + action_connect "/popup/Certs" + (fun () -> ctrl#display_certs (get_popup_data m).popup_id) ; + action_connect "/popup_cert/Copy_cert" + (fun () -> + may + (set_clipboard m) + ctrl#get_current_cert_value) ; + action_connect "/FindEntry" ctrl#focus_find_entry - (* Menubar & Toolbar *) - b#pack (ui#get_widget "/menubar") ; - b#pack (ui#get_widget "/toolbar") ; - (* Statusbar *) - Status.make_reporter := new status_bar ~packing:(b#pack ~from:`END) ; +let open_db m ctrl = + (m.manager#get_action "/toolbar/Close")#set_sensitive true - (* View *) - let v = View.make ~aa ~prefs ~packing:(b#pack ~expand:true) in - - let open_dialog = lazy - begin - let dialog = GWindow.file_chooser_dialog - ~action:`OPEN ~parent:w - ~title:"Open a Monotone database" () in - dialog#add_button_stock `CLOSE `CLOSE ; - dialog#add_select_button_stock `OPEN `OPEN ; - ignore (dialog#connect#close (fun () -> dialog#response `CLOSE)) ; - dialog - end in +let close_db m ctrl = + (m.manager#get_action "/toolbar/Close")#set_sensitive false - (* Connect signals and actions *) - begin - let action_connect name callback = - ignore ((ui#get_action name)#connect#activate ~callback) in +let clear m = + m.view_group#set_sensitive false +let update_begin m = + m.view_group#set_sensitive true - action_connect "/toolbar/Close" - (fun () -> View.close v) ; - - action_connect "/toolbar/Open" - (fun () -> - may - (fun db_fname -> View.open_db v db_fname) - (show_open_dialog open_dialog)) ; - - action_connect "/toolbar/Quit" GMain.quit ; - - action_connect "/toolbar/Zoom_in" - (View.zoom v `IN) ; - - action_connect "/toolbar/Zoom_out" - (View.zoom v `OUT) ; - - action_connect "/toolbar/Refresh" - (fun () -> View.reload v) ; - - action_connect "/toolbar/Prefs" - (Prefs.show v) ; - - action_connect "/toolbar/Query" - (Query.show v) ; - - action_connect "/popup/Certs" - (fun () -> - View.display_certs v - (get_popup_data manager).popup_id) ; - - action_connect "/popup_cert/Copy_cert" - (fun () -> - may - (fun c -> - let p = get_popup_data manager in - p.clipboard1#set_text c ; - p.clipboard2#set_text c) - (View.Info_Display.get_current_cert_value v)) ; - - action_connect "/FindEntry" - (fun () -> View.Find.focus_find_entry v) ; - - let view_group = manager.view_group in - let action_close = ui#get_action "/toolbar/Close" in - - View.connect_event v - (function - | `OPEN_DB -> - action_close#set_sensitive true - | `CLOSE_DB -> - action_close#set_sensitive false - | `CLEAR -> - view_group#set_sensitive false - | `UPDATE_BEGIN -> - view_group#set_sensitive true - | `NODE_POPUP (popup_id, button) -> - popup manager v ~selected_id:(v.View.selected_node) ~popup_id button - | `CERT_POPUP button -> - popup_cert manager button - | _ -> ()) - end ; - - { ui_manager = manager ; - open_dialog = open_dialog ; - view = v ; } - ======================================================================== --- ui.mli +++ ui.mli 08c8f50676d3c3b1e5f2f2e479b6b343b3ca7012 @@ -0,0 +1,46 @@ +val valid_utf8 : string -> bool + +val error_notice : parent:#GWindow.window_skel -> string -> unit +val error_notice_f : + parent:#GWindow.window_skel -> ('a, unit, string, unit) format4 -> 'a + +val nice_fetch : (Database.t -> 'a) -> Database.t -> 'a + +val wrap_in_scroll_window : (GObj.widget -> unit) -> GObj.widget -> unit +val add_label : text:string -> packing:(GObj.widget -> unit) -> unit + +val set_busy_cursor : #GObj.widget -> bool -> unit + + +class status_bar : + packing:(GObj.widget -> unit) -> + string -> + App.status + +module Prefs : sig + val update_prefs : + #App.t -> + Viz_style.prefs -> Viz_style.prefs -> unit + val show : #App.t -> unit -> unit +end + +module Open : sig + type t + val make : #App.t -> t + val show : t -> string option +end + + +type manager +val make : packing:(GObj.widget -> 'a) -> manager +val setup : manager -> #App.t -> unit + +val popup : + manager -> #App.t -> + popup_id:string -> int -> unit +val popup_cert : manager -> int -> unit +val open_db : manager -> #App.t -> unit +val close_db : manager -> #App.t -> unit +val clear : manager -> unit +val update_begin : manager -> unit + ======================================================================== --- unidiff.ml 8364675a96bfe736ac395bc7f4924ddfa2755928 +++ unidiff.ml c91173ccdf199cfe6a93689b234f7864c7353110 @@ -92,6 +92,7 @@ s#add_button_stock `CANCEL `CANCEL ; s#add_select_button_stock `SAVE `SAVE ; s#set_default_response `SAVE ; + ignore (s#connect#after#close s#misc#hide) ; ignore (s#connect#response (function | `CANCEL | `DELETE_EVENT -> s#misc#hide () | `SAVE -> @@ -104,16 +105,18 @@ Viz_types.errorf "Could not write monotone diff output to '%s'" f)) ; s -let view_diff ?parent (junk_end, tags_coords) text orig_text = +let view_diff ctrl (junk_end, tags_coords) text orig_text = let window = GWindow.dialog - ~no_separator:true ?parent + ~no_separator:true ~title:"Monotone diff output" + ~screen:ctrl#get_toplevel#screen ~type_hint:`NORMAL () in window#add_button_stock `SAVE `SAVE ; window#add_button_stock `CLOSE `CLOSE ; window#set_default_response `CLOSE ; let s = lazy (save_dialog window orig_text) in + ignore (window#connect#after#close window#destroy) ; ignore (window#connect#response (function | `CLOSE | `DELETE_EVENT -> window#destroy () | `SAVE -> (Lazy.force s)#present () )) ; @@ -206,19 +209,38 @@ else careful_convert_utf8 s -let view ~parent text = - let parent = GWindow.toplevel parent in +let view ctrl text = try let display_text = utf8ize text in - view_diff ?parent (analyze_diff_output display_text) display_text text + view_diff ctrl (analyze_diff_output display_text) display_text text with Not_found -> let d = GWindow.message_dialog ~message:"No changes" ~message_type:`INFO ~buttons:GWindow.Buttons.close - ?parent + ~parent:ctrl#get_toplevel ~destroy_with_parent:true ~title:"Monotone diff output" () in - ignore (d#connect#response (fun _ -> d#destroy ())) ; + ignore (d#connect#close d#misc#hide) ; + ignore (d#connect#response (fun _ -> d#misc#hide ())) ; d#show () + +let show ctrl old_id new_id = + match ctrl#get_db with + | None -> () + | Some db -> + try + Database.run_monotone_diff + db + ctrl#get_prefs.Viz_style.monotone_path + (ctrl#status "monotone") + (fun res -> + match res with + | `OUTPUT d -> + view ctrl d + | `SUB_PROC_ERROR msg -> + ctrl#error_notice msg) + (old_id, new_id) + with Viz_types.Error msg -> + ctrl#error_notice msg ======================================================================== --- unidiff.mli d31d60a0f12c3a892bf4a12581dc1d8cf7aee0ee +++ unidiff.mli a99a05e08d5504eb5e064d5120d50d64b204def2 @@ -1,2 +1 @@ -val view : parent:#GObj.widget -> string -> unit - +val show : #App.t -> string -> string -> unit ======================================================================== --- view.ml 6ee2e4a63701af0bdeed8b77a544f91ef9b96c93 +++ view.ml 6302ab124e672800f67cf9fc3288bc83b16c3345 @@ -1,139 +1,31 @@ open Viz_misc open Viz_types open Revision_types +open Ui -let valid_utf8 = Glib.Utf8.validate +let ( ++ ) x f = f x -let wrap_in_scroll_window packing = - let sw = GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC ~packing () in - sw#add + +module Info_Display = struct + type t = { + revision_label : GMisc.label ; + empty_label : string ; -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 ())) + revision_c_type : GtkStock.id GTree.column ; + revision_c_file : string GTree.column ; + revision_model : GTree.tree_store ; + revision_view : GTree.view ; -let error_notice_f ~parent fmt = - Printf.kprintf (error_notice ~parent) fmt + 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 ; -let with_grab f = - let w = Viz_gmisc.invisible_new () in - GtkMain.Grab.add w ; - try let r = f () in GtkMain.Grab.remove w ; r - with exn -> GtkMain.Grab.remove w ; raise exn + mutable current_row : Gtk.tree_path option ; + } -let nice_fetch f db = - with_grab (fun () -> - Database.with_progress - (fun () -> - while Glib.Main.iteration false do () done) - f - db) - -let busy_cursor = lazy (Gdk.Cursor.create `WATCH) -let normal_cursor = lazy (Gdk.Cursor.create `LEFT_PTR) -let set_busy_cursor w busy = - Gdk.Window.set_cursor w#misc#window - (Lazy.force - (if busy then busy_cursor else normal_cursor)) - -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 ; - - mutable current_row : Gtk.tree_path option ; - } - -type select_info = { - query : Viz_types.query ; - preselect : string option ; - } -type branch_selector = { - combo : GEdit.combo_box GEdit.text_combo ; - mutable combo_signal : GtkSignal.id option ; - sub : GButton.toggle_button ; - mutable branches : string array ; - select_signal : select_info Signal.t ; - mutable preselected_id : string option ; - } - -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 * string - | `CERT_POPUP of int] - -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 ; - mutable drag_active : bool ; - } - -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 @@ -273,23 +165,23 @@ current_row = None ; } - let setup_popup v = + let setup info ctrl = (* setup the signal for the popup menu *) - ignore (v.info.cert_view#event#connect#button_press (fun ev -> + 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 v.info.cert_view#get_path_at_pos ~x ~y with - | Some (path, _, _, _) -> v.info.current_row <- Some path - | None -> v.info.current_row <- None + match info.cert_view#get_path_at_pos ~x ~y with + | Some (path, _, _, _) -> info.current_row <- Some path + | None -> info.current_row <- None end ; - Signal.emit v.event_signal (`CERT_POPUP button) + ctrl#cert_popup button end ; false)) - let clear_info { info = i } = + let clear i = i.current_row <- None ; i.revision_label#set_label i.empty_label ; i.revision_model#clear () ; @@ -376,29 +268,40 @@ 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 v id = - let data = - 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 in - display_info v.info - (filter_certs v.prefs.Viz_style.ignored_certs data) + 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 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 v = + let get_current_cert_value info = maybe (fun path -> - v.info.cert_model#get - ~row:(v.info.cert_model#get_iter path) - ~column:v.info.cert_c_value) - v.info.current_row + info.cert_model#get + ~row:(info.cert_model#get_iter path) + ~column:info.cert_c_value) + info.current_row end module Branch_selector = struct - let select_branch s = + type t = { + combo : GEdit.combo_box GEdit.text_combo ; + mutable combo_signal : GtkSignal.id option ; + sub : GButton.toggle_button ; + mutable branches : string array ; + mutable preselected_id : string option ; + } + + let select_branch s ctrl = let (combo, _) = s.combo in let id = s.preselected_id in s.preselected_id <- None ; @@ -421,22 +324,31 @@ end else QUERY_BRANCHES [ b ] in - Signal.emit s.select_signal + ctrl#query { query = (query, QUERY_NO_LIMIT) ; preselect = id } 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 with_inactive_combo s f = + match s.combo_signal with + | None -> + f s.combo + | Some id -> + let combo_w = + let (combo_w, _) = s.combo in + combo_w#as_widget in + GtkSignal.handler_block combo_w id ; + try + f s.combo ; + GtkSignal.handler_unblock combo_w id + with exn -> + GtkSignal.handler_unblock combo_w id ; + raise exn let make ~packing = - let hb = GPack.hbox ~border_width:4 ~packing () in let combo = - ignore (GMisc.label ~text:"Branch: " ~packing:hb#pack ()) ; + add_label ~text:"Branch: " ~packing ; let (model, column) as store = GTree.store_of_list Gobject.Data.string [] in - let combo = GEdit.combo_box ~model ~packing:hb#pack () in + let combo = GEdit.combo_box ~model ~packing () in let r = GTree.cell_renderer_text [] in combo#pack r ; combo#add_attribute r "markup" column ; @@ -444,49 +356,31 @@ let checkb = GButton.check_button ~label:"Include sub-branches" - ~active:false ~packing:hb#pack () 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, tag or date (YYYY-MM-DD)" - entry#coerce - end ; - let lbl = GMisc.label ~text:"Find:" ~packing:(hb#pack ~from:`END) () in - let c = - { combo = combo ; combo_signal = None ; - sub = checkb ; branches = [||] ; - select_signal = Signal.make () ; - preselected_id = None } in - begin - let callback () = - ignore (Glib.Idle.add (fun () -> - try select_branch c ; false - with Viz_types.Error msg -> - error_notice ~parent:hb msg ; false)) in - let (combo, _) = combo in - c.combo_signal <- Some (combo#connect#changed ~callback) ; - ignore (checkb#connect#toggled ~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) + ~active:false ~packing () in + { combo = combo ; combo_signal = None ; + sub = checkb ; branches = [||] ; + preselected_id = None } - let connect v f = - Signal.connect v.selector.select_signal f + let setup s ctrl = + let (combo, _) = s.combo in + let callback () = + ignore (Glib.Idle.add (fun () -> + try select_branch s ctrl ; false + with Viz_types.Error msg -> + ctrl#error_notice msg ; false)) in + s.combo_signal <- Some (combo#connect#changed ~callback) ; + ignore (s.sub#connect#toggled ~callback) - let get_display_sub_branches v = v.selector.sub#active - - let clear { selector = s } = + let clear s = s.branches <- [||] ; s.preselected_id <- None ; with_inactive_combo s (fun (_, (model, _)) -> model#clear ()) - let populate { selector = s } br = + let populate s br = with_inactive_combo s (fun (combo, (model, column)) -> + assert (model#get_iter_first = None) ; s.branches <- Array.of_list br ; begin let row = model#append () in @@ -504,18 +398,19 @@ end) br) - let set_branch { selector = s } ?id b = + let set_branch s ctrl ?id b = let (combo, _) = s.combo in s.preselected_id <- id ; combo#set_active begin try 1 + array_index s.branches b with Not_found -> - error_notice_f ~parent:s.sub "Could not find the branch '%s'" b ; + ctrl#error_notice + (Printf.sprintf "Could not find the branch '%s'" b) ; -1 end - let get_branch { selector = s } = + let get_branch s = let (combo, _) = s.combo in match combo#active with | i when i > 0 -> Some s.branches.(i - 1) @@ -523,9 +418,19 @@ 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 ; @@ -563,41 +468,44 @@ | `PARENT | `CHILD -> match k.previous_selected_node with | None -> Some (List.hd sx) - | Some p_id -> + | 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 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 + | `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 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 id d - let select { keyboard_nav = k } id = + let select k id = if not (navigate_is_sibling k id) then k.keyboard_nav_siblings <- [] - let clear { keyboard_nav = k } = + let clear k = k.previous_selected_node <- None ; k.keyboard_nav_siblings <- [] @@ -614,53 +522,145 @@ external pango_fix : unit -> unit = "ml_fix_libgnomecanvas_pango" let _ = pango_fix () - let set_busy_cursor canvas busy = - set_busy_cursor canvas.w busy + 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 () ; - ignore (canvas#event#connect#button_press (fun ev -> - canvas#misc#grab_focus () ; - false)) ; - { w = canvas ; + { 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 get_string_font_descr v = - v.prefs.Viz_style.font + let dnd_targets = [| + { Gtk.target = "text/uri-list" ; Gtk.flags = [] ; Gtk.info = 0 } ; + { Gtk.target = "text/plain" ; Gtk.flags = [] ; Gtk.info = 1 } ; + |] - let get_pango_font_descr v = - Pango.Font.from_string (get_string_font_descr v) + 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 set_busy_cursor c busy = + set_busy_cursor c.canvas busy + + 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 v = - let desc = get_pango_font_descr v in - v.canvas.w#misc#pango_context#get_metrics ~desc () + let get_font_metrics c ctrl = + let desc = get_pango_font_descr ctrl in + c.canvas#misc#pango_context#get_metrics ~desc () - let zoom ({ canvas = canv } as v) dir () = - let old_ppu = canv.ppu in + let zoom c ctrl dir () = + let old_ppu = c.ppu in begin match dir with - | `IN -> canv.ppu <- canv.ppu *. sqrt 2. - | `OUT -> canv.ppu <- canv.ppu /. sqrt 2. + | `IN -> c.ppu <- c.ppu *. sqrt 2. + | `OUT -> c.ppu <- c.ppu /. sqrt 2. end ; - canv.w#set_pixels_per_unit canv.ppu ; - let font_size = get_font_size (get_string_font_descr v) in + 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%!" canv.ppu (canv.ppu *. font_size) ; - let new_size = canv.ppu *. font_size in + 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 @@ -670,43 +670,40 @@ else (* disable label when zooming out a lot: it's unreadable anyway *) t#hide ()) - canv.text_items + c.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 display_selection_marker c ctrl sel = + c.selected_node <- Some sel ; + let (id, node_data) = sel in 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 + let marker = c.selected_marker in marker#set [ `X1 x1; `X2 x2; `Y1 y1; `Y2 y2 ] ; marker#lower_to_bottom () ; - marker#show () + marker#show () ; + KeyNav.select c.keynav id ; + ctrl#display_certs id - let clear ({ canvas = c } as v) = + let clear c ctrl = may (fun g -> g#destroy ()) c.branch_items ; c.branch_items <- None ; c.text_items <- [] ; c.selected_marker#hide () ; + KeyNav.clear c.keynav ; 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 + (ctrl#status "canvas")#progress_end () ; + set_busy_cursor c false) + c.background_rendering let id_width = 8 - let id_size c = - let metrics = get_font_metrics c in + 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 @@ -727,40 +724,36 @@ 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 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.w#hadjustment in + let a = c.canvas#hadjustment in scroll a#value a#page_size (float c_x) n.n_w in let y = - let a = c.w#vadjustment in + let a = c.canvas#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) + c.canvas#scroll_to ~x ~y ; + display_selection_marker c ctrl sel - let center_on_by_id v id = - match v.agraph with - | Some g -> - center_on v (Agraph.get_node g id) - | None -> () - let default_node_props = [ `OUTLINE_COLOR "black" ; `WIDTH_PIXELS 2 ], [ `FILL_COLOR "black" ] let border = 10. - let update_graph v preselect_id = - let canvas = v.canvas.w in - let graph = some v.agraph in + 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 v.db in - let lr_layout = v.prefs.Viz_style.lr_layout 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 v.canvas.ppu ; + 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) @@ -793,17 +786,15 @@ set_page_incr canvas#vadjustment end ; - let main_group = GnoCanvas.group ~x:0. ~y:0. canvas#root in + 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 = prefs.Viz_style.font in let font_size = get_font_size font in - let font_desc = get_pango_font_descr v in + let font_desc = Pango.Font.from_string font in - let match_style = Viz_style.match_style v.prefs graph db 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 @@ -826,13 +817,13 @@ then rect#affine_relative [| 0.5 ; 0.5 ; 0.5 ; -0.5 ; 0. ; 0. |] ; if node.c_kind = REGULAR || is_neighbor node then begin - let scaled_font_size = font_size *. v.canvas.ppu in + let scaled_font_size = font_size *. c.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 + c.text_items <- t :: c.text_items end ; ignore (g#connect#event @@ -840,12 +831,11 @@ | `BUTTON_PRESS b -> begin match GdkEvent.Button.button b with | 1 -> - KeyNav.select v id ; - Signal.emit v.event_signal (`NODE_SELECT id) ; - v.drag_active <- true ; + display_selection_marker c ctrl (id, node) ; + c.drag_active <- true ; true | 3 -> - Signal.emit v.event_signal (`NODE_POPUP (id, 3)) ; + ctrl#view_popup (id, 3) ; true | _ -> false end @@ -853,7 +843,7 @@ begin match Database.fetch_cert_value db id "branch" with | other_branch :: _ -> - Signal.emit v.event_signal (`NODE_SWITCH_BRANCH (other_branch, id)) + ctrl#switch_branch (other_branch, id) | [] -> () end ; true | _ -> false)) ; @@ -899,54 +889,54 @@ 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 + | `KEY_PRESS k when c.selected_node <> None -> + may + (center_on c ctrl) + (KeyNav.navigate c.keynav ctrl k) ; + true | _ -> false)) ; - v.canvas.branch_items <- Some main_group ; - let presel_node = - maybe (fun id -> NodeMap.find id layout.c_nodes) 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 + c.branch_items <- Some main_group ; 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) - layout.c_edges - acc in - let q = - List.sort - (fun ((p1 : float), _) (p2, _) -> compare p2 p1) - q in - + 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) + layout.c_edges + acc in + let q = + List.sort + (fun ((p1 : float), _) (p2, _) -> compare p2 p1) + q in + ref q, count in + let id = - let q = ref q in Glib.Idle.add (fun () -> try for i = 1 to 10 do @@ -956,182 +946,139 @@ q := tl ; action () done ; true with Exit -> - v.canvas.background_rendering <- None ; + c.background_rendering <- None ; pr#progress_end () ; - set_busy_cursor v.canvas false ; - Signal.emit v.event_signal `UPDATE_END ; + set_busy_cursor c false ; + ctrl#update_end ; false | exn -> Printf.eprintf "Uncaught exception: '%s'\n%!" (Printexc.to_string exn) ; true) in may - (fun id -> ignore (Glib.Idle.add (fun () -> center_on_by_id v id ; false))) + (fun id -> ignore (Glib.Idle.add (fun () -> ctrl#center_on_by_id id ; false))) preselect_id ; - v.canvas.background_rendering <- Some id ; + c.background_rendering <- Some id ; pr#progress_start "Drawing ancestry graph ..." count ; - set_busy_cursor v.canvas true ; - Signal.emit v.event_signal `UPDATE_BEGIN + set_busy_cursor c true ; + ctrl#update_begin end module Find = struct - let clear v = - v.find.find_entry#set_text "" ; - v.find.last_find <- "", [] + type t = { + mutable last_find : string * (string * Viz_types.c_node) list ; + find_entry : GEdit.entry ; + } - let connect v f = - Signal.connect v.find.find_signal f + let make ~packing = + let entry = GEdit.entry ~packing () in + begin + let tooltips = GData.tooltips () in + tooltips#set_tip + ~text:"Find a node by its revision id, tag or date (YYYY-MM-DD)" + entry#coerce + end ; + add_label ~text:"Find:" ~packing ; + { last_find = "", [] ; find_entry = entry } + let setup fb ctrl = + ignore (fb.find_entry#connect#activate (fun () -> + ctrl#find fb.find_entry#text)) + + let clear find = + find.find_entry#set_text "" ; + find.last_find <- "", [] + let is_id = - let re = Str.regexp "^[0-9a-fA-f]*$" in + 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 locate_id ctrl id = + match ctrl#get_agraph with + | None -> [] + | Some g -> + let id = String.lowercase id 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) + (Agraph.get_layout g).c_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 - let db = some v.db 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 db))) + let locate_with_db ctrl f = + match ctrl#get_db with + | None -> [] + | Some db -> + match ctrl#get_agraph with + | None -> [] + | Some g -> + f db + ++ List.filter (fun (id, _) -> Agraph.mem g id) + ++ List.sort (fun (_,a) (_,b) -> compare a b) + ++ List.map (fun (id, _) -> Agraph.get_node g id) - let locate_date v date_prefix = - locate_with_db v + let locate_date ctrl date_prefix = + locate_with_db ctrl (fun db -> Database.get_matching_dates db date_prefix) - let locate_tag v re = - locate_with_db v + let locate_tag ctrl q = + locate_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 locate v q = - match v.find.last_find with + let locate find ctrl q = + match find.last_find with | (last_q, n :: t) when last_q = q -> - v.find.last_find <- (last_q, t) ; - Canvas.center_on v n + find.last_find <- (last_q, t) ; + ctrl#center_on n | _ -> let candidates = try if is_id q - then locate_id v q + then locate_id ctrl q else if is_date q - then locate_date v q - else locate_tag v (Str.regexp q) + then locate_date ctrl q + else locate_tag ctrl q with Failure _ | Invalid_argument _ -> [] in match candidates with | [] -> - v.find.last_find <- (q, []) + find.last_find <- (q, []) | n :: t -> - v.find.last_find <- (q, t) ; - Canvas.center_on v n + find.last_find <- (q, t) ; + ctrl#center_on n - let focus_find_entry v = - v.find.find_entry#misc#grab_focus () + let focus_find_entry find = + 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 ; - Agraph.dot_program = v.prefs.Viz_style.dot_path } +type t = { + info : Info_Display.t ; + selector : Branch_selector.t ; + canvas : Canvas.t ; + find : Find.t ; + } -let connect_event v f = - Signal.connect v.event_signal f - - - -let handle_query v ?id query = - may - (fun db -> - may Agraph.abort_layout v.agraph ; - Canvas.clear v ; - v.agraph <- Some ( - let agraph = - Status.with_status - (Lazy.force v.status_reporter) - "Building ancestry graph ..." - (fun () -> - nice_fetch - (fun db -> Database.fetch_ancestry_graph db query) - db) in - Agraph.make - agraph - query - (layout_params v) (function - | `LAYOUT_ERROR msg -> - error_notice ~parent:v.canvas.w msg - | `LAYOUT_DONE -> - Canvas.update_graph v id))) - v.db - - - - - -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 ?id ?branch fname = - (* fname should be in filesystem encoding, - branch should be UTF-8 *) - close v ; - try - let db = Database.open_db fname in - v.db <- Some db ; - Branch_selector.populate v - (nice_fetch Database.fetch_branches db) ; - may (Branch_selector.set_branch v ?id) branch ; - Signal.emit v.event_signal `OPEN_DB - with Viz_types.Error msg -> - error_notice ~parent:v.canvas.w msg - - - -let dnd_targets = [| - { Gtk.target = "text/uri-list" ; Gtk.flags = [] ; Gtk.info = 0 } ; - { Gtk.target = "text/plain" ; Gtk.flags = [] ; Gtk.info = 1 } ; -|] - -let make ~aa ~prefs ~packing = +let make ~aa ~packing = let b = GPack.vbox ~packing () in (* Branches selection *) - let (selector, find_box) = Branch_selector.make ~packing:b#pack in + let hb = GPack.hbox ~border_width:4 ~packing:b#pack () in + let selector = Branch_selector.make ~packing:hb#pack in + let find_box = Find.make ~packing:(hb#pack ~from:`END) in let view_pane = GPack.paned `VERTICAL ~packing:(b#pack ~expand:true) () in @@ -1143,202 +1090,37 @@ (* Info pane *) let info_display = Info_Display.make ~packing:(view_pane#pack2 ~shrink:true) in - let v = { - info = info_display ; + { 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") ; - drag_active = false - } in + find = find_box } - Info_Display.setup_popup v ; - Branch_selector.connect v - (fun i -> handle_query v ?id:i.preselect i.query) ; - - 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 ; - begin - let canvas = v.canvas.w 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 begin (* a file dropped from a file manager *) - try - let f = - List.find - (fun f -> Viz_misc.string_is_prefix "file://" f) - (Str.split (Str.regexp "\r\n") sel#data) in - open_db v - (Viz_misc.string_slice ~s:7 f) - with Not_found -> () - end)) ; +let setup v ctrl = + Info_Display.setup v.info ctrl ; + Branch_selector.setup v.selector ctrl ; + Canvas.setup v.canvas ctrl ; + Find.setup v.find ctrl - let setup_drag () = - canvas#drag#source_set - ~modi:[`BUTTON1] ~actions:[`COPY] - [ dnd_targets.(1) ] in - setup_drag () ; +let clear v ctrl = + Info_Display.clear v.info ; + Canvas.clear v.canvas ctrl ; + Find.clear v.find +let close_db v ctrl = + clear v ctrl ; + Branch_selector.clear v.selector - (* 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. *) +let open_db v ctrl = + Branch_selector.populate + v.selector + (Ui.nice_fetch Database.fetch_branches (some ctrl#get_db)) - ignore (canvas#event#connect#after#button_press - (fun ev -> - if GdkEvent.Button.button ev = 1 && not v.drag_active - then canvas#drag#source_unset () ; - false)) ; +let update v ctrl id = + Canvas.update_graph v.canvas ctrl id +let get_selected_node v = + maybe fst v.canvas.Canvas.selected_node - ignore (canvas#event#connect#button_release - (fun ev -> - if GdkEvent.Button.button ev = 1 - then begin - if v.drag_active - then v.drag_active <- false - else setup_drag () - end ; - false)) ; - - ignore (canvas#drag#connect#data_get - (fun ctx sel_ctx ~info ~time -> - match v.selected_node with - | Some id when info = 1 -> - sel_ctx#return id - | _ -> ())) - end ; - - - connect_event v (function - | `NODE_SELECT id -> - Canvas.display_selection_marker v id ; - Info_Display.fetch_and_display_data v id - | `NODE_SWITCH_BRANCH (branch, id) -> - Branch_selector.set_branch v ~id branch - | `CLEAR -> - Info_Display.clear_info v ; - KeyNav.clear v ; - Find.clear v ; - v.selected_node <- None ; - | _ -> ()) ; - - Find.connect v (Find.locate v) ; - - v - - - - -let reload v = - may (fun db -> - let branch = Branch_selector.get_branch v in - let fname = Database.get_filename db in - open_db v ?id:v.selected_node ?branch fname) - 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 ; - dot_path : string ; - ignored_certs : string list ; - 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 v.selected_node - | _ -> () - -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 - (Lazy.force v.status_reporter) - (fun res -> - match res with - | `OUTPUT d -> - Unidiff.view ~parent d - | `SUB_PROC_ERROR msg -> - error_notice ~parent msg) - (old_id, new_id) - with Viz_types.Error msg -> - error_notice ~parent msg - -let get_toplevel v = - GWindow.toplevel v.canvas.w ======================================================================== --- view.mli 01d6087db6831d53ec35e1da6c9eb63ecc523804 +++ view.mli 5d2ee84a233b89a239b459c0e2ac4cfb1c37aee9 @@ -1,98 +1,44 @@ -val error_notice : parent:#GObj.widget -> string -> unit - -val wrap_in_scroll_window : (GObj.widget -> unit) -> GObj.widget -> unit - -val nice_fetch : (Database.t -> 'a) -> Database.t -> 'a - -val set_busy_cursor : #GObj.widget -> bool -> unit - -type info_display -type select_info -type branch_selector -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 * string - | `CERT_POPUP of int] -type canvas -type keyboard_nav -type find -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 Viz_misc.Signal.t; - mutable selected_node : string option; - status_reporter : Status.reporter Lazy.t; - mutable drag_active : bool; -} - module Info_Display : sig - val make : packing:(GObj.widget -> unit) -> info_display - val clear_info : t -> unit - val fetch_and_display_data : t -> string -> unit + type t + val fetch_and_display_data : t -> #App.t -> string -> unit val get_current_cert_value : t -> string option - val setup_popup : t -> unit end module Branch_selector : sig - val make : packing:(GObj.widget -> unit) -> branch_selector * find - val connect : t -> (select_info -> unit) -> unit - val get_display_sub_branches : t -> bool - val clear : t -> unit - val populate : t -> string list -> unit - val set_branch : t -> ?id:string -> string -> unit + type t + val set_branch : t -> #App.t -> ?id:string -> string -> unit val get_branch : t -> string option end -module KeyNav : - sig - val navigate : t -> GdkEvent.Key.t -> (string * Viz_types.c_node) option - val select : t -> string -> unit - val clear : t -> unit - end - module Canvas : sig - val make : aa:bool -> packing:(GObj.widget -> unit) -> canvas - val zoom : t -> [< `IN | `OUT ] -> unit -> unit - val clear : t -> unit - val center_on : t -> string * Viz_types.c_node -> unit - val center_on_by_id : t -> string -> unit - val update_graph : t -> string option -> unit + type t + val zoom : t -> #App.t -> [< `IN | `OUT ] -> unit -> unit + val id_size : t -> #App.t -> int * int + val center_on : t -> #App.t -> string * Viz_types.c_node -> unit end module Find : sig - val clear : t -> unit - val connect : t -> (string -> unit) -> unit - val locate : t -> string -> unit + type t + val locate : t -> #App.t -> string -> unit val focus_find_entry : t -> unit end -val make : - aa:bool -> prefs:Viz_style.prefs -> packing:(GObj.widget -> unit) -> t -val connect_event : t -> (event -> unit) -> unit -val close : t -> unit -val finalize : t -> unit -val open_db : t -> ?id:string -> ?branch:string -> string -> unit -val reload : t -> unit -val zoom : t -> [< `IN | `OUT ] -> unit -> unit -val display_certs : t -> string -> unit -val set_prefs : t -> Viz_style.prefs -> unit -val view_diff : t -> string -> string -> unit +type t = { + info : Info_Display.t; + selector : Branch_selector.t; + canvas : Canvas.t; + find : Find.t; +} +val make : aa:bool -> packing:(GObj.widget -> unit) -> t +val setup : t -> #App.t -> unit + +val clear : t -> #App.t -> unit +val close_db : t -> #App.t -> unit +val open_db : t -> #App.t -> unit +val update : t -> #App.t -> string option -> unit +val get_selected_node : t -> string option -val get_ancestors : t -> string -> string list -val get_toplevel : t -> GWindow.window option ======================================================================== --- viz_types.ml ac47415114692a19bdf32928c5d78f2402e1fa47 +++ viz_types.ml 2348af90556459bd15ea99ce8d5b45b2f2dbe82c @@ -14,6 +14,8 @@ | QUERY_BETWEEN of date * date type query = query_domain * query_limit +type select_info = { query : query; preselect : string option; } + module NodeMap = StringMap module EdgeMap = Map.Make (struct type t = string * string let compare = Pervasives.compare end) module IdSet = Set.Make(String) ======================================================================== --- viz_types.mli 292b0505def1f086f2705c3bcc7d10f780bca15a +++ viz_types.mli c3524724d488bbf3da18ba9de56ab98d9a08599f @@ -16,6 +16,9 @@ | QUERY_BETWEEN of date * date type query = query_domain * query_limit +type select_info = { query : query; preselect : string option; } + + module NodeMap : Map.S with type key = string module EdgeMap : Map.S with type key = string * string module IdSet : Set.S with type elt = string