Merge pull request #68 from jestabro/mask-exclusive

T8488: add mask exclusive and supporting utilitlies

6 files changed, 162 insertions, 5 deletions

diff --git a/src/config_diff.ml b/src/config_diff.ml
index 5d71c34..c00705d 100644
--- a/src/config_diff.ml
+++ b/src/config_diff.ml
@@ -706,7 +706,7 @@ let diff_show rt path left right =
         diff_show_result.config_diff
 
 (* mask function; mask applied on right *)
-let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
+let mask_func_inclusive ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
     (* alert exn Vytree.delete:
         [Vytree.Empty_path] not possible since Unchanged pattern is only empty path
         [Vytree.Nonexistent_path] not possible as called on existing config paths (res.left)
@@ -716,18 +716,43 @@ let mask_func ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
     match m with
     | Added -> Diff_tree (res)
     | Subtracted ->
-            (match path with
+        begin
+            match path with
             | [_] ->
                 Diff_tree {res with left = (Vytree.delete[@alert "-exn"]) res.left path}
             |  _  ->
                 if not ((Vytree.is_terminal_path[@alert "-exn"]) res.right (list_but_last path)) then
                     Diff_tree {res with left = (Vytree.delete[@alert "-exn"]) res.left path}
-                else Diff_tree (res))
+                else Diff_tree (res)
+        end
     | Unchanged -> Diff_tree (res)
     | Updated _ -> Diff_tree (res)
 
+(* mask function; mask applied on right *)
+let mask_func_exclusive ?recurse:_ (path : string list) (Diff_tree res) (m : change) =
+    (* alert exn Vytree.delete:
+        [Vytree.Empty_path] not possible in pattern match case
+        [Vytree.Nonexistent_path] not possible as called on existing config paths (res.left)
+       alert exn Vytree.is_terminal_path:
+        [Vytree.Empty_path] not possible in pattern match case
+     *)
+    match m with
+    | Added -> Diff_tree (res)
+    | Subtracted -> Diff_tree (res)
+    | Unchanged | Updated _ ->
+        begin
+            match path with
+            | [] -> Diff_tree(res)
+            | _ ->
+                if ((Vytree.is_terminal_path[@alert "-exn"]) res.right path) then
+                    let tmp = (Vytree.delete[@alert "-exn"]) res.left path in
+                    let left' = (Config_tree.prune_delete[@alert "-exn"]) tmp path in
+                    Diff_tree {res with left = left'}
+                else Diff_tree (res)
+        end
+
 (* call recursive diff with mask_func; mask applied on right *)
-let mask_tree left right =
+let mask_tree ?(exclusive=false) left right =
     (* raises:
         [Empty_comparison] from diff
         [Incommensurable]
@@ -736,11 +761,84 @@ let mask_tree left right =
         raise Incommensurable
     else
     let trees = make_diff_trees left right in
+    let mask_func =
+        if exclusive then mask_func_exclusive else mask_func_inclusive
+    in
     let d = diff [] mask_func trees (Option.some left, Option.some right)
     in
     let res = eval_diff_result d in
     res.left
 
+(* Convert from a path that may or may not include intervening tag_values,
+   returning a subtree of matches *)
+exception Malformed_path of string
+
+let subtree_from_partial reftree ctree result path =
+    if Util.is_empty path then result
+    else
+    let check_reftree p =
+        match p with
+        | [] -> false
+        | _ ->
+            let rpath =
+                Reference_tree.refpath_from_partial reftree p
+            in
+            match rpath with
+            | [] -> false
+            | _ -> true
+    in
+    let check_ctree p =
+        match p with
+        | [] -> false
+        | _ -> (Vytree.exists[@alert "-exn"]) ctree p
+    in
+    let clone_node tree p =
+        if (Vytree.exists[@alert "-exn"]) tree p then
+            tree
+        else
+        if not ((Vytree.exists[@alert "-exn"]) ctree p) then
+            tree
+        else
+            clone ~recurse:false ctree tree p
+    in
+    let clone_children tree p =
+        let children = Vytree.list_children ((Vytree.get[@alert "-exn"]) ctree p) in
+        let paths = List.map (fun n -> p @ [n]) children in
+        List.fold_left clone_node tree paths
+    in
+    let rec aux acc path_done p =
+        if not (check_reftree (path_done @ p)) then
+            raise (Malformed_path (Util.string_of_list (path_done @ p)))
+        else
+        match path_done, p with
+        | [], h :: tl ->
+                if check_reftree [h] then aux (clone_node acc [h]) [h] tl
+                else
+                raise (Malformed_path (Util.string_of_list p))
+        | _, h :: tl ->
+                let p' = path_done @ [h] in
+                if check_ctree p' then aux (clone_node acc p') p' tl
+                else
+                    if (Config_tree.is_tag[@alert "-exn"]) ctree path_done then
+                    let children =
+                        Vytree.list_children ((Vytree.get[@alert "-exn"]) ctree path_done)
+                    in
+                    let func accum child =
+                        let path = path_done @ [child] @ [h] in
+                        if check_ctree path then
+                            aux (clone_node accum path) path tl
+                        else accum
+                    in
+                    List.fold_left func acc children
+                else
+                (* [h] is a tag_value not present in the config tree *)
+                raise (Malformed_path (Util.string_of_list p'))
+        | _, [] ->
+                if (Config_tree.is_tag[@alert "-exn"]) ctree path_done then clone_children acc path_done
+                else acc
+    in aux result [] path
+
+
 let union_of_values (n : Config_tree.t) (m : Config_tree.t) =
     let set_n = ValueS.of_list (data_of n).values in
     let set_m = ValueS.of_list (data_of m).values in
diff --git a/src/config_diff.mli b/src/config_diff.mli
index 7579e32..168b748 100644
--- a/src/config_diff.mli
+++ b/src/config_diff.mli
@@ -65,8 +65,12 @@ val tree_merge : ?destructive:bool -> Config_tree.t -> Config_tree.t -> Config_t
 [@@alert exn "Tree_alg.Incompatible_union"]
 [@@alert exn "Tree_alg.Nonexistent_child"]
 
-val mask_tree : Config_tree.t -> Config_tree.t -> Config_tree.t
+val mask_tree : ?exclusive:bool -> Config_tree.t -> Config_tree.t -> Config_tree.t
 [@@alert exn "Config_diff.Incommensurable"]
 [@@alert exn "Config_diff.Empty_comparison"]
 
 val get_tagged_delete_tree : Config_tree.t -> Config_tree.t
+
+exception Malformed_path of string
+val subtree_from_partial : Reference_tree.t -> Config_tree.t -> Config_tree.t -> string list -> Config_tree.t
+[@@alert exn "Config_diff.Malformed_path"]
diff --git a/src/internal.ml b/src/internal.ml
index bb3ab66..88f8b0c 100644
--- a/src/internal.ml
+++ b/src/internal.ml
@@ -16,6 +16,9 @@ module type T =
 
 module type FI = functor (M: T) ->
     sig
+        val write_string : M.t -> string
+        val read_string : string -> M.t
+        [@@alert exn "Internal.Read_error"]
         val write_internal : M.t -> string -> unit
         [@@alert exn "Internal.Write_error"]
         val write_internal_atomic : M.t -> string -> unit
@@ -27,6 +30,24 @@ module type FI = functor (M: T) ->
     end
 
 module Make : FI = functor (M: T) -> struct
+    let write_string x =
+        let yt = M.to_yojson x in
+        Yojson.Safe.to_string yt
+
+    let read_string s =
+        try
+            let yt = Yojson.Safe.from_string s in
+            let res = M.of_yojson yt in
+            match res with
+            | Error _ -> raise (Read_error "Corrupted string")
+            | Ok r -> r
+        with
+        | Read_error _ as e -> raise e
+        | Yojson.Json_error msg ->
+            raise (Read_error ("Corrupted string: " ^ msg))
+        | exn ->
+            raise (Read_error ("Corrupted string: " ^ Printexc.to_string exn))
+
     let write_internal x file_name =
         let yt = M.to_yojson x in
         let ys = Yojson.Safe.to_string yt in
diff --git a/src/internal.mli b/src/internal.mli
index 030bdaf..a424a08 100644
--- a/src/internal.mli
+++ b/src/internal.mli
@@ -11,6 +11,11 @@ module type T =
 
 module type FI = functor (M : T) ->
     sig
+        val write_string : M.t -> string
+
+        val read_string : string -> M.t
+        [@@alert exn "Internal.Read_error"]
+
         val write_internal : M.t -> string -> unit
         [@@alert exn "Internal.Write_error"]
 
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 8ff7b54..dead1be 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -648,6 +648,33 @@ let refpath reftree path =
     | _, [] -> acc
     in aux [] path
 
+(* Convert from partial config path to reference tree path.
+   'Partial' here means that there may or may not be intervening tag node
+   values.
+ *)
+let refpath_from_partial reftree path =
+    let check_existence p =
+        match p with
+        | [] -> false
+        | _ -> (Vytree.exists[@alert "-exn"]) reftree p
+    in
+    let rec aux acc p =
+    match acc, p with
+    | [], h :: tl ->
+            if check_existence [h] then aux [h] tl else []
+    | _, [h] ->
+            let p = acc @ [h] in
+            if check_existence p then p else
+            if is_tag reftree acc then acc else []
+    | _, h :: h' :: tl ->
+            let p = acc @ [h] in
+            if check_existence p then aux p ([h'] @ tl) else
+            let p = acc @ [h'] in
+            if is_tag reftree acc && check_existence p then aux p tl
+            else []
+    | _, [] -> acc
+    in aux [] path
+
 let set_tag_data rtree ctree path =
     (* raises:
         [Vytree.Empty_path],
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index 04347a5..b1341da 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -117,6 +117,8 @@ val get_subtree : ?with_node:bool -> t -> string list -> t
 
 val refpath : t -> string list -> string list
 
+val refpath_from_partial : t -> string list -> string list
+
 val set_tag_data : t -> Config_tree.t -> string list -> Config_tree.t
 [@@alert exn "Vytree.Empty_path"]
 [@@alert exn "Vytree.Nonexistent_path"]