Merge pull request #33 from jestabro/modular-reference-tree

T7046: add utilities for update of reference tree

6 files changed, 163 insertions, 29 deletions

diff --git a/src/config_diff.ml b/src/config_diff.ml
index 6fd57c6..09167b3 100644
--- a/src/config_diff.ml
+++ b/src/config_diff.ml
@@ -432,29 +432,10 @@ let union_of_values (n : Config_tree.t) (m : Config_tree.t) =
     let set_m = ValueS.of_list (data_of m).values in
     ValueS.elements (ValueS.union set_n set_m)
 
-let union_of_children n m =
-    let set_n = ChildrenS.of_list (children_of n) in
-    let set_m = ChildrenS.of_list (children_of m) in
-    ChildrenS.elements (ChildrenS.union set_n set_m)
-
-(* tree_union is currently used only for unit tests, so only values of data
-   are considered. Should there be a reason to expose it in the future,
-   consistency check and union of remaining data will need to be added.
- *)
-let rec tree_union s t =
-    let child_of_union s t c =
-        let s_c = Vytree.find s (name_of c) in
-        let t_c = Vytree.find t (name_of c) in
-        match s_c, t_c with
-        | Some child, None -> clone s t [(name_of child)]
-        | None, Some _ -> t
-        | Some u, Some v ->
-                if u ^~ v then
-                    let values = union_of_values u v in
-                    let data = {(data_of v) with Config_tree.values = values} in
-                    Vytree.replace t (Vytree.make data (name_of v))
-                else
-                    Vytree.replace t (tree_union u v)
-        | None, None -> raise Nonexistent_child
+let tree_union s t =
+    let f u v =
+        let values = union_of_values u v in
+        let data = {(data_of v) with Config_tree.values = values} in
+        Vytree.make_full data (name_of v) (children_of v)
     in
-    List.fold_left (fun x c -> child_of_union s x c) t (union_of_children s t)
+    Tree_alg.ConfigAlg.tree_union s t f
diff --git a/src/generate.ml b/src/generate.ml
index 632c678..28f0be1 100644
--- a/src/generate.ml
+++ b/src/generate.ml
@@ -22,6 +22,47 @@ let load_interface_definitions dir =
         | Error msg -> Error msg end
     with Bad_interface_definition msg -> Error msg
 
+let interface_definitions_to_cache from_dir cache_path =
+    let ref_tree_result =
+        load_interface_definitions from_dir
+    in
+    let ref_tree =
+    match ref_tree_result with
+        | Ok ref -> ref
+        | Error msg -> raise (Load_error msg)
+    in
+    I.write_internal ref_tree cache_path
+
+let reference_tree_cache_to_json cache_path render_file =
+    let ref_tree =
+        I.read_internal cache_path
+    in
+    let out = Reference_tree.render_json ref_tree in
+    let oc =
+        try
+            open_out render_file
+        with Sys_error msg -> raise (Write_error msg)
+    in
+    Printf.fprintf oc "%s" out;
+    close_out oc
+
+let merge_reference_tree_cache cache_dir primary_name result_name =
+    let file_arr = Sys.readdir cache_dir in
+    let file_list' = Array.to_list file_arr in
+    let file_list =
+        List.filter (fun x -> x <> primary_name && x <> result_name) file_list' in
+    let file_path_list =
+        List.map (FilePath.concat cache_dir) file_list in
+    let primary_tree = I.read_internal (FilePath.concat cache_dir primary_name) in
+    let ref_trees = List.map I.read_internal file_path_list in
+    match ref_trees with
+    | [] ->
+        I.write_internal primary_tree (FilePath.concat cache_dir result_name)
+    | _ ->
+        let f _ v = v in
+        let res = List.fold_left (fun p r -> Tree_alg.RefAlg.tree_union r p f) primary_tree ref_trees in
+        I.write_internal res (FilePath.concat cache_dir result_name)
+
 let reference_tree_to_json ?(internal_cache="") from_dir to_file =
     let ref_tree_result =
         load_interface_definitions from_dir
diff --git a/src/generate.mli b/src/generate.mli
index 6f8e775..4243ef0 100644
--- a/src/generate.mli
+++ b/src/generate.mli
@@ -3,3 +3,6 @@ exception Write_error of string
 
 val load_interface_definitions : string -> (Reference_tree.t, string) result
 val reference_tree_to_json : ?internal_cache:string -> string -> string -> unit
+val interface_definitions_to_cache : string -> string -> unit
+val reference_tree_cache_to_json : string -> string -> unit
+val merge_reference_tree_cache : string -> string -> string -> unit
diff --git a/src/internal.ml b/src/internal.ml
index 0c761e0..a57f3db 100644
--- a/src/internal.ml
+++ b/src/internal.ml
@@ -1,3 +1,6 @@
+exception Read_error of string
+exception Write_error of string
+
 module type T =
     sig
         type t
@@ -10,20 +13,54 @@ module type FI = functor (M: T) ->
     sig
         val write_internal : M.t -> string -> unit
         val read_internal : string -> M.t
+        val replace_internal : string -> string -> unit
     end
 
 module Make : FI = functor (M: T) -> struct
     let write_internal x file_name =
         let yt = M.to_yojson x in
         let ys = Yojson.Safe.to_string yt in
-        let oc = open_out file_name in
-        Printf.fprintf oc "%s" ys; close_out oc
+        let fd = Unix.openfile file_name [Unix.O_CREAT;Unix.O_WRONLY] 0o664 in
+        let () =
+            try
+                Unix.lockf fd Unix.F_TLOCK 0
+            with _ ->
+                Unix.close fd; raise (Write_error "write lock unavailable")
+        in
+        let oc = Unix.out_channel_of_descr fd in
+        let () = Unix.ftruncate fd 0 in
+        let () = Printf.fprintf oc "%s" ys in
+        let () = Unix.fsync fd in
+        let () = Unix.lockf fd Unix.F_ULOCK 0 in
+        close_out_noerr oc
 
     let read_internal file_name =
-        let ic = open_in file_name in
+        let fd =
+            try
+                Unix.openfile file_name [Unix.O_RDONLY] 0o664
+            with Unix.Unix_error (e,f,p) ->
+                let out =
+                    Printf.sprintf "%s %s: %s" (Unix.error_message e) f p
+                in raise (Read_error out)
+        in
+        let () =
+            try
+                Unix.lockf fd Unix.F_TEST 0
+            with _ ->
+                Unix.close fd; raise (Read_error "read lock unavailable")
+        in
+        let ic = Unix.in_channel_of_descr fd in
         let ys = really_input_string ic (in_channel_length ic) in
         let yt = Yojson.Safe.from_string ys in
         let ct_res = M.of_yojson yt in
         let ct = Result.value ct_res ~default:M.default in
-        close_in ic; ct
+        close_in_noerr ic; ct
+
+    let replace_internal dst src =
+        let tmp = src ^ ".tmp" in
+        try
+            let () = FileUtil.cp ~force:Force [src] tmp in
+            let () = FileUtil.rm ~force:Force [dst] in
+            FileUtil.mv ~force:Force tmp dst
+        with _ -> raise (Write_error "replace error")
 end
diff --git a/src/internal.mli b/src/internal.mli
index 33918c7..a82232d 100644
--- a/src/internal.mli
+++ b/src/internal.mli
@@ -1,3 +1,6 @@
+exception Read_error of string
+exception Write_error of string
+
 module type T =
     sig
         type t
@@ -10,6 +13,7 @@ module type FI = functor (M : T) ->
     sig
       val write_internal : M.t -> string -> unit
       val read_internal : string -> M.t
+      val replace_internal : string -> string -> unit
     end
 
 module Make : FI
diff --git a/src/tree_alg.ml b/src/tree_alg.ml
new file mode 100644
index 0000000..23af99d
--- /dev/null
+++ b/src/tree_alg.ml
@@ -0,0 +1,68 @@
+exception Incompatible_union
+exception Nonexistent_child
+
+module type Data = sig
+    type t
+end
+
+module type Tree = sig
+    module D: Data
+    type t = D.t Vytree.t
+end
+
+module Tree_impl (D: Data): Tree with module D = D = struct
+    module D = D
+    type t = D.t Vytree.t
+end
+
+module Alg (D: Data) (T: Tree with module D = D) = struct
+    module TreeOrd = struct
+        type t = T.t
+        let compare a b =
+            Util.lexical_numeric_compare (Vytree.name_of_node a) (Vytree.name_of_node b)
+    end
+    module SetT = Set.Make(TreeOrd)
+
+    let union_of_children n m =
+        let set_n = SetT.of_list (Vytree.children_of_node n) in
+        let set_m = SetT.of_list (Vytree.children_of_node m) in
+        SetT.elements (SetT.union set_n set_m)
+
+    let find_child n c = Vytree.find n (Vytree.name_of_node c)
+
+    let insert_child n c = Vytree.insert ~position:Vytree.Lexical ~children:(Vytree.children_of_node c) n [(Vytree.name_of_node c)] (Vytree.data_of_node c)
+
+    let replace_child n c =
+        Vytree.replace n c
+
+    let rec tree_union s t f =
+        if (Vytree.name_of_node s) <> (Vytree.name_of_node t) then
+            raise Incompatible_union
+        else
+        let child_of_union s t c =
+            let s_c = find_child s c in
+            let t_c = find_child t c in
+            match s_c, t_c with
+            | Some child, None ->
+                insert_child t child
+            | None, Some _ -> t
+            | Some u, Some v ->
+                    if (Vytree.data_of_node u <> Vytree.data_of_node v) then
+                        replace_child t (tree_union u (f u v) f)
+                    else
+                        replace_child t (tree_union u v f)
+            | None, None -> raise Nonexistent_child
+        in
+        List.fold_left (fun x c -> child_of_union s x c) t (union_of_children s t)
+end
+
+module ConfigData: Data with type t = Config_tree.config_node_data = struct
+    type t = Config_tree.config_node_data
+end
+
+module RefData: Data with type t = Reference_tree.ref_node_data = struct
+    type t = Reference_tree.ref_node_data
+end
+
+module ConfigAlg = Alg(ConfigData)(Tree_impl(ConfigData))
+module RefAlg = Alg(RefData)(Tree_impl(RefData))