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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
type 'a ocaml_array = 'a array
let input_file fname read =
let ic = open_in_bin fname in
try
let x = read ic in
close_in ic;
x
with e ->
close_in_noerr ic;
raise e
let output_file fname write =
let oc = open_out_bin fname in
try
write oc;
close_out oc
with e ->
close_out_noerr oc;
raise e
module Biniou =
struct
type 'a reader = Bi_inbuf.t -> 'a
type 'a writer = Bi_outbuf.t -> 'a -> unit
let from_channel ?len ?(shrlen = 0) read ic =
let ib = Bi_inbuf.from_channel ?len ~shrlen ic in
read ib
let from_file ?len ?(shrlen = 0) read fname =
input_file fname (fun ic -> from_channel ?len ~shrlen read ic)
let to_channel ?len ?(shrlen = 0) write oc x =
let ob = Bi_outbuf.create_channel_writer ?len ~shrlen oc in
write ob x;
Bi_outbuf.flush_channel_writer ob
let to_file ?len ?(shrlen = 0) write fname x =
output_file fname (fun oc -> to_channel ?len ~shrlen write oc x)
end
module Json =
struct
type 'a reader = Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a
type 'a writer = Bi_outbuf.t -> 'a -> unit
let finish ls lexbuf =
Yojson.Safe.read_space ls lexbuf;
if not (Yojson.Safe.read_eof lexbuf) then
Yojson.json_error "Junk after end of JSON value"
let from_lexbuf ?(stream = false) read ls lexbuf =
Yojson.Safe.read_space ls lexbuf;
let x =
if Yojson.Safe.read_eof lexbuf then
raise Yojson.End_of_input
else
read ls lexbuf
in
if not stream then
finish ls lexbuf;
x
let from_string ?buf ?fname ?lnum read s =
let lexbuf = Lexing.from_string s in
let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in
from_lexbuf read ls lexbuf
let from_channel ?buf ?fname ?lnum read ic =
let lexbuf = Lexing.from_channel ic in
let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in
from_lexbuf read ls lexbuf
let from_file ?buf ?fname:src ?lnum read fname =
let fname0 =
match src with
None -> fname
| Some s -> s
in
input_file fname (fun ic -> from_channel ?buf ~fname:fname0 ?lnum read ic)
let stream_from_lexbuf ?(fin = fun () -> ()) read ls lexbuf =
let stream = Some true in
let f _ =
try Some (from_lexbuf ?stream read ls lexbuf)
with
Yojson.End_of_input ->
fin ();
None
| e ->
(try fin () with _ -> ());
raise e
in
Stream.from f
let stream_from_string ?buf ?fin ?fname ?lnum read ic =
let lexbuf = Lexing.from_string ic in
let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in
stream_from_lexbuf ?fin read ls lexbuf
let stream_from_channel ?buf ?fin ?fname ?lnum read ic =
let lexbuf = Lexing.from_channel ic in
let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in
stream_from_lexbuf ?fin read ls lexbuf
let stream_from_file ?buf ?(fin = fun () -> ()) ?fname:src ?lnum read fname =
let fname0 =
match src with
None -> fname
| Some s -> s
in
let ic = open_in_bin fname in
let fin () = close_in_noerr ic; fin () in
stream_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic
let list_from_string ?buf ?fin ?fname ?lnum read ic =
let stream = stream_from_string ?buf ?fin ?fname ?lnum read ic in
let acc = ref [] in
Stream.iter (fun x -> acc := x :: !acc) stream;
List.rev !acc
let list_from_channel ?buf ?fin ?fname ?lnum read ic =
let stream = stream_from_channel ?buf ?fin ?fname ?lnum read ic in
let acc = ref [] in
Stream.iter (fun x -> acc := x :: !acc) stream;
List.rev !acc
let list_from_file ?buf ?fname:src ?lnum read fname =
let fname0 =
match src with
None -> fname
| Some s -> s
in
let ic = open_in_bin fname in
let fin () = close_in_noerr ic in
list_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic
let to_string ?(len = 1024) write x =
let ob = Bi_outbuf.create len in
write ob x;
Bi_outbuf.contents ob
let to_channel ?len write oc x = Biniou.to_channel ?len ~shrlen:0 write oc x
let to_file ?len write fname x = Biniou.to_file ?len ~shrlen:0 write fname x
let stream_to_string ?(len = 1024) ?(lf = "\n") write stream =
let ob = Bi_outbuf.create len in
Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream;
Bi_outbuf.contents ob
let stream_to_channel ?len ?(lf = "\n") write oc stream =
let ob = Bi_outbuf.create_channel_writer ?len ~shrlen:0 oc in
Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream;
Bi_outbuf.flush_channel_writer ob
let stream_to_file ?len ?lf write fname stream =
output_file fname (fun oc -> stream_to_channel ?len ?lf write oc stream)
let list_to_string ?len ?lf write l =
stream_to_string ?len ?lf write (Stream.of_list l)
let list_to_channel ?len ?lf write oc l =
stream_to_channel ?len ?lf write oc (Stream.of_list l)
let list_to_file ?len ?lf write fname l =
stream_to_file ?len ?lf write fname (Stream.of_list l)
let preset_unknown_field_handler loc name =
let msg =
Printf.sprintf
"Found unknown JSON field %s while expecting type defined at: %s"
name loc
in
failwith msg
let unknown_field_handler = ref preset_unknown_field_handler
end
module Validation =
struct
type path_elem = [ `Field of string | `Index of int ]
type path = path_elem list
let string_of_path l =
String.concat "" (
List.rev_map (
function
| `Field s -> "." ^ s
| `Index n -> "[" ^ string_of_int n ^ "]"
) l
)
type error = {
error_path : path;
error_msg : string option;
}
let error ?msg path = {
error_path = path;
error_msg = msg;
}
let string_of_error x =
let path = string_of_path x.error_path in
match x.error_msg with
None ->
"Validation error; path = <root>" ^ path
| Some msg ->
Printf.sprintf "Validation error: %s; path = <root>%s" msg path
end