summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/config_diff.ml207
-rw-r--r--src/config_diff.mli23
-rw-r--r--src/config_tree.ml39
-rw-r--r--src/config_tree.mli5
4 files changed, 263 insertions, 11 deletions
diff --git a/src/config_diff.ml b/src/config_diff.ml
new file mode 100644
index 0000000..604668b
--- /dev/null
+++ b/src/config_diff.ml
@@ -0,0 +1,207 @@
+type change = Unchanged | Added | Subtracted | Updated of string list
+
+type diff_func = ?recurse:bool -> string list -> change -> unit
+
+type diff_trees = {
+ left: Config_tree.t;
+ right: Config_tree.t;
+ add: Config_tree.t ref;
+ sub: Config_tree.t ref;
+ inter: Config_tree.t ref;
+}
+
+exception Incommensurable
+exception Empty_comparison
+
+module ValueS = Set.Make(struct type t = string let compare = compare end)
+
+let make_diff_trees l r = { left = l; right = r;
+ add = ref (Config_tree.make "root");
+ sub = ref (Config_tree.make "root");
+ inter = ref (Config_tree.make "root");
+}
+
+let name_of n = Vytree.name_of_node n
+let data_of n = Vytree.data_of_node n
+let children_of n = Vytree.children_of_node n
+let make data name children = Vytree.make_full data name children
+
+let (^~) (node : Config_tree.t) (node' : Config_tree.t) =
+ name_of node = name_of node' &&
+ (data_of node).values <> (data_of node').values
+
+let left_opt_pairs n m =
+ (children_of n) |> List.map (fun x ->
+ let maybe_node =
+ (children_of m) |> List.find_opt (fun y ->
+ name_of y = name_of x) in
+ (Some x, maybe_node))
+
+let right_opt_pairs n m =
+ (children_of m) |> List.map (fun y ->
+ let maybe_node =
+ (children_of n) |> List.find_opt (fun x ->
+ name_of x = name_of y) in
+ (maybe_node, Some y))
+
+let opt_zip n m =
+ left_opt_pairs n m @ right_opt_pairs n m |> List.sort_uniq compare
+
+let get_opt_name left_opt right_opt =
+ match left_opt, right_opt with
+ | Some left_node, None -> name_of left_node
+ | None, Some right_node -> name_of right_node
+ | Some left_node, Some _ -> name_of left_node
+ | None, None -> raise Empty_comparison
+
+let update_path path left_opt right_opt =
+ let name = get_opt_name left_opt right_opt in
+ if name = "root" then path
+ else path @ [name]
+
+(* tree diff algorithm: walk the tree pair, calling a function of type
+ diff_func at bifurcation points; f acts as a form of continuation.
+ The idea of matching on pairs of (node opt) is from
+ https://github.com/LukeBurgessYeo/tree-diff
+*)
+let rec diff (path : string list) (f : diff_func) (l : (Config_tree.t option * Config_tree.t option) list) =
+ match l with
+ | [] -> ()
+ | (left_node_opt, right_node_opt) :: ls ->
+ (let path = update_path path left_node_opt right_node_opt in
+ match left_node_opt, right_node_opt with
+ | Some _, None -> f path Subtracted
+ | None, Some _ -> f path Added
+ | Some left_node, Some right_node when left_node = right_node ->
+ f path Unchanged
+ | Some left_node, Some right_node when left_node ^~ right_node ->
+ let values = (data_of right_node).values in
+ f path (Updated values)
+ | Some left_node, Some right_node ->
+ (f ~recurse:false path Unchanged;
+ diff path f (opt_zip left_node right_node))
+ | None, None -> raise Empty_comparison)
+ ; diff path f ls
+
+(* copy node paths between trees *)
+let rec clone_path ?(recurse=true) ?(set_values=None) old_root new_root path_done path_remaining =
+ match path_remaining with
+ | [] | [_] ->
+ let path_total = path_done @ path_remaining in
+ let old_node = Vytree.get old_root path_total in
+ let data =
+ match set_values with
+ | Some v -> { (data_of old_node) with Config_tree.values = v }
+ | None -> data_of old_node
+ in
+ if recurse then
+ Vytree.insert ~children:(children_of old_node) new_root path_total data
+ else
+ Vytree.insert new_root path_total data
+ | name :: names ->
+ let path_done = path_done @ [name] in
+ let old_node = Vytree.get old_root path_done in
+ let new_root = Vytree.insert new_root path_done (data_of old_node) in
+ clone_path ~recurse:recurse ~set_values:set_values old_root new_root path_done names
+
+let clone ?(recurse=true) ?(set_values=None) old_root new_root path =
+ match path with
+ | [] -> if recurse then old_root else new_root
+ | _ ->
+ let path_existing = Vytree.get_existent_path new_root path in
+ 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 rec graft_children children stock path =
+ match children with
+ | [] -> stock
+ | x::xs ->
+ let stock = Vytree.insert ~children:(children_of x) stock (path @ [name_of x]) (data_of x)
+ in graft_children xs stock path
+
+let graft_tree stem stock path =
+ graft_children (children_of stem) stock path
+
+let is_empty l = (l = [])
+
+(* define the diff_func; in this instance, we imperatively build the difference trees *)
+let decorate_trees (trees : diff_trees) ?(recurse=true) (path : string list) (m : change) =
+ match m with
+ | Added -> trees.add := clone trees.right !(trees.add) path
+ | Subtracted -> trees.sub := clone trees.left !(trees.sub) path
+ | Unchanged -> trees.inter := clone ~recurse:recurse trees.left !(trees.inter) path
+ | Updated v ->
+ (* if in this case, node at path is guaranteed to exist *)
+ let ov = Config_tree.get_values trees.left path in
+ match ov, v with
+ | [_], [_] -> trees.sub := clone trees.left !(trees.sub) path;
+ trees.add := clone trees.right !(trees.add) path
+ | _, _ -> let ov_set = ValueS.of_list ov in
+ let v_set = ValueS.of_list v in
+ 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 inter_vals = ValueS.elements (ValueS.inter ov_set v_set) in
+ if not (is_empty sub_vals) then
+ trees.sub := clone ~set_values:(Some sub_vals) trees.left !(trees.sub) path;
+ if not (is_empty add_vals) then
+ trees.add := clone ~set_values:(Some add_vals) trees.right !(trees.add) path;
+ if not (is_empty inter_vals) then
+ trees.inter := clone ~set_values:(Some inter_vals) trees.left !(trees.inter) path
+
+let trim_trees (trees : diff_trees) ?(recurse=false) (path : string list) (m : change) =
+ match m with
+ | Added -> ()
+ | Subtracted -> trees.sub := clone ~recurse:recurse ~set_values:(Some []) trees.left !(trees.sub) path
+ | Unchanged -> ()
+ | Updated v ->
+ (* if in this case, node at path is guaranteed to exist *)
+ let ov = Config_tree.get_values trees.left path in
+ match ov, v with
+ | [_], [_] -> trees.sub := clone trees.left !(trees.sub) path;
+ | _, _ -> let ov_set = ValueS.of_list ov in
+ let v_set = ValueS.of_list v in
+ let sub_vals = ValueS.elements (ValueS.diff ov_set v_set) in
+ let add_vals = ValueS.elements (ValueS.diff v_set ov_set) in
+ (* in practice, the above sets will be disjoint *)
+ let inter_vals = ValueS.elements (ValueS.inter ov_set v_set) in
+ if not (is_empty sub_vals) then
+ if (is_empty add_vals) && (is_empty inter_vals) then
+ (* delete whole node, not just values *)
+ trees.sub := clone ~set_values:(Some []) trees.left !(trees.sub) path
+ else
+ trees.sub := clone ~set_values:(Some sub_vals) trees.left !(trees.sub) path
+
+(* get sub trees for path-relative comparison *)
+let tree_at_path path node =
+ try
+ let node = Vytree.get node path in
+ make Config_tree.default_data "root" [node]
+ with Vytree.Nonexistent_path -> raise Empty_comparison
+
+(* call recursive diff on config_trees with decorate_trees as the diff_func *)
+let compare path left right =
+ if (name_of left) <> (name_of right) then
+ raise Incommensurable
+ else
+ let (left, right) = if not (path = []) then
+ (tree_at_path path left, tree_at_path path right) else (left, right) in
+ let trees = make_diff_trees left right in
+ diff [] (decorate_trees trees) [(Option.some left, Option.some right)];
+ trees
+
+(* wrapper to return diff trees *)
+let diff_tree path left right =
+ let trees = compare path left right in
+ let add_node = Config_tree.make "add" in
+ let sub_node = Config_tree.make "sub" in
+ let int_node = Config_tree.make "inter" in
+ let ret = make Config_tree.default_data "root" [add_node; sub_node; int_node] in
+ let ret = graft_tree !(trees.add) ret ["add"] in
+ let ret = graft_tree !(trees.sub) ret ["sub"] in
+ let ret = graft_tree !(trees.inter) ret ["inter"] in
+ ret
+
+let trim_tree left right =
+ let trees = make_diff_trees left right in
+ diff [] (trim_trees trees) [(Option.some left, Option.some right)];
+ !(trees.sub)
diff --git a/src/config_diff.mli b/src/config_diff.mli
new file mode 100644
index 0000000..70fb2e0
--- /dev/null
+++ b/src/config_diff.mli
@@ -0,0 +1,23 @@
+type change = Unchanged | Added | Subtracted | Updated of string list
+
+type diff_func = ?recurse:bool -> string list -> change -> unit
+
+type diff_trees = {
+ left: Config_tree.t;
+ right: Config_tree.t;
+ add: Config_tree.t ref;
+ sub: Config_tree.t ref;
+ inter: Config_tree.t ref;
+}
+
+exception Incommensurable
+exception Empty_comparison
+
+val make_diff_trees : Config_tree.t -> Config_tree.t -> diff_trees
+val clone : ?recurse:bool -> ?set_values:(string list) option -> Config_tree.t -> Config_tree.t -> string list -> Config_tree.t
+val decorate_trees : diff_trees -> ?recurse:bool -> string list -> change -> unit
+val trim_trees : diff_trees -> ?recurse:bool -> string list -> change -> unit
+val compare : string list -> Config_tree.t -> Config_tree.t -> diff_trees
+val diff_tree : string list -> Config_tree.t -> Config_tree.t -> Config_tree.t
+val trim_tree : Config_tree.t -> Config_tree.t -> Config_tree.t
+
diff --git a/src/config_tree.ml b/src/config_tree.ml
index c85b358..3e97e80 100644
--- a/src/config_tree.ml
+++ b/src/config_tree.ml
@@ -1,4 +1,5 @@
type value_behaviour = AddValue | ReplaceValue
+type command = Set | Delete
exception Duplicate_value
exception Node_has_no_value
@@ -21,6 +22,11 @@ let default_data = {
let make name = Vytree.make default_data name
+let op_to_string op =
+ match op with
+ | Set -> "set"
+ | Delete -> "delete"
+
let replace_value node path value =
let data = {default_data with values=[value]} in
Vytree.update node path data
@@ -95,19 +101,32 @@ let is_tag node path =
let data = Vytree.get_data node path in
data.tag
+let get_subtree ?(with_node=false) node path =
+ try
+ let n = Vytree.get node path in
+ if with_node then
+ Vytree.make_full default_data "root" [n]
+ else
+ Vytree.make_full default_data "root" (Vytree.children_of_node n)
+ with Vytree.Nonexistent_path -> make "root"
+
module Renderer =
struct
(* Rendering configs as set commands *)
- let render_set_path path value =
+ let render_set_path ?(op=Set) path value =
let v = Printf.sprintf "\'%s\'" value in
- List.append path [v] |> String.concat " " |> Printf.sprintf "set %s"
+ List.append path [v] |> String.concat " " |> Printf.sprintf "%s %s" (op_to_string op)
- let rec render_commands path ct =
+ let rec render_commands ?(op=Set) path ct =
let new_path = List.append path [Vytree.name_of_node ct] in
let new_path_str = String.concat " " new_path in
let data = Vytree.data_of_node ct in
(* Get the node comment, if any *)
- let comment = Util.default "" data.comment in
+ let comment =
+ match op with
+ | Set -> Util.default "" data.comment
+ | Delete -> ""
+ in
let comment_cmd = (if comment = "" then "" else Printf.sprintf "comment %s \'%s\'" new_path_str comment) in
let child_names = Vytree.list_children ct in
(* Now handle the different cases for nodes with and without children *)
@@ -120,20 +139,20 @@ struct
match values with
| [] ->
(* Valueless leaf node *)
- String.concat " " new_path |> Printf.sprintf "set %s"
+ String.concat " " new_path |> Printf.sprintf "%s %s" (op_to_string op)
| [v] ->
(* Single value, just one command *)
- render_set_path new_path v
+ render_set_path ~op:op new_path v
| vs ->
(* A leaf node with multiple values *)
- List.map (render_set_path new_path) vs |> String.concat "\n"
+ List.map (render_set_path ~op:op new_path) vs |> String.concat "\n"
end
in
if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd
| _ :: _ ->
(* A node with children *)
let children = List.map (fun n -> Vytree.get ct [n]) child_names in
- let rendered_children = List.map (render_commands new_path) children in
+ let rendered_children = List.map (render_commands ~op:op new_path) children in
let cmds = String.concat "\n" rendered_children in
if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd
@@ -239,14 +258,14 @@ module JSONRenderer = struct
Printf.sprintf "{%s}" child_configs
end (* JSONRenderer *)
-let render_commands node path =
+let render_commands ?(op=Set) node path =
let node =
match path with
| [] -> node
| _ -> Vytree.get node path
in
let children = Vytree.children_of_node node in
- let commands = List.map (Renderer.render_commands path) children in
+ let commands = List.map (Renderer.render_commands ~op:op path) children in
String.concat "\n" commands
let render_config = Renderer.render_config
diff --git a/src/config_tree.mli b/src/config_tree.mli
index 730b32f..5375c23 100644
--- a/src/config_tree.mli
+++ b/src/config_tree.mli
@@ -1,4 +1,5 @@
type value_behaviour = AddValue | ReplaceValue
+type command = Set | Delete
exception Duplicate_value
exception Node_has_no_value
@@ -33,7 +34,9 @@ val set_tag : t -> string list -> bool -> t
val is_tag : t -> string list -> bool
-val render_commands : t -> string list -> string
+val get_subtree : ?with_node:bool -> t -> string list -> t
+
+val render_commands : ?op:command -> t -> string list -> string
val render_config : t -> string
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 03:59:09 +0000