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

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_view : 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 =
  let busy = Ui.Busy.make w in
  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 private locked_db _ =
      Ui.LockedDB.show self

    method open_db ?id ?branch fname =
      self#close_db () ;
      let m_db = Database.open_db ~busy_handler:self#locked_db fname in
      db <- Some m_db ;
      View.open_db view self ;
      Ui.open_db manager self ;
      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 () =
      self#clear ;
      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 =
      Ui.Busy.start busy ;
      View.Info_Display.fetch_and_display_data
	view.View.info self id ;
      Ui.Busy.stop busy

    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 s = view.View.selector in
      let fname = maybe Database.get_filename db in
      let id = self#get_selected_node in
      let state = View.Branch_selector.get_state s in
      self#close_db () ;
      may self#open_db fname ;
      View.Branch_selector.set_state s self ?id state

    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 =
      Ui.Busy.stop busy ;
      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 ->
	  Ui.Busy.start busy ;
	  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 ->
		    Ui.Busy.stop busy ;
		    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, cw) = View.Canvas.id_size view.View.canvas self in
      { Agraph.char_width = float cw ;
	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 =
      Ui.Busy.stop busy

    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_view () =
      View.Branch_selector.present_dialog
	view.View.selector

    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, menubar, toolbar = Ui.make () in
  b#pack menubar ;
  let hb = GPack.hbox ~packing:b#pack () in
  hb#pack ~expand:true toolbar ;
  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 ~parent:w
      ~pack_find_entry:(hb#pack ~from:`END)
      ~pack_canvas:(b#pack ~expand:true) in
  new ctrl w ~prefs ~manager ~status ~view