diff options
| -rw-r--r-- | src/config_diff.ml | 207 | ||||
| -rw-r--r-- | src/config_diff.mli | 23 | ||||
| -rw-r--r-- | src/config_tree.ml | 39 | ||||
| -rw-r--r-- | src/config_tree.mli | 5 |
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 |