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

open Viz_misc
open Viz_types

let ui_info = "\
  <ui>\
    <toolbar>\
      <toolitem action='Open'/>\
      <toolitem action='Close'/>\
      <toolitem action='Quit'/>\
      <separator name='Sep1'/>\
      <toolitem action='Refresh'/>\
      <toolitem action='Zoom_in'/>\
      <toolitem action='Zoom_out'/>\
      <separator name='Sep2'/>\
      <toolitem action='Prefs'/>\
    </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>\
    <menubar>\
      <menu action='FileMenu'>\
        <menuitem action='Open'/>\
        <menuitem action='Close'/>\
        <menuitem action='Prefs'/>\
        <menuitem action='Quit'/>\
      </menu>\
      <menu action='ViewMenu'>\
        <menuitem action='Refresh'/>\
        <menuitem action='Zoom_in'/>\
        <menuitem action='Zoom_out'/>\
      </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 ;
    clipboard       : GData.clipboard ;
  }

type manager = {
    manager      : GAction.ui_manager ;
    main_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 "Open"  ~stock:`OPEN  ~tooltip:"Open a database" ;
  add "Close" ~stock:`CLOSE ~tooltip:"Close the database" ;
  add "Quit"  ~stock:`QUIT  ~tooltip:"Exit" ;
  add "FileMenu" ~label:"_File" ;
  add "Prefs" ~stock:`PREFERENCES ~tooltip:"Edit Preferences" ;
  add "FindEntry" ~accel:"<Ctrl>l" ] ;
  (g_main#get_action "Close")#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_revision" ~label:"Copy revision id to the clipboard" ;
  add "Copy_manifest" ~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:"Reload"   ~accel:"<Ctrl>R" ;
  add "Zoom_in"  ~stock:`ZOOM_IN  ~tooltip:"Zoom in"  ~accel:"KP_Add" ;
  add "Zoom_out" ~stock:`ZOOM_OUT ~tooltip:"Zoom out" ~accel:"KP_Subtract" ] ;
  g_view#set_sensitive false ;
  (g_main, 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   = "" ;
    clipboard  = GData.clipboard Gdk.Atom.primary
  }

let make_manager () =
  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) ;
  { manager = m ;
    main_group = g_main; view_group = g_view ;
    popup_data = lazy (make_popup_data m g_popup)
  }

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 m v ~selected_id ~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 v.View.db) popup_id in
    remember_signal copy_revision
      (fun () ->
	p.clipboard#set_text data.revision_id) ;
    remember_signal copy_manifest
      (fun () ->
	p.clipboard#set_text 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
    | Some id when id <> popup_id ->
	diff_other#set_sensitive true ;
	remember_signal diff_other
	  (fun () -> View.view_diff v 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 View.get_ancestors v 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 () -> View.view_diff v 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 () -> View.view_diff v 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


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 "<b>%s</b>" (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"
	~icon:(Lazy.force Icon.monotone)
	?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 hb = GPack.hbox ~packing () in
      let _ = GMisc.label ~text:"monotone:" ~packing:hb#pack () in
      let e = GEdit.entry ~text:(!prefs.Viz_style.monotone_path) ~packing:(hb#pack ~expand:true) () in
      ignore (e#connect#changed (fun () ->
	prefs := { !prefs with Viz_style.monotone_path = e#text })) ;
    end ;

    w#add_button_stock `CLOSE `CLOSE ;
    w#add_button_stock `SAVE  `SAVE ;
    w#add_button_stock `APPLY `APPLY ;
    ignore (w#connect#response (function
      | `APPLY ->
	  View.set_prefs v !prefs
      | `SAVE ->
	  Viz_style.save !prefs
      | `CLOSE | `DELETE_EVENT ->
	  w#destroy ())) ;
    w#show ()
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 make w ~aa ~prefs =
  let b = GPack.vbox ~packing:w#add () in

  let { manager = ui } as manager = make_manager () in
  w#add_accel_group ui#get_accel_group ;

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

  (* 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:(match Database.kind with `FILE -> `OPEN | `DIRECTORY -> `SELECT_FOLDER)
	  ~parent:w
	  ~title:"Open a Monotone database" () in
      dialog#add_button_stock `CLOSE `CLOSE ;
      dialog#add_select_button_stock `OPEN `OPEN ;
      dialog
    end in

  (* Connect signals and actions *)
  begin
    let action_connect name callback =
      ignore ((ui#get_action name)#connect#activate ~callback) in

    action_connect "/toolbar/Close"
      (fun () -> View.close v) ;

    action_connect "/toolbar/Open"
      (fun () ->
	may
	  (fun db_fname -> View.open_db v db_fname None)
	  (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.make v) ;

    action_connect "/popup/Certs"
      (fun () ->
	View.display_certs v
	  (get_popup_data manager).popup_id) ;

    action_connect "/FindEntry"
      (fun () -> View.Find.focus_find_entry v) ;

    let view_group = manager.view_group in

    View.connect_event v
      (function
	| `OPEN_DB ->
	    (ui#get_action "/toolbar/Close")#set_sensitive true
	| `CLOSE_DB ->
	    (ui#get_action "/toolbar/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
	| _ -> ())
  end ;

  { ui_manager = manager ;
    open_dialog = open_dialog ;
    view = v ; }