The unified diff between revisions [c0298de2..] and [fac83dcc..] is displayed below. It can also be downloaded as a raw diff.
This diff has been restricted to the following files: 'view.ml'
#
#
# patch "view.ml"
# from [e2d0e8ea6928c04c7002e37d08aee0c5de5a1c3e]
# to [60ed1b72ef4581b1b5bd247f86c921b877ca2384]
#
============================================================
--- view.ml e2d0e8ea6928c04c7002e37d08aee0c5de5a1c3e
+++ view.ml 60ed1b72ef4581b1b5bd247f86c921b877ca2384
@@ -1,6 +1,6 @@ open Viz_types
open Viz_misc
open Viz_types
-open Revision_types
+open Revision
open Ui
let ( ++ ) x f = f x
@@ -188,14 +188,12 @@ module Info_Display = struct
i.cert_model#clear ()
let stock_of_delta_type = function
- | PATCH _ -> None
+ | PATCH _ -> None
| ADD_FILE _
- | ADD_DIR _ -> Some `ADD
- | DELETE_FILE _
- | DELETE_DIR _ -> Some `REMOVE
- | RENAME_FILE _
- | RENAME_DIR _ -> Some `CONVERT
- | ATTR_SET _ -> Some `PROPERTIES
+ | ADD_DIR _ -> Some `ADD
+ | DELETE _ -> Some `REMOVE
+ | RENAME _ -> Some `CONVERT
+ | ATTR_SET _ -> Some `PROPERTIES
| ATTR_CLEAR _ -> Some `CLEAR
let text_of_delta_type = function
@@ -203,11 +201,9 @@ module Info_Display = struct
| PATCH (f, _, "") -> ""
| PATCH (f, _, _)
| ADD_FILE (f, _)
- | DELETE_FILE f -> f
- | ADD_DIR f
- | DELETE_DIR f -> f ^ "/"
- | RENAME_FILE (o, n) -> Printf.sprintf "%s -> %s" o n
- | RENAME_DIR (o, n) -> Printf.sprintf "%s/ -> %s/" o n
+ | DELETE f -> f
+ | ADD_DIR f -> f ^ "/"
+ | RENAME (o, n) -> Printf.sprintf "%s -> %s" o n
| ATTR_CLEAR (attr, f)
| ATTR_SET (attr, f, _) -> Printf.sprintf "%s on %s" attr f
@@ -275,14 +271,12 @@ module Info_Display = struct
{ data with certs = List.filter (fun c -> not (List.mem c.c_name ignored_certs)) data.certs }
let fetch_and_display_data info ctrl id =
- match ctrl#get_db with
+ match ctrl#get_mtn with
| None -> ()
- | Some db ->
+ | Some mtn ->
let data =
- try Database.fetch_certs_and_revision db id
+ try Monotone.get_certs_and_revision mtn id
with
- | Sqlite3.Error ((Sqlite3.BUSY | Sqlite3.LOCKED), _) ->
- failed_node_data
| Viz_types.Error msg ->
ctrl#error_notice msg ;
failed_node_data in
@@ -302,43 +296,10 @@ module Complete = struct
module Complete = struct
- let is_id =
- let re = Str.regexp "^[0-9a-fA-F]+$" in
- fun id -> Str.string_match re id 0
-
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 complete_with_db ctrl f =
- match ctrl#get_db with
- | None -> []
- | Some db -> f db
-
- let complete_id ctrl query_domain q =
- complete_with_db ctrl
- (fun db ->
- let data = Database.get_matching_ids db q in
- match query_domain with
- | QUERY_ALL -> data
- | QUERY_BRANCHES allowed_branches ->
- List.filter
- (fun (_, branch_name) -> List.mem branch_name allowed_branches)
- data)
-
- let complete_tag ctrl q =
- complete_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 get_id_and_uniquify data =
- data
- ++ List.map fst
- ++ List.sort compare
- ++ Viz_misc.list_uniq
-
let several_completions parent (t, ids) =
let txt = Buffer.create 128 in
Printf.bprintf txt
@@ -360,27 +321,26 @@ module Complete = struct
ignore (m#connect#response (fun _ -> m#destroy ())) ;
m#show ()
- exception None
+ exception None_
exception Many of (string * string list)
let complete_date ctrl domain t =
if is_date t
then t
else
- let match_data =
- if is_id t
- then complete_id ctrl domain t
- else complete_tag ctrl t in
- match get_id_and_uniquify match_data with
- | [] -> raise None
- | [ id ] ->
- begin
- match Database.fetch_cert_value (some ctrl#get_db) id "date" with
- | t :: _ -> t
- | [] -> raise None
- end
- | ids ->
- raise (Many (t, ids))
+ match ctrl#get_mtn with
+ | None -> raise None_
+ | Some mtn ->
+ match Monotone.select mtn t with
+ | [] -> raise None_
+ | [ id ] ->
+ begin
+ match Monotone.cert_value mtn id "date" with
+ | t :: _ -> t
+ | [] -> raise None_
+ end
+ | ids ->
+ raise (Many (t, ids))
end
@@ -567,31 +527,24 @@ module Branch_selector = struct
s.view#scroll_to_cell path (s.view#get_column 0)
let get_query_domain s =
- let all = ref true in
let acc = ref [] in
s.store#foreach
(fun path row ->
let v = s.store#get ~row ~column:s.in_view_column in
- all := !all && v ;
if v
then begin
let b = s.store#get ~row ~column:s.branch_column in
acc := b :: !acc
end ;
false) ;
- if !all
- then QUERY_ALL
- else QUERY_BRANCHES !acc
+ !acc
- let future = "9999-12"
- let past = "0001-01"
-
let make_query_limit_interval ctrl domain s_from s_to =
- let t_from = Complete.complete_date ctrl domain
- (if s_from = "" then past else s_from) in
- let t_to = Complete.complete_date ctrl domain
- (if s_to = "" then future else s_to) in
- QUERY_BETWEEN (t_from, t_to)
+ let t_from = Complete.complete_date ctrl domain s_from in
+ let t_to = Complete.complete_date ctrl domain s_to in
+ if t_from = "" && t_to = ""
+ then QUERY_NO_LIMIT
+ else QUERY_BETWEEN (t_from, t_to)
let make_query ctrl ?id s =
@@ -611,7 +564,7 @@ module Branch_selector = struct
all_propagates = query_propagate };
preselect = id }
with
- | Complete.None -> None
+ | Complete.None_ -> None
| Complete.Many compl ->
Complete.several_completions s.w compl ; None
@@ -750,10 +703,7 @@ module Branch_selector = struct
let set_state s ctrl ?id state =
s.w#misc#hide () ;
let (domain, limit_kind, entries_text) = state in
- let in_domain v =
- match domain with
- | QUERY_ALL -> true
- | QUERY_BRANCHES b -> List.mem v b in
+ let in_domain v = List.mem v domain in
s.selected_b <- 0 ;
s.store#foreach
(fun path row ->
@@ -805,8 +755,8 @@ module Branch_selector = struct
s.entries.(1)#set_text ""
| Some id ->
match
- Database.fetch_cert_value
- (some ctrl#get_db) id "date"
+ Monotone.cert_value
+ (some ctrl#get_mtn) id "date"
with
| [] ->
s.radio_buttons.(0)#set_active true
@@ -874,10 +824,10 @@ module KeyNav = struct
let navigate_is_sibling k id =
List.exists (fun (i, _) -> i = id) k.keyboard_nav_siblings
- let on_same_branch db id =
- let b_target = Database.fetch_cert_value db id "branch" in
+ let on_same_branch mtn id =
+ let b_target = Monotone.cert_value mtn id "branch" in
fun (id, _) ->
- let b_node = Database.fetch_cert_value db id "branch" in
+ let b_node = Monotone.cert_value mtn id "branch" in
List.exists
(fun b -> List.mem b b_target)
b_node
@@ -895,7 +845,7 @@ module KeyNav = struct
| `NEXT -> locate sx
| `PREV -> locate (List.rev sx)
| `PARENT | `CHILD ->
- match List.filter (on_same_branch (some ctrl#get_db) current_id) sx with
+ match List.filter (on_same_branch (some ctrl#get_mtn) current_id) sx with
| [] -> Some (List.hd sx)
| h :: _ -> Some h
@@ -1171,7 +1121,7 @@ module Canvas = struct
let canvas = c.canvas in
let graph = some ctrl#get_agraph in
let layout = Agraph.get_layout graph in
- let db = some ctrl#get_db in
+ let mtn = some ctrl#get_mtn in
let pr = ctrl#status "canvas" in
let prefs = ctrl#get_prefs in
let lr_layout = prefs.Viz_style.lr_layout in
@@ -1219,7 +1169,7 @@ module Canvas = struct
let font = prefs.Viz_style.font in
let font_size = get_font_size font in
- let match_style = Viz_style.match_style prefs graph db in
+ let match_style = Viz_style.match_style prefs graph mtn in
let node_item id node () =
let g = GnoCanvas.group ~x:node.n_x ~y:node.n_y nodes_group in
@@ -1271,7 +1221,7 @@ module Canvas = struct
false end
| `TWO_BUTTON_PRESS b when is_neighbor node && GdkEvent.Button.button b = 1 ->
begin
- match Database.fetch_cert_value db id "branch" with
+ match Monotone.cert_value mtn id "branch" with
| other_branch :: _ ->
ctrl#switch_branch (other_branch, id)
| [] -> ()
@@ -1406,7 +1356,7 @@ module Find = struct
begin
let tooltips = GData.tooltips () in
tooltips#set_tip
- ~text:"Find a node by its revision id, tag or date (YYYY-MM-DD)"
+ ~text:"Find a node using a monotone selector"
entry#coerce
end ;
add_label ~text:"Find:" ~packing ;
@@ -1420,58 +1370,29 @@ module Find = struct
find.find_entry#set_text "" ;
find.last_find <- "", []
- let locate_id ctrl id =
+ let order lr_layout (_, n1) (_, n2) =
+ if lr_layout
+ then compare n1.n_x n2.n_x
+ else compare n1.n_y n2.n_y
+
+ let filter_in_agraph ctrl ids =
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 []
+ ids
+ ++ List.filter (Agraph.mem g)
+ ++ List.map (Agraph.get_node g)
+ ++ List.sort (order ctrl#get_prefs.Viz_style.lr_layout)
+
- 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 ctrl date_prefix =
- locate_with_db ctrl
- (fun db -> Database.get_matching_dates db date_prefix)
-
- 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 find ctrl q =
match find.last_find with
| (last_q, n :: t) when last_q = q ->
find.last_find <- (last_q, t) ;
ctrl#center_on n
| _ ->
- let candidates =
- try
- if Complete.is_id q
- then locate_id ctrl q
- else if Complete.is_date q
- then locate_date ctrl q
- else locate_tag ctrl q
- with Failure _ | Invalid_argument _ -> [] in
+ let ids = Monotone.select (some ctrl#get_mtn) q in
+ let candidates = filter_in_agraph ctrl ids in
match candidates with
| [] ->
find.last_find <- (q, [])
@@ -1534,7 +1455,11 @@ let open_db v ctrl =
let open_db v ctrl =
Branch_selector.populate
v.selector
- (Ui.nice_fetch Database.fetch_branches (some ctrl#get_db))
+ (Ui.with_grab (fun () ->
+ let mtn = some ctrl#get_mtn in
+ let b = Monotone.branches mtn
+ and c = Monotone.run_monotone_count_branches mtn in
+ List.map (fun b -> b, c b) b))
let update v ctrl id =
Canvas.update_graph v.canvas ctrl id