# # patch "Makefile" # from [a6a4476838ce1258815d403a108049fa43bc3540] # to [1dace8176e230713577906f438dabea2e22f1497] # # patch "app.ml" # from [f9300ac837228bfc33ec40ed4a4579e30a5121f8] # to [43b61f04329b4a55f1f280fed8a9c8cf54bc3191] # # patch "query.ml" # from [5270f57a5b635185afdd82cc3c3a4c95f5e6fe4a] # to [b433130eeeeb458c8f6711e2d4f3d43f9b7ec85c] # # patch "ui.ml" # from [efc792f464a51b8195e93003337ebca0cdceaa90] # to [ac08a5570e6835f62d32e9db7802dca117fd801b] # # patch "ui.mli" # from [a6d8610ca91bd94c1c7669e953e36381b9bf4031] # to [9fc86ec4a44065737b468fbe8d2139d7485cec1b] # # patch "view.ml" # from [e2d5db9b44af998c30fc38475e59a3ad21d225db] # to [6bf0a5e41c1cc55c466e458fba3e12f14885c092] # # patch "view.mli" # from [bc7ff10ffd879caa1204c7625aa1056b0e31a35f] # to [a035848f2c374e946742b4b07a465531e4ad1bd1] # ======================================================================== --- Makefile a6a4476838ce1258815d403a108049fa43bc3540 +++ Makefile 1dace8176e230713577906f438dabea2e22f1497 @@ -23,7 +23,7 @@ database.ml database.mli agraph.ml agraph.mli \ autocolor.ml autocolor.mli viz_style.ml viz_style.mli \ 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 + 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 \ @@ -41,10 +41,11 @@ viz_misc.ml viz_misc.mli viz_types.ml viz_types.mli q.ml q.mli \ autocolor.ml autocolor.mli viz_style.ml viz_style.mli \ dot_types.mli dot_lexer.mll dot_parser.mly \ - subprocess.ml subprocess.mli icon.ml status.ml ui.ml \ + subprocess.ml subprocess.mli icon.ml ui.ml ui.mli \ revision_types.mli revision_lexer.mll revision_parser.mly \ components.ml database.ml database.mli agraph.ml agraph.mli \ - unidiff.ml unidiff.mli gnomecanvas_hack.c view.ml view.mli query.ml main.ml \ + unidiff.ml unidiff.mli gnomecanvas_hack.c view.ml view.mli \ + query.ml query.mli app.mli app.ml main.ml \ mlsqlite/sqlite3.ml mlsqlite/sqlite3.mli mlsqlite/ocaml-sqlite3.c \ ocamlnet-0.97.1/base64.ml ocamlnet-0.97.1/base64.mli ocamlnet-0.97.1/LICENSE \ extlib-1.3/IO.ml extlib-1.3/IO.mli extlib-1.3/unzip.ml extlib-1.3/unzip.mli \ ======================================================================== --- app.ml f9300ac837228bfc33ec40ed4a4579e30a5121f8 +++ app.ml 43b61f04329b4a55f1f280fed8a9c8cf54bc3191 @@ -53,6 +53,7 @@ open Viz_misc class ctrl w ~prefs ~manager ~status ~view : t = + let busy = new Ui.busy_indicator w in object (self) val mutable db = None val mutable agraph = None @@ -93,10 +94,13 @@ 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 + match branch with + | Some b -> + View.Branch_selector.set_branch + view.View.selector self ?id b + | None -> + View.Branch_selector.present_dialog + view.View.selector method close_db () = may Database.close_db db ; @@ -110,8 +114,10 @@ may Database.close_db db method display_certs id = + busy#start ; View.Info_Display.fetch_and_display_data - view.View.info self id + view.View.info self id ; + busy#stop method focus_find_entry () = View.Find.focus_find_entry view.View.find @@ -143,6 +149,7 @@ agraph method private clear = + busy#stop ; View.clear view self ; Ui.clear manager ; may Query.clear query @@ -158,6 +165,7 @@ self#clear ; may (fun db -> + busy#start ; let g1 = (self#status "agraph")#with_status "Building ancestry graph" @@ -173,6 +181,7 @@ (self#status "dot") (function | `LAYOUT_ERROR msg -> + busy#stop ; self#error_notice msg | `LAYOUT_DONE -> View.update @@ -202,7 +211,8 @@ Ui.update_begin manager ; may Query.activate query ; - method update_end = () + method update_end = + busy#stop method center_on n = View.Canvas.center_on view.View.canvas self n ======================================================================== --- query.ml 5270f57a5b635185afdd82cc3c3a4c95f5e6fe4a +++ query.ml b433130eeeeb458c8f6711e2d4f3d43f9b7ec85c @@ -1,14 +1,3 @@ -let make_factory () = - let id = "mviz-query" in - let set = GtkStock.Icon_factory.lookup_default "gtk-execute" in - GtkStock.Item.add - { GtkStock.stock_id = id ; label = "_Query" ; - modifier = [] ; keyval = 0 } ; - ignore (GtkStock.make_icon_factory ~icons:[ `STOCK id, set ] ()) - -let init_stock = Lazy.lazy_from_fun make_factory - - open Viz_types module Selector = struct @@ -76,7 +65,7 @@ "Searching the monotone database ..." (fun () -> let pat = Gpattern.make revision_content in - List.fold_left + Ui.fold_in_loop (fun acc id -> let r = Database.fetch_revision db id in if revision_contains pat r.revision_set @@ -151,7 +140,6 @@ (al#add, set_label) let setup_query_builder vbox = - Lazy.force init_stock ; let (packing, _) = category "Query" vbox in let packing = (GPack.vbox ~packing ())#pack in let hbox = GPack.hbox ~packing () in @@ -255,7 +243,8 @@ set_label 0 | `QUERY -> w#set_response_sensitive `QUERY false ; - Ui.set_busy_cursor w true ; + let busy = new Ui.busy_indicator w in + busy#start ; do_query ~selector:e1#text ~revision_content:e2#text @@ -269,7 +258,7 @@ | `SUB_PROC_ERROR msg -> Ui.error_notice ~parent:w msg end ; - Ui.set_busy_cursor w false ; + busy#stop ; w#set_response_sensitive `QUERY true))) ; ignore (rv#connect#row_activated (fun path view_col -> ======================================================================== --- ui.ml efc792f464a51b8195e93003337ebca0cdceaa90 +++ ui.ml ac08a5570e6835f62d32e9db7802dca117fd801b @@ -29,13 +29,23 @@ with exn -> GtkMain.Grab.remove w ; GtkBase.Object.destroy w ; raise exn +let pump () = + while Glib.Main.iteration false do () done + let nice_fetch f db = + with_grab (fun () -> Database.with_progress pump f db) + +let fold_in_loop ?(granularity=10) f init l = with_grab (fun () -> - Database.with_progress - (fun () -> - while Glib.Main.iteration false do () done) - f - db) + let i = ref 0 in + List.fold_left + (fun acc e -> + incr i ; + if !i mod granularity = 0 + then pump () ; + f acc e) + init + l) let add_label ~text ~packing = ignore (GMisc.label ~text ~packing ()) @@ -48,6 +58,39 @@ (if busy then busy_cursor else normal_cursor)) +class busy_indicator (widget : #GObj.widget) = + object + val mutable depth = 0 + val mutable timer_id = None + + method start = + depth <- depth + 1 ; + match timer_id with + | None when depth = 1 -> + let id = + Glib.Timeout.add 500 + (fun () -> + timer_id <- None ; + set_busy_cursor widget true ; + false) in + timer_id <- Some id + | _ -> () + + method stop = + if depth > 0 then begin + depth <- depth - 1 ; + if depth = 0 then + match timer_id with + | None -> + set_busy_cursor widget false + | Some id -> + Glib.Timeout.remove id ; + timer_id <- None + end + end + + + let category title packing = let vb = GPack.vbox ~packing () in let _ = @@ -60,6 +103,19 @@ (GPack.vbox ~packing:al#add ())#pack +let make_factory () = + let id = "mviz-query" in + let set = GtkStock.Icon_factory.lookup_default "gtk-execute" in + let add id label = + GtkStock.Item.add + { GtkStock.stock_id = id ; label = label ; + modifier = [] ; keyval = 0 } ; + ignore (GtkStock.make_icon_factory ~icons:[ `STOCK id, set ] ()) in + add "mviz-query" "_Query" ; + add "mviz-view" "_View" + +let _ = make_factory () + class status_bar ~packing = let status = GMisc.statusbar ~packing () in ======================================================================== --- ui.mli a6d8610ca91bd94c1c7669e953e36381b9bf4031 +++ ui.mli 9fc86ec4a44065737b468fbe8d2139d7485cec1b @@ -5,11 +5,17 @@ parent:#GWindow.window_skel -> ('a, unit, string, unit) format4 -> 'a val nice_fetch : (Database.t -> 'a) -> Database.t -> 'a +val fold_in_loop : ?granularity:int -> ('a -> 'b -> 'a) -> 'a -> 'b list -> '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 busy_indicator : + #GObj.widget -> + object + method start : unit + method stop : unit + end val category : string -> ======================================================================== --- view.ml e2d5db9b44af998c30fc38475e59a3ad21d225db +++ view.ml 6bf0a5e41c1cc55c466e458fba3e12f14885c092 @@ -338,8 +338,7 @@ ~title:"Ancestry graph view specification" () in w#add_button_stock `CANCEL `CANCEL ; - w#add_button_stock `GO_FORWARD `VIEW ; - w#set_default_response `VIEW ; + w#add_button_stock (`STOCK "mviz-view") `VIEW ; w#set_response_sensitive `VIEW false ; let packing = w#vbox#pack in @@ -517,6 +516,7 @@ s.toggle_signal <- Some id ; ignore (s.button#connect#clicked (fun () -> expand_rows s ; + s.w#set_default_response `VIEW ; s.w#present ())) ; ignore (s.w#connect#after#close s.w#misc#hide) ; ignore (s.w#event#connect#delete (fun _ -> s.w#misc#hide () ; true)) ; @@ -652,7 +652,9 @@ may ctrl#query (make_query ?id s) - + + let present_dialog s = + s.button#clicked () end @@ -870,9 +872,6 @@ 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 @@ -936,8 +935,7 @@ (fun id -> Glib.Idle.remove id ; c.background_rendering <- None ; - (ctrl#status "canvas")#progress_end () ; - set_busy_cursor c false) + (ctrl#status "canvas")#progress_end ()) c.background_rendering let id_width = 8 @@ -1188,7 +1186,6 @@ with Exit -> c.background_rendering <- None ; pr#progress_end () ; - set_busy_cursor c false ; ctrl#update_end ; false | exn -> @@ -1199,7 +1196,6 @@ preselect_id ; c.background_rendering <- Some id ; pr#progress_start "Drawing ancestry graph ..." count ; - set_busy_cursor c true ; ctrl#update_begin end ======================================================================== --- view.mli bc7ff10ffd879caa1204c7625aa1056b0e31a35f +++ view.mli a035848f2c374e946742b4b07a465531e4ad1bd1 @@ -12,6 +12,7 @@ val get_state : t -> state val set_state : t -> #App.t -> ?id:string -> state -> unit val set_branch : t -> #App.t -> ?id:string -> string -> unit + val present_dialog : t -> unit end module Canvas :