package hack_parallel

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

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.
*)

(*
<value> ::=
  | <object>
  | <array>
  | <string>
  | <number>
  | 'true'
  | 'false'
  | 'null'
<object>   ::= '{' <members>* '}'
<members>  ::= <pair> { ',' <pair> }* [',']
<pair>     ::= <string> ':' <value>
<array>    ::= '{' <elements>* '}'
<elements> ::= <value> { ',' <value> }* [',']
<number>   ::=
Caveats:
 (+) No handling of Unicode yet
 (+) Numbers are just stored as strings
 *)

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

(* Ignore whitespace in peek/eat/next/has_more to make code that uses them
   cleaner
*)

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)

(* skip all blank and new line characters *)
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
      () (* encountered a non-digit char, stop *)
  else
    () (* end of string, stop *)

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; (* ['-'] digits *)
  let c = peek env in
  if c = '.'  then (* ['.' digits ] *)
    begin
      buf_eat buf env '.';
      buf_eat_digits buf env;
    end;
  buf_eat_exp buf env; (* [exp digits] *)
  JSON_Number(Buffer.contents buf)

(* The recursive rules *)
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 ()

(* Writing JSON *)

(* buf_concat :
 * Designed as a substitute for String.concat that passes a buffer
 * into which intermediate strings are added, and also includes left
 * and right bracket (lb and rb) in addition to sep. They are strings,
 * despite common case of (), [],{}, or even <>, to handle missing brackets,
 * brackets with spacing and multichar brackets like OCaml's arrays ([| and |]).
 * The A conc_elt function parameter performs the operation of transforming
 * the list element to a string and adding it to the buffer, the simplest
 * example would be fun x -> Buffer.add_string (to_string x)
*)
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 (* need a better estimate! *)
    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
OCaml

Innovation. Community. Security.