Source file hh_json.ml
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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
(**
* Copyright (c) 2015, Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD-style license found in the
* LICENSE file in the "hack" directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*
*)
(**
* Hh_json parsing and pretty printing library.
*)
module List = Hack_core_list
type json =
| JSON_Object of (string * json) list
| JSON_Array of json list
| JSON_String of string
| JSON_Number of string
| JSON_Bool of bool
| JSON_Null
let is_digit = function '0' .. '9' -> true | _ -> false
let is_whitespace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false
type env = {
allow_trailing_comma : bool;
data : string;
mutable pos : int;
}
exception Syntax_error of string
let peek env = String.get env.data env.pos
let has_more env = String.length env.data > env.pos
let syntax_error env msg =
let err_msg =
if has_more env then
Printf.sprintf "%s at char[%d]=%c" msg env.pos env.data.[env.pos]
else
Printf.sprintf "%s after the last character" msg in
raise (Syntax_error err_msg)
let skip_blank_chars env =
while has_more env && is_whitespace (peek env) do
env.pos <- env.pos + 1
done
let create_env strict s =
let env = { allow_trailing_comma=not strict; data=s; pos=0 } in
skip_blank_chars env;
env
let eat_ws env c =
let c' = peek env in
if c' = c then
env.pos <- env.pos + 1
else
let err_msg = Printf.sprintf "eat_ws: expected %c, saw %c" c c' in
syntax_error env err_msg
let eat env c =
skip_blank_chars env;
let c' = peek env in
if c' = c then
begin
env.pos <- env.pos + 1;
skip_blank_chars env
end
else
let err_msg = Printf.sprintf "eat: expected %c, saw %c" c c' in
syntax_error env err_msg
let match_substring_at s offset ss =
let ss_len = String.length ss in
if String.length s - offset >= ss_len then
try
for i = 0 to ss_len - 1 do
if s.[i + offset] <> ss.[i] then
raise Exit
done;
true
with Exit -> false
else
false
let js_literal env s js =
skip_blank_chars env;
if match_substring_at env.data env.pos s then
begin env.pos <- env.pos + String.length s; js end
else
let err_msg =
Printf.sprintf "expected '%s'" s in
syntax_error env err_msg
let js_true env = js_literal env "true" (JSON_Bool(true))
let js_false env = js_literal env "false" (JSON_Bool(false))
let js_null env = js_literal env "null" JSON_Null
let buf_eat buf env c = (eat env c; Buffer.add_char buf c)
let buf_eat_all buf env c = (eat_ws env c; Buffer.add_char buf c)
let char_code env =
let rec char_code_ (acc : int) env len =
if len = 0 then acc
else begin
env.pos <- env.pos + 1;
let c = peek env in
let i =
if '0' <= c && c <= '9' then (Char.code c) - (Char.code '0')
else if 'a' <= c && c <= 'f' then 10 + (Char.code c) - (Char.code 'a')
else syntax_error env "expected hexadecimal digit"
in
char_code_ (16*acc + i) env (len-1)
end
in
char_code_ 0 env 4
let js_string env =
let buf = Buffer.create 128 in
let rec loop env =
let c = peek env in
match c with
| '"' -> JSON_String (Buffer.contents buf)
| '\\' ->
env.pos <- env.pos + 1;
let c' = peek env in
let c' = match c' with
| 'n' -> '\n'
| 'r' -> '\r'
| 't' -> '\t'
| 'u' ->
let code = char_code env in
Char.chr code
| x -> x in
env.pos <- env.pos + 1;
Buffer.add_char buf c';
loop env
| _ ->
buf_eat_all buf env c;
loop env
in
(match peek env with
| '"' -> env.pos <- env.pos + 1
| _ -> syntax_error env "expected '\"' character");
if peek env = '"' then
begin eat env '"'; JSON_String("") end
else
let res = loop env in
eat env '"';
res
let rec buf_eat_digits buf env =
if has_more env then
let c = peek env in
if is_digit c then
begin buf_eat buf env c; buf_eat_digits buf env end
else
()
else
()
let buf_eat_exp buf env =
let c = peek env in
if c = 'e' || c = 'E' then
begin
buf_eat buf env c;
let sign = peek env in
if sign = '+' || sign = '-' then
buf_eat buf env sign;
buf_eat_digits buf env;
end
let js_number env =
let buf = Buffer.create 32 in
let c = peek env in
if c = '-' then
buf_eat buf env '-';
buf_eat_digits buf env;
let c = peek env in
if c = '.' then
begin
buf_eat buf env '.';
buf_eat_digits buf env;
end;
buf_eat_exp buf env;
JSON_Number(Buffer.contents buf)
let rec js_value env =
let js_value_syntax_error () =
let err_msg = "expected '{[\"0123456789' or {t,f,n}" in
syntax_error env err_msg in
if not (has_more env) then
js_value_syntax_error ()
else
match peek env with
| '{' -> js_object env
| '[' -> js_array env
| '"' -> js_string env
| c when is_digit c || c = '-' -> js_number env
| 't' -> js_true env
| 'f' -> js_false env
| 'n' -> js_null env
| _ -> js_value_syntax_error ()
and js_object env =
let rec loop members =
let p = js_pair env in
if peek env <> ',' then
JSON_Object(List.rev (p::members))
else
begin
eat env ',';
if peek env = '}' then
if env.allow_trailing_comma then
JSON_Object(List.rev (p::members))
else
syntax_error env "Hh_json.object: trailing comma"
else
loop (p::members)
end
in
eat env '{';
if peek env = '}' then
begin eat env '}'; JSON_Object([]) end
else
let res = loop [] in
eat env '}';
res
and js_array env =
let rec elements accum =
let v = js_value env in
if peek env <> ',' then
JSON_Array(List.rev (v::accum))
else
begin
eat env ',';
if peek env = ']' then
if env.allow_trailing_comma then
JSON_Array(List.rev (v::accum))
else
syntax_error env "Hh_json.array: trailing comma"
else
elements (v::accum)
end
in
eat env '[';
if peek env = ']' then
begin eat env ']'; JSON_Array([]) end
else
let res = elements [] in
begin eat env ']'; res end
and js_pair env =
skip_blank_chars env;
let k = js_string env in
skip_blank_chars env;
eat env ':';
let v = js_value env in
match k with
| JSON_String s -> (s,v)
| _ -> syntax_error env "Hh_json.js_pair: expected a JSON String"
let string_of_file filename =
let ic = open_in filename in
let buf = Buffer.create 5096 in
let rec loop () =
match try Some(input_line ic) with _ -> None with
| None -> Buffer.contents buf
| Some l ->
begin
Buffer.add_string buf l;
Buffer.add_char buf '\n';
loop ();
end
in
loop ()
let buf_concat ~buf ~lb ~rb ~sep ~concat_elt l =
Buffer.add_string buf lb;
(match l with
| [] -> ()
| elt :: elts ->
concat_elt buf elt;
List.iter elts ~f:begin fun e ->
Buffer.add_string buf sep; concat_elt buf e
end);
Buffer.add_string buf rb
let add_char buf c = Buffer.add_char buf c
let add_string buf s = Buffer.add_string buf s
let escape s =
let b = Buffer.create ((String.length s) + 2) in
Buffer.add_char b '"';
s |> String.iter begin fun c ->
let code = Char.code c in
match c, code with
| '\\', _ -> Buffer.add_string b "\\\\"
| '"', _ -> Buffer.add_string b "\\\""
| '\n', _ -> Buffer.add_string b "\\n"
| '\r', _ -> Buffer.add_string b "\\r"
| '\t', _ -> Buffer.add_string b "\\t"
| _, _ when code <= 0x1f ->
Printf.sprintf "\\u%04x" code
|> Buffer.add_string b
| _ -> Buffer.add_char b c
end;
Buffer.add_char b '"';
Buffer.contents b
let rec add_json_to_buffer (buf:Buffer.t) (json:json): unit =
match json with
| JSON_Object l ->
buf_concat ~buf ~lb:"{" ~rb:"}" ~sep:"," ~concat_elt:add_assoc_to_buffer l
| JSON_Array l ->
buf_concat ~buf ~lb:"[" ~rb:"]" ~sep:"," ~concat_elt:add_json_to_buffer l
| JSON_String s -> add_string buf (escape s)
| JSON_Number n -> add_string buf n
| JSON_Bool b -> if b then add_string buf "true" else add_string buf "false"
| JSON_Null -> add_string buf "null"
and add_assoc_to_buffer (buf:Buffer.t) (k,v) =
add_string buf (escape k);
add_char buf ':';
add_json_to_buffer buf v
let rec json_to_string ?(pretty=false) (json:json): string =
if pretty
then json_to_multiline json
else
let buf = Buffer.create 1024 in
add_json_to_buffer buf json;
Buffer.contents buf
and json_to_multiline json =
let rec loop indent json =
let single = json_to_string json in
if String.length single < 80 then single else
match json with
| JSON_Array l ->
let nl = List.map l ~f:(loop (indent ^ " ")) in
"[\n" ^ indent ^ " " ^ (String.concat (",\n" ^ indent ^ " ") nl) ^
"\n" ^ indent ^ "]"
| JSON_Object l ->
let nl =
List.map l
~f:(fun (k, v) ->
indent ^ " " ^ (json_to_string (JSON_String k)) ^ ":" ^
(loop (indent ^ " ") v))
in
"{\n" ^ (String.concat ",\n" nl) ^ "\n" ^ indent ^ "}"
| _ -> single
in
loop "" json
let rec output_list oc elems output_elem : unit =
match elems with
| [] -> ()
| [elem] -> output_elem oc elem
| elem :: other_elems ->
output_elem oc elem;
output_string oc ",";
output_list oc other_elems output_elem
let rec json_to_output oc (json:json): unit =
match json with
| JSON_Object l ->
output_string oc "{";
output_list oc l json_assoc_to_output;
output_string oc "}";
| JSON_Array l ->
output_string oc "[";
output_list oc l json_to_output;
output_string oc "]";
| JSON_String s ->
output_string oc (escape s)
| JSON_Number n ->
output_string oc n
| JSON_Bool b ->
output_string oc (if b then "true" else "false")
| JSON_Null ->
output_string oc "null"
and json_assoc_to_output oc (k,v) : unit =
output_string oc (escape k);
output_string oc ":";
json_to_output oc v
let json_of_string ?(strict=true) s =
let lb = create_env strict s in
js_value lb
let json_of_file ?strict filename =
json_of_string ?strict (string_of_file filename)
let int_ n = JSON_Number (string_of_int n)
let string_ s = JSON_String s
let get_object_exn = function
| JSON_Object o -> o
| _ -> assert false
let get_array_exn = function
| JSON_Array a -> a
| _ -> assert false
let get_string_exn = function
| JSON_String s -> s
| _ -> assert false
let get_number_exn = function
| JSON_Number s -> s
| _ -> assert false
let get_number_int_exn = function
| JSON_Number s -> int_of_string s
| _ -> assert false
let get_bool_exn = function
| JSON_Bool b -> b
| _ -> assert false
let opt_string_to_json = function
| Some x -> JSON_String x
| None -> JSON_Null
let opt_int_to_json = function
| Some x -> JSON_Number (string_of_int x)
| None -> JSON_Null
type json_type =
| Object_t
| Array_t
| String_t
| Number_t
| Integer_t
| Bool_t
let json_type_to_string = function
| Object_t -> "Object"
| Array_t -> "Array"
| String_t -> "String"
| Number_t -> "Number"
| Integer_t -> "Integer"
| Bool_t -> "Bool"
module type Access = sig
type keytrace = string list
type access_failure =
| Not_an_object of keytrace
| Missing_key_error of string * keytrace
| Wrong_type_error of keytrace * json_type
type 'a m = (('a * keytrace), access_failure) Hack_result.t
val access_failure_to_string : access_failure -> string
val return : 'a -> 'a m
val (>>=) : 'a m -> (('a * keytrace) -> 'b m) -> 'b m
val counit_with : (access_failure -> 'a) -> 'a m -> 'a
val get_obj : string -> json * keytrace -> json m
val get_bool : string -> json * keytrace -> bool m
val get_string : string -> json * keytrace -> string m
val get_number : string -> json * keytrace -> string m
val get_number_int : string -> json * keytrace -> int m
val get_array: string -> json * keytrace -> (json list) m
val get_val: string -> json * keytrace -> json m
end
module Access = struct
type keytrace = string list
type access_failure =
| Not_an_object of keytrace
| Missing_key_error of string * keytrace
| Wrong_type_error of keytrace * json_type
type 'a m = (('a * keytrace), access_failure) Hack_result.t
let keytrace_to_string x =
if x = [] then "" else
let res = List.map x ~f:(fun x -> "[" ^ x ^ "]") |> String.concat " " in
" (at field " ^ res ^ ")"
let access_failure_to_string = function
| Not_an_object x ->
Printf.sprintf "Value is not an object %s" (keytrace_to_string x)
| Missing_key_error (x, y) ->
Printf.sprintf "Missing key: %s%s" x (keytrace_to_string y)
| Wrong_type_error (x, y) ->
Printf.sprintf "Value expected to be %s%s"
(json_type_to_string y) (keytrace_to_string x)
let return v = Hack_result.Ok (v, [])
let (>>=) m f = Hack_result.bind m f
let counit_with f m = match m with
| Hack_result.Ok (v, _) ->
v
| Hack_result.Error e ->
f e
let catch_type_error exp f (v, keytrace) =
try Hack_result.Ok (f v, keytrace) with
| Failure msg when (String.equal "int_of_string" msg) ->
Hack_result.Error (Wrong_type_error (keytrace, exp))
| Assert_failure _ ->
Hack_result.Error (Wrong_type_error (keytrace, exp))
let get_val k (v, keytrace) =
try begin
let obj = get_object_exn v in
let candidate = List.fold_left obj ~init:None ~f:(fun opt (key, json) ->
if opt <> None then opt
else if key = k then (Some json)
else None
) in
match candidate with
| None -> Hack_result.Error (Missing_key_error (k, keytrace))
| Some obj ->
Hack_result.Ok (obj, k :: keytrace)
end with
| Assert_failure _ ->
Hack_result.Error (Not_an_object (keytrace))
let make_object_json v =
JSON_Object (get_object_exn v)
let get_obj k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error Object_t make_object_json
let get_bool k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error Bool_t get_bool_exn
let get_string k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error String_t get_string_exn
let get_number k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error Number_t get_number_exn
let get_number_int k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error Integer_t get_number_int_exn
let get_array k (v, keytrace) =
get_val k (v, keytrace) >>= catch_type_error Array_t get_array_exn
end