blob: 28f0be1d64b62ddfde900c254091ca5ed2c74508 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(* Load interface definitions from a directory into a reference tree *)
exception Load_error of string
exception Write_error of string
module I = Internal.Make(Reference_tree)
let load_interface_definitions dir =
let open Reference_tree in
let dir_paths = FileUtil.ls dir in
let relative_paths =
List.filter (fun x -> Filename.extension x = ".xml") dir_paths
in
let absolute_paths =
try Ok (List.map Util.absolute_path relative_paths)
with Sys_error no_dir_msg -> Error no_dir_msg
in
let load_aux tree file =
load_from_xml tree file
in
try begin match absolute_paths with
| Ok paths -> Ok (List.fold_left load_aux default paths)
| 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
in
let ref_tree =
match ref_tree_result with
| Ok ref -> ref
| Error msg -> raise (Load_error msg)
in
let out = Reference_tree.render_json ref_tree in
let oc =
try
open_out to_file
with Sys_error msg -> raise (Write_error msg)
in
Printf.fprintf oc "%s" out;
close_out oc;
match internal_cache with
| "" -> ()
| _ -> I.write_internal ref_tree internal_cache
|
