Merge pull request #34 from jestabro/commit-alg

T6946: add utilities for commit algorithm

10 files changed, 156 insertions, 18 deletions

diff --git a/src/config_diff.ml b/src/config_diff.ml
index 09167b3..87b2663 100644
--- a/src/config_diff.ml
+++ b/src/config_diff.ml
@@ -181,8 +181,6 @@ let clone ?(recurse=true) ?(set_values=None) old_root new_root path =
             let path_remaining = Vylist.complement path path_existing in
             clone_path ~recurse:recurse ~set_values:set_values old_root new_root path_existing path_remaining
 
-let is_empty l = (l = [])
-
 (* define the diff_func *)
 let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : change) =
     match m with
@@ -205,14 +203,14 @@ let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : cha
                       let add_vals = ValueS.elements (ValueS.diff v_set ov_set) in
                       let inter_vals = ValueS.elements (ValueS.inter ov_set v_set) in
                       let sub_tree =
-                          if not (is_empty sub_vals) then
+                          if not (Util.is_empty sub_vals) then
                               clone ~set_values:(Some sub_vals) res.left res.sub path
                           else
                               res.sub
                       in
                       let del_tree =
-                          if not (is_empty sub_vals) then
-                              if (is_empty add_vals) && (is_empty inter_vals) then
+                          if not (Util.is_empty sub_vals) then
+                              if (Util.is_empty add_vals) && (Util.is_empty inter_vals) then
                                   (* delete whole node, not just values *)
                                   clone ~set_values:(Some []) res.left res.del path
                               else
@@ -221,13 +219,13 @@ let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : cha
                               res.del
                       in
                       let add_tree =
-                          if not (is_empty add_vals) then
+                          if not (Util.is_empty add_vals) then
                             clone ~set_values:(Some add_vals) res.right res.add path
                           else
                               res.add
                       in
                       let inter_tree =
-                          if not (is_empty inter_vals) then
+                          if not (Util.is_empty inter_vals) then
                               clone ~set_values:(Some inter_vals) res.left res.inter path
                           else
                               res.inter
@@ -264,6 +262,33 @@ let diff_tree path left right =
     let ret = make Config_tree.default_data "" [add_node; sub_node; del_node; int_node] in
     ret
 
+(* convenience function needed for commit algorithm:
+    we need a hybrid tree between the 'del' tree and the 'sub' tree, namely:
+    in case the del tree has a terminal tag node (== all tag values have
+    been removed) add tag node values for proper removal in commit execution
+    *)
+
+let get_tagged_delete_tree dt =
+    let del_tree = Config_tree.get_subtree dt ["del"] in
+    let sub_tree = Config_tree.get_subtree dt ["sub"] in
+    let f (p, a) _t =
+        let q = List.rev p in
+        match q with
+        | [] -> (p, a)
+        | _ ->
+        if Config_tree.is_tag a q && Vytree.is_terminal_path a q then
+            let children = Vytree.children_of_path sub_tree q in
+            let insert_child path node name =
+                Vytree.insert ~position:Lexical node (path @ [name]) Config_tree.default_data
+            in
+            let a' = List.fold_left (insert_child q) a children in
+            (p, a')
+        else
+            (p, a)
+    in
+    snd (Vytree.fold_tree_with_path f ([], del_tree) del_tree)
+
+
 (* the following builds a diff_func to return a unified diff string of
    configs or config commands
  *)
@@ -340,14 +365,14 @@ let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res)
                       let sub_vals = ValueS.elements (ValueS.diff ov_set v_set) in
                       let add_vals = ValueS.elements (ValueS.diff v_set ov_set) in
                       let str_diff =
-                          if not (is_empty sub_vals) then
+                          if not (Util.is_empty sub_vals) then
                               let sub_tree =
                                   clone ~set_values:(Some sub_vals) res.left res.skel path
                               in str_diff ^ (removed_lines ~cmds:cmds sub_tree path)
                           else str_diff
                       in
                       let str_diff =
-                          if not (is_empty add_vals) then
+                          if not (Util.is_empty add_vals) then
                               let add_tree =
                                   clone ~set_values:(Some add_vals) res.right res.skel path
                               in str_diff ^ (added_lines ~cmds:cmds add_tree path)
@@ -398,14 +423,6 @@ let show_diff ?(cmds=false) path left right =
         in
         strs
 
-let is_terminal_path node path =
-    try
-        let n = Vytree.get node path in
-        match (Vytree.children_of_node n) with
-        | [] -> true
-        | _ -> false
-    with Vytree.Nonexistent_path -> false
-
 (* mask function; mask applied on right *)
 let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
     match m with
@@ -413,7 +430,7 @@ let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
     | Subtracted ->
             (match path with
             | [_] -> Diff_tree {res with left = Vytree.delete res.left path}
-            |  _  -> if not (is_terminal_path res.right (list_but_last path)) then
+            |  _  -> if not (Vytree.is_terminal_path res.right (list_but_last path)) then
                          Diff_tree {res with left = Vytree.delete res.left path}
                      else Diff_tree (res))
     | Unchanged -> Diff_tree (res)
diff --git a/src/config_diff.mli b/src/config_diff.mli
index af8f87d..ee34532 100644
--- a/src/config_diff.mli
+++ b/src/config_diff.mli
@@ -46,3 +46,4 @@ val show_diff : ?cmds:bool -> string list -> Config_tree.t -> Config_tree.t -> s
 val tree_union : Config_tree.t -> Config_tree.t -> Config_tree.t
 val mask_tree : Config_tree.t -> Config_tree.t -> Config_tree.t
 val make_diff_cstore : Config_tree.t -> Config_tree.t -> int -> Diff_cstore.t result
+val get_tagged_delete_tree : Config_tree.t -> Config_tree.t
diff --git a/src/config_tree.ml b/src/config_tree.ml
index 89f85bf..712db2b 100644
--- a/src/config_tree.ml
+++ b/src/config_tree.ml
@@ -113,6 +113,11 @@ let is_tag node path =
     let data = Vytree.get_data node path in
     data.tag
 
+let is_tag_value node path =
+    match path with
+    | [] | [_] -> false
+    | _ -> is_tag node (Util.drop_last path)
+
 let set_leaf node path leaf =
     let data = Vytree.get_data node path in
     Vytree.update node path {data with leaf=leaf}
diff --git a/src/config_tree.mli b/src/config_tree.mli
index c05bab9..f24a906 100644
--- a/src/config_tree.mli
+++ b/src/config_tree.mli
@@ -39,6 +39,8 @@ val set_tag : t -> string list -> bool -> t
 
 val is_tag : t -> string list -> bool
 
+val is_tag_value : t -> string list -> bool
+
 val set_leaf : t -> string list -> bool -> t
 
 val is_leaf : t -> string list -> bool
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 874991d..65725a8 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -480,6 +480,10 @@ let get_owner reftree path =
     let data = Vytree.get_data reftree path in
     data.owner
 
+let get_priority reftree path =
+    let data = Vytree.get_data reftree path in
+    data.priority
+
 let get_help_string reftree path =
     let data = Vytree.get_data reftree path in
     data.help
@@ -505,6 +509,21 @@ let refpath reftree path =
     | _, [] -> acc
     in aux [] path
 
+let get_ceil_data f reftree path =
+    let data_of_path d p =
+        let data = Vytree.get_data reftree p in
+        match (f data) with
+        | Some d' -> Some d'
+        | None -> d
+    in
+    let rec aux d acc p =
+        match acc, p with
+        | _, h :: tl ->
+                let acc' = acc @ [h] in
+                aux (data_of_path d (refpath reftree acc')) acc' tl
+        | _, [] -> d
+    in aux None [] path
+
 module JSONRenderer =
 struct
     let render_data data =
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index b1447df..b2942a3 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -71,6 +71,8 @@ val is_valueless : t -> string list -> bool
 
 val get_owner : t -> string list -> string option
 
+val get_priority : t -> string list -> string option
+
 val get_help_string : t -> string list -> string
 
 val get_value_help : t -> string list -> (string * string) list
@@ -79,4 +81,6 @@ val get_completion_data : t -> string list -> (node_type * bool * string) list
 
 val refpath : t -> string list -> string list
 
+val get_ceil_data : (ref_node_data -> string option) -> t -> string list -> string option
+
 val render_json : t -> string
diff --git a/src/util.ml b/src/util.ml
index cbee955..8fc5899 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -110,3 +110,52 @@ let list_of_path p =
     | [h] -> Pcre.split ~pat:"\\s+" h
     | h :: h' :: _ -> (Pcre.split ~pat:"\\s+" h) @ [h']
     | _ -> []
+
+
+let drop_last l =
+    let rec aux acc l =
+        match l with
+        | [] | [_] -> List.rev acc
+        | hd :: tl ->
+            let acc' = hd :: acc in
+            aux acc' tl
+    in
+    aux [] l
+
+let drop_last_n l n =
+    let rec aux k l =
+        match l with
+        | [] -> []
+        | _ -> if k <= 0 then l else aux (k - 1) (drop_last l)
+    in aux n l
+
+let drop_first l =
+    match l with
+    | [] -> []
+    | _ :: tl -> tl
+
+let rec get_last l =
+    match l with
+    | [] -> None
+    | h :: [] -> Some h
+    | _ :: tl -> get_last tl
+
+let get_last_n l n =
+    get_last (drop_last_n l n)
+
+let lex_order l k =
+    let c = compare (get_last l) (get_last k) in
+    match c with
+    | 0 -> compare (drop_last l) (drop_last k)
+    | _ as r -> r
+
+let colex_order l k =
+    let rec comp x y =
+        let c = compare (get_last x) (get_last y) in
+        match c with
+        | 0 -> comp (drop_last x) (drop_last y)
+        | _ as r -> r
+    in comp l k
+
+let is_empty l =
+    List.compare_length_with l 0 = 0
diff --git a/src/util.mli b/src/util.mli
index 9a52268..fc25cff 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -15,3 +15,19 @@ val string_of_list : string list -> string
 val json_of_list : string list -> string
 
 val list_of_path : string -> string list
+
+val drop_last : 'a list -> 'a list
+
+val drop_last_n : 'a list -> int -> 'a list
+
+val drop_first : 'a list -> 'a list
+
+val get_last : 'a list -> 'a option
+
+val get_last_n : 'a list -> int -> 'a option
+
+val lex_order : string list -> string list -> int
+
+val colex_order : string list -> string list -> int
+
+val is_empty : 'a list -> bool
diff --git a/src/vytree.ml b/src/vytree.ml
index 05b3088..dec1666 100644
--- a/src/vytree.ml
+++ b/src/vytree.ml
@@ -207,3 +207,24 @@ let move node path position =
     let child = get node path in
     let node = delete node path in
     insert ~position:position ~children:child.children node path child.data
+
+let is_terminal_path node path =
+    try
+        let n = get node path in
+        match (children_of_node n) with
+        | [] -> true
+        | _ -> false
+    with Nonexistent_path -> false
+
+let rec fold_tree_with_path f (p', a) t =
+    let p =
+        match name_of_node t with
+        | "" -> p'
+        | name -> name :: p'
+    in
+    let children = children_of_node t in
+    match children with
+    | [] -> (Util.drop_first p), snd (f (p, a) t)
+    | c -> let res =
+        List.fold_left (fold_tree_with_path f) (f (p, a) t) c in
+        (Util.drop_first p), snd res
diff --git a/src/vytree.mli b/src/vytree.mli
index 412379a..9839728 100644
--- a/src/vytree.mli
+++ b/src/vytree.mli
@@ -56,3 +56,7 @@ val sort_children : (string -> string -> int) -> 'a t -> 'a t
 val copy : 'a t -> string list -> string list -> 'a t
 
 val move : 'a t -> string list -> position -> 'a t
+
+val is_terminal_path : 'a t -> string list -> bool
+
+val fold_tree_with_path: (string list * 'acc -> 'b t -> string list * 'acc) -> string list * 'acc -> 'b t -> string list * 'acc