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

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

module Busy = struct
  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 t = {
      widget : GObj.widget ;
      mutable depth : int ;
      mutable timer_id : Glib.Timeout.id option ;
    }

  let make w =
    { widget = w#coerce ; depth = 0 ; timer_id = None }

  let start b =
    b.depth <- b.depth + 1 ;
    match b.timer_id with
    | None when b.depth = 1 ->
	let id =
	  Glib.Timeout.add 500
	    (fun () ->
	      b.timer_id <- None ;
	      set_busy_cursor b.widget true ;
	      false) in
	b.timer_id <- Some id
    | _ -> ()

  let stop b =
    match b.timer_id with
    | None when b.depth = 1 ->
	set_busy_cursor b.widget false ;
	b.depth <- 0
    | Some id when b.depth = 1 ->
	Glib.Timeout.remove id ;
	b.timer_id <- None ;
	b.depth <- 0
    | _ when b.depth > 1 ->
	b.depth <- b.depth - 1
    | _ -> ()
end


let category title packing =
  let vb = GPack.vbox ~packing () in
  let _ =
    GMisc.label
      ~markup:(Printf.sprintf "<b>%s</b>" (Glib.Markup.escape_text title))
      ~xalign:0.
      ~packing:(vb#pack ~expand:false) () in
  let al = GBin.alignment ~border_width:8 ~packing:(vb#pack ~expand:true) () in
  al#misc#set_property "left-padding" (`INT 16) ;
  (GPack.vbox ~packing:al#add ())#pack


let make_factory () =
  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
  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 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
	~allow_grow:false
	~border_width:8 () in
    begin
      let packing = 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 = 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 = 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

module LockedDB = struct

  let message ctrl =
    let db_fname =
      Database.get_filename
	(some ctrl#get_db) in
    Printf.sprintf
      "<big>Database <tt>%s</tt> is currently in use by another process.</big>"
      (Glib.Markup.escape_text db_fname)

  let show ctrl =
    (* for some reason GtkMessageDialog looks ugly here, so I rool my own GtkDialog *)
    let dialog =
      GWindow.dialog
	~no_separator:true
	~parent:ctrl#get_toplevel
	~destroy_with_parent:true
	~title:"Monotone-viz: database locked"
	~modal:true () in
    begin
      let vbox = dialog#vbox in
      vbox#set_border_width 12 ;
      let hbox = GPack.hbox ~spacing:12 ~border_width:12 ~packing:vbox#pack () in
      ignore (GMisc.image
		~stock:`DIALOG_WARNING
		~icon_size:`DIALOG
		~yalign:0.
		~packing:hbox#pack
		()) ;
      ignore (GMisc.label
		~markup:(message ctrl)
		~line_wrap:true ~selectable:true
		~xalign:0. ~yalign:0.
		~packing:(hbox#pack ~expand:true)
		())
    end ;
    begin
      ignore (dialog#connect#close (fun () -> dialog#response `CANCEL)) ;
      dialog#add_button_stock `CANCEL `CANCEL ;
      dialog#add_button "Retry" `RETRY
    end ;
    let resp =
      match dialog#run () with
      | `CANCEL | `DELETE_EVENT -> `FAIL
      | `RETRY -> `RETRY in
    dialog#destroy () ;
    resp

end




let ui_info = "\
  <ui>\
    <toolbar>\
      <toolitem action='New'/>\
      <toolitem action='Refresh'/>\
      <toolitem action='Zoom_in'/>\
      <toolitem action='Zoom_out'/>\
      <toolitem action='Query'/>\
    </toolbar>\
    <popup>\
      <menuitem action='Certs'/>\
      <menuitem action='Diff_one'/>\
      <menu     action='Diff_many'/>\
      <menuitem action='Diff_other'/>\
      <menuitem action='Copy_revision'/>\
      <menuitem action='Copy_manifest'/>\
    </popup>\
    <popup name='popup_cert'>\
      <menuitem action='Copy_cert'/>\
    </popup>\
    <menubar>\
      <menu action='FileMenu'>\
        <menuitem action='Open'/>\
        <menuitem action='Close'/>\
        <menuitem action='New'/>\
        <menuitem action='Prefs'/>\
        <menuitem action='Quit'/>\
      </menu>\
      <menu action='ViewMenu'>\
        <menuitem action='Refresh'/>\
        <menuitem action='Zoom_in'/>\
        <menuitem action='Zoom_out'/>\
        <menuitem action='Query'/>\
      </menu>\
    </menubar>\
    <accelerator action='FindEntry'/>\
  </ui>"

type popup_data = {
    menu            : GMenu.menu ;
    diff_many       : GMenu.menu_item ;
    mutable popup_id : string ;
    group           : GAction.action_group ;
    mutable signals : (unit Gobject.obj * GtkSignal.id) list ;
    menu_cert       : GMenu.menu ;
    clipboard1       : GData.clipboard ;
    clipboard2       : GData.clipboard ;
  }

type manager = {
    manager      : GAction.ui_manager ;
    db_group     : GAction.action_group ;
    view_group   : GAction.action_group ;
    popup_data   : popup_data Lazy.t ;
  }

let make_groups () =
  let add = GAction.add_action in
  let g_main = GAction.action_group ~name:"main" () in
  GAction.add_actions g_main [
  add "FileMenu" ~label:"_File" ;
  add "Open"  ~stock:`OPEN  ~tooltip:"Open a database" ;
  add "Quit"  ~stock:`QUIT  ~tooltip:"Exit" ;
  add "Prefs" ~stock:`PREFERENCES ~tooltip:"Edit Preferences" ;
  add "FindEntry" ~accel:"<Ctrl>l" ] ;
  let g_db = GAction.action_group ~name:"db" () in
  GAction.add_actions g_db [
  add "Close" ~stock:`CLOSE ~tooltip:"Close the database" ;
  add "New"   ~stock:`NEW   ~label:"New view" ~tooltip:"View a monotone ancestry graph" ] ;
  g_db#set_sensitive false ;
  let g_popup = GAction.action_group ~name:"popup" () in
  GAction.add_actions g_popup [
  add "Certs" ~label:"Display certs" ;
  add "Diff_one"   ~label:"Diff with ancestor" ;
  add "Diff_many"  ~label:"Diff with ancestor" ;
  add "Diff_other" ~label:"Diff with selected node" ;
  add "Copy_cert"     ~stock:`COPY ~label:"Copy the cert value to the clipboard" ;
  add "Copy_revision" ~stock:`COPY ~label:"Copy revision id to the clipboard" ;
  add "Copy_manifest" ~stock:`COPY ~label:"Copy manifest id to the clipboard" ] ;
  let g_view = GAction.action_group ~name:"view" () in
  GAction.add_actions g_view [
  add "ViewMenu" ~label:"_View" ;
  add "Refresh"  ~stock:`REFRESH  ~tooltip:"Redraw"   ~accel:"<Ctrl>R" ;
  add "Zoom_in"  ~stock:`ZOOM_IN  ~tooltip:"Zoom in"  ~accel:"<Ctrl>plus" ;
  add "Zoom_out" ~stock:`ZOOM_OUT ~tooltip:"Zoom out" ~accel:"<Ctrl>minus" ;
  add "Query"    ~stock:`FIND     ~tooltip:"Search the database" ] ;
  g_view#set_sensitive false ;
  (g_main, g_db, g_popup, g_view)

let get_obj m name =
  (m#get_widget name)#as_widget

let make_popup_data m g =
  { menu       = new GMenu.menu (GtkMenu.Menu.cast (get_obj m "/popup")) ;
    diff_many  = new GMenu.menu_item (GtkMenu.MenuItem.cast (get_obj m "/popup/Diff_many")) ;
    group      = g ;
    signals    = [] ;
    popup_id   = "" ;
    menu_cert  = new GMenu.menu (GtkMenu.Menu.cast (get_obj m "/popup_cert")) ;
    clipboard1  = GData.clipboard Gdk.Atom.clipboard ;
    clipboard2  = GData.clipboard Gdk.Atom.primary
  }

let make () =
  let m = GAction.ui_manager () in
  let (g_main, g_db, g_popup, g_view) = make_groups () in
  m#insert_action_group g_main  1 ;
  m#insert_action_group g_db    2 ;
  m#insert_action_group g_popup 3 ;
  m#insert_action_group g_view  4 ;
  ignore (m#add_ui_from_string ui_info) ;
  let tb = new GButton.toolbar (GtkButton.Toolbar.cast (get_obj m "/toolbar")) in
  tb#set_style `ICONS ;
  tb#set_icon_size `SMALL_TOOLBAR ;
  let menubar = m#get_widget "/menubar" in
  let toolbar = m#get_widget "/toolbar" in
  { manager = m ;
    db_group = g_db ; view_group = g_view ;
    popup_data = lazy (make_popup_data m g_popup)
  }, menubar, toolbar

let get_popup_data { popup_data = p } = Lazy.force p

let reset_popup_menu p id =
  List.iter
    (fun (o, id) -> GtkSignal.disconnect o id)
    p.signals ;
  p.signals <- [] ;
  p.diff_many#remove_submenu () ;
  p.popup_id <- id

let popup_cert m button =
  let p = get_popup_data m in
  let time = GtkMain.Main.get_current_event_time () in
  p.menu_cert#popup ~button ~time


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

  (* setup the copy entries *)
  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 ctrl#get_db) popup_id in
    remember_signal copy_revision
      (fun () -> set_clipboard m data.revision_id) ;
    remember_signal copy_manifest
      (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 ctrl#get_selected_node with
    | Some id when id <> popup_id ->
	diff_other#set_sensitive true ;
	remember_signal diff_other
	  (fun () -> ctrl#show_diff id popup_id)
    | _ ->
	diff_other#set_sensitive false
  end ;

  (* Setup the "diff with ancestor(s)" entry *)
  begin
    let diff_one = p.group#get_action "Diff_one" in
    match Agraph.get_ancestors (some ctrl#get_agraph) popup_id with
    | [] ->
	p.diff_many#misc#hide () ;
	diff_one#set_visible true;
	diff_one#set_sensitive false ;
    | [ ancestor_id ] ->
	p.diff_many#misc#hide () ;
	remember_signal diff_one
	  (fun () -> ctrl#show_diff ancestor_id popup_id) ;
	diff_one#set_visible true ;
	diff_one#set_sensitive true
    | a ->
	diff_one#set_visible false ;
	let submenu = GMenu.menu ~packing:p.diff_many#set_submenu () in
	List.iter
          (fun (ancestor_id as label) ->
            let i = GMenu.menu_item ~label ~packing:submenu#append () in
	    ignore (i#connect#activate
		      (fun () -> ctrl#show_diff ancestor_id popup_id)))
	  a ;
	p.diff_many#misc#show ()
  end ;

  (* popup the menu *)
  let time = GtkMain.Main.get_current_event_time () in
  p.menu#popup ~button ~time

















let setup ({ manager = ui } as m) ctrl =
  ctrl#get_toplevel#add_accel_group
    m.manager#get_accel_group ;

  let action_connect name callback =
    ignore ((ui#get_action name)#connect#activate ~callback) in

  action_connect "/menubar/FileMenu/Close"    ctrl#close_db ;
  action_connect "/menubar/FileMenu/Open"     ctrl#show_open ;
  action_connect "/menubar/FileMenu/Quit"     GMain.quit ;
  action_connect "/menubar/ViewMenu/Zoom_in"  ctrl#zoom_in ;
  action_connect "/menubar/ViewMenu/Zoom_out" ctrl#zoom_out ;
  action_connect "/menubar/ViewMenu/Refresh"  ctrl#reload ;
  action_connect "/menubar/FileMenu/Prefs"    ctrl#show_prefs ;
  action_connect "/menubar/ViewMenu/Query"    ctrl#show_search ;
  action_connect "/menubar/FileMenu/New"      ctrl#show_view ;
  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


let open_db m ctrl =
  m.db_group#set_sensitive true

let close_db m ctrl =
  m.db_group#set_sensitive false

let clear m =
  m.view_group#set_sensitive false

let update_begin m =
  m.view_group#set_sensitive true