Merge pull request #56 from jestabro/show-config

T7988: calculation for config-mode 'show' command

1 files changed, 273 insertions, 52 deletions

diff --git a/src/config_diff.ml b/src/config_diff.ml
index b0e48d3..b69440d 100644
--- a/src/config_diff.ml
+++ b/src/config_diff.ml
@@ -14,7 +14,7 @@ module Diff_tree = struct
              }
 end
 
-module Diff_string = struct
+module Diff_compare = struct
     type t = { left: Config_tree.t;
                right: Config_tree.t;
                skel: Config_tree.t;
@@ -23,25 +23,26 @@ module Diff_string = struct
              }
 end
 
-module Diff_cstore = struct
+module Diff_show = struct
     type t = { left: Config_tree.t;
                right: Config_tree.t;
-               handle: int;
-               out: string;
+               base_path: string list;
+               open_blocks: string list list;
+               config_diff: string;
              }
 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
+type _ diff_result =
+    | Diff_tree : Diff_tree.t -> Diff_tree.t diff_result
+    | Diff_compare : Diff_compare.t -> Diff_compare.t diff_result
+    | Diff_show : Diff_show.t -> Diff_show.t diff_result
 
-let eval_result : type a. a result -> a = function
+let eval_diff_result : type a. a diff_result -> a = function
     | Diff_tree x -> x
-    | Diff_string x -> x
-    | Diff_cstore x -> x
+    | Diff_compare x -> x
+    | Diff_show x -> x
 
-type 'a diff_func = ?recurse:bool -> string list -> 'a result -> change -> 'a result
+type 'a diff_func = ?recurse:bool -> string list -> 'a diff_result -> change -> 'a diff_result
 
 let make_diff_trees l r = Diff_tree { left = l; right = r;
                                 add = (Config_tree.make "");
@@ -50,16 +51,17 @@ let make_diff_trees l r = Diff_tree { left = l; right = r;
                                 inter = (Config_tree.make "");
 }
 
-let make_diff_string l r = Diff_string { left = l; right = r;
+let make_diff_compare l r = Diff_compare { left = l; right = r;
                                 skel = (Config_tree.make "");
                                 ppath = [];
                                 udiff = "";
                            }
 
-let make_diff_cstore l r h = Diff_cstore { left = l; right = r;
-                                handle = h;
-                                out = "";
-}
+let make_diff_show l r path = Diff_show { left = l; right = r;
+                                base_path = path;
+                                open_blocks = [];
+                                config_diff = "";
+                              }
 
 let name_of n = Vytree.name_of_node n
 let data_of n = Vytree.data_of_node n
@@ -101,24 +103,17 @@ let right_opt_pairs n m =
                 name_of x = name_of y) in
         (maybe_node, Some y))
 
-(* this is module option 'compare', but with Some _ preceding None, which is
-   useful for maintaing left-right -> top-down order for show_diff
- *)
-let opt_cmp o0 o1 =
-    match o0, o1 with
-    | Some v0, Some v1 -> compare (name_of v0) (name_of v1)
-    | None, None -> 0
-    | None, Some _ -> 1
-    | Some _, None -> -1
-
-let tuple_cmp t1 t2 =
-    match t1, t2 with
-    | (x1, y1), (x2, y2) ->
-            let first = opt_cmp x1 x2 in
-            if first <> 0 then first else opt_cmp y1 y2
+let opt_tuple_cmp t1 t2 =
+    let opt_tuple_val t =
+        match t with
+        | None, None -> ""
+        | Some x, None -> name_of x
+        | None, Some y -> name_of y
+        | Some x, Some _ -> name_of x
+    in Util.lexical_numeric_compare (opt_tuple_val t1) (opt_tuple_val t2)
 
 let opt_zip n m =
-    left_opt_pairs n m @ right_opt_pairs n m |> List.sort_uniq tuple_cmp
+    left_opt_pairs n m @ right_opt_pairs n m |> List.sort_uniq opt_tuple_cmp
 
 let get_opt_name left_opt right_opt =
     match left_opt, right_opt with
@@ -137,7 +132,7 @@ 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 : 'a diff_func) (res: 'a result) ((left_node_opt, right_node_opt) : Config_tree.t option * Config_tree.t option) =
+let rec diff (path : string list) (f : 'a diff_func) (res: 'a diff_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
@@ -196,7 +191,7 @@ let clone ?(recurse=true) ?(set_values=None) old_root new_root path =
             clone_path ~recurse:recurse ~set_values:set_values old_root new_root path_existing path_remaining
 
 (* define the diff_func *)
-let decorate_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : change) =
+let build_trees ?(recurse=true) (path : string list) (Diff_tree res) (m : change) =
     (* raises no exception:
         clone will always be called on extant path of left or right
        alert exn Vytree.get_values:
@@ -268,8 +263,8 @@ let tree_at_path path node =
         make Config_tree.default_data "" [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 =
+(* call recursive diff on config_trees with build_trees as the diff_func *)
+let diff_trees path left right =
     (* raises:
         [Empty_comparison] from tree_at_path
         [Incommensurable]
@@ -280,16 +275,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
-        let d = diff [] decorate_trees trees (Option.some left, Option.some right)
-        in eval_result d
+        let d = diff [] build_trees trees (Option.some left, Option.some right)
+        in eval_diff_result d
 
-(* wrapper to return diff trees *)
+(* wrapper to return single tree with diff trees as subtrees *)
 let diff_tree path left right =
     (* raises:
         [Incommensurable],
         [Empty_comparison] from compare
      *)
-    let trees = compare path left right in
+    let trees = diff_trees 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
@@ -339,8 +334,9 @@ let get_tagged_delete_tree dt =
 
 
 (* the following builds a diff_func to return a unified diff string of
-   configs or config commands
+   configs or config commands for use in the config-mode 'compare' command
  *)
+
 let list_but_last l =
     let len = List.length l in
     List.filteri (fun i _ -> i < len - 1) l
@@ -377,7 +373,7 @@ let order_commands (strl: string) =
     let set = List.filter (fun s -> (s <> "") && (s.[0] = 's')) l in
     (String.concat "\n" del) ^ "\n" ^ (String.concat "\n" set) ^ "\n"
 
-let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res) (m : change) =
+let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_compare res) (m : change) =
     (* raises no exception:
         clone will always be called on extant path of left or right
        alert exn Vytree.get_values:
@@ -400,14 +396,14 @@ let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res)
                 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; }
+            Diff_compare { res with ppath = ppath_l; udiff = str_diff; }
     | Subtracted ->
             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)
+            Diff_compare { res with ppath = ppath_l; udiff = str_diff; }
+    | Unchanged -> Diff_compare (res)
     | Updated v ->
             let ov = (Config_tree.get_values[@alert "-exn"]) res.left path in
             match ov, v with
@@ -420,7 +416,7 @@ let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res)
                         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; }
+                    Diff_compare { 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
@@ -439,7 +435,7 @@ let unified_diff ?(cmds=false) ?recurse:_ (path : string list) (Diff_string res)
                               in str_diff ^ (added_lines ~cmds:cmds add_tree path)
                           else str_diff
                       in
-                      Diff_string { res with ppath = ppath_l; udiff = str_diff; }
+                      Diff_compare { 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
@@ -465,7 +461,7 @@ let compare_at_path_maybe_empty left right path =
                  raise Empty_comparison
     in (left, right)
 
-let show_diff ?(cmds=false) path left right =
+let diff_compare ?(cmds=false) path left right =
     (* raises:
         [Incommensurable],
         [Empty_comparison] from compare_at_path_maybe_empty
@@ -477,17 +473,242 @@ let show_diff ?(cmds=false) path left right =
             if (path <> []) then
                 compare_at_path_maybe_empty left right path
             else (left, right) in
-        let dstr = make_diff_string left right in
+        let dstr = make_diff_compare 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 dstr = eval_diff_result dstr in
         let strs =
             if cmds then order_commands dstr.udiff
             else dstr.udiff
         in
         strs
 
+(* the following builds a diff_func for 'show config' *)
+
+let annotate_rendered change rendered =
+    let mark =
+        match change with
+        | Unchanged -> " "
+        | Added -> "+"
+        | Subtracted -> "-"
+        | Updated _ -> ">"
+    in
+    let lst = String.split_on_char '\n' rendered in
+    let marked = List.map (fun x -> match x with "" -> x | _ -> mark ^ x) lst in
+    String.concat "\n" marked
+
+let get_level_at_path node path =
+    (* alert exn Config_tree.is_tag_value:
+        [Vytree.Empty_path] called in pattern path non-empty
+        [Vytree.Nonexistent_path] function diff never calls diff_func on nonexistent path
+     *)
+    let f level p =
+        if (Config_tree.is_tag_value[@alert "-exn"]) node p then level
+        else level + 1
+    in
+    match path with
+    | [] -> 0
+    | _ ->
+        List.fold_left f 0 (Util.flag path) - 1
+
+let render_level_open indent node path =
+    (* alert exn Config_tree.is_tag, Config_tree.is_tag_value:
+        [Vytree.Empty_path] called in branch path non-empty
+        [Vytree.Nonexistent_path] function diff never calls diff_func on nonexistent path
+     *)
+    if Util.is_empty path || (Config_tree.is_tag[@alert "-exn"]) node path then
+        ""
+    else
+    let level = get_level_at_path node path in
+    let indent_str = Config_tree.make_indent indent level in
+    if (Config_tree.is_tag_value[@alert "-exn"]) node path then
+        let tag_node =
+            match Util.get_last_n path 1 with
+            | None -> (* not possible as path non-empty *) "none"
+            | Some n -> n
+        in
+        let tag_value =
+            match Util.get_last path with
+            | None -> (* not possible as path non-empty *) "none"
+            | Some v -> v
+        in
+        Printf.sprintf "%s%s %s {\n" indent_str tag_node tag_value
+    else
+        let name =
+            match Util.get_last path with
+            | None -> (* not possible as path non-empty *) "none"
+            | Some v -> v
+        in
+        Printf.sprintf "%s%s {\n" indent_str name
+
+let render_level_close indent node path =
+    (* alert exn Config_tree.is_tag:
+        [Vytree.Empty_path] called in branch path non-empty
+        [Vytree.Nonexistent_path] function diff never calls diff_func on nonexistent path
+     *)
+    if Util.is_empty path || (Config_tree.is_tag[@alert "-exn"]) node path then
+        ""
+    else
+    let level = get_level_at_path node path in
+    let indent_str = Config_tree.make_indent indent level in
+    Printf.sprintf "%s}\n" indent_str
+
+let config_diff (rt : Reference_tree.t) ?(recurse=true) (path : string list) (Diff_show res) (m : change) =
+    (* alert exn Vytree.get, Reference_tree.refpath, Config_tree.get_values,
+       Reference_tree.is_multi, Config_tree.is_tag_value:
+        [Vytree.Empty_path] checked at only point possible (Unchanged)
+        [Vytree.Nonexistent_path] function diff never calls diff_func on nonexistent path
+     *)
+
+    let indent = 4 in
+    (* the only subtlety in all this is the bookkeeping of closing open
+       braces at correct level:
+       (1) a rendered line with open brace will occur before the next
+       depth-first step
+       (2) at each return to (local) root, the path is checked for the
+       matching closing brace
+       explicitly: the record field open_blocks is a list of open paths
+       ordered by reverse inclusion, which are closed when the path being
+       passed to config_diff no longer contains that element
+     *)
+    let rec close_blocks s l =
+        match l with
+        | [] -> s, []
+        | h :: tl ->
+            if Util.is_sublist h path then
+                s, l
+            else
+                let rendered = render_level_close indent res.left h in
+                let s' = s ^ annotate_rendered Unchanged rendered
+                in close_blocks s' tl
+    in
+    let diff_str, rev_blocks = close_blocks res.config_diff res.open_blocks
+    in
+    match m with
+    | Added ->
+        let node =
+            if (Config_tree.is_tag_value[@alert "-exn"]) res.right path then
+                (Vytree.get[@alert "-exn"]) res.right (Util.drop_last path)
+            else
+                (Vytree.get[@alert "-exn"]) res.right path
+        in
+        let level = get_level_at_path res.right path in
+        let rendered =
+            Config_tree.render_node indent level node
+        in
+        let rev_diff = diff_str ^ annotate_rendered m rendered in
+        Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+    | Subtracted ->
+        let node =
+            if (Config_tree.is_tag_value[@alert "-exn"]) res.left path then
+                (Vytree.get[@alert "-exn"]) res.left (Util.drop_last path)
+            else
+                (Vytree.get[@alert "-exn"]) res.left path
+        in
+        let level = get_level_at_path res.left path in
+        let rendered =
+            Config_tree.render_node indent level node
+        in
+        let rev_diff = diff_str ^ annotate_rendered m rendered in
+        Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+    | Unchanged ->
+        begin
+        match recurse with
+        | false ->
+            let rendered = render_level_open indent res.left path in
+            let rev_diff = diff_str ^ annotate_rendered m rendered in
+            Diff_show {res with config_diff = rev_diff; open_blocks = path::rev_blocks}
+        | true ->
+            match path with
+            | [] -> (* case left = right *)
+                let rendered =
+                    Config_tree.render_config res.left
+                in
+                let rev_diff = diff_str ^ annotate_rendered m rendered in
+                Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+            | _ ->
+                let level = get_level_at_path res.left path in
+                let node = (Vytree.get[@alert "-exn"]) res.left path in
+                let rendered =
+                    Config_tree.render_node indent level node
+                in
+                let rev_diff = diff_str ^ annotate_rendered m rendered in
+                Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+        end
+    | Updated v ->
+        let refp =
+            (Reference_tree.refpath[@alert "-exn"]) rt (res.base_path @ path) in
+        let multi = (Reference_tree.is_multi[@alert "-exn"]) rt refp in
+        let level = get_level_at_path res.left path in
+        let indent_str =
+            Config_tree.make_indent indent level
+        in
+        let name =
+            match Util.get_last path with
+            | None -> (* not possible *) "none"
+            | Some n -> n
+        in
+        match multi with
+        | false ->
+            let rendered =
+                Config_tree.render_values indent_str name v
+            in
+            let rev_diff = diff_str ^ annotate_rendered m rendered in
+            Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+        | true ->
+            let ov = (Config_tree.get_values[@alert "-exn"]) res.left path in
+            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
+            let sub_rendered =
+                match sub_vals with
+                | [] -> ""
+                | _ ->
+                    Config_tree.render_values indent_str name sub_vals
+            in
+            let sub_diff = annotate_rendered Subtracted sub_rendered in
+            let add_rendered =
+                match add_vals with
+                | [] -> ""
+                | _ ->
+                    Config_tree.render_values indent_str name add_vals
+            in
+            let add_diff = annotate_rendered Added add_rendered in
+            let inter_rendered =
+                match inter_vals with
+                | [] -> ""
+                | _ ->
+                    Config_tree.render_values indent_str name inter_vals
+            in
+            let inter_diff = annotate_rendered Unchanged inter_rendered in
+            let value_diff = sub_diff ^ inter_diff ^ add_diff in
+            let rev_diff = diff_str ^ value_diff in
+            Diff_show {res with config_diff = rev_diff; open_blocks = rev_blocks;}
+
+(* call recursive diff on config_trees with config_diff as the diff_func *)
+let diff_show rt path left right =
+    (* raises:
+        [Incommensurable]
+        [Empty_comparison]
+     *)
+    if (name_of left) <> (name_of right) then
+        raise Incommensurable
+    else
+        let (left, right) =
+            if not (Util.is_empty path) then
+            (Config_tree.get_subtree left path, Config_tree.get_subtree right path)
+            else (left, right)
+        in
+        let config_show = make_diff_show left right path in
+        let ret = diff [] (config_diff rt) config_show (Option.some left, Option.some right) in
+        (* close final braces *)
+        let d = config_diff rt ~recurse:false [] ret Unchanged in
+        let diff_show_result = eval_diff_result d in
+        diff_show_result.config_diff
+
 (* mask function; mask applied on right *)
 let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
     (* alert exn Vytree.delete:
@@ -521,7 +742,7 @@ let mask_tree left right =
     let trees = make_diff_trees left right in
     let d = diff [] mask_func trees (Option.some left, Option.some right)
     in
-    let res = eval_result d in
+    let res = eval_diff_result d in
     res.left
 
 let union_of_values (n : Config_tree.t) (m : Config_tree.t) =