blob: d4d3f0e8f8147fe122d063e080b1e2075e83ea23 (
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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
(* 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 =
(* alert exn Reference_tree.load_from_xml:
[Reference_tree.Bad_interface_definition] caught
*)
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[@alert "-exn"]) 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 =
(* raises:
[Write_error]
alert exn Internal.write_internal:
[Internecl.Write_error] caught
*)
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
try
(I.write_internal[@alert "-exn"]) ref_tree cache_path
with Internal.Write_error msg -> raise (Write_error msg)
let reference_tree_cache_to_json cache_path render_file =
(* raises:
[Load_error]
[Write_error]
alert exn Internal.read_internal:
[Internal.Read_error] caught
*)
let ref_tree =
try
(I.read_internal[@alert "-exn"]) cache_path
with Internal.Read_error msg -> raise (Load_error msg)
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 =
(* raises:
[Tree_alg.Incompatible_union],
[Tree_alg.Nonexistent_child] from Tree_alg.RefAlg.tree_union
[Load_error]
[Write_error]
alert exn Internal.read_internal:
[Internal.Read_error] caught
alert exn Internal.write_internal:
[Internal.Write_error] caught
alert exn Tree_alg.RefAlg.tree_union:
[Tree_alg.Incompatible_union] allow raise
[Tree_alg.Nonexistent_child] allow raise
*)
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 =
try
(I.read_internal[@alert "-exn"]) (FilePath.concat cache_dir primary_name)
with Internal.Read_error msg -> raise (Load_error msg)
in
let ref_trees =
try
List.map (I.read_internal[@alert "-exn"]) file_path_list
with Internal.Read_error msg -> raise (Load_error msg)
in
match ref_trees with
| [] ->
begin
try
(I.write_internal[@alert "-exn"])
primary_tree
(FilePath.concat cache_dir result_name)
with Internal.Write_error msg -> raise (Write_error msg)
end
| _ ->
let f _ v = v in
let res =
List.fold_left
(fun p r -> (Tree_alg.RefAlg.tree_union[@alert "-exn"]) r p f)
primary_tree
ref_trees
in
try
(I.write_internal[@alert "-exn"])
res
(FilePath.concat cache_dir result_name)
with Internal.Write_error msg -> raise (Write_error msg)
let reference_tree_to_json ?(internal_cache="") from_dir to_file =
(* raises:
[Load_error]
[Write_error]
alert exn Internal.write_internal:
[Internal.Write_error] caught
*)
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
| "" -> ()
| _ ->
try
(I.write_internal[@alert "-exn"]) ref_tree internal_cache
with Internal.Write_error msg -> raise (Write_error msg)
|
