diff options
| -rw-r--r-- | src/config_diff.ml | 276 | ||||
| -rw-r--r-- | src/config_diff.mli | 43 |
2 files changed, 206 insertions, 113 deletions
diff --git a/src/config_diff.ml b/src/config_diff.ml index cd9104b..35a5b55 100644 --- a/src/config_diff.ml +++ b/src/config_diff.ml @@ -1,27 +1,61 @@ 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; - del: Config_tree.t ref; - inter: Config_tree.t ref; -} - exception Incommensurable exception Empty_comparison exception Nonexistent_child -let make_diff_trees l r = { left = l; right = r; - add = ref (Config_tree.make ""); - sub = ref (Config_tree.make ""); - del = ref (Config_tree.make ""); - inter = ref (Config_tree.make ""); +module Diff_tree = struct + type t = { left: Config_tree.t; + right: Config_tree.t; + add: Config_tree.t; + sub: Config_tree.t; + del: Config_tree.t; + inter: Config_tree.t; + } +end + +module Diff_string = struct + type t = { left: Config_tree.t; + right: Config_tree.t; + skel: Config_tree.t; + ppath: string list; + udiff: string; + } +end + +module Diff_cstore = struct + type t = { left: Config_tree.t; + right: Config_tree.t; + handle: int; + } +end + +type _ result = + | Diff_tree : Diff_tree.t -> Diff_tree.t result + | Diff_string : Diff_string.t -> Diff_string.t result + | Diff_cstore : Diff_cstore.t -> Diff_cstore.t result + +let eval_result : type a. a result -> a = function + | Diff_tree x -> x + | Diff_string x -> x + | Diff_cstore x -> x + +type 'a diff_func = ?recurse:bool -> string list -> 'a result -> change -> 'a result + +let make_diff_trees l r = Diff_tree { left = l; right = r; + add = (Config_tree.make ""); + sub = (Config_tree.make ""); + del = (Config_tree.make ""); + inter = (Config_tree.make ""); } +let make_diff_string l r = Diff_string { + left = l; right = r; + skel = (Config_tree.make ""); + ppath = []; + udiff = ""; + } + 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 @@ -64,7 +98,7 @@ let right_opt_pairs n m = *) let opt_cmp o0 o1 = match o0, o1 with - | Some v0, Some v1 -> compare v0 v1 + | Some v0, Some v1 -> compare (name_of v0) (name_of v1) | None, None -> 0 | None, Some _ -> 1 | Some _, None -> -1 @@ -95,24 +129,20 @@ let update_path path left_opt right_opt = 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 +let rec diff (path : string list) (f : 'a diff_func) (res: 'a result) ((left_node_opt, right_node_opt) : Config_tree.t option * Config_tree.t option) = + let path = update_path path left_node_opt right_node_opt in + match left_node_opt, right_node_opt with + | None, None -> raise Empty_comparison + | Some _, None -> f path res Subtracted + | None, Some _ -> f path res Added + | Some left_node, Some right_node when left_node = right_node -> + f ~recurse:true path res Unchanged + | Some left_node, Some right_node when left_node ^~ right_node -> + let values = (data_of right_node).values in + f path res (Updated values) + | Some left_node, Some right_node -> + let ret = f ~recurse:false path res Unchanged in + List.fold_left (diff path f) ret (opt_zip left_node right_node) (* copy node paths between trees *) let rec clone_path ?(recurse=true) ?(set_values=None) old_root new_root path_done path_remaining = @@ -145,37 +175,58 @@ let clone ?(recurse=true) ?(set_values=None) old_root new_root 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) = +(* define the diff_func *) +let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : change) = match m with - | Added -> trees.add := clone trees.right !(trees.add) path - | Subtracted -> trees.sub := clone trees.left !(trees.sub) path; - trees.del := clone ~recurse:false ~set_values:(Some []) trees.left !(trees.del) path - | Unchanged -> trees.inter := clone ~recurse:recurse trees.left !(trees.inter) path + | Added -> Diff_tree {res with add = clone res.right res.add path; } + | Subtracted -> + Diff_tree {res with sub = clone res.left res.sub path; + del = clone ~recurse:false ~set_values:(Some []) res.left res.del path; } + | Unchanged -> + Diff_tree {res with inter = clone ~recurse:recurse res.left res.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 + let ov = Config_tree.get_values res.left path in match ov, v with - | [_], [_] -> trees.sub := clone trees.left !(trees.sub) path; - trees.del := clone trees.left !(trees.del) path; - trees.add := clone trees.right !(trees.add) path + | [_], [_] -> Diff_tree {res with sub = clone res.left res.sub path; + del = clone res.left res.del path; + add = clone res.right res.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 sub_vals) then - if (is_empty add_vals) && (is_empty inter_vals) then - (* delete whole node, not just values *) - trees.del := clone ~set_values:(Some []) trees.left !(trees.del) path + let sub_tree = + if not (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 + (* delete whole node, not just values *) + clone ~set_values:(Some []) res.left res.del path + else + clone ~set_values:(Some sub_vals) res.left res.del path else - trees.del := clone ~set_values:(Some sub_vals) trees.left !(trees.del) 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 + res.del + in + let add_tree = + if not (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 + clone ~set_values:(Some inter_vals) res.left res.inter path + else + res.inter + in Diff_tree { res with add = add_tree; + sub = sub_tree; + del = del_tree; + inter = inter_tree; } (* get sub trees for path-relative comparison *) let tree_at_path path node = @@ -192,16 +243,16 @@ let compare path left right = 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 + let d = diff [] decorate_trees trees (Option.some left, Option.some right) + in eval_result d (* wrapper to return diff trees *) let diff_tree path left right = let trees = compare path left right in - let add_node = make Config_tree.default_data "add" (children_of !(trees.add)) in - let sub_node = make Config_tree.default_data "sub" (children_of !(trees.sub)) in - let del_node = make Config_tree.default_data "del" (children_of !(trees.del)) in - let int_node = make Config_tree.default_data "inter" (children_of !(trees.inter)) in + let add_node = make Config_tree.default_data "add" (children_of (trees.add)) in + let sub_node = make Config_tree.default_data "sub" (children_of (trees.sub)) in + let del_node = make Config_tree.default_data "del" (children_of (trees.del)) in + let int_node = make Config_tree.default_data "inter" (children_of (trees.inter)) in let ret = make Config_tree.default_data "" [add_node; sub_node; del_node; int_node] in ret @@ -212,10 +263,8 @@ let list_but_last l = let len = List.length l in List.filteri (fun i _ -> i < len - 1) l -let ppath_to_string_if_new (c: string list ref) (path: string list) = - let p = list_but_last path in - if (!c <> p) then - (c := p; Printf.sprintf "[%s]\n" (String.concat " " !c)) else "" +let path_to_string (path: string list) = + Printf.sprintf "[%s]\n" (String.concat " " path) let marked_render mark node = let lines = Config_tree.render_config node in @@ -227,51 +276,76 @@ let marked_render mark node = let added_lines ?(cmds=false) node path = if not cmds then marked_render "+ " (tree_at_path path node) else - let skel = Config_tree.make "" in - let snode = clone node skel path in - (Config_tree.render_commands ~op:Set snode []) ^ "\n" + (Config_tree.render_commands ~op:Set node []) ^ "\n" let removed_lines ?(cmds=false) node path = if not cmds then marked_render "- " (tree_at_path path node) else - let skel = Config_tree.make "" in - let snode = clone node skel path in - (Config_tree.render_commands ~op:Delete snode []) ^ "\n" + (Config_tree.render_commands ~op:Delete node []) ^ "\n" -let order_commands (strl: string ref) = - let l = String.split_on_char '\n' !strl in +let order_commands (strl: string) = + let l = String.split_on_char '\n' strl in let del = List.filter (fun s -> (s <> "") && (s.[0] = 'd')) l in let set = List.filter (fun s -> (s <> "") && (s.[0] = 's')) l in - strl := (String.concat "\n" del) ^ "\n" ^ (String.concat "\n" set) ^ "\n" - -let ppath = ref [""] + (String.concat "\n" del) ^ "\n" ^ (String.concat "\n" set) ^ "\n" -let unified_diff ?(cmds=false) (str_diff: string ref) (trees : diff_trees) ?recurse:_ (path : string list) (m : change) = +let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res) (m : change) = + let ppath_l = list_but_last path + in + let ppath_s = + if (ppath_l <> res.ppath) then path_to_string ppath_l + else "" + in + let str_diff = + if not cmds then res.udiff ^ ppath_s + else res.udiff + in match m with | Added -> - if not cmds then str_diff := !str_diff ^ (ppath_to_string_if_new ppath path); - str_diff := !str_diff ^ (added_lines ~cmds:cmds trees.right path) + let str_diff = + let add_tree = clone res.right res.skel path in + str_diff ^ (added_lines ~cmds:cmds add_tree path) + in + Diff_string { res with ppath = ppath_l; udiff = str_diff; } | Subtracted -> - if not cmds then str_diff := !str_diff ^ (ppath_to_string_if_new ppath path); - str_diff := !str_diff ^ (removed_lines ~cmds:cmds trees.left path) - | Unchanged -> () + let str_diff = + let sub_tree = clone res.left res.skel path in + str_diff ^ (removed_lines ~cmds:cmds sub_tree path) + in + Diff_string { res with ppath = ppath_l; udiff = str_diff; } + | Unchanged -> Diff_string (res) | Updated v -> - if not cmds then str_diff := !str_diff ^ (ppath_to_string_if_new ppath path); - let ov = Config_tree.get_values trees.left path in + let ov = Config_tree.get_values res.left path in match ov, v with | [_], [_] -> - str_diff := !str_diff ^ (removed_lines ~cmds:cmds trees.left path); - str_diff := !str_diff ^ (added_lines ~cmds:cmds trees.right path) + let str_diff = + let sub_tree = clone res.left res.skel path in + str_diff ^ (removed_lines ~cmds:cmds sub_tree path) + in + let str_diff = + let add_tree = clone res.right res.skel path in + str_diff ^ (added_lines ~cmds:cmds add_tree path) + in + Diff_string { res with ppath = ppath_l; udiff = str_diff; } | _, _ -> 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 - if not (is_empty sub_vals) then - (trees.sub := clone ~set_values:(Some sub_vals) trees.left !(trees.sub) path; - str_diff := !str_diff ^ (removed_lines ~cmds:cmds !(trees.sub) path)); - if not (is_empty add_vals) then - (trees.add := clone ~set_values:(Some add_vals) trees.right !(trees.add) path; - str_diff := !str_diff ^ (added_lines ~cmds:cmds !(trees.add) path)) + let str_diff = + if not (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 + let add_tree = + clone ~set_values:(Some add_vals) res.right res.skel path + in str_diff ^ (added_lines ~cmds:cmds add_tree path) + else str_diff + in + Diff_string { res with ppath = ppath_l; udiff = str_diff; } let add_empty_path src_node dest_node path = clone ~recurse:false ~set_values:(Some []) src_node dest_node path @@ -305,12 +379,16 @@ let show_diff ?(cmds=false) path left right = if (path <> []) then compare_at_path_maybe_empty left right path else (left, right) in - let trees = make_diff_trees left right in - let udiff = ref "" in - ppath := [""]; - diff [] (unified_diff ~cmds:cmds udiff trees) [(Option.some left, Option.some right)]; - if cmds then order_commands udiff; - !udiff + let dstr = make_diff_string left right in + let dstr = + diff [] (unified_diff ~cmds:cmds) dstr (Option.some left, Option.some right) + in + let dstr = eval_result dstr in + let strs = + if cmds then order_commands dstr.udiff + else dstr.udiff + in + strs let union_of_values (n : Config_tree.t) (m : Config_tree.t) = let set_n = ValueS.of_list (data_of n).values in diff --git a/src/config_diff.mli b/src/config_diff.mli index b1c3c09..c995ba3 100644 --- a/src/config_diff.mli +++ b/src/config_diff.mli @@ -1,24 +1,39 @@ -type change = Unchanged | Added | Subtracted | Updated of string list -type diff_func = ?recurse:bool -> string list -> change -> unit +module Diff_tree : sig + type t = { left: Config_tree.t; + right: Config_tree.t; + add: Config_tree.t; + sub: Config_tree.t; + del: Config_tree.t; + inter: Config_tree.t; + } +end -type diff_trees = { - left: Config_tree.t; - right: Config_tree.t; - add: Config_tree.t ref; - sub: Config_tree.t ref; - del: Config_tree.t ref; - inter: Config_tree.t ref; -} +module Diff_string : sig + type t = { left: Config_tree.t; + right : Config_tree.t; + skel: Config_tree.t; + ppath: string list; + udiff: string; + } +end + +module Diff_cstore : sig + type t = { left: Config_tree.t; + right: Config_tree.t; + handle: int; + } +end + +type _ result = + | Diff_tree : Diff_tree.t -> Diff_tree.t result + | Diff_string : Diff_string.t -> Diff_string.t result + | Diff_cstore : Diff_cstore.t -> Diff_cstore.t result exception Incommensurable exception Empty_comparison exception Nonexistent_child -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 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 show_diff : ?cmds:bool -> string list -> Config_tree.t -> Config_tree.t -> string val tree_union : Config_tree.t -> Config_tree.t -> Config_tree.t |