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
include Json_base
(** A position. *)
type pos = Lexing.position * Lexing.position
let sedlexing_error ~pos ~message lexbuf =
let lexbuf_position = Sedlexing.lexing_bytes_positions lexbuf in
let message =
Printf.sprintf "In json data %s: %s" (Pos.to_string lexbuf_position) message
in
Runtime_error.raise ~message ~pos "json"
let from_string ?(pos = []) ?(json5 = false) s =
let parser = if json5 then Json_parser.json5 else Json_parser.json in
let processor = MenhirLib.Convert.Simplified.traditional2revised parser in
let lexbuf =
let gen =
let pos = ref (-1) in
let len = String.length s in
fun () ->
incr pos;
if !pos < len then Some s.[!pos] else None
in
Sedlexing.Utf8.from_gen gen
in
let tokenizer () =
let token =
if json5 then Json_lexer.json5_token lexbuf
else Json_lexer.json_token lexbuf
in
let startp, endp = Sedlexing.lexing_bytes_positions lexbuf in
(token, startp, endp)
in
try processor tokenizer with
| Runtime_error.Runtime_error _ as exn ->
let bt = Printexc.get_raw_backtrace () in
Printexc.raise_with_backtrace exn bt
| Json_base.Parse_error { pos = lexbuf_pos; message } ->
let message =
Printf.sprintf "In json data %s: %s" (Pos.to_string lexbuf_pos)
message
in
Runtime_error.raise ~message ~pos "json"
| Sedlexing.InvalidCodepoint c ->
sedlexing_error ~pos
~message:(Printf.sprintf "Invalid codepoint: %d" c)
lexbuf
| Sedlexing.MalFormed ->
sedlexing_error ~pos ~message:"Malformed input" lexbuf
| _ -> Runtime_error.raise ~message:"Parse error" ~pos "json"
let quote_string =
let escape_char =
let utf8_char_code s pos len =
try Lang_string.utf8_char_code s pos len
with _ -> Uchar.to_int Uchar.rep
in
Lang_string.escape_char ~escape_fun:(fun s pos len ->
Printf.sprintf "\\u%04X" (utf8_char_code s pos len))
in
let escape_formatter ~next special_char =
Lang_string.escape
~special_char:(fun s pos len ->
if s.[pos] = '\'' && len = 1 then false else special_char s pos len)
~escape_char ~next
in
let escape_utf8_formatter =
escape_formatter ~next:Lang_string.utf8_next Lang_string.utf8_special_char
in
let escape_ascii_formatter =
escape_formatter ~next:Lang_string.ascii_next Lang_string.ascii_special_char
in
fun s ->
Printf.sprintf "\"%s\""
(try Lang_string.escape_string escape_utf8_formatter s
with _ -> Lang_string.escape_string escape_ascii_formatter s)
let rec to_string_compact ~json5 = function
| `Null -> "null"
| `String s -> quote_string s
| `Bool b -> string_of_bool b
| `Int i -> string_of_int i
| `Float f -> (
match classify_float f with
| FP_infinite when json5 -> if f < 0. then "-Infinity" else "Infinity"
| FP_nan when json5 -> if f < 0. then "-NaN" else "NaN"
| FP_infinite | FP_nan ->
Runtime_error.raise ~pos:[]
~message:
"Infinite or Nan number cannot be represented in JSON. You \
might want to consider using the `json5` representation."
"json"
| _ ->
let s = string_of_float f in
let s = Printf.sprintf "%s" s in
if s.[String.length s - 1] = '.' then Printf.sprintf "%s0" s else s)
| `Tuple l ->
"[" ^ String.concat "," (List.map (to_string_compact ~json5) l) ^ "]"
| `Assoc l ->
let l =
List.map
(fun (l, v) ->
Printf.sprintf "\"%s\":%s" l (to_string_compact ~json5 v))
l
in
Printf.sprintf "{%s}" (String.concat "," l)
let pp_list sep ppx f l =
let pp_sep f () = Format.fprintf f "%s@ " sep in
Format.pp_print_list ~pp_sep ppx f l
let rec to_string_pp ~json5 f v =
match v with
| `Tuple [] -> Format.fprintf f "[]"
| `Tuple l ->
Format.fprintf f "[@;<1 0>%a@;<1 -2>]"
(pp_list "," (to_string_pp ~json5))
l
| `Assoc [] -> Format.fprintf f "{}"
| `Assoc l ->
let format_field f (k, v) =
Format.fprintf f "@[<hv2>%s: %a@]"
(Lang_string.quote_string k)
(to_string_pp ~json5) v
in
Format.fprintf f "{@;<1 0>%a@;<1 -2>}" (pp_list "," format_field) l
| `Null | `String _ | `Int _ | `Float _ | `Bool _ ->
Format.fprintf f "%s" (to_string_compact ~json5 v)
let to_string_pp ~json5 v =
Format.asprintf "@[<hv2>%a@]" (to_string_pp ~json5) v
let to_string ?(compact = true) ?(json5 = false) v =
if compact then to_string_compact ~json5 v else to_string_pp ~json5 v