Declarative JSON data manipulation for OCaml
ocaml-json: to_string/to_writer return plain types per spec; add Json.Value.* shorthand
Per the ocaml-encodings skill, [to_string] and [to_writer] return plain
[string] / [unit], not [result]. Broken codecs (missing encoders, [todo]
entries, invalid UTF-8 in fields) raise [Json.exception-Error] — that's a
codec-definition bug, not a runtime condition to route through Result.
Drop the [to_string_exn]/[to_writer_exn] pair; the bare form is now
raising, the pair collapses.
Add [Json.Value.{of_string,of_string_exn,of_reader,of_reader_exn,to_string,
to_writer}] as shorthand: same API as the codec-taking forms but with
[Json.Codec.Value.t] baked in. Replaces [Json.to_string Json.Codec.Value.t v]
with [Json.Value.to_string v].
+870
-2576
+1
-1
bench/bench.ml
+1
-1
bench/bench.ml
···
114
114
let content = read_file path in
115
115
let size_bytes = String.length content in
116
116
let size_mb = float_of_int size_bytes /. 1_048_576.0 in
117
-
let dom_decode s = Json.of_string Json.Codec.Value.t s in
117
+
let dom_decode s = Json.Value.of_string s in
118
118
let field_decode =
119
119
let codec = field_codec name in
120
120
fun s -> Json.of_string codec s
-1
fuzz/dune
-1
fuzz/dune
+6
-8
fuzz/fuzz_json.ml
+6
-8
fuzz/fuzz_json.ml
···
46
46
matches. *)
47
47
let test_roundtrip buf =
48
48
let buf = truncate ~max_len:4096 buf in
49
-
match Json.of_string Json.Codec.Value.t buf with
49
+
match Json.Value.of_string buf with
50
50
| Error _ -> ()
51
51
| Ok v -> (
52
-
match Json.to_string Json.Codec.Value.t v with
53
-
| Error _ -> ()
54
-
| Ok s -> (
55
-
match Json.of_string Json.Codec.Value.t s with
56
-
| Error e -> failf "roundtrip: re-decode failed on %S: %a" s Json.Error.pp e
57
-
| Ok v' ->
58
-
if not (Json.equal v v') then failf "roundtrip: value changed"))
52
+
let s = Json.Value.to_string v in
53
+
match Json.Value.of_string s with
54
+
| Error e -> failf "roundtrip: re-decode failed on %S: %a" s Json.Error.pp e
55
+
| Ok v' ->
56
+
if not (Json.equal v v') then failf "roundtrip: value changed")
59
57
60
58
let suite =
61
59
( "json",
+1
-2
lib/brr/json_brr.ml
+1
-2
lib/brr/json_brr.ml
···
33
33
let type_object = Jstr.v "object"
34
34
let type_number = Jstr.v "number"
35
35
let type_string = Jstr.v "string"
36
-
let type_array = Jv.get Jv.global "Array"
37
36
38
37
let jv_sort jv =
39
38
if Jv.is_null jv then Json.Sort.Null
···
334
333
and encode_unknown_mems : type o mems a builder.
335
334
(o, o) object_map -> (mems, a, builder) mems_map -> mems -> Jv.t -> Jv.t =
336
335
fun map umap mems jv ->
337
-
let encode_mem map meta name v jv =
336
+
let encode_mem map _meta name v jv =
338
337
try
339
338
Jv.set' jv (Jstr.of_string name) (encode umap.mems_type v);
340
339
jv
-4
lib/bytesrw/dune
-4
lib/bytesrw/dune
-1519
lib/bytesrw/json_bytesrw.ml
-1519
lib/bytesrw/json_bytesrw.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Bytesrw
7
-
open Json.Codec
8
-
9
-
(* XXX add these things to Stdlib.Uchar *)
10
-
11
-
let uchar_max_utf8_bytes = 4
12
-
13
-
let[@inline] uchar_utf8_decode_length = function
14
-
| '\x00' .. '\x7F' -> 1
15
-
| '\x80' .. '\xC1' -> 0
16
-
| '\xC2' .. '\xDF' -> 2
17
-
| '\xE0' .. '\xEF' -> 3
18
-
| '\xF0' .. '\xF4' -> 4
19
-
| _ -> 0
20
-
21
-
(* Character classes *)
22
-
23
-
let[@inline] is_digit u = 0x0030 (* 0 *) <= u && u <= 0x0039 (* 9 *)
24
-
let[@inline] is_number_start u = is_digit u || u = 0x002D (* - *)
25
-
let[@inline] is_surrogate u = 0xD800 <= u && u <= 0xDFFF
26
-
let[@inline] _is_hi_surrogate u = 0xD800 <= u && u <= 0xDBFF
27
-
let[@inline] is_lo_surrogate u = 0xDC00 <= u && u <= 0xDFFF
28
-
29
-
let[@inline] is_control u =
30
-
(0x0000 <= u && u <= 0x001F)
31
-
(* C0 control characters *)
32
-
|| u = 0x007F
33
-
(* Delete *)
34
-
|| (0x0080 <= u && u <= 0x009F)
35
-
(* C1 control characters *)
36
-
|| u = 0x2028
37
-
(* Line separator *) || u = 0x2029
38
-
(* Paragraph separator *) || u = 0x200E
39
-
(* left-to-right mark *) || u = 0x200F (* right-to-left mark *)
40
-
41
-
let sot = 0x1A0000 (* start of text U+10FFFF + 1 *)
42
-
let eot = 0x1A0001 (* end of text U+10FFFF + 2 *)
43
-
let pp_code = Json.Codec.pp_code
44
-
45
-
let pp_quchar ppf u =
46
-
pp_code ppf
47
-
@@
48
-
if u = sot then "start of text"
49
-
else if u = eot then "end of text"
50
-
else if is_control u || is_surrogate u then Fmt.str "U+%04X" u
51
-
else
52
-
let u = Uchar.of_int u in
53
-
let b = Stdlib.Bytes.make (Uchar.utf_8_byte_length u) '\x00' in
54
-
Stdlib.(
55
-
Stdlib.ignore (Bytes.set_utf_8_uchar b 0 u);
56
-
Bytes.unsafe_to_string b)
57
-
58
-
(* A simple growable byte buffer used for token and whitespace
59
-
accumulation. Raw [Bytes.t] access lets us compare buffer content
60
-
against candidate keys without allocating an intermediate string. *)
61
-
type tokbuf = { mutable bytes : Stdlib.Bytes.t; mutable len : int }
62
-
63
-
let tokbuf_create n = { bytes = Stdlib.Bytes.create n; len = 0 }
64
-
let[@inline] tokbuf_clear t = t.len <- 0
65
-
66
-
let[@inline] tokbuf_ensure t need =
67
-
let cap = Stdlib.Bytes.length t.bytes in
68
-
if t.len + need > cap then (
69
-
let new_cap = max (cap * 2) (t.len + need) in
70
-
let b = Stdlib.Bytes.create new_cap in
71
-
Stdlib.Bytes.blit t.bytes 0 b 0 t.len;
72
-
t.bytes <- b)
73
-
74
-
let[@inline] tokbuf_add_char t c =
75
-
tokbuf_ensure t 1;
76
-
Stdlib.Bytes.unsafe_set t.bytes t.len c;
77
-
t.len <- t.len + 1
78
-
79
-
let[@inline] tokbuf_add_utf_8_uchar t u =
80
-
let n = Uchar.utf_8_byte_length u in
81
-
tokbuf_ensure t n;
82
-
Stdlib.ignore (Stdlib.Bytes.set_utf_8_uchar t.bytes t.len u : int);
83
-
t.len <- t.len + n
84
-
85
-
let[@inline] tokbuf_contents t = Stdlib.Bytes.sub_string t.bytes 0 t.len
86
-
87
-
(* Byte-compare buffer content to a string without allocating. *)
88
-
let tokbuf_equal_string t s =
89
-
let n = String.length s in
90
-
if t.len <> n then false
91
-
else
92
-
let rec loop i =
93
-
if i >= n then true
94
-
else if Stdlib.Bytes.unsafe_get t.bytes i <> String.unsafe_get s i then
95
-
false
96
-
else loop (i + 1)
97
-
in
98
-
loop 0
99
-
100
-
(* Decoder *)
101
-
102
-
type decoder = {
103
-
file : string;
104
-
meta_none : Json.Meta.t; (* A meta with just [file] therein. *)
105
-
locs : bool; (* [true] if text locations should be computed. *)
106
-
layout : bool; (* [true] if text layout should be kept. *)
107
-
reader : Bytes.Reader.t; (* The source of bytes. *)
108
-
mutable i : Stdlib.Bytes.t; (* Current input slice. *)
109
-
mutable i_max : int; (* Maximum byte index in [i]. *)
110
-
mutable i_next : int; (* Next byte index to read in [i]. *)
111
-
overlap : Stdlib.Bytes.t; (* Buffer for overlapping decodes. *)
112
-
mutable u : int; (* Current Unicode scalar value or sot or eot. *)
113
-
mutable byte_count : int; (* Global byte count. *)
114
-
mutable line : int; (* Current line number. *)
115
-
mutable line_start : int; (* Current line global byte position. *)
116
-
token : tokbuf;
117
-
ws : tokbuf; (* Bufferizes whitespace when layout is [true]. *)
118
-
}
119
-
120
-
let decoder ?(locs = false) ?(layout = false) ?(file = "-") reader =
121
-
let overlap = Stdlib.Bytes.create uchar_max_utf8_bytes in
122
-
let token = tokbuf_create 255 and ws = tokbuf_create 255 in
123
-
let meta_none = Json.Meta.make (Loc.(set_file none) file) in
124
-
{
125
-
file;
126
-
meta_none;
127
-
locs;
128
-
layout;
129
-
reader;
130
-
i = overlap (* overwritten by initial refill *);
131
-
i_max = 0;
132
-
i_next = 1 (* triggers an initial refill *);
133
-
overlap;
134
-
u = sot;
135
-
byte_count = 0;
136
-
line = 1;
137
-
line_start = 0;
138
-
token;
139
-
ws;
140
-
}
141
-
142
-
(* Decoder positions *)
143
-
144
-
let last_byte_of d =
145
-
if d.u <= 0x7F then d.byte_count - 1
146
-
else if d.u = sot || d.u = eot then d.byte_count
147
-
else
148
-
(* On multi-bytes uchars we want to point on the first byte. *)
149
-
d.byte_count - Uchar.utf_8_byte_length (Uchar.of_int d.u)
150
-
151
-
(* Decoder errors *)
152
-
153
-
let[@inline] textloc_of_pos d ~first_byte ~last_byte ~first_line_num
154
-
~first_line_byte ~last_line_num ~last_line_byte =
155
-
Loc.make ~file:d.file ~first_byte ~last_byte ~first_line_num ~first_line_byte
156
-
~last_line_num ~last_line_byte
157
-
158
-
let error_meta d =
159
-
let first_byte = last_byte_of d in
160
-
let first_line_num = d.line and first_line_byte = d.line_start in
161
-
Json.Meta.make
162
-
@@ textloc_of_pos d ~first_byte ~last_byte:first_byte ~first_line_num
163
-
~first_line_byte ~last_line_num:first_line_num
164
-
~last_line_byte:first_line_byte
165
-
166
-
let error_meta_to_current ~first_byte ~first_line_num ~first_line_byte d =
167
-
let last_byte = last_byte_of d in
168
-
let last_line_num = d.line and last_line_byte = d.line_start in
169
-
Json.Meta.make
170
-
@@ textloc_of_pos d ~first_byte ~last_byte ~first_line_num ~first_line_byte
171
-
~last_line_num ~last_line_byte
172
-
173
-
let err_here d fmt = Json.Error.failf (error_meta d) fmt
174
-
175
-
let err_to_here ~first_byte ~first_line_num ~first_line_byte d fmt =
176
-
Json.Error.failf
177
-
(error_meta_to_current ~first_byte ~first_line_num ~first_line_byte d)
178
-
fmt
179
-
180
-
let err_malformed_utf_8 d =
181
-
if d.i_next > d.i_max then
182
-
err_here d "UTF-8 decoding error: unexpected end of bytes"
183
-
else
184
-
err_here d "UTF-8 decoding error: invalid byte %a" pp_code
185
-
(Fmt.str "%x02x" (Bytes.get_uint8 d.i d.i_next))
186
-
187
-
let err_exp d = err_here d "Expected %a but found %a"
188
-
let err_exp_while d = err_here d "Expected %a while parsing %a but found %a"
189
-
let err_exp_eot d = err_exp d pp_quchar eot pp_quchar d.u
190
-
let err_not_json_value d = err_exp d pp_code "JSON value" pp_quchar d.u
191
-
192
-
let current_json_sort d =
193
-
match d.u with
194
-
| 0x0066 (* f *) | 0x0074 (* t *) -> Json.Sort.Bool
195
-
| 0x006E (* n *) -> Json.Sort.Null
196
-
| 0x007B (* { *) -> Json.Sort.Object
197
-
| 0x005B (* [ *) -> Json.Sort.Array
198
-
| 0x0022 (* DQUOTE *) -> Json.Sort.String
199
-
| u when is_number_start u -> Json.Sort.Number
200
-
| _ -> err_not_json_value d
201
-
202
-
let type_error d t =
203
-
Json.Codec.type_error (error_meta d) t ~fnd:(current_json_sort d)
204
-
205
-
(* Errors for constants *)
206
-
207
-
let err_exp_in_const ~first_byte ~first_line_num ~first_line_byte d ~exp ~fnd
208
-
~const =
209
-
err_to_here ~first_byte ~first_line_num ~first_line_byte d
210
-
"Expected %a while parsing %a but found: %a" pp_quchar exp pp_code const
211
-
pp_quchar fnd
212
-
213
-
(* Errors for numbers *)
214
-
215
-
let err_float_parse meta tok =
216
-
Json.Error.failf meta "Could not parse %S to a %a" tok pp_code "float"
217
-
218
-
let err_exp_digit d =
219
-
err_exp_while d pp_code "decimal digit" pp_code "number" pp_quchar d.u
220
-
221
-
(* Errors for strings *)
222
-
223
-
let err_exp_hex_digit d =
224
-
err_exp_while d pp_code "hex digit" pp_code "character escape" pp_quchar d.u
225
-
226
-
let err_exp_lo_surrogate d u =
227
-
err_exp_while d pp_code "low surrogate" pp_code "character escape" pp_quchar u
228
-
229
-
let err_unpaired_lo_surrogate d u =
230
-
err_here d "Unpaired low surrogate %a in %a" pp_quchar u pp_code "string"
231
-
232
-
let err_unpaired_hi_surrogate d u =
233
-
err_here d "Unpaired high surrogate %a in %a" pp_quchar u pp_code "string"
234
-
235
-
let err_exp_esc ~first_byte ~first_line_num ~first_line_byte d u =
236
-
err_to_here ~first_byte ~first_line_num ~first_line_byte d
237
-
"Expected %a while parsing %a found %a" pp_code "escape character" pp_code
238
-
"escape" pp_quchar u
239
-
240
-
let err_unclosed_string ~first_byte ~first_line_num ~first_line_byte d =
241
-
err_to_here ~first_byte ~first_line_num ~first_line_byte d "Unclosed %a"
242
-
pp_code "string"
243
-
244
-
let err_illegal_ctrl_char ~first_byte ~first_line_num ~first_line_byte d =
245
-
err_to_here ~first_byte ~first_line_num ~first_line_byte d
246
-
"Illegal control character %a in %a" pp_quchar d.u pp_code "string"
247
-
248
-
(* Errors for arrays *)
249
-
250
-
let err_exp_comma_or_eoa d ~fnd =
251
-
err_here d "Expected %a or %a after %a but found %a" pp_code "," pp_code "]"
252
-
pp_code "array element" pp_quchar fnd
253
-
254
-
let err_unclosed_array d = err_here d "Unclosed %a" pp_code "array"
255
-
256
-
let err_exp_comma_or_eoo d =
257
-
err_here d "Expected %a or %a after %a but found: %a" pp_code "," pp_code "}"
258
-
pp_code "object member" pp_quchar d.u
259
-
260
-
(* Errors for objects *)
261
-
262
-
let err_exp_mem d =
263
-
err_here d "Expected %a but found %a" pp_code "object member" pp_quchar d.u
264
-
265
-
let err_exp_mem_or_eoo d =
266
-
err_here d "Expected: %a or %a but found %a" pp_code "object member" pp_code
267
-
"}" pp_quchar d.u
268
-
269
-
let err_exp_colon d =
270
-
err_here d "Expected %a after %a but found %a" pp_code ":" pp_code
271
-
"member name" pp_quchar d.u
272
-
273
-
let err_unclosed_object d (map : ('o, 'o) Json.Codec.object_map) =
274
-
err_here d "Unclosed %a" Json.Codec.pp_kind
275
-
(Json.Codec.object_kinded_sort map)
276
-
277
-
(* Decode next character in d.u *)
278
-
279
-
let[@inline] is_eoslice d = d.i_next > d.i_max
280
-
let[@inline] is_eod d = d.i_max = -1 (* Only happens on Slice.eod *)
281
-
let[@inline] available d = d.i_max - d.i_next + 1
282
-
283
-
let[@inline] set_slice d slice =
284
-
d.i <- Bytes.Slice.bytes slice;
285
-
d.i_next <- Bytes.Slice.first slice;
286
-
d.i_max <- d.i_next + Bytes.Slice.length slice - 1
287
-
288
-
let rec setup_overlap d start need =
289
-
match need with
290
-
| 0 ->
291
-
let slice =
292
-
match available d with
293
-
| 0 -> Bytes.Reader.read d.reader
294
-
| length -> Bytes.Slice.make d.i ~first:d.i_next ~length
295
-
in
296
-
d.i <- d.overlap;
297
-
d.i_next <- 0;
298
-
d.i_max <- start;
299
-
slice
300
-
| need ->
301
-
if is_eoslice d then set_slice d (Bytes.Reader.read d.reader);
302
-
if is_eod d then (
303
-
d.byte_count <- d.byte_count - start;
304
-
err_malformed_utf_8 d);
305
-
let available = available d in
306
-
let take = Int.min need available in
307
-
for i = 0 to take - 1 do
308
-
Bytes.set d.overlap (start + i) (Bytes.get d.i (d.i_next + i))
309
-
done;
310
-
d.i_next <- d.i_next + take;
311
-
d.byte_count <- d.byte_count + take;
312
-
setup_overlap d (start + take) (need - take)
313
-
314
-
let rec nextc d =
315
-
let a = available d in
316
-
if a <= 0 then
317
-
if is_eod d then d.u <- eot
318
-
else (
319
-
set_slice d (Bytes.Reader.read d.reader);
320
-
nextc d)
321
-
else
322
-
let b = Bytes.get d.i d.i_next in
323
-
if a < uchar_max_utf8_bytes && a < uchar_utf8_decode_length b then begin
324
-
let s = setup_overlap d 0 (uchar_utf8_decode_length b) in
325
-
nextc d;
326
-
set_slice d s
327
-
end
328
-
else
329
-
d.u <-
330
-
(match b with
331
-
| ('\x00' .. '\x09' | '\x0B' | '\x0E' .. '\x7F') as u ->
332
-
(* ASCII fast path *)
333
-
d.i_next <- d.i_next + 1;
334
-
d.byte_count <- d.byte_count + 1;
335
-
Char.code u
336
-
| '\x0D' (* CR *) ->
337
-
d.i_next <- d.i_next + 1;
338
-
d.byte_count <- d.byte_count + 1;
339
-
d.line_start <- d.byte_count;
340
-
d.line <- d.line + 1;
341
-
0x000D
342
-
| '\x0A' (* LF *) ->
343
-
d.i_next <- d.i_next + 1;
344
-
d.byte_count <- d.byte_count + 1;
345
-
d.line_start <- d.byte_count;
346
-
if d.u <> 0x000D then d.line <- d.line + 1;
347
-
0x000A
348
-
| _ ->
349
-
let udec = Bytes.get_utf_8_uchar d.i d.i_next in
350
-
if not (Uchar.utf_decode_is_valid udec) then err_malformed_utf_8 d
351
-
else
352
-
let u = Uchar.to_int (Uchar.utf_decode_uchar udec) in
353
-
let ulen = Uchar.utf_decode_length udec in
354
-
d.i_next <- d.i_next + ulen;
355
-
d.byte_count <- d.byte_count + ulen;
356
-
u)
357
-
358
-
(* Decoder tokenizer *)
359
-
360
-
let[@inline] token_clear d = tokbuf_clear d.token
361
-
362
-
let[@inline] token_pop d =
363
-
let t = tokbuf_contents d.token in
364
-
token_clear d;
365
-
t
366
-
367
-
let[@inline] token_add d u =
368
-
if u <= 0x7F then tokbuf_add_char d.token (Char.unsafe_chr u)
369
-
else tokbuf_add_utf_8_uchar d.token (Uchar.unsafe_of_int u)
370
-
371
-
(* Find a member in [mem_decs] whose key matches the current token
372
-
buffer content byte-for-byte, without allocating a string. Returns
373
-
the matching mem_dec together with the key string (owned by the
374
-
map). Used as a fast-path for object member dispatch. *)
375
-
let mem_by_token d mem_decs =
376
-
let r = ref None in
377
-
(try
378
-
String_map.iter
379
-
(fun k v ->
380
-
if tokbuf_equal_string d.token k then begin
381
-
r := Some (v, k);
382
-
raise_notrace Exit
383
-
end)
384
-
mem_decs
385
-
with Exit -> ());
386
-
!r
387
-
388
-
let[@inline] accept d =
389
-
token_add d d.u;
390
-
nextc d
391
-
392
-
let token_pop_float d ~meta =
393
-
let token = token_pop d in
394
-
match float_of_string_opt token with
395
-
| Some f -> f
396
-
| None -> err_float_parse meta token (* likely [assert false] *)
397
-
398
-
(* Decoder layout and position tracking *)
399
-
400
-
let[@inline] ws_pop d =
401
-
if not d.layout then ""
402
-
else
403
-
let t = tokbuf_contents d.ws in
404
-
tokbuf_clear d.ws;
405
-
t
406
-
407
-
let textloc_to_current ~first_byte ~first_line_num ~first_line_byte d =
408
-
if not d.locs then Loc.none
409
-
else
410
-
let last_byte = last_byte_of d in
411
-
let last_line_num = d.line and last_line_byte = d.line_start in
412
-
textloc_of_pos d ~first_byte ~last_byte ~first_line_num ~first_line_byte
413
-
~last_line_num ~last_line_byte
414
-
415
-
let textloc_prev_ascii_char ~first_byte ~first_line_num ~first_line_byte d =
416
-
(* N.B. when we call that the line doesn't move and the char was on
417
-
a single byte *)
418
-
if not d.locs then Loc.none
419
-
else
420
-
let last_byte = last_byte_of d - 1 in
421
-
let last_line_num = d.line and last_line_byte = d.line_start in
422
-
textloc_of_pos d ~first_byte ~last_byte ~first_line_num ~first_line_byte
423
-
~last_line_num ~last_line_byte
424
-
425
-
let meta_make d ?ws_before ?ws_after textloc =
426
-
if (not d.locs) && not d.layout then d.meta_none
427
-
else Json.Meta.make ?ws_before ?ws_after textloc
428
-
429
-
(* Decoding *)
430
-
431
-
let false_uchars = [| 0x0066; 0x0061; 0x006C; 0x0073; 0x0065 |]
432
-
let true_uchars = [| 0x0074; 0x0072; 0x0075; 0x0065 |]
433
-
let null_uchars = [| 0x006E; 0x0075; 0x006C; 0x006C |]
434
-
435
-
let ascii_str us =
436
-
String.init (Stdlib.Array.length us) (fun i ->
437
-
Char.chr (Stdlib.Array.get us i))
438
-
439
-
let[@inline] is_ws u =
440
-
if u > 0x20 then false
441
-
else
442
-
match Char.unsafe_chr u with ' ' | '\t' | '\r' | '\n' -> true | _ -> false
443
-
444
-
let[@inline] read_ws d =
445
-
while is_ws d.u do
446
-
if d.layout then tokbuf_add_char d.ws (Char.unsafe_chr d.u);
447
-
nextc d
448
-
done
449
-
450
-
let read_json_const d const =
451
-
(* First character was checked. *)
452
-
let ws_before = ws_pop d in
453
-
let first_byte = last_byte_of d in
454
-
let first_line_num = d.line and first_line_byte = d.line_start in
455
-
for i = 1 to Stdlib.Array.length const - 1 do
456
-
nextc d;
457
-
let c = Stdlib.Array.get const i in
458
-
if not (Int.equal d.u c) then
459
-
err_exp_in_const ~first_byte ~first_line_num ~first_line_byte d ~exp:c
460
-
~fnd:d.u ~const:(ascii_str const)
461
-
done;
462
-
let textloc =
463
-
textloc_to_current d ~first_byte ~first_line_num ~first_line_byte
464
-
in
465
-
let ws_after =
466
-
nextc d;
467
-
read_ws d;
468
-
ws_pop d
469
-
in
470
-
meta_make d ~ws_before ~ws_after textloc
471
-
472
-
let[@inline] read_json_false d = read_json_const d false_uchars
473
-
let[@inline] read_json_true d = read_json_const d true_uchars
474
-
let[@inline] read_json_null d = read_json_const d null_uchars
475
-
476
-
let read_json_number d =
477
-
(* [is_number_start d.u] = true *)
478
-
let[@inline] read_digits d =
479
-
while is_digit d.u do
480
-
accept d
481
-
done
482
-
in
483
-
let[@inline] read_int d =
484
-
match d.u with
485
-
| 0x0030 (* 0 *) -> accept d
486
-
| u when is_digit u ->
487
-
accept d;
488
-
read_digits d
489
-
| _ -> err_exp_digit d
490
-
in
491
-
let[@inline] read_opt_frac d =
492
-
match d.u with
493
-
| 0x002E (* . *) ->
494
-
accept d;
495
-
if is_digit d.u then read_digits d else err_exp_digit d
496
-
| _ -> ()
497
-
in
498
-
let[@inline] read_opt_exp d =
499
-
match d.u with
500
-
| 0x0065 (* e *) | 0x0045 (* E *) ->
501
-
token_add d d.u;
502
-
nextc d;
503
-
(match d.u with
504
-
| 0x002D (* - *) | 0x002B (* + *) ->
505
-
token_add d d.u;
506
-
nextc d
507
-
| _ -> ());
508
-
if is_digit d.u then read_digits d else err_exp_digit d
509
-
| _ -> ()
510
-
in
511
-
let first_byte = last_byte_of d in
512
-
let first_line_num = d.line and first_line_byte = d.line_start in
513
-
let ws_before = ws_pop d in
514
-
token_clear d;
515
-
if d.u = 0x002D (* - *) then accept d;
516
-
read_int d;
517
-
read_opt_frac d;
518
-
read_opt_exp d;
519
-
let textloc =
520
-
textloc_prev_ascii_char d ~first_byte ~first_line_num ~first_line_byte
521
-
in
522
-
let ws_after =
523
-
read_ws d;
524
-
ws_pop d
525
-
in
526
-
meta_make d ~ws_before ~ws_after textloc
527
-
528
-
let read_json_string d =
529
-
(* d.u is 0x0022 *)
530
-
let first_byte = last_byte_of d in
531
-
let first_line_num = d.line and first_line_byte = d.line_start in
532
-
let rec read_uescape d hi uc count =
533
-
if count > 0 then
534
-
match d.u with
535
-
| u when 0x0030 <= u && u <= 0x0039 ->
536
-
nextc d;
537
-
read_uescape d hi ((uc * 16) + u - 0x30) (count - 1)
538
-
| u when 0x0041 <= u && u <= 0x0046 ->
539
-
nextc d;
540
-
read_uescape d hi ((uc * 16) + u - 0x37) (count - 1)
541
-
| u when 0x0061 <= u && u <= 0x0066 ->
542
-
nextc d;
543
-
read_uescape d hi ((uc * 16) + u - 0x57) (count - 1)
544
-
| _ -> err_exp_hex_digit d
545
-
else
546
-
match hi with
547
-
| Some hi ->
548
-
(* combine high and low surrogate. *)
549
-
if not (is_lo_surrogate uc) then err_exp_lo_surrogate d uc
550
-
else
551
-
let u = (((hi land 0x3FF) lsl 10) lor (uc land 0x3FF)) + 0x10000 in
552
-
token_add d u
553
-
| None ->
554
-
if not (is_surrogate uc) then token_add d uc
555
-
else if uc > 0xDBFF then err_unpaired_lo_surrogate d uc
556
-
else if d.u <> 0x005C (* \ *) then err_unpaired_hi_surrogate d uc
557
-
else (
558
-
nextc d;
559
-
if d.u <> 0x0075 (* u *) then err_unpaired_hi_surrogate d uc
560
-
else (
561
-
nextc d;
562
-
read_uescape d (Some uc) 0 4))
563
-
in
564
-
let read_escape d =
565
-
match d.u with
566
-
| 0x0022 (* DQUOTE *) | 0x005C (* \ *) | 0x002F (* / *) -> accept d
567
-
| 0x0062 (* b *) ->
568
-
token_add d 0x0008 (* backspace *);
569
-
nextc d
570
-
| 0x0066 (* f *) ->
571
-
token_add d 0x000C (* form feed *);
572
-
nextc d
573
-
| 0x006E (* n *) ->
574
-
token_add d 0x000A (* line feed *);
575
-
nextc d
576
-
| 0x0072 (* r *) ->
577
-
token_add d 0x000D (* carriage return *);
578
-
nextc d
579
-
| 0x0074 (* t *) ->
580
-
token_add d 0x0009 (* tab *);
581
-
nextc d
582
-
| 0x0075 (* u *) ->
583
-
nextc d;
584
-
read_uescape d None 0 4
585
-
| u -> err_exp_esc ~first_byte ~first_line_num ~first_line_byte d u
586
-
in
587
-
let rec loop d =
588
-
match d.u with
589
-
| 0x005C (* \ *) ->
590
-
nextc d;
591
-
read_escape d;
592
-
loop d
593
-
| 0x0022 (* DQUOTE *) -> ()
594
-
| u when u = eot ->
595
-
err_unclosed_string ~first_byte ~first_line_num ~first_line_byte d
596
-
| u when 0x0000 <= u && u <= 0x001F ->
597
-
err_illegal_ctrl_char ~first_byte ~first_line_num ~first_line_byte d
598
-
| _ ->
599
-
accept d;
600
-
loop d
601
-
in
602
-
let ws_before = ws_pop d in
603
-
nextc d;
604
-
token_clear d;
605
-
loop d;
606
-
let textloc =
607
-
textloc_to_current d ~first_byte ~first_line_num ~first_line_byte
608
-
in
609
-
let ws_after =
610
-
nextc d;
611
-
read_ws d;
612
-
ws_pop d
613
-
in
614
-
meta_make d ~ws_before ~ws_after textloc
615
-
616
-
let read_json_name d =
617
-
let meta = read_json_string d in
618
-
if d.u = 0x003A (* : *) then (
619
-
nextc d;
620
-
meta)
621
-
else err_exp_colon d
622
-
623
-
let read_json_mem_sep d =
624
-
if d.u = 0x007D (* } *) then ()
625
-
else if d.u = 0x002C (* , *) then (
626
-
nextc d;
627
-
read_ws d;
628
-
if d.u <> 0x0022 then err_exp_mem d)
629
-
else err_exp_comma_or_eoo d
630
-
631
-
(* Skip-parse a JSON value: advance past [d.u] at the byte level without
632
-
materialising token buffers, parsing numbers, or decoding string
633
-
escapes. The only decoding done is UTF-8 in [nextc]; escapes in
634
-
strings are recognised only enough to not stop at a backslash-quote. *)
635
-
let rec skip_json_value d =
636
-
read_ws d;
637
-
match d.u with
638
-
| 0x007B (* { *) -> skip_json_object d
639
-
| 0x005B (* [ *) -> skip_json_array d
640
-
| 0x0022 (* DQUOTE *) -> skip_json_string d
641
-
| 0x006E (* n *) -> Stdlib.ignore (read_json_null d)
642
-
| 0x0074 (* t *) -> Stdlib.ignore (read_json_true d)
643
-
| 0x0066 (* f *) -> Stdlib.ignore (read_json_false d)
644
-
| u when is_number_start u -> skip_json_number d
645
-
| _ -> err_not_json_value d
646
-
647
-
and skip_json_string d =
648
-
(* Byte-level scan for the closing quote; matches simdjson On-Demand
649
-
semantics. Structural contract (bracket nesting, string termination)
650
-
is enforced; content (escape correctness, exact hex digits after
651
-
[\u]) is NOT validated. Consumers needing strict content
652
-
validation should decode with [Json.json] and then discard rather
653
-
than [Json.Codec.ignore]. *)
654
-
let done_ = ref false in
655
-
while not !done_ do
656
-
if d.i_next > d.i_max then
657
-
if is_eod d then
658
-
err_unclosed_string ~first_byte:0 ~first_line_num:Loc.line_num_none
659
-
~first_line_byte:Loc.byte_pos_none d
660
-
else set_slice d (Bytes.Reader.read d.reader)
661
-
else begin
662
-
let b = Stdlib.Bytes.unsafe_get d.i d.i_next in
663
-
d.i_next <- d.i_next + 1;
664
-
d.byte_count <- d.byte_count + 1;
665
-
match b with
666
-
| '\\' ->
667
-
if d.i_next > d.i_max then
668
-
if is_eod d then
669
-
err_unclosed_string ~first_byte:0
670
-
~first_line_num:Loc.line_num_none
671
-
~first_line_byte:Loc.byte_pos_none d
672
-
else set_slice d (Bytes.Reader.read d.reader);
673
-
d.i_next <- d.i_next + 1;
674
-
d.byte_count <- d.byte_count + 1
675
-
| '"' -> done_ := true
676
-
| _ -> ()
677
-
end
678
-
done;
679
-
nextc d;
680
-
read_ws d
681
-
682
-
and skip_json_number d =
683
-
(* Consume number-continuation characters; matches simdjson
684
-
On-Demand. Structural number shape ([1..2], [+5], [1eE2]) is NOT
685
-
validated here. *)
686
-
let done_ = ref false in
687
-
while not !done_ do
688
-
if d.i_next > d.i_max then
689
-
if is_eod d then done_ := true
690
-
else set_slice d (Bytes.Reader.read d.reader)
691
-
else
692
-
match Stdlib.Bytes.unsafe_get d.i d.i_next with
693
-
| '0' .. '9' | '-' | '+' | '.' | 'e' | 'E' ->
694
-
d.i_next <- d.i_next + 1;
695
-
d.byte_count <- d.byte_count + 1
696
-
| _ -> done_ := true
697
-
done;
698
-
nextc d;
699
-
read_ws d
700
-
701
-
and skip_json_array d =
702
-
nextc d;
703
-
(* [ *)
704
-
read_ws d;
705
-
if d.u = 0x005D (* ] *) then (
706
-
nextc d;
707
-
read_ws d)
708
-
else
709
-
let rec loop () =
710
-
skip_json_value d;
711
-
match d.u with
712
-
| 0x002C (* , *) ->
713
-
nextc d;
714
-
read_ws d;
715
-
loop ()
716
-
| 0x005D (* ] *) ->
717
-
nextc d;
718
-
read_ws d
719
-
| fnd -> err_exp_comma_or_eoa d ~fnd
720
-
in
721
-
loop ()
722
-
723
-
and skip_json_object d =
724
-
nextc d;
725
-
(* { *)
726
-
read_ws d;
727
-
if d.u = 0x007D (* } *) then (
728
-
nextc d;
729
-
read_ws d)
730
-
else
731
-
let rec loop () =
732
-
if d.u <> 0x0022 then err_exp_mem d;
733
-
skip_json_string d;
734
-
if d.u <> 0x003A (* : *) then err_exp_colon d;
735
-
nextc d;
736
-
read_ws d;
737
-
skip_json_value d;
738
-
match d.u with
739
-
| 0x002C (* , *) ->
740
-
nextc d;
741
-
read_ws d;
742
-
loop ()
743
-
| 0x007D (* } *) ->
744
-
nextc d;
745
-
read_ws d
746
-
| _ -> err_exp_comma_or_eoo d
747
-
in
748
-
loop ()
749
-
750
-
let rec decode : type a. decoder -> a t -> a =
751
-
fun d t ->
752
-
match
753
-
read_ws d;
754
-
t
755
-
with
756
-
| Null map -> (
757
-
match d.u with
758
-
| 0x006E (* n *) -> map.dec (read_json_null d) ()
759
-
| _ -> type_error d t)
760
-
| Bool map -> (
761
-
match d.u with
762
-
| 0x0066 (* f *) -> map.dec (read_json_false d) false
763
-
| 0x0074 (* t *) -> map.dec (read_json_true d) true
764
-
| _ -> type_error d t)
765
-
| Number map -> (
766
-
match d.u with
767
-
| u when is_number_start u ->
768
-
let meta = read_json_number d in
769
-
map.dec meta (token_pop_float d ~meta)
770
-
| 0x006E (* n *) -> map.dec (read_json_null d) Float.nan
771
-
| _ -> type_error d t)
772
-
| String map -> (
773
-
match d.u with
774
-
| 0x0022 (* DQUOTE *) ->
775
-
let meta = read_json_string d in
776
-
map.dec meta (token_pop d)
777
-
| _ -> type_error d t)
778
-
| Array map -> (
779
-
match d.u with
780
-
| 0x005B (* [ *) -> decode_array d map
781
-
| _ -> type_error d t)
782
-
| Object map -> (
783
-
match d.u with
784
-
| 0x007B (* { *) -> decode_object d map
785
-
| _ -> type_error d t)
786
-
| Map map -> map.dec (decode d map.dom)
787
-
| Any map -> decode_any d t map
788
-
| Rec t -> decode d (Lazy.force t)
789
-
| Ignore -> skip_json_value d
790
-
791
-
and decode_array : type a elt b. decoder -> (a, elt, b) array_map -> a =
792
-
fun d map ->
793
-
let ws_before = ws_pop d in
794
-
let first_byte = last_byte_of d in
795
-
let first_line_num = d.line and first_line_byte = d.line_start in
796
-
let b, len =
797
-
match
798
-
nextc d;
799
-
read_ws d;
800
-
d.u
801
-
with
802
-
| 0x005D (* ] *) -> (map.dec_empty (), 0)
803
-
| _ -> (
804
-
let b = ref (map.dec_empty ()) in
805
-
let i = ref 0 in
806
-
let next = ref true in
807
-
try
808
-
while !next do
809
-
begin
810
-
let first_byte = last_byte_of d in
811
-
let first_line_num = d.line and first_line_byte = d.line_start in
812
-
try
813
-
if map.dec_skip !i !b then decode d Json.Codec.ignore
814
-
else b := map.dec_add !i (decode d map.elt) !b
815
-
with Json.Error e ->
816
-
let imeta =
817
-
error_meta_to_current ~first_byte ~first_line_num
818
-
~first_line_byte d
819
-
in
820
-
Json.Codec.error_push_array (error_meta d) map (!i, imeta) e
821
-
end;
822
-
incr i;
823
-
match
824
-
read_ws d;
825
-
d.u
826
-
with
827
-
| 0x005D (* ] *) -> next := false
828
-
| 0x002C (* , *) ->
829
-
nextc d;
830
-
read_ws d
831
-
| u when u = eot -> err_unclosed_array d
832
-
| fnd -> err_exp_comma_or_eoa d ~fnd
833
-
done;
834
-
(!b, !i)
835
-
with Json.Error e ->
836
-
Json.Error.adjust_context ~first_byte ~first_line_num ~first_line_byte
837
-
e)
838
-
in
839
-
let textloc =
840
-
textloc_to_current d ~first_byte ~first_line_num ~first_line_byte
841
-
in
842
-
let ws_after =
843
-
nextc d;
844
-
read_ws d;
845
-
ws_pop d
846
-
in
847
-
let meta = meta_make d ~ws_before ~ws_after textloc in
848
-
map.dec_finish meta len b
849
-
850
-
and decode_object : type a. decoder -> (a, a) object_map -> a =
851
-
fun d map ->
852
-
let ws_before = ws_pop d in
853
-
let first_byte = last_byte_of d in
854
-
let first_line_num = d.line and first_line_byte = d.line_start in
855
-
let dict =
856
-
try
857
-
nextc d;
858
-
read_ws d;
859
-
decode_object_map d map (Unknown_mems None) String_map.empty
860
-
String_map.empty [] Dict.empty
861
-
with
862
-
| Json.Error (ctx, meta, k) when Json.Error.Context.is_empty ctx ->
863
-
let meta =
864
-
(* This is for when Json.Codec.finish_object_decode raises. *)
865
-
if Loc.is_none (Json.Meta.textloc meta) then
866
-
error_meta_to_current d ~first_byte ~first_line_num ~first_line_byte
867
-
else meta
868
-
in
869
-
Json.Error.raise ctx meta k
870
-
| Json.Error e ->
871
-
Json.Error.adjust_context ~first_byte ~first_line_num ~first_line_byte e
872
-
in
873
-
let textloc =
874
-
textloc_to_current d ~first_byte ~first_line_num ~first_line_byte
875
-
in
876
-
let ws_after =
877
-
nextc d;
878
-
read_ws d;
879
-
ws_pop d
880
-
in
881
-
let meta = meta_make d ~ws_before ~ws_after textloc in
882
-
let dict = Dict.add Json.Codec.object_meta_arg meta dict in
883
-
Json.Codec.apply_dict map.dec dict
884
-
885
-
and decode_object_delayed : type o.
886
-
decoder ->
887
-
(o, o) object_map ->
888
-
mem_dec String_map.t ->
889
-
mem_dec String_map.t ->
890
-
Json.object' ->
891
-
Dict.t ->
892
-
mem_dec String_map.t * Json.object' * Dict.t =
893
-
fun d map mem_miss mem_decs delay dict ->
894
-
let rec loop d map mem_miss mem_decs rem_delay dict = function
895
-
| [] -> (mem_miss, rem_delay, dict)
896
-
| ((((name, _meta) as nm), v) as mem) :: delay -> (
897
-
match String_map.find_opt name mem_decs with
898
-
| None -> loop d map mem_miss mem_decs (mem :: rem_delay) dict delay
899
-
| Some (Mem_dec m) ->
900
-
let dict =
901
-
try
902
-
let t = m.type' in
903
-
let v =
904
-
match Json.decode t v with
905
-
| Ok v -> v
906
-
| Error e -> raise_notrace (Json.Error e)
907
-
in
908
-
Dict.add m.id v dict
909
-
with Json.Error e ->
910
-
Json.Codec.error_push_object (error_meta d) map nm e
911
-
in
912
-
let mem_miss = String_map.remove name mem_miss in
913
-
loop d map mem_miss mem_decs rem_delay dict delay)
914
-
in
915
-
loop d map mem_miss mem_decs [] dict delay
916
-
917
-
and decode_object_map : type o.
918
-
decoder ->
919
-
(o, o) object_map ->
920
-
unknown_mems_option ->
921
-
mem_dec String_map.t ->
922
-
mem_dec String_map.t ->
923
-
Json.object' ->
924
-
Dict.t ->
925
-
Dict.t =
926
-
fun d map umems mem_miss mem_decs delay dict ->
927
-
let u _ _ _ = assert false in
928
-
let mem_miss = String_map.union u mem_miss map.mem_decs in
929
-
let mem_decs = String_map.union u mem_decs map.mem_decs in
930
-
match map.shape with
931
-
| Object_cases (umems', cases) ->
932
-
let umems' = Unknown_mems umems' in
933
-
let umems, dict =
934
-
Json.Codec.override_unknown_mems ~by:umems umems' dict
935
-
in
936
-
decode_object_case d map umems cases mem_miss mem_decs delay dict
937
-
| Object_basic umems' -> (
938
-
let mem_miss, delay, dict =
939
-
decode_object_delayed d map mem_miss mem_decs delay dict
940
-
in
941
-
let umems' = Unknown_mems (Some umems') in
942
-
let umems, dict =
943
-
Json.Codec.override_unknown_mems ~by:umems umems' dict
944
-
in
945
-
match umems with
946
-
| Unknown_mems (Some Unknown_skip | None) ->
947
-
decode_object_basic d map Unknown_skip () mem_miss mem_decs dict
948
-
| Unknown_mems (Some (Unknown_error as u)) ->
949
-
if delay = [] then
950
-
decode_object_basic d map u () mem_miss mem_decs dict
951
-
else
952
-
let fnd = List.map fst delay in
953
-
Json.Codec.unexpected_mems_error (error_meta d) map ~fnd
954
-
| Unknown_mems (Some (Unknown_keep (umap, _) as u)) ->
955
-
let add_delay umems (((n, meta) as nm), v) =
956
-
try
957
-
let t = umap.mems_type in
958
-
let v =
959
-
match Json.decode t v with
960
-
| Ok v -> v
961
-
| Error e -> raise_notrace (Json.Error e)
962
-
in
963
-
umap.dec_add meta n v umems
964
-
with Json.Error e ->
965
-
Json.Codec.error_push_object (error_meta d) map nm e
966
-
in
967
-
let umems = List.fold_left add_delay (umap.dec_empty ()) delay in
968
-
decode_object_basic d map u umems mem_miss mem_decs dict)
969
-
970
-
and decode_object_basic : type o p mems builder.
971
-
decoder ->
972
-
(o, o) object_map ->
973
-
(p, mems, builder) unknown_mems ->
974
-
builder ->
975
-
mem_dec String_map.t ->
976
-
mem_dec String_map.t ->
977
-
Dict.t ->
978
-
Dict.t =
979
-
fun d map u umap mem_miss mem_decs dict ->
980
-
match d.u with
981
-
| 0x007D (* } *) ->
982
-
let meta =
983
-
d.meta_none
984
-
(* we add a correct one in decode_object *)
985
-
in
986
-
Json.Codec.finish_object_decode map meta u umap mem_miss dict
987
-
| 0x0022 ->
988
-
let meta = read_json_name d in
989
-
(* Fast path: byte-compare the token buffer against [mem_decs]
990
-
keys without allocating. Only materialise the name as a
991
-
string if no match was found (for Unknown_keep paths and
992
-
error messages). *)
993
-
begin match mem_by_token d mem_decs with
994
-
| Some (Mem_dec mem, name) ->
995
-
token_clear d;
996
-
let mem_miss = String_map.remove name mem_miss in
997
-
let dict =
998
-
try Dict.add mem.id (decode d mem.type') dict
999
-
with Json.Error e ->
1000
-
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1001
-
in
1002
-
read_json_mem_sep d;
1003
-
decode_object_basic d map u umap mem_miss mem_decs dict
1004
-
| None -> (
1005
-
match u with
1006
-
| Unknown_skip ->
1007
-
(* The name is never read, so we don't need to allocate it. *)
1008
-
token_clear d;
1009
-
let () =
1010
-
try decode d Json.Codec.ignore
1011
-
with Json.Error e ->
1012
-
Json.Codec.error_push_object (error_meta d) map
1013
-
(token_pop d, meta)
1014
-
e
1015
-
in
1016
-
read_json_mem_sep d;
1017
-
decode_object_basic d map u umap mem_miss mem_decs dict
1018
-
| Unknown_error ->
1019
-
let name = token_pop d in
1020
-
let fnd = [ (name, meta) ] in
1021
-
Json.Codec.unexpected_mems_error (error_meta d) map ~fnd
1022
-
| Unknown_keep (umap', _) ->
1023
-
let name = token_pop d in
1024
-
let umap =
1025
-
try umap'.dec_add meta name (decode d umap'.mems_type) umap
1026
-
with Json.Error e ->
1027
-
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1028
-
in
1029
-
read_json_mem_sep d;
1030
-
decode_object_basic d map u umap mem_miss mem_decs dict)
1031
-
end
1032
-
| u when u = eot -> err_unclosed_object d map
1033
-
| _ -> err_exp_mem_or_eoo d
1034
-
1035
-
and decode_object_case : type o cases tag.
1036
-
decoder ->
1037
-
(o, o) object_map ->
1038
-
unknown_mems_option ->
1039
-
(o, cases, tag) object_cases ->
1040
-
mem_dec String_map.t ->
1041
-
mem_dec String_map.t ->
1042
-
Json.object' ->
1043
-
Dict.t ->
1044
-
Dict.t =
1045
-
fun d map umems cases mem_miss mem_decs delay dict ->
1046
-
let decode_case_tag ~sep map umems cases mem_miss mem_decs nmeta tag delay =
1047
-
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
1048
-
match List.find_opt eq_tag cases.cases with
1049
-
| None -> (
1050
-
try Json.Codec.unexpected_case_tag_error (error_meta d) map cases tag
1051
-
with Json.Error e ->
1052
-
Json.Codec.error_push_object (error_meta d) map
1053
-
(cases.tag.name, nmeta) e)
1054
-
| Some (Case case) ->
1055
-
if sep then read_json_mem_sep d;
1056
-
let dict =
1057
-
decode_object_map d case.object_map umems mem_miss mem_decs delay dict
1058
-
in
1059
-
Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
1060
-
in
1061
-
match d.u with
1062
-
| 0x007D (* } *) -> (
1063
-
match cases.tag.dec_absent with
1064
-
| Some tag ->
1065
-
decode_case_tag ~sep:false map umems cases mem_miss mem_decs
1066
-
d.meta_none tag delay
1067
-
| None ->
1068
-
let fnd = List.map (fun ((n, _), _) -> n) delay in
1069
-
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
1070
-
Json.Codec.missing_mems_error (error_meta d) map ~exp ~fnd)
1071
-
| 0x0022 ->
1072
-
let meta = read_json_name d in
1073
-
let name = token_pop d in
1074
-
if String.equal name cases.tag.name then
1075
-
let tag =
1076
-
try decode d cases.tag.type'
1077
-
with Json.Error e ->
1078
-
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1079
-
in
1080
-
decode_case_tag ~sep:true map umems cases mem_miss mem_decs meta tag
1081
-
delay
1082
-
else
1083
-
begin match String_map.find_opt name mem_decs with
1084
-
| Some (Mem_dec mem) ->
1085
-
let mem_miss = String_map.remove name mem_miss in
1086
-
let dict =
1087
-
try Dict.add mem.id (decode d mem.type') dict
1088
-
with Json.Error e ->
1089
-
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1090
-
in
1091
-
read_json_mem_sep d;
1092
-
decode_object_case d map umems cases mem_miss mem_decs delay dict
1093
-
| None ->
1094
-
(* Because JSON can be out of order we don't know how to decode
1095
-
this yet. Generic decode *)
1096
-
let v =
1097
-
try decode d Json.Codec.Value.t
1098
-
with Json.Error e ->
1099
-
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1100
-
in
1101
-
let delay = ((name, meta), v) :: delay in
1102
-
read_json_mem_sep d;
1103
-
decode_object_case d map umems cases mem_miss mem_decs delay dict
1104
-
end
1105
-
| u when u = eot -> err_unclosed_object d map
1106
-
| _ -> err_exp_mem_or_eoo d
1107
-
1108
-
and decode_any : type a. decoder -> a t -> a any_map -> a =
1109
-
fun d t map ->
1110
-
let case d t map =
1111
-
match map with None -> type_error d t | Some t -> decode d t
1112
-
in
1113
-
match d.u with
1114
-
| 0x006E (* n *) -> case d t map.dec_null
1115
-
| 0x0066 (* f *) | 0x0074 (* t *) -> case d t map.dec_bool
1116
-
| 0x0022 (* DQUOTE *) -> case d t map.dec_string
1117
-
| 0x005B (* [ *) -> case d t map.dec_array
1118
-
| 0x007B (* { *) -> case d t map.dec_object
1119
-
| u when is_number_start u -> case d t map.dec_number
1120
-
| _ -> err_not_json_value d
1121
-
1122
-
let of_reader_exn ?layout ?locs ?file t reader =
1123
-
let d = decoder ?layout ?locs ?file reader in
1124
-
let v =
1125
-
nextc d;
1126
-
decode d t
1127
-
in
1128
-
if d.u <> eot then err_exp_eot d else v
1129
-
1130
-
let of_reader ?layout ?locs ?file t reader =
1131
-
try Ok (of_reader_exn ?layout ?locs ?file t reader)
1132
-
with Json.Error e -> Error e
1133
-
1134
-
let of_string_exn ?layout ?locs ?file t s =
1135
-
of_reader_exn ?layout ?locs ?file t (Bytes.Reader.of_string s)
1136
-
1137
-
let of_string ?layout ?locs ?file t s =
1138
-
of_reader ?layout ?locs ?file t (Bytes.Reader.of_string s)
1139
-
1140
-
(* Encoding *)
1141
-
1142
-
type encoder = {
1143
-
writer : Bytes.Writer.t; (* Destination of bytes. *)
1144
-
o : Bytes.t; (* Buffer for slices. *)
1145
-
o_max : int; (* Max index in [o]. *)
1146
-
mutable o_next : int; (* Next writable index in [o]. *)
1147
-
format : Json.format;
1148
-
number_format : string;
1149
-
}
1150
-
1151
-
let encoder ?buf ?(format = Json.Minify)
1152
-
?(number_format = Json.default_number_format) writer =
1153
-
let o =
1154
-
match buf with
1155
-
| Some buf -> buf
1156
-
| None -> Bytes.create (Bytes.Writer.slice_length writer)
1157
-
in
1158
-
let len = Bytes.length o in
1159
-
let number_format = string_of_format number_format in
1160
-
let o_max = len - 1 and o_next = 0 in
1161
-
{ writer; o; o_max; o_next; format; number_format }
1162
-
1163
-
let[@inline] rem_len e = e.o_max - e.o_next + 1
1164
-
1165
-
let flush e =
1166
-
Bytes.Writer.write e.writer (Bytes.Slice.make e.o ~first:0 ~length:e.o_next);
1167
-
e.o_next <- 0
1168
-
1169
-
let write_eot ~eod e =
1170
-
flush e;
1171
-
if eod then Bytes.Writer.write_eod e.writer
1172
-
1173
-
let write_char e c =
1174
-
if e.o_next > e.o_max then flush e;
1175
-
Stdlib.Bytes.set e.o e.o_next c;
1176
-
e.o_next <- e.o_next + 1
1177
-
1178
-
let rec write_substring e s first length =
1179
-
if length = 0 then ()
1180
-
else
1181
-
let len = Int.min (rem_len e) length in
1182
-
if len = 0 then (
1183
-
flush e;
1184
-
write_substring e s first length)
1185
-
else begin
1186
-
Bytes.blit_string s first e.o e.o_next len;
1187
-
e.o_next <- e.o_next + len;
1188
-
write_substring e s (first + len) (length - len)
1189
-
end
1190
-
1191
-
let write_bytes e s = write_substring e s 0 (String.length s)
1192
-
let write_sep e = write_char e ','
1193
-
1194
-
let write_indent e ~nest =
1195
-
for _i = 1 to nest do
1196
-
write_char e ' ';
1197
-
write_char e ' '
1198
-
done
1199
-
1200
-
let write_ws_before e m = write_bytes e (Json.Meta.ws_before m)
1201
-
let write_ws_after e m = write_bytes e (Json.Meta.ws_after m)
1202
-
let write_json_null e = write_bytes e "null"
1203
-
let write_json_bool e b = write_bytes e (if b then "true" else "false")
1204
-
1205
-
(* XXX we bypass the printf machinery as it costs quite quite a bit.
1206
-
Would be even better if we could format directly to a bytes values
1207
-
rather than allocating a string per number. *)
1208
-
external format_float : string -> float -> string = "caml_format_float"
1209
-
1210
-
let write_json_number e f =
1211
-
if Float.is_finite f then write_bytes e (format_float e.number_format f)
1212
-
else write_json_null e
1213
-
1214
-
let write_json_string e s =
1215
-
let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in
1216
-
let len = String.length s in
1217
-
let flush e start i max =
1218
-
if start <= max then write_substring e s start (i - start)
1219
-
in
1220
-
let rec loop start i max =
1221
-
if i > max then flush e start i max
1222
-
else
1223
-
let next = i + 1 in
1224
-
match String.get s i with
1225
-
| '\"' ->
1226
-
flush e start i max;
1227
-
write_bytes e "\\\"";
1228
-
loop next next max
1229
-
| '\\' ->
1230
-
flush e start i max;
1231
-
write_bytes e "\\\\";
1232
-
loop next next max
1233
-
| '\n' ->
1234
-
flush e start i max;
1235
-
write_bytes e "\\n";
1236
-
loop next next max
1237
-
| '\r' ->
1238
-
flush e start i max;
1239
-
write_bytes e "\\r";
1240
-
loop next next max
1241
-
| '\t' ->
1242
-
flush e start i max;
1243
-
write_bytes e "\\t";
1244
-
loop next next max
1245
-
| c when is_control c ->
1246
-
flush e start i max;
1247
-
write_bytes e "\\u";
1248
-
write_bytes e (Fmt.str "%04X" (Char.code c));
1249
-
loop next next max
1250
-
| _ -> loop start next max
1251
-
in
1252
-
write_char e '"';
1253
-
loop 0 0 (len - 1);
1254
-
write_char e '"'
1255
-
1256
-
let encode_null (map : ('a, 'b) Json.Codec.base_map) e v =
1257
-
let () = map.enc v in
1258
-
match e.format with
1259
-
| Json.Minify | Json.Indent -> write_json_null e
1260
-
| Json.Layout ->
1261
-
let meta = map.enc_meta v in
1262
-
write_ws_before e meta;
1263
-
write_json_null e;
1264
-
write_ws_after e meta
1265
-
1266
-
let encode_bool (map : ('a, 'b) Json.Codec.base_map) e v =
1267
-
let b = map.enc v in
1268
-
match e.format with
1269
-
| Json.Minify | Json.Indent -> write_json_bool e b
1270
-
| Json.Layout ->
1271
-
let meta = map.enc_meta v in
1272
-
write_ws_before e meta;
1273
-
write_json_bool e b;
1274
-
write_ws_after e meta
1275
-
1276
-
let encode_number (map : ('a, 'b) Json.Codec.base_map) e v =
1277
-
let n = map.enc v in
1278
-
match e.format with
1279
-
| Json.Minify | Json.Indent -> write_json_number e n
1280
-
| Json.Layout ->
1281
-
let meta = map.enc_meta v in
1282
-
write_ws_before e meta;
1283
-
write_json_number e n;
1284
-
write_ws_after e meta
1285
-
1286
-
let encode_string (map : ('a, 'b) Json.Codec.base_map) e v =
1287
-
let s = map.enc v in
1288
-
match e.format with
1289
-
| Json.Minify | Json.Indent -> write_json_string e s
1290
-
| Json.Layout ->
1291
-
let meta = map.enc_meta v in
1292
-
write_ws_before e meta;
1293
-
write_json_string e s;
1294
-
write_ws_after e meta
1295
-
1296
-
let encode_mem_indent ~nest e =
1297
-
write_char e '\n';
1298
-
write_indent e ~nest
1299
-
1300
-
let encode_mem_name e meta n =
1301
-
match e.format with
1302
-
| Json.Minify ->
1303
-
write_json_string e n;
1304
-
write_char e ':'
1305
-
| Json.Indent ->
1306
-
write_json_string e n;
1307
-
write_bytes e ": "
1308
-
| Json.Layout ->
1309
-
write_ws_before e meta;
1310
-
write_json_string e n;
1311
-
write_ws_after e meta;
1312
-
write_char e ':'
1313
-
1314
-
let rec encode : type a. nest:int -> a Json.Codec.t -> encoder -> a -> unit =
1315
-
fun ~nest t e v ->
1316
-
match t with
1317
-
| Null map -> encode_null map e v
1318
-
| Bool map -> encode_bool map e v
1319
-
| Number map -> encode_number map e v
1320
-
| String map -> encode_string map e v
1321
-
| Array map -> encode_array ~nest map e v
1322
-
| Object map -> encode_object ~nest map e v
1323
-
| Any map -> encode ~nest (map.enc v) e v
1324
-
| Map map -> encode ~nest map.dom e (map.enc v)
1325
-
| Rec t -> encode ~nest (Lazy.force t) e v
1326
-
| Ignore -> Json.Error.failf Json.Meta.none "Cannot encode Ignore value"
1327
-
1328
-
and encode_array : type a elt b.
1329
-
nest:int -> (a, elt, b) Json.Codec.array_map -> encoder -> a -> unit =
1330
-
fun ~nest map e v ->
1331
-
let encode_element ~nest map e i v =
1332
-
if i <> 0 then write_sep e;
1333
-
try
1334
-
encode ~nest map.elt e v;
1335
-
e
1336
-
with Json.Error e ->
1337
-
Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e
1338
-
in
1339
-
match e.format with
1340
-
| Json.Minify ->
1341
-
write_char e '[';
1342
-
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1343
-
write_char e ']'
1344
-
| Json.Layout ->
1345
-
let meta = map.enc_meta v in
1346
-
write_ws_before e meta;
1347
-
write_char e '[';
1348
-
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1349
-
write_char e ']';
1350
-
write_ws_after e meta
1351
-
| Json.Indent ->
1352
-
let encode_element ~nest map e i v =
1353
-
if i <> 0 then write_sep e;
1354
-
write_char e '\n';
1355
-
write_indent e ~nest;
1356
-
try
1357
-
encode ~nest map.elt e v;
1358
-
e
1359
-
with Json.Error e ->
1360
-
Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e
1361
-
in
1362
-
let array_not_empty e =
1363
-
e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[')
1364
-
in
1365
-
write_char e '[';
1366
-
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1367
-
if array_not_empty e then (
1368
-
write_char e '\n';
1369
-
write_indent e ~nest);
1370
-
write_char e ']'
1371
-
1372
-
and encode_object : type o.
1373
-
nest:int -> (o, o) Json.Codec.object_map -> encoder -> o -> unit =
1374
-
fun ~nest map e o ->
1375
-
match e.format with
1376
-
| Json.Minify ->
1377
-
write_char e '{';
1378
-
Stdlib.ignore
1379
-
(encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o);
1380
-
write_char e '}'
1381
-
| Json.Layout ->
1382
-
let meta = map.enc_meta o in
1383
-
write_ws_before e meta;
1384
-
write_char e '{';
1385
-
Stdlib.ignore
1386
-
(encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o);
1387
-
write_char e '}';
1388
-
write_ws_after e meta
1389
-
| Json.Indent ->
1390
-
write_char e '{';
1391
-
let start =
1392
-
encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o
1393
-
in
1394
-
if not start then (
1395
-
write_char e '\n';
1396
-
write_indent e ~nest);
1397
-
write_char e '}'
1398
-
1399
-
and encode_object_map : type o.
1400
-
nest:int ->
1401
-
(o, o) Json.Codec.object_map ->
1402
-
do_unknown:bool ->
1403
-
encoder ->
1404
-
start:bool ->
1405
-
o ->
1406
-
bool =
1407
-
fun ~nest map ~do_unknown e ~start o ->
1408
-
let encode_mem ~nest map e o start (Mem_enc mmap) =
1409
-
try
1410
-
let v = mmap.enc o in
1411
-
if mmap.enc_omit v then start
1412
-
else begin
1413
-
if not start then write_char e ',';
1414
-
if e.format = Json.Indent then encode_mem_indent ~nest e;
1415
-
let meta =
1416
-
(* if e.format = Json.Layout then mmap.enc_name_meta v else *)
1417
-
Json.Meta.none
1418
-
in
1419
-
encode_mem_name e meta mmap.name;
1420
-
encode ~nest mmap.type' e v;
1421
-
false
1422
-
end
1423
-
with Json.Error e ->
1424
-
Json.Codec.error_push_object Json.Meta.none map
1425
-
(mmap.name, Json.Meta.none)
1426
-
e
1427
-
in
1428
-
match map.shape with
1429
-
| Object_basic u ->
1430
-
let start =
1431
-
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
1432
-
in
1433
-
begin match u with
1434
-
| Unknown_keep (umap, enc) when do_unknown ->
1435
-
encode_unknown_mems ~nest map umap e ~start (enc o)
1436
-
| _ -> start
1437
-
end
1438
-
| Object_cases (umap, cases) -> (
1439
-
let (Case_value (case, c)) = cases.enc_case (cases.enc o) in
1440
-
let start =
1441
-
if cases.tag.enc_omit case.tag then start
1442
-
else encode_mem ~nest map e case.tag start (Mem_enc cases.tag)
1443
-
in
1444
-
let start =
1445
-
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
1446
-
in
1447
-
match umap with
1448
-
| Some (Unknown_keep (umap, enc)) ->
1449
-
let start =
1450
-
encode_object_map ~nest case.object_map ~do_unknown:false e ~start c
1451
-
in
1452
-
encode_unknown_mems ~nest map umap e ~start (enc o)
1453
-
| _ -> encode_object_map ~nest case.object_map ~do_unknown e ~start c)
1454
-
1455
-
and encode_unknown_mems : type o mems a builder.
1456
-
nest:int ->
1457
-
(o, o) object_map ->
1458
-
(mems, a, builder) mems_map ->
1459
-
encoder ->
1460
-
start:bool ->
1461
-
mems ->
1462
-
bool =
1463
-
fun ~nest map umap e ~start mems ->
1464
-
let encode_unknown_mem ~nest map umap e meta n v start =
1465
-
try
1466
-
if not start then write_char e ',';
1467
-
if e.format = Json.Indent then encode_mem_indent ~nest e;
1468
-
encode_mem_name e meta n;
1469
-
encode ~nest umap.mems_type e v;
1470
-
false
1471
-
with Json.Error e ->
1472
-
Json.Codec.error_push_object Json.Meta.none map (n, Json.Meta.none) e
1473
-
in
1474
-
umap.enc (encode_unknown_mem ~nest map umap e) mems start
1475
-
1476
-
let to_writer_exn ?buf ?format ?number_format t v ~eod w =
1477
-
let e = encoder ?buf ?format ?number_format w in
1478
-
encode ~nest:0 t e v;
1479
-
write_eot ~eod e
1480
-
1481
-
let to_writer ?buf ?format ?number_format t v ~eod w =
1482
-
try Ok (to_writer_exn ?buf ?format ?number_format t v ~eod w)
1483
-
with Json.Error e -> Error e
1484
-
1485
-
let to_string_exn ?buf ?format ?number_format t v =
1486
-
let b = Buffer.create 255 in
1487
-
let w = Bytes.Writer.of_buffer b in
1488
-
to_writer_exn ?buf ?format ?number_format ~eod:true t v w;
1489
-
Buffer.contents b
1490
-
1491
-
let to_string ?buf ?format ?number_format t v =
1492
-
try Ok (to_string_exn ?buf ?format ?number_format t v)
1493
-
with Json.Error e -> Error e
1494
-
1495
-
(* Recode *)
1496
-
1497
-
let unsurprising_defaults layout format =
1498
-
match (layout, format) with
1499
-
| Some true, None -> (Some true, Some Json.Layout)
1500
-
| None, (Some Json.Layout as l) -> (Some true, l)
1501
-
| l, f -> (l, f)
1502
-
1503
-
let recode_exn ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1504
-
let layout, format = unsurprising_defaults layout format in
1505
-
let v = of_reader_exn ?layout ?locs ?file t r in
1506
-
to_writer_exn ?buf ?format ?number_format t v ~eod w
1507
-
1508
-
let recode ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1509
-
try Ok (recode_exn ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod)
1510
-
with Json.Error e -> Error e
1511
-
1512
-
let recode_string_exn ?layout ?locs ?file ?buf ?format ?number_format t s =
1513
-
let layout, format = unsurprising_defaults layout format in
1514
-
let v = of_string_exn ?layout ?locs ?file t s in
1515
-
to_string_exn ?buf ?format ?number_format t v
1516
-
1517
-
let recode_string ?layout ?locs ?file ?buf ?format ?number_format t s =
1518
-
try Ok (recode_string_exn ?layout ?locs ?file ?buf ?format ?number_format t s)
1519
-
with Json.Error e -> Error e
-186
lib/bytesrw/json_bytesrw.mli
-186
lib/bytesrw/json_bytesrw.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JSON codec.
7
-
8
-
According to {{:https://www.rfc-editor.org/rfc/rfc8259}RFC 8259}.
9
-
10
-
See notes about {{!layout}layout preservation} and behaviour on
11
-
{{!duplicate}duplicate members}.
12
-
13
-
{b Tip.} For maximal performance decode with [~layout:false] and
14
-
[~locs:false], this is the default. However using [~locs:true] improves some
15
-
error reports. *)
16
-
17
-
open Bytesrw
18
-
19
-
(** {1:decode Decode} *)
20
-
21
-
val of_reader :
22
-
?layout:bool ->
23
-
?locs:bool ->
24
-
?file:Loc.fpath ->
25
-
'a Json.codec ->
26
-
Bytes.Reader.t ->
27
-
('a, Json.Error.t) result
28
-
(** [of_reader t r] decodes a value from [r] according to [t].
29
-
- If [layout] is [true] whitespace is preserved in {!Json.Meta.t} values.
30
-
Defaults to [false].
31
-
- If [locs] is [true] locations are preserved in {!Json.Meta.t} values and
32
-
error messages are precisely located. Defaults to [false].
33
-
- [file] is the file path from which [r] is assumed to read. Defaults to
34
-
{!Loc.file_none}. *)
35
-
36
-
val of_reader_exn :
37
-
?layout:bool ->
38
-
?locs:bool ->
39
-
?file:Loc.fpath ->
40
-
'a Json.codec ->
41
-
Bytes.Reader.t ->
42
-
'a
43
-
(** [of_reader_exn] is like {!val-of_reader} but raises {!Json.exception-Error}.
44
-
*)
45
-
46
-
val of_string :
47
-
?layout:bool ->
48
-
?locs:bool ->
49
-
?file:Loc.fpath ->
50
-
'a Json.codec ->
51
-
string ->
52
-
('a, Json.Error.t) result
53
-
(** [of_string] is like {!val-of_reader} but decodes directly from a string. *)
54
-
55
-
val of_string_exn :
56
-
?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> 'a Json.codec -> string -> 'a
57
-
(** [of_string_exn] is like {!val-of_string} but raises {!Json.exception-Error}.
58
-
*)
59
-
60
-
(** {1:encode Encode} *)
61
-
62
-
val to_writer :
63
-
?buf:Bytes.t ->
64
-
?format:Json.format ->
65
-
?number_format:Json.number_format ->
66
-
'a Json.codec ->
67
-
'a ->
68
-
eod:bool ->
69
-
Bytes.Writer.t ->
70
-
(unit, Json.Error.t) result
71
-
(** [to_writer t v ~eod w] encodes value [v] according to [t] on [w].
72
-
- If [buf] is specified it is used as a buffer for the slices written on
73
-
[w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w].
74
-
- [format] specifies how the JSON should be formatted. Defaults to
75
-
{!Json.Minify}.
76
-
- [number_format] specifies the format string to format numbers. Defaults to
77
-
{!Json.default_number_format}.
78
-
- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be written on
79
-
[w]. *)
80
-
81
-
val to_writer_exn :
82
-
?buf:Bytes.t ->
83
-
?format:Json.format ->
84
-
?number_format:Json.number_format ->
85
-
'a Json.codec ->
86
-
'a ->
87
-
eod:bool ->
88
-
Bytes.Writer.t ->
89
-
unit
90
-
(** [to_writer_exn] is like {!val-to_writer} but raises {!Json.exception-Error}.
91
-
*)
92
-
93
-
val to_string :
94
-
?buf:Bytes.t ->
95
-
?format:Json.format ->
96
-
?number_format:Json.number_format ->
97
-
'a Json.codec ->
98
-
'a ->
99
-
(string, Json.Error.t) result
100
-
(** [to_string] is like {!val-to_writer} but writes to a string. *)
101
-
102
-
val to_string_exn :
103
-
?buf:Bytes.t ->
104
-
?format:Json.format ->
105
-
?number_format:Json.number_format ->
106
-
'a Json.codec ->
107
-
'a ->
108
-
string
109
-
(** [to_string_exn] is like {!val-to_string} but raises {!Json.exception-Error}.
110
-
*)
111
-
112
-
(** {1:recode Recode}
113
-
114
-
The defaults in these functions are those of {!val-of_reader} and
115
-
{!val-to_writer}, except if [layout] is [true], [format] defaults to
116
-
[Json.Layout] and vice-versa. *)
117
-
118
-
val recode :
119
-
?layout:bool ->
120
-
?locs:bool ->
121
-
?file:Loc.fpath ->
122
-
?buf:Bytes.t ->
123
-
?format:Json.format ->
124
-
?number_format:Json.number_format ->
125
-
'a Json.codec ->
126
-
Bytes.Reader.t ->
127
-
Bytes.Writer.t ->
128
-
eod:bool ->
129
-
(unit, Json.Error.t) result
130
-
(** [recode] is {!val-of_reader} followed by {!val-to_writer}. *)
131
-
132
-
val recode_exn :
133
-
?layout:bool ->
134
-
?locs:bool ->
135
-
?file:Loc.fpath ->
136
-
?buf:Bytes.t ->
137
-
?format:Json.format ->
138
-
?number_format:Json.number_format ->
139
-
'a Json.codec ->
140
-
Bytes.Reader.t ->
141
-
Bytes.Writer.t ->
142
-
eod:bool ->
143
-
unit
144
-
(** [recode_exn] is like {!val-recode} but raises {!Json.exception-Error}. *)
145
-
146
-
val recode_string :
147
-
?layout:bool ->
148
-
?locs:bool ->
149
-
?file:Loc.fpath ->
150
-
?buf:Bytes.t ->
151
-
?format:Json.format ->
152
-
?number_format:Json.number_format ->
153
-
'a Json.codec ->
154
-
string ->
155
-
(string, Json.Error.t) result
156
-
(** [recode_string] is {!of_string} followed by {!to_string}. *)
157
-
158
-
val recode_string_exn :
159
-
?layout:bool ->
160
-
?locs:bool ->
161
-
?file:Loc.fpath ->
162
-
?buf:Bytes.t ->
163
-
?format:Json.format ->
164
-
?number_format:Json.number_format ->
165
-
'a Json.codec ->
166
-
string ->
167
-
string
168
-
(** [recode_string_exn] is like {!val-recode_string} but raises
169
-
{!Json.exception-Error}. *)
170
-
171
-
(** {1:layout Layout preservation}
172
-
173
-
In order to simplify the implementation not all layout is preserved. In
174
-
particular:
175
-
- White space in empty arrays and objects is dropped.
176
-
- Unicode escapes are replaced by their UTF-8 encoding.
177
-
- The format of numbers is not preserved. *)
178
-
179
-
(** {1:duplicate Duplicate object members}
180
-
181
-
Duplicate object members are undefined behaviour in JSON. We follow the
182
-
behaviour of
183
-
{{:https://262.ecma-international.org/6.0/#sec-internalizejsonproperty}
184
-
[JSON.parse]} and the last one takes over, however duplicate members all
185
-
have to parse with the specified type as we error as soon as possible. Also
186
-
{{!Json.Object.case_mem}case members} are not allowed to duplicate. *)
+1
-1
lib/codec.ml
+1
-1
lib/codec.ml
-1
lib/core.ml
-1
lib/core.ml
+25
-16
lib/json.ml
+25
-16
lib/json.ml
···
1386
1386
1387
1387
let value_recode_exn t v = encode_exn t (decode_exn t v)
1388
1388
1389
-
let value_recode t v =
1390
-
try Ok (value_recode_exn t v) with Error e -> Result.Error e
1391
-
1392
1389
(* Queries and updates *)
1393
1390
1394
1391
let const t v =
···
3145
3142
in
3146
3143
umap.enc (encode_unknown_mem ~nest map umap e) mems start
3147
3144
3148
-
let to_writer_exn ?buf ?format ?number_format t v ~eod w =
3145
+
let to_writer ?buf ?format ?number_format t v ~eod w =
3149
3146
let e = encoder ?buf ?format ?number_format w in
3150
3147
write ~nest:0 t e v;
3151
3148
write_eot ~eod e
3152
3149
3153
-
let to_writer ?buf ?format ?number_format t v ~eod w =
3154
-
try Ok (to_writer_exn ?buf ?format ?number_format t v ~eod w)
3155
-
with Error e -> Error e
3156
-
3157
-
let to_string_exn ?buf ?format ?number_format t v =
3150
+
let to_string ?buf ?format ?number_format t v =
3158
3151
let b = Buffer.create 255 in
3159
3152
let w = Bytes.Writer.of_buffer b in
3160
-
to_writer_exn ?buf ?format ?number_format ~eod:true t v w;
3153
+
to_writer ?buf ?format ?number_format ~eod:true t v w;
3161
3154
Buffer.contents b
3162
3155
3163
-
let to_string ?buf ?format ?number_format t v =
3164
-
try Ok (to_string_exn ?buf ?format ?number_format t v)
3165
-
with Error e -> Error e
3166
-
3167
3156
(* Recode *)
3168
3157
3169
3158
let unsurprising_defaults layout format =
···
3175
3164
let recode_exn ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
3176
3165
let layout, format = unsurprising_defaults layout format in
3177
3166
let v = of_reader_exn ?layout ?locs ?file t r in
3178
-
to_writer_exn ?buf ?format ?number_format t v ~eod w
3167
+
to_writer ?buf ?format ?number_format t v ~eod w
3179
3168
3180
3169
let recode ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
3181
3170
try Ok (recode_exn ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod)
···
3184
3173
let recode_string_exn ?layout ?locs ?file ?buf ?format ?number_format t s =
3185
3174
let layout, format = unsurprising_defaults layout format in
3186
3175
let v = of_string_exn ?layout ?locs ?file t s in
3187
-
to_string_exn ?buf ?format ?number_format t v
3176
+
to_string ?buf ?format ?number_format t v
3188
3177
3189
3178
let recode_string ?layout ?locs ?file ?buf ?format ?number_format t s =
3190
3179
try Ok (recode_string_exn ?layout ?locs ?file ?buf ?format ?number_format t s)
3191
3180
with Error e -> Error e
3181
+
3182
+
module Value = struct
3183
+
let of_string ?layout ?locs ?file s =
3184
+
of_string ?layout ?locs ?file Codec.Value.t s
3185
+
3186
+
let of_string_exn ?layout ?locs ?file s =
3187
+
of_string_exn ?layout ?locs ?file Codec.Value.t s
3188
+
3189
+
let of_reader ?layout ?locs ?file r =
3190
+
of_reader ?layout ?locs ?file Codec.Value.t r
3191
+
3192
+
let of_reader_exn ?layout ?locs ?file r =
3193
+
of_reader_exn ?layout ?locs ?file Codec.Value.t r
3194
+
3195
+
let to_string ?buf ?format ?number_format v =
3196
+
to_string ?buf ?format ?number_format Codec.Value.t v
3197
+
3198
+
let to_writer ?buf ?format ?number_format v ~eod w =
3199
+
to_writer ?buf ?format ?number_format Codec.Value.t v ~eod w
3200
+
end
+58
-25
lib/json.mli
+58
-25
lib/json.mli
···
1584
1584
'a ->
1585
1585
eod:bool ->
1586
1586
Bytes.Writer.t ->
1587
-
(unit, Error.t) result
1588
-
(** [to_writer t v ~eod w] encodes value [v] according to [t] on [w].
1587
+
unit
1588
+
(** [to_writer t v ~eod w] encodes value [v] according to [t] on [w]. Raises
1589
+
{!Json.exception-Error} if the codec has no encoder (a codec bug, not a
1590
+
runtime condition).
1589
1591
- If [buf] is specified it is used as a buffer for the slices written on
1590
1592
[w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w].
1591
1593
- [format] specifies how the JSON should be formatted. Defaults to
···
1595
1597
- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be written on
1596
1598
[w]. *)
1597
1599
1598
-
val to_writer_exn :
1599
-
?buf:Bytes.t ->
1600
-
?format:format ->
1601
-
?number_format:number_format ->
1602
-
'a codec ->
1603
-
'a ->
1604
-
eod:bool ->
1605
-
Bytes.Writer.t ->
1606
-
unit
1607
-
(** [to_writer_exn] is like {!val-to_writer} but raises {!Json.exception-Error}.
1608
-
*)
1609
-
1610
1600
val to_string :
1611
1601
?buf:Bytes.t ->
1612
1602
?format:format ->
1613
1603
?number_format:number_format ->
1614
1604
'a codec ->
1615
1605
'a ->
1616
-
(string, Error.t) result
1617
-
(** [to_string] is like {!val-to_writer} but writes to a string. *)
1618
-
1619
-
val to_string_exn :
1620
-
?buf:Bytes.t ->
1621
-
?format:format ->
1622
-
?number_format:number_format ->
1623
-
'a codec ->
1624
-
'a ->
1625
1606
string
1626
-
(** [to_string_exn] is like {!val-to_string} but raises {!Json.exception-Error}.
1627
-
*)
1607
+
(** [to_string] is like {!val-to_writer} but writes to a string. Raises
1608
+
{!Json.exception-Error} on broken codecs. *)
1628
1609
1629
1610
(** {1:recode Recode}
1630
1611
···
1701
1682
[JSON.parse]} and the last one takes over, however duplicate members all
1702
1683
have to parse with the specified type as we error as soon as possible. Also
1703
1684
{{!Json.Object.case_mem}case members} are not allowed to duplicate. *)
1685
+
1686
+
(** {1:value_api Generic value API}
1687
+
1688
+
Convenience entry points for the generic JSON AST {!t}: skip the codec
1689
+
argument, use {!Codec.Value.t} implicitly. For typed values use the
1690
+
codec-taking forms at the top level. *)
1691
+
1692
+
module Value : sig
1693
+
val of_string :
1694
+
?layout:bool ->
1695
+
?locs:bool ->
1696
+
?file:Loc.fpath ->
1697
+
string ->
1698
+
(t, Error.t) result
1699
+
(** [of_string s] parses [s] to a generic JSON value. *)
1700
+
1701
+
val of_string_exn :
1702
+
?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> string -> t
1703
+
(** [of_string_exn] is like {!val-of_string} but raises
1704
+
{!Json.exception-Error}. *)
1705
+
1706
+
val of_reader :
1707
+
?layout:bool ->
1708
+
?locs:bool ->
1709
+
?file:Loc.fpath ->
1710
+
Bytesrw.Bytes.Reader.t ->
1711
+
(t, Error.t) result
1712
+
(** [of_reader r] parses [r] to a generic JSON value. *)
1713
+
1714
+
val of_reader_exn :
1715
+
?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> Bytesrw.Bytes.Reader.t -> t
1716
+
(** [of_reader_exn] is like {!val-of_reader} but raises
1717
+
{!Json.exception-Error}. *)
1718
+
1719
+
val to_string :
1720
+
?buf:Bytes.t ->
1721
+
?format:format ->
1722
+
?number_format:number_format ->
1723
+
t ->
1724
+
string
1725
+
(** [to_string v] encodes [v] as JSON. *)
1726
+
1727
+
val to_writer :
1728
+
?buf:Bytes.t ->
1729
+
?format:format ->
1730
+
?number_format:number_format ->
1731
+
t ->
1732
+
eod:bool ->
1733
+
Bytesrw.Bytes.Writer.t ->
1734
+
unit
1735
+
(** [to_writer v ~eod w] encodes [v] to [w]. *)
1736
+
end
-1
lib/value.ml
-1
lib/value.ml
+2
-3
test/bytesrw/test_json_bytesrw.ml
+2
-3
test/bytesrw/test_json_bytesrw.ml
···
7
7
| Ok n -> Alcotest.(check int) "42 round-trip" 42 n
8
8
9
9
let test_encode_primitive () =
10
-
match Json.to_string Json.Codec.int 7 with
11
-
| Error e -> Alcotest.failf "encode failed: %a" Json.Error.pp e
12
-
| Ok s -> Alcotest.(check string) "7 encoded" "7" s
10
+
let s = Json.to_string Json.Codec.int 7 in
11
+
Alcotest.(check string) "7 encoded" "7" s
13
12
14
13
let test_roundtrip_object () =
15
14
let pair_codec =
+87
-87
test/codecs/cookbook.ml
+87
-87
test/codecs/cookbook.ml
···
6
6
(* Dealing with null values. *)
7
7
8
8
let string_null_is_empty =
9
-
let null = Jsont.null "" in
10
-
let enc = function "" -> null | _ -> Jsont.string in
11
-
Jsont.any ~dec_null:null ~dec_string:Jsont.string ~enc ()
9
+
let null = Json.null "" in
10
+
let enc = function "" -> null | _ -> Json.string in
11
+
Json.any ~dec_null:null ~dec_string:Json.string ~enc ()
12
12
13
13
(* Base maps *)
14
14
···
21
21
end
22
22
23
23
let m_jsont =
24
-
let dec = Jsont.Base.dec_result M.result_of_string in
25
-
let enc = Jsont.Base.enc M.to_string in
26
-
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
24
+
let dec = Json.Base.dec_result M.result_of_string in
25
+
let enc = Json.Base.enc M.to_string in
26
+
Json.Base.string (Json.Base.map ~kind:"M.t" ~dec ~enc ())
27
27
28
28
let m_jsont' =
29
-
let dec = Jsont.Base.dec_failure M.of_string_or_failure in
30
-
let enc = Jsont.Base.enc M.to_string in
31
-
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
29
+
let dec = Json.Base.dec_failure M.of_string_or_failure in
30
+
let enc = Json.Base.enc M.to_string in
31
+
Json.Base.string (Json.Base.map ~kind:"M.t" ~dec ~enc ())
32
32
33
33
let m_jsont'' =
34
-
Jsont.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string
34
+
Json.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string
35
35
36
36
(* Objects as records *)
37
37
···
43
43
let age p = p.age
44
44
45
45
let jsont =
46
-
Jsont.Object.map ~kind:"Person" make
47
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
48
-
|> Jsont.Object.mem "age" Jsont.int ~enc:age
49
-
|> Jsont.Object.finish
46
+
Json.Object.map ~kind:"Person" make
47
+
|> Json.Object.mem "name" Json.string ~enc:name
48
+
|> Json.Object.mem "age" Json.int ~enc:age
49
+
|> Json.Object.finish
50
50
end
51
51
52
52
(* Objects as key-value maps *)
53
53
54
54
module String_map = Map.Make (String)
55
55
56
-
let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t =
56
+
let map : ?kind:string -> 'a Json.codec -> 'a String_map.t Json.codec =
57
57
fun ?kind t ->
58
-
Jsont.Object.map ?kind Fun.id
59
-
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id
60
-
|> Jsont.Object.finish
58
+
Json.Object.map ?kind Fun.id
59
+
|> Json.Object.keep_unknown (Json.Object.Mems.string_map t) ~enc:Fun.id
60
+
|> Json.Object.finish
61
61
62
62
(* Optional members *)
63
63
···
69
69
let age p = p.age
70
70
71
71
let jsont =
72
-
Jsont.Object.map ~kind:"Person" make
73
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
74
-
|> Jsont.Object.mem "age"
75
-
Jsont.(some int)
72
+
Json.Object.map ~kind:"Person" make
73
+
|> Json.Object.mem "name" Json.string ~enc:name
74
+
|> Json.Object.mem "age"
75
+
Json.(some int)
76
76
~dec_absent:None ~enc_omit:Option.is_none ~enc:age
77
-
|> Jsont.Object.finish
77
+
|> Json.Object.finish
78
78
end
79
79
80
80
(* Unknown object members *)
···
87
87
let age p = p.age
88
88
89
89
let jsont =
90
-
Jsont.Object.map ~kind:"Person" make
91
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
92
-
|> Jsont.Object.mem "age" Jsont.int ~enc:age
93
-
|> Jsont.Object.error_unknown |> Jsont.Object.finish
90
+
Json.Object.map ~kind:"Person" make
91
+
|> Json.Object.mem "name" Json.string ~enc:name
92
+
|> Json.Object.mem "age" Json.int ~enc:age
93
+
|> Json.Object.error_unknown |> Json.Object.finish
94
94
end
95
95
96
96
module Person_keep = struct
97
-
type t = { name : string; age : int; unknown : Jsont.json }
97
+
type t = { name : string; age : int; unknown : Json.t }
98
98
99
99
let make name age unknown = { name; age; unknown }
100
100
let name p = p.name
···
102
102
let unknown v = v.unknown
103
103
104
104
let jsont =
105
-
Jsont.Object.map ~kind:"Person" make
106
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
107
-
|> Jsont.Object.mem "age" Jsont.int ~enc:age
108
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
109
-
|> Jsont.Object.finish
105
+
Json.Object.map ~kind:"Person" make
106
+
|> Json.Object.mem "name" Json.string ~enc:name
107
+
|> Json.Object.mem "age" Json.int ~enc:age
108
+
|> Json.Object.keep_unknown Json.json_mems ~enc:unknown
109
+
|> Json.Object.finish
110
110
end
111
111
112
112
(* Dealing with recursive JSON *)
···
121
121
let jsont value_type =
122
122
let rec t =
123
123
lazy
124
-
(Jsont.Object.map ~kind:"Tree" make
125
-
|> Jsont.Object.mem "value" value_type ~enc:value
126
-
|> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children
127
-
|> Jsont.Object.finish)
124
+
(Json.Object.map ~kind:"Tree" make
125
+
|> Json.Object.mem "value" value_type ~enc:value
126
+
|> Json.Object.mem "children" (Json.list (Json.rec' t)) ~enc:children
127
+
|> Json.Object.finish)
128
128
in
129
129
Lazy.force t
130
130
end
···
140
140
let radius c = c.radius
141
141
142
142
let jsont =
143
-
Jsont.Object.map ~kind:"Circle" make
144
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
145
-
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
146
-
|> Jsont.Object.finish
143
+
Json.Object.map ~kind:"Circle" make
144
+
|> Json.Object.mem "name" Json.string ~enc:name
145
+
|> Json.Object.mem "radius" Json.number ~enc:radius
146
+
|> Json.Object.finish
147
147
end
148
148
149
149
module Rect = struct
···
155
155
let height r = r.height
156
156
157
157
let jsont =
158
-
Jsont.Object.map ~kind:"Rect" make
159
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
160
-
|> Jsont.Object.mem "width" Jsont.number ~enc:width
161
-
|> Jsont.Object.mem "height" Jsont.number ~enc:height
162
-
|> Jsont.Object.finish
158
+
Json.Object.map ~kind:"Rect" make
159
+
|> Json.Object.mem "name" Json.string ~enc:name
160
+
|> Json.Object.mem "width" Json.number ~enc:width
161
+
|> Json.Object.mem "height" Json.number ~enc:height
162
+
|> Json.Object.finish
163
163
end
164
164
165
165
type t = Circle of Circle.t | Rect of Rect.t
···
168
168
let rect r = Rect r
169
169
170
170
let jsont =
171
-
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
172
-
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
171
+
let circle = Json.Object.Case.map "Circle" Circle.jsont ~dec:circle in
172
+
let rect = Json.Object.Case.map "Rect" Rect.jsont ~dec:rect in
173
173
let enc_case = function
174
-
| Circle c -> Jsont.Object.Case.value circle c
175
-
| Rect r -> Jsont.Object.Case.value rect r
174
+
| Circle c -> Json.Object.Case.value circle c
175
+
| Rect r -> Json.Object.Case.value rect r
176
176
in
177
-
let cases = Jsont.Object.Case.[ make circle; make rect ] in
178
-
Jsont.Object.map ~kind:"Geometry" Fun.id
179
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
180
-
|> Jsont.Object.finish
177
+
let cases = Json.Object.Case.[ make circle; make rect ] in
178
+
Json.Object.map ~kind:"Geometry" Fun.id
179
+
|> Json.Object.case_mem "type" Json.string ~enc:Fun.id ~enc_case cases
180
+
|> Json.Object.finish
181
181
end
182
182
183
183
module Geometry_record = struct
···
188
188
let radius c = c.radius
189
189
190
190
let jsont =
191
-
Jsont.Object.map ~kind:"Circle" make
192
-
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
193
-
|> Jsont.Object.finish
191
+
Json.Object.map ~kind:"Circle" make
192
+
|> Json.Object.mem "radius" Json.number ~enc:radius
193
+
|> Json.Object.finish
194
194
end
195
195
196
196
module Rect = struct
···
201
201
let height r = r.height
202
202
203
203
let jsont =
204
-
Jsont.Object.map ~kind:"Rect" make
205
-
|> Jsont.Object.mem "width" Jsont.number ~enc:width
206
-
|> Jsont.Object.mem "height" Jsont.number ~enc:height
207
-
|> Jsont.Object.finish
204
+
Json.Object.map ~kind:"Rect" make
205
+
|> Json.Object.mem "width" Json.number ~enc:width
206
+
|> Json.Object.mem "height" Json.number ~enc:height
207
+
|> Json.Object.finish
208
208
end
209
209
210
210
type type' = Circle of Circle.t | Rect of Rect.t
···
219
219
let type' g = g.type'
220
220
221
221
let jsont =
222
-
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
223
-
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
222
+
let circle = Json.Object.Case.map "Circle" Circle.jsont ~dec:circle in
223
+
let rect = Json.Object.Case.map "Rect" Rect.jsont ~dec:rect in
224
224
let enc_case = function
225
-
| Circle c -> Jsont.Object.Case.value circle c
226
-
| Rect r -> Jsont.Object.Case.value rect r
225
+
| Circle c -> Json.Object.Case.value circle c
226
+
| Rect r -> Json.Object.Case.value rect r
227
227
in
228
-
let cases = Jsont.Object.Case.[ make circle; make rect ] in
229
-
Jsont.Object.map ~kind:"Geometry" make
230
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
231
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
232
-
|> Jsont.Object.finish
228
+
let cases = Json.Object.Case.[ make circle; make rect ] in
229
+
Json.Object.map ~kind:"Geometry" make
230
+
|> Json.Object.mem "name" Json.string ~enc:name
231
+
|> Json.Object.case_mem "type" Json.string ~enc:type' ~enc_case cases
232
+
|> Json.Object.finish
233
233
end
234
234
235
235
(* Untagged object types *)
236
236
237
237
module Response = struct
238
-
type t = { id : int; value : (Jsont.json, string) result }
238
+
type t = { id : int; value : (Json.t, string) result }
239
239
240
240
let make id result error =
241
-
let pp_mem = Jsont.Codec.pp_code in
241
+
let pp_mem = Json.Codec.pp_code in
242
242
match (result, error) with
243
243
| Some result, None -> { id; value = Ok result }
244
244
| None, Some error -> { id; value = Error error }
245
245
| Some _, Some _ ->
246
-
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
246
+
Json.Error.msgf Json.Meta.none "Both %a and %a members are defined"
247
247
pp_mem "result" pp_mem "error"
248
248
| None, None ->
249
-
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" pp_mem
249
+
Json.Error.msgf Json.Meta.none "Missing either %a or %a member" pp_mem
250
250
"result" pp_mem "error"
251
251
252
252
let result r = match r.value with Ok v -> Some v | Error _ -> None
253
253
let error r = match r.value with Ok _ -> None | Error e -> Some e
254
254
255
255
let jsont =
256
-
Jsont.Object.map make
257
-
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id)
258
-
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:result
259
-
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:error
260
-
|> Jsont.Object.finish
256
+
Json.Object.map make
257
+
|> Json.Object.mem "id" Json.int ~enc:(fun r -> r.id)
258
+
|> Json.Object.opt_mem "result" Json.json ~enc:result
259
+
|> Json.Object.opt_mem "error" Json.string ~enc:error
260
+
|> Json.Object.finish
261
261
end
262
262
263
263
(* Flattening objects on queries *)
···
268
268
let make id name persons = { id; name; persons }
269
269
270
270
let info_jsont =
271
-
Jsont.Object.map make
272
-
|> Jsont.Object.mem "id" Jsont.int
273
-
|> Jsont.Object.mem "name" Jsont.string
274
-
|> Jsont.Object.finish
271
+
Json.Object.map make
272
+
|> Json.Object.mem "id" Json.int
273
+
|> Json.Object.mem "name" Json.string
274
+
|> Json.Object.finish
275
275
276
276
let jsont =
277
-
Jsont.Object.map (fun k persons -> k persons)
278
-
|> Jsont.Object.mem "info" info_jsont
279
-
|> Jsont.Object.mem "persons" (Jsont.list Person.jsont)
280
-
|> Jsont.Object.finish
277
+
Json.Object.map (fun k persons -> k persons)
278
+
|> Json.Object.mem "info" info_jsont
279
+
|> Json.Object.mem "persons" (Json.list Person.jsont)
280
+
|> Json.Object.finish
281
281
end
+65
-69
test/codecs/geojson.ml
+65
-69
test/codecs/geojson.ml
···
18
18
19
19
type float_array = float array
20
20
21
-
let float_array_jsont ~kind = Jsont.array ~kind Jsont.number
21
+
let float_array_jsont ~kind = Json.array ~kind Json.number
22
22
23
23
type 'a garray = 'a array
24
24
25
-
let garray = Jsont.array
25
+
let garray = Json.array
26
26
27
27
module Bbox = struct
28
28
type t = float_array
···
37
37
end
38
38
39
39
module Geojson_object = struct
40
-
type 'a t = { type' : 'a; bbox : Bbox.t option; unknown : Jsont.json }
40
+
type 'a t = { type' : 'a; bbox : Bbox.t option; unknown : Json.t }
41
41
42
42
let make type' bbox unknown = { type'; bbox; unknown }
43
43
let type' o = o.type'
···
46
46
47
47
let finish_jsont map =
48
48
map
49
-
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
50
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
51
-
|> Jsont.Object.finish
49
+
|> Json.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
50
+
|> Json.Object.keep_unknown Json.json_mems ~enc:unknown
51
+
|> Json.Object.finish
52
52
53
53
let geometry ~kind coordinates =
54
-
Jsont.Object.map ~kind make
55
-
|> Jsont.Object.mem "coordinates" coordinates ~enc:type'
54
+
Json.Object.map ~kind make
55
+
|> Json.Object.mem "coordinates" coordinates ~enc:type'
56
56
|> finish_jsont
57
57
end
58
58
···
116
116
type t = {
117
117
id : id option;
118
118
geometry : geometry option;
119
-
properties : Jsont.json option;
119
+
properties : Json.t option;
120
120
}
121
121
122
122
let make id geometry properties = { id; geometry; properties }
···
148
148
149
149
let feature_id_jsont =
150
150
let number =
151
-
let dec = Jsont.Base.dec (fun n -> `Number n) in
152
-
let enc =
153
-
Jsont.Base.enc (function `Number n -> n | _ -> assert false)
154
-
in
155
-
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
151
+
let dec = Json.Base.dec (fun n -> `Number n) in
152
+
let enc = Json.Base.enc (function `Number n -> n | _ -> assert false) in
153
+
Json.Base.number (Json.Base.map ~enc ~dec ())
156
154
in
157
155
let string =
158
-
let dec = Jsont.Base.dec (fun n -> `String n) in
159
-
let enc =
160
-
Jsont.Base.enc (function `String n -> n | _ -> assert false)
161
-
in
162
-
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
156
+
let dec = Json.Base.dec (fun n -> `String n) in
157
+
let enc = Json.Base.enc (function `String n -> n | _ -> assert false) in
158
+
Json.Base.string (Json.Base.map ~enc ~dec ())
163
159
in
164
160
let enc = function `Number _ -> number | `String _ -> string in
165
-
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
161
+
Json.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
166
162
167
163
(* The first two Json types below handle subtyping by redoing
168
164
cases for subsets of types. *)
169
165
170
-
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec
166
+
let case_map obj dec = Json.Object.Case.map (Json.kind obj) obj ~dec
171
167
172
168
let rec geometry_jsont =
173
169
lazy begin
···
183
179
case_map (Lazy.force geometry_collection_jsont) geometry_collection
184
180
in
185
181
let enc_case = function
186
-
| `Point v -> Jsont.Object.Case.value case_point v
187
-
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
188
-
| `Line_string v -> Jsont.Object.Case.value case_line_string v
182
+
| `Point v -> Json.Object.Case.value case_point v
183
+
| `Multi_point v -> Json.Object.Case.value case_multi_point v
184
+
| `Line_string v -> Json.Object.Case.value case_line_string v
189
185
| `Multi_line_string v ->
190
-
Jsont.Object.Case.value case_multi_line_string v
191
-
| `Polygon v -> Jsont.Object.Case.value case_polygon v
192
-
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
186
+
Json.Object.Case.value case_multi_line_string v
187
+
| `Polygon v -> Json.Object.Case.value case_polygon v
188
+
| `Multi_polygon v -> Json.Object.Case.value case_multi_polygon v
193
189
| `Geometry_collection v ->
194
-
Jsont.Object.Case.value case_geometry_collection v
190
+
Json.Object.Case.value case_geometry_collection v
195
191
in
196
192
let cases =
197
-
Jsont.Object.Case.
193
+
Json.Object.Case.
198
194
[
199
195
make case_point;
200
196
make case_multi_point;
···
205
201
make case_geometry_collection;
206
202
]
207
203
in
208
-
Jsont.Object.map ~kind:"Geometry object" Fun.id
209
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
204
+
Json.Object.map ~kind:"Geometry object" Fun.id
205
+
|> Json.Object.case_mem "type" Json.string ~enc:Fun.id ~enc_case cases
210
206
~tag_to_string:Fun.id ~tag_compare:String.compare
211
-
|> Jsont.Object.finish
207
+
|> Json.Object.finish
212
208
end
213
209
214
-
and feature_jsont : Feature.t object' Jsont.t Lazy.t =
210
+
and feature_jsont : Feature.t object' Json.codec Lazy.t =
215
211
lazy begin
216
212
let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in
217
-
let enc_case v = Jsont.Object.Case.value case_feature v in
218
-
let cases = Jsont.Object.Case.[ make case_feature ] in
219
-
Jsont.Object.map ~kind:"Feature" Fun.id
220
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
213
+
let enc_case v = Json.Object.Case.value case_feature v in
214
+
let cases = Json.Object.Case.[ make case_feature ] in
215
+
Json.Object.map ~kind:"Feature" Fun.id
216
+
|> Json.Object.case_mem "type" Json.string ~enc:Fun.id ~enc_case cases
221
217
~tag_to_string:Fun.id ~tag_compare:String.compare
222
-
|> Jsont.Object.finish
218
+
|> Json.Object.finish
223
219
end
224
220
225
-
and case_feature_jsont : Feature.t object' Jsont.t Lazy.t =
221
+
and case_feature_jsont : Feature.t object' Json.codec Lazy.t =
226
222
lazy begin
227
-
Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object
228
-
|> Jsont.Object.opt_mem "id" feature_id_jsont ~enc:(fun o ->
223
+
Json.Object.map ~kind:"Feature" Feature.make_geojson_object
224
+
|> Json.Object.opt_mem "id" feature_id_jsont ~enc:(fun o ->
229
225
Feature.id (Geojson_object.type' o))
230
-
|> Jsont.Object.mem "geometry"
231
-
(Jsont.option (Jsont.rec' geometry_jsont))
226
+
|> Json.Object.mem "geometry"
227
+
(Json.option (Json.rec' geometry_jsont))
232
228
~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
233
-
|> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object)
229
+
|> Json.Object.mem "properties" (Json.option Json.json_object)
234
230
~enc:(fun o -> Feature.properties (Geojson_object.type' o))
235
231
|> Geojson_object.finish_jsont
236
232
end
237
233
238
234
and geometry_collection_jsont =
239
235
lazy begin
240
-
Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make
241
-
|> Jsont.Object.mem "geometries"
242
-
(Jsont.list (Jsont.rec' geometry_jsont))
236
+
Json.Object.map ~kind:"GeometryCollection" Geojson_object.make
237
+
|> Json.Object.mem "geometries"
238
+
(Json.list (Json.rec' geometry_jsont))
243
239
~enc:Geojson_object.type'
244
240
|> Geojson_object.finish_jsont
245
241
end
246
242
247
243
and feature_collection_json =
248
244
lazy begin
249
-
Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make
250
-
|> Jsont.Object.mem "features"
251
-
Jsont.(list (Jsont.rec' feature_jsont))
245
+
Json.Object.map ~kind:"FeatureCollection" Geojson_object.make
246
+
|> Json.Object.mem "features"
247
+
Json.(list (Json.rec' feature_jsont))
252
248
~enc:Geojson_object.type'
253
249
|> Geojson_object.finish_jsont
254
250
end
255
251
256
-
and jsont : t Jsont.t Lazy.t =
252
+
and jsont : t Json.codec Lazy.t =
257
253
lazy begin
258
254
let case_point = case_map Point.jsont point in
259
255
let case_multi_point = case_map Multi_point.jsont multi_point in
···
271
267
case_map (Lazy.force feature_collection_json) feature_collection
272
268
in
273
269
let enc_case = function
274
-
| `Point v -> Jsont.Object.Case.value case_point v
275
-
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
276
-
| `Line_string v -> Jsont.Object.Case.value case_line_string v
270
+
| `Point v -> Json.Object.Case.value case_point v
271
+
| `Multi_point v -> Json.Object.Case.value case_multi_point v
272
+
| `Line_string v -> Json.Object.Case.value case_line_string v
277
273
| `Multi_line_string v ->
278
-
Jsont.Object.Case.value case_multi_line_string v
279
-
| `Polygon v -> Jsont.Object.Case.value case_polygon v
280
-
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
274
+
Json.Object.Case.value case_multi_line_string v
275
+
| `Polygon v -> Json.Object.Case.value case_polygon v
276
+
| `Multi_polygon v -> Json.Object.Case.value case_multi_polygon v
281
277
| `Geometry_collection v ->
282
-
Jsont.Object.Case.value case_geometry_collection v
283
-
| `Feature v -> Jsont.Object.Case.value case_feature v
278
+
Json.Object.Case.value case_geometry_collection v
279
+
| `Feature v -> Json.Object.Case.value case_feature v
284
280
| `Feature_collection v ->
285
-
Jsont.Object.Case.value case_feature_collection v
281
+
Json.Object.Case.value case_feature_collection v
286
282
in
287
283
let cases =
288
-
Jsont.Object.Case.
284
+
Json.Object.Case.
289
285
[
290
286
make case_point;
291
287
make case_multi_point;
···
298
294
make case_feature_collection;
299
295
]
300
296
in
301
-
Jsont.Object.map ~kind:"GeoJSON" Fun.id
302
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
297
+
Json.Object.map ~kind:"GeoJSON" Fun.id
298
+
|> Json.Object.case_mem "type" Json.string ~enc:Fun.id ~enc_case cases
303
299
~tag_to_string:Fun.id ~tag_compare:String.compare
304
-
|> Jsont.Object.finish
300
+
|> Json.Object.finish
305
301
end
306
302
307
303
let jsont = Lazy.force jsont
···
316
312
| Ok v -> v
317
313
| Error e ->
318
314
let lines = String.split_on_char '\n' e in
319
-
Format.eprintf "@[%a @[<v>%a@]@]" Jsont.Error.puterr ()
315
+
Format.eprintf "@[%a @[<v>%a@]@]" Json.Error.puterr ()
320
316
(Format.pp_print_list Format.pp_print_string)
321
317
lines;
322
318
use
···
338
334
@@ fun r ->
339
335
log_if_error ~use:1
340
336
@@
341
-
let* t = Jsont_bytesrw.decode ~file ~locs Geojson.jsont r in
337
+
let* t = Json.of_reader ~file ~locs Geojson.jsont r in
342
338
if dec_only then Ok 0
343
339
else
344
340
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
345
-
let* () = Jsont_bytesrw.encode ~format ~eod:true Geojson.jsont t w in
341
+
let* () = Json.to_writer ~format ~eod:true Geojson.jsont t w in
346
342
Ok 0
347
343
348
344
open Cmdliner
···
358
354
let doc = "Preserve locations (better errors)." in
359
355
Arg.(value & flag & info [ "l"; "locs" ] ~doc)
360
356
and+ format =
361
-
let fmt = [ ("indent", Jsont.Indent); ("minify", Jsont.Minify) ] in
357
+
let fmt = [ ("indent", Json.Indent); ("minify", Json.Minify) ] in
362
358
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt) in
363
359
Arg.(
364
360
value
365
-
& opt (enum fmt) Jsont.Minify
361
+
& opt (enum fmt) Json.Minify
366
362
& info [ "f"; "format" ] ~doc ~docv:"FMT")
367
363
and+ dec_only =
368
364
let doc = "Decode only." in
+37
-41
test/codecs/json_rpc.ml
+37
-41
test/codecs/json_rpc.ml
···
9
9
10
10
type jsonrpc = [ `V2 ]
11
11
12
-
let jsonrpc_jsont = Jsont.enum [ ("2.0", `V2) ]
12
+
let jsonrpc_jsont = Json.enum [ ("2.0", `V2) ]
13
13
14
14
(* JSON-RPC identifiers *)
15
15
16
16
type id = [ `String of string | `Number of float | `Null ]
17
17
18
-
let id_jsont : id Jsont.t =
19
-
let null = Jsont.null `Null in
18
+
let id_jsont : id Json.codec =
19
+
let null = Json.null `Null in
20
20
let string =
21
21
let dec s = `String s in
22
22
let enc = function `String s -> s | _ -> assert false in
23
-
Jsont.map ~dec ~enc Jsont.string
23
+
Json.map ~dec ~enc Json.string
24
24
in
25
25
let number =
26
26
let dec n = `Number n in
27
27
let enc = function `Number n -> n | _ -> assert false in
28
-
Jsont.map ~dec ~enc Jsont.number
28
+
Json.map ~dec ~enc Json.number
29
29
in
30
30
let enc = function
31
31
| `Null -> null
32
32
| `String _ -> string
33
33
| `Number _ -> number
34
34
in
35
-
Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
35
+
Json.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
36
36
37
37
(* JSON-RPC request object *)
38
38
39
-
type params = Jsont.json (* An array or object *)
39
+
type params = Json.json (* An array or object *)
40
40
41
41
let params_jsont =
42
42
let enc = function
43
-
| Jsont.Object _ | Jsont.Array _ -> Jsont.json
43
+
| Json.Object _ | Json.Array _ -> Json.t
44
44
| j ->
45
-
let meta = Jsont.Meta.none in
46
-
let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in
47
-
Jsont.Error.expected meta "object or array" ~fnd
45
+
let meta = Json.Meta.none in
46
+
let fnd = Json.Sort.to_string (Json.Value.sort j) in
47
+
Json.Error.expected meta "object or array" ~fnd
48
48
in
49
49
let kind = "JSON-RPC params" in
50
-
Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc ()
50
+
Json.any ~kind ~dec_array:Json.json ~dec_object:Json.json ~enc ()
51
51
52
52
type request = {
53
53
jsonrpc : jsonrpc;
···
58
58
59
59
let request jsonrpc method' params id = { jsonrpc; method'; params; id }
60
60
61
-
let request_jsont : request Jsont.t =
62
-
Jsont.Object.map request
63
-
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
64
-
|> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method')
65
-
|> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
66
-
|> Jsont.Object.opt_mem "id" id_jsont ~enc:(fun r -> r.id)
67
-
|> Jsont.Object.finish
61
+
let request_jsont : request Json.codec =
62
+
Json.Object.map request
63
+
|> Json.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
64
+
|> Json.Object.mem "method" Json.string ~enc:(fun r -> r.method')
65
+
|> Json.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
66
+
|> Json.Object.opt_mem "id" id_jsont ~enc:(fun r -> r.id)
67
+
|> Json.Object.finish
68
68
69
69
(* JSON-RPC error objects *)
70
70
71
-
type error = { code : int; message : string; data : Jsont.json option }
71
+
type error = { code : int; message : string; data : Json.t option }
72
72
73
73
let error code message data = { code; message; data }
74
74
75
75
let error_jsont =
76
-
Jsont.Object.map error
77
-
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
78
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
79
-
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
80
-
|> Jsont.Object.finish
76
+
Json.Object.map error
77
+
|> Json.Object.mem "code" Json.int ~enc:(fun e -> e.code)
78
+
|> Json.Object.mem "message" Json.string ~enc:(fun e -> e.message)
79
+
|> Json.Object.opt_mem "data" Json.json ~enc:(fun e -> e.data)
80
+
|> Json.Object.finish
81
81
82
82
(* JSON-RPC response object *)
83
83
84
-
type response = {
85
-
jsonrpc : jsonrpc;
86
-
value : (Jsont.json, error) result;
87
-
id : id;
88
-
}
84
+
type response = { jsonrpc : jsonrpc; value : (Json.t, error) result; id : id }
89
85
90
86
let response jsonrpc result error id : response =
91
87
let err_both () =
92
-
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
93
-
Jsont.Codec.pp_code "result" Jsont.Codec.pp_code "error"
88
+
Json.Error.msgf Json.Meta.none "Both %a and %a members are defined"
89
+
Json.Codec.pp_code "result" Json.Codec.pp_code "error"
94
90
in
95
91
let err_none () =
96
-
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
97
-
Jsont.Codec.pp_code "result" Jsont.Codec.pp_code "error"
92
+
Json.Error.msgf Json.Meta.none "Missing either %a or %a member"
93
+
Json.Codec.pp_code "result" Json.Codec.pp_code "error"
98
94
in
99
95
match (result, error) with
100
96
| Some result, None -> { jsonrpc; value = Ok result; id }
···
105
101
let response_result r = match r.value with Ok v -> Some v | Error _ -> None
106
102
let response_error r = match r.value with Ok _ -> None | Error e -> Some e
107
103
108
-
let response_jsont : response Jsont.t =
109
-
Jsont.Object.map response
110
-
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
111
-
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result
112
-
|> Jsont.Object.opt_mem "error" error_jsont ~enc:response_error
113
-
|> Jsont.Object.mem "id" id_jsont ~enc:(fun r -> r.id)
114
-
|> Jsont.Object.finish
104
+
let response_jsont : response Json.codec =
105
+
Json.Object.map response
106
+
|> Json.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
107
+
|> Json.Object.opt_mem "result" Json.json ~enc:response_result
108
+
|> Json.Object.opt_mem "error" error_jsont ~enc:response_error
109
+
|> Json.Object.mem "id" id_jsont ~enc:(fun r -> r.id)
110
+
|> Json.Object.finish
+36
-42
test/codecs/jsont_tool.ml
+36
-42
test/codecs/jsont_tool.ml
···
11
11
| Error e ->
12
12
let exec = Filename.basename Sys.executable_name in
13
13
let lines = String.split_on_char '\n' e in
14
-
Format.eprintf "%s: %a @[<v>%a@]@." exec Jsont.Error.puterr ()
14
+
Format.eprintf "%s: %a @[<v>%a@]@." exec Json.Error.puterr ()
15
15
Format.(pp_print_list pp_print_string)
16
16
lines;
17
17
use
···
90
90
91
91
let output ~format ~number_format j =
92
92
match format with
93
-
| `Pretty ->
94
-
Ok (Format.printf "@[%a@]@." (Jsont.pp_json' ~number_format ()) j)
93
+
| `Pretty -> Ok (Format.printf "@[%a@]@." (Json.pp_json' ~number_format ()) j)
95
94
| `Format format ->
96
95
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
97
-
Jsont_bytesrw.encode ~format ~number_format ~eod:true Jsont.json j w
96
+
Json.to_writer ~format ~number_format ~eod:true Json.json j w
98
97
99
98
let output_string ~format ~number_format j =
100
99
match format with
101
-
| `Pretty ->
102
-
Ok (Format.asprintf "@[%a@]" (Jsont.pp_json' ~number_format ()) j)
103
-
| `Format format ->
104
-
Jsont_bytesrw.encode_string ~format ~number_format Jsont.json j
100
+
| `Pretty -> Ok (Format.asprintf "@[%a@]" (Json.pp_json' ~number_format ()) j)
101
+
| `Format format -> Json.to_string ~format ~number_format Json.json j
105
102
106
103
let trip_type ?(dec_only = false) ~file ~format ~number_format ~diff:do_diff
107
104
~locs t =
···
110
107
@@ fun r ->
111
108
log_if_error ~use:exit_err_json
112
109
@@
113
-
let layout = format = `Format Jsont.Layout in
110
+
let layout = format = `Format Json.Layout in
114
111
match do_diff with
115
112
| false ->
116
-
let* j = Jsont_bytesrw.decode ~file ~layout ~locs t r in
113
+
let* j = Json.of_reader ~file ~layout ~locs t r in
117
114
if dec_only then Ok 0
118
115
else
119
116
let* () = output ~format ~number_format j in
120
117
Ok 0
121
118
| true -> (
122
119
let src = Bytesrw.Bytes.Reader.to_string r in
123
-
let* j = Jsont_bytesrw.decode_string ~file ~layout ~locs t src in
120
+
let* j = Json.of_string ~file ~layout ~locs t src in
124
121
let* fmted = output_string ~format ~number_format j in
125
122
match diff src fmted with
126
123
| Ok exit -> if exit = 0 then Ok 0 else Ok exit_err_diff
···
129
126
Ok Cmdliner.Cmd.Exit.some_error)
130
127
131
128
let delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs =
132
-
let del = Jsont.delete_path ~allow_absent path in
129
+
let del = Json.delete_path ~allow_absent path in
133
130
trip_type ~file ~format ~number_format ~diff ~locs del
134
131
135
132
let fmt ~file ~format ~number_format ~diff ~locs ~dec_only =
136
-
trip_type ~file ~format ~number_format ~diff ~locs ~dec_only Jsont.json
133
+
trip_type ~file ~format ~number_format ~diff ~locs ~dec_only Json.t
137
134
138
135
let get ~file ~path ~format ~number_format ~diff ~absent ~locs =
139
-
let get = Jsont.path ?absent path Jsont.json in
136
+
let get = Json.path ?absent path Json.json in
140
137
trip_type ~file ~format ~number_format ~diff ~locs get
141
138
142
139
let locs' ~file =
143
140
let pf = Format.fprintf in
144
-
let pp_code = Jsont.Codec.pp_code in
141
+
let pp_code = Json.Codec.pp_code in
145
142
let pp_locs_outline ppf v =
146
143
let indent = 2 in
147
144
let loc label ppf m =
148
-
pf ppf "@[<v>%s:@,%a@]@," label Jsont.Textloc.pp_ocaml
149
-
(Jsont.Meta.textloc m)
145
+
pf ppf "@[<v>%s:@,%a@]@," label Loc.pp_ocaml (Json.Meta.textloc m)
150
146
in
151
147
let rec value ppf = function
152
-
| Jsont.Null ((), m) ->
153
-
loc (strf "%a" pp_code (strf "%a" Jsont.pp_null ())) ppf m
154
-
| Jsont.Bool (b, m) ->
155
-
loc (strf "Bool %a" pp_code (strf "%a" Jsont.pp_bool b)) ppf m
156
-
| Jsont.Number (n, m) ->
157
-
loc (strf "Number %a" pp_code (strf "%a" Jsont.pp_number n)) ppf m
158
-
| Jsont.String (s, m) ->
159
-
loc (strf "String %a" pp_code (strf "%a" Jsont.pp_string s)) ppf m
160
-
| Jsont.Array (l, m) ->
148
+
| Json.Null ((), m) ->
149
+
loc (strf "%a" pp_code (strf "%a" Json.pp_null ())) ppf m
150
+
| Json.Bool (b, m) ->
151
+
loc (strf "Bool %a" pp_code (strf "%a" Json.pp_bool b)) ppf m
152
+
| Json.Number (n, m) ->
153
+
loc (strf "Number %a" pp_code (strf "%a" Json.pp_number n)) ppf m
154
+
| Json.String (s, m) ->
155
+
loc (strf "String %a" pp_code (strf "%a" Json.pp_string s)) ppf m
156
+
| Json.Array (l, m) ->
161
157
Format.pp_open_vbox ppf indent;
162
158
loc "Array" ppf m;
163
159
(Format.pp_print_list value) ppf l;
164
160
Format.pp_close_box ppf ()
165
-
| Jsont.Object (o, m) ->
161
+
| Json.Object (o, m) ->
166
162
let mem ppf ((name, m), v) =
167
-
let l = strf "Member %a" pp_code (strf "%a" Jsont.pp_string name) in
163
+
let l = strf "Member %a" pp_code (strf "%a" Json.pp_string name) in
168
164
loc l ppf m;
169
165
value ppf v
170
166
in
···
180
176
@@ fun reader ->
181
177
log_if_error ~use:exit_err_json
182
178
@@
183
-
let* j = Jsont_bytesrw.decode ~file ~locs:true Jsont.json reader in
179
+
let* j = Json.of_reader ~file ~locs:true Json.json reader in
184
180
pp_locs_outline Format.std_formatter j;
185
181
Ok 0
186
182
187
183
let set ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json:j
188
184
~locs =
189
-
let set = Jsont.set_path ?stub ~allow_absent Jsont.json path j in
185
+
let set = Json.set_path ?stub ~allow_absent Json.json path j in
190
186
trip_type ~file ~format ~number_format ~diff ~locs set
191
187
192
188
(* Command line interface *)
···
200
196
:: Cmd.Exit.info exit_err_diff ~doc:"on JSON output differences."
201
197
:: Cmd.Exit.defaults
202
198
203
-
let path_arg = Arg.conv' ~docv:"JSON_PATH" Jsont.Path.(of_string, pp)
199
+
let path_arg = Arg.conv' ~docv:"JSON_PATH" Json.Path.(of_string, pp)
204
200
205
201
let json_arg =
206
-
let of_string s =
207
-
Jsont_bytesrw.decode_string ~locs:true ~layout:true Jsont.json s
208
-
in
209
-
let pp = Jsont.pp_json in
202
+
let of_string s = Json.of_string ~locs:true ~layout:true Json.json s in
203
+
let pp = Json.pp_json in
210
204
Arg.conv' ~docv:"JSON" (of_string, pp)
211
205
212
206
let format_opt ~default =
213
207
let fmt =
214
208
[
215
-
("indent", `Format Jsont.Indent);
216
-
("minify", `Format Jsont.Minify);
217
-
("preserve", `Format Jsont.Layout);
209
+
("indent", `Format Json.Indent);
210
+
("minify", `Format Json.Minify);
211
+
("preserve", `Format Json.Layout);
218
212
("pretty", `Pretty);
219
213
]
220
214
in
···
228
222
Arg.(value & opt (enum fmt) default & info [ "f"; "format" ] ~doc ~docv:"FMT")
229
223
230
224
let format_opt_default_pretty = format_opt ~default:`Pretty
231
-
let format_opt_default_preserve = format_opt ~default:(`Format Jsont.Layout)
225
+
let format_opt_default_preserve = format_opt ~default:(`Format Json.Layout)
232
226
233
227
let allow_absent_opt =
234
228
let doc = "Do not error if $(i,JSON_PATH) does not exist." in
···
244
238
245
239
let number_format_opt =
246
240
let doc = "Use C float format string $(docv) to format JSON numbers." in
247
-
let number_format : Jsont.number_format Arg.conv =
241
+
let number_format : Json.number_format Arg.conv =
248
242
let parse s =
249
-
try Ok (Scanf.format_from_string s Jsont.default_number_format)
243
+
try Ok (Scanf.format_from_string s Json.default_number_format)
250
244
with Scanf.Scan_failure _ ->
251
245
Error (strf "Cannot format a float with %S" s)
252
246
in
···
255
249
in
256
250
Arg.(
257
251
value
258
-
& opt number_format Jsont.default_number_format
252
+
& opt number_format Json.default_number_format
259
253
& info [ "n"; "number-format" ] ~doc ~docv:"FMT")
260
254
261
255
let diff_flag =
+13
-13
test/codecs/quickstart.ml
+13
-13
test/codecs/quickstart.ml
···
11
11
"tags": ["work", "softwre"] }|}
12
12
13
13
let () =
14
-
let p = Jsont.Path.(root |> mem "tags" |> nth 1) in
15
-
let update = Jsont.(set_path string p "software") in
16
-
let correct = Jsont_bytesrw.recode_string ~layout:true update data in
14
+
let p = Json.Path.(root |> mem "tags" |> nth 1) in
15
+
let update = Json.(set_path string p "software") in
16
+
let correct = Json.recode_string ~layout:true update data in
17
17
print_endline (Result.get_ok correct)
18
18
19
19
module Status = struct
20
20
type t = Todo | Done | Cancelled
21
21
22
22
let assoc = [ ("todo", Todo); ("done", Done); ("cancelled", Cancelled) ]
23
-
let jsont = Jsont.enum ~kind:"Status" assoc
23
+
let jsont = Json.enum ~kind:"Status" assoc
24
24
end
25
25
26
26
module Item = struct
···
32
32
let tags i = i.tags
33
33
34
34
let jsont =
35
-
Jsont.Object.map ~kind:"Item" make
36
-
|> Jsont.Object.mem "task" Jsont.string ~enc:task
37
-
|> Jsont.Object.mem "status" Status.jsont ~enc:status
38
-
|> Jsont.Object.mem "tags"
39
-
Jsont.(list string)
35
+
Json.Object.map ~kind:"Item" make
36
+
|> Json.Object.mem "task" Json.string ~enc:task
37
+
|> Json.Object.mem "status" Status.jsont ~enc:status
38
+
|> Json.Object.mem "tags"
39
+
Json.(list string)
40
40
~enc:tags ~dec_absent:[] ~enc_omit:(( = ) [])
41
-
|> Jsont.Object.finish
41
+
|> Json.Object.finish
42
42
end
43
43
44
-
let items = Jsont.list Item.jsont
45
-
let items_of_json s = Jsont_bytesrw.decode_string items s
46
-
let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is
44
+
let items = Json.list Item.jsont
45
+
let items_of_json s = Json.of_string items s
46
+
let items_to_json ?format is = Json.to_string ?format items is
+6
-8
test/codecs/test_bytesrw.ml
+6
-8
test/codecs/test_bytesrw.ml
···
9
9
10
10
(* Tests the common test suite with the Jsont_bytesrw codec. *)
11
11
12
-
let decode ?layout t json =
13
-
Jsont_bytesrw.decode_string ?layout ~locs:true t json
14
-
15
-
let encode ?format t v = Jsont_bytesrw.encode_string ?format t v
12
+
let decode ?layout t json = Json.of_string ?layout ~locs:true t json
13
+
let encode ?format t v = Json.to_string ?format t v
16
14
let test_funs = { Test_common.supports_layout = true; decode; encode }
17
15
18
16
(* Other tests *)
19
17
20
18
let test_eod =
21
-
Test.test "Jsont_bytesrw.encode ~eod" @@ fun () ->
19
+
Test.test "Json.to_writer ~eod" @@ fun () ->
22
20
let b = Buffer.create 255 in
23
21
let w = Bytes.Writer.of_buffer b in
24
-
let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:false w) in
25
-
let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:true w) in
22
+
let () = Result.get_ok (Json.to_writer' Json.bool true ~eod:false w) in
23
+
let () = Result.get_ok (Json.to_writer' Json.bool true ~eod:true w) in
26
24
Test.string (Buffer.contents b) "truetrue";
27
-
Snap.raise (fun () -> Jsont_bytesrw.encode' Jsont.bool true ~eod:true w)
25
+
Snap.raise (fun () -> Json.to_writer' Json.bool true ~eod:true w)
28
26
@> __POS_OF__ (Invalid_argument "slice written after eod");
29
27
()
30
28
+299
-302
test/codecs/test_common.ml
+299
-302
test/codecs/test_common.ml
···
9
9
10
10
let ( let* ) = Result.bind
11
11
12
-
(* This abstracts over codecs Jsont_brr, Jsont_bytesrw and Jsont.Json *)
12
+
(* This abstracts over codecs Jsont_brr, Jsont_bytesrw and Json.Json *)
13
13
14
14
type test_funs = {
15
15
supports_layout : bool;
16
-
decode : 'a. ?layout:bool -> 'a Jsont.t -> string -> ('a, string) result;
16
+
decode : 'a. ?layout:bool -> 'a Json.codec -> string -> ('a, string) result;
17
17
encode :
18
-
'a. ?format:Jsont.format -> 'a Jsont.t -> 'a -> (string, string) result;
18
+
'a. ?format:Json.format -> 'a Json.codec -> 'a -> (string, string) result;
19
19
}
20
20
21
21
let test_funs : test_funs ref =
···
67
67
| None -> ()
68
68
| Some msg -> Test.styled_string msg e ~__POS__)
69
69
70
-
let update ?__POS__:pos ?(format = Jsont.Minify) q j j' =
71
-
let layout = format = Jsont.Layout in
70
+
let update ?__POS__:pos ?(format = Json.Minify) q j j' =
71
+
let layout = format = Json.Layout in
72
72
Test.block ?__POS__:pos @@ fun () ->
73
73
match decode ~layout q j with
74
74
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
75
-
| Ok v when supports_layout () || not (format = Jsont.Layout) ->
76
-
encode_ok ~format Jsont.json ~value:v j' ~__POS__
75
+
| Ok v when supports_layout () || not (format = Json.Layout) ->
76
+
encode_ok ~format Json.json ~value:v j' ~__POS__
77
77
| Ok v ->
78
78
let j' =
79
-
encode ~format:Jsont.Indent Jsont.json
80
-
(decode Jsont.json j' |> Result.get_ok)
79
+
encode ~format:Json.Indent Json.t (decode Json.json j' |> Result.get_ok)
81
80
|> Result.get_ok
82
81
in
83
-
encode_ok ~format:Jsont.Indent Jsont.json ~value:v j' ~__POS__
82
+
encode_ok ~format:Json.Indent Json.json ~value:v j' ~__POS__
84
83
85
84
(* [trip t src] is the über testing combinator.
86
85
···
88
87
that the generated JSON [trip] has the same data unless [lossy] is
89
88
specified. If [value] is provided both decodes of [src] and [trip]
90
89
are tested against [value]. If [format] is specified with
91
-
[Jsont.Indent] or [Jsont.Layout] it assumes that [src] and [trip]
90
+
[Json.Indent] or [Json.Layout] it assumes that [src] and [trip]
92
91
must be equal *)
93
92
94
-
let trip ?(format = Jsont.Minify) ?(lossy = false) ?value ?(eq = Test.T.any)
93
+
let trip ?(format = Json.Minify) ?(lossy = false) ?value ?(eq = Test.T.any)
95
94
?__POS__:pos t src =
96
95
Test.block ?__POS__:pos @@ fun () ->
97
-
let layout = format = Jsont.Layout in
96
+
let layout = format = Json.Layout in
98
97
let v =
99
98
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode ~layout t src)
100
99
in
···
110
109
end;
111
110
if not lossy then begin
112
111
let json =
113
-
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Jsont.json src)
112
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Json.json src)
114
113
in
115
114
let trip =
116
-
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Jsont.json trip)
115
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Json.json trip)
117
116
in
118
-
Test.eq (module Jsont.Json) json trip ~__POS__
117
+
Test.eq (module Json.Json) json trip ~__POS__
119
118
end;
120
-
if format <> Jsont.Minify then
121
-
begin if format = Jsont.Layout && not (supports_layout ()) then ()
119
+
if format <> Json.Minify then
120
+
begin if format = Json.Layout && not (supports_layout ()) then ()
122
121
else
123
122
(* Test that src is a representation of the requested encoding format *)
124
123
Test.string src trip ~__POS__
125
124
end
126
125
127
-
let eq : (module Test.T with type t = 'a) = (module Jsont.Json)
126
+
let eq : (module Test.T with type t = 'a) = (module Json.Json)
128
127
129
128
(* Tests *)
130
129
131
130
let test_basic_invalid =
132
131
Test.test "basic invalid JSON" @@ fun () ->
133
-
decode_error Jsont.json "" ~__POS__;
134
-
decode_error (Jsont.null ()) "" ~__POS__;
135
-
decode_error Jsont.bool "" ~__POS__;
136
-
decode_error Jsont.json "ha" ~__POS__;
137
-
decode_error (Jsont.null ()) "ha" ~__POS__;
138
-
decode_error Jsont.bool "ha" ~__POS__;
139
-
decode_error Jsont.json " ha" ~__POS__;
140
-
decode_error Jsont.json " r6 " ~__POS__;
141
-
decode_error Jsont.json " { " ~__POS__;
142
-
decode_error Jsont.json " [ " ~__POS__;
143
-
decode_error Jsont.json " ][ " ~__POS__;
132
+
decode_error Json.json "" ~__POS__;
133
+
decode_error (Json.null ()) "" ~__POS__;
134
+
decode_error Json.bool "" ~__POS__;
135
+
decode_error Json.json "ha" ~__POS__;
136
+
decode_error (Json.null ()) "ha" ~__POS__;
137
+
decode_error Json.bool "ha" ~__POS__;
138
+
decode_error Json.json " ha" ~__POS__;
139
+
decode_error Json.json " r6 " ~__POS__;
140
+
decode_error Json.json " { " ~__POS__;
141
+
decode_error Json.json " [ " ~__POS__;
142
+
decode_error Json.json " ][ " ~__POS__;
144
143
()
145
144
146
145
let test_indent = Test.test "Encode with indentation" @@ fun () -> ()
147
146
148
147
let test_null =
149
-
Test.test "Jsont.null" @@ fun () ->
150
-
trip ~eq ~format:Layout Jsont.json " null \r\n" ~__POS__;
151
-
trip ~eq ~format:Layout Jsont.json "\n null " ~__POS__;
152
-
trip ~eq ~format:Layout Jsont.json "null" ~__POS__;
153
-
trip ~eq ~format:Indent Jsont.json "null" ~__POS__;
154
-
decode_error Jsont.json " nu " ~__POS__;
155
-
decode_error Jsont.json " nul " ~__POS__;
156
-
decode_error Jsont.json " n " ~__POS__;
157
-
trip (Jsont.null ()) " \n null \n " ~value:() ~__POS__;
158
-
trip (Jsont.null ()) " null " ~value:() ~__POS__;
159
-
decode_error (Jsont.null ()) " true " ~__POS__;
148
+
Test.test "Json.null" @@ fun () ->
149
+
trip ~eq ~format:Layout Json.json " null \r\n" ~__POS__;
150
+
trip ~eq ~format:Layout Json.json "\n null " ~__POS__;
151
+
trip ~eq ~format:Layout Json.json "null" ~__POS__;
152
+
trip ~eq ~format:Indent Json.json "null" ~__POS__;
153
+
decode_error Json.json " nu " ~__POS__;
154
+
decode_error Json.json " nul " ~__POS__;
155
+
decode_error Json.json " n " ~__POS__;
156
+
trip (Json.null ()) " \n null \n " ~value:() ~__POS__;
157
+
trip (Json.null ()) " null " ~value:() ~__POS__;
158
+
decode_error (Json.null ()) " true " ~__POS__;
160
159
()
161
160
162
161
let test_bool =
163
-
Test.test "Jsont.bool" @@ fun () ->
164
-
trip ~eq ~format:Layout Jsont.json " true \r\n" ~__POS__;
165
-
trip ~eq ~format:Layout Jsont.json "\n false " ~__POS__;
166
-
trip ~eq ~format:Layout Jsont.json "false" ~__POS__;
167
-
trip ~eq ~format:Indent Jsont.json "true" ~__POS__;
168
-
trip ~eq ~format:Indent Jsont.json "false" ~__POS__;
169
-
decode_error Jsont.json " fals " ~__POS__;
170
-
decode_error Jsont.json " falsee " ~__POS__;
171
-
decode_error Jsont.json " f " ~__POS__;
172
-
trip ~eq:Test.T.bool Jsont.bool " true \n " ~value:true ~__POS__;
173
-
trip ~eq:Test.T.bool Jsont.bool " false " ~value:false ~__POS__;
174
-
decode_error Jsont.bool " fals " ~__POS__;
162
+
Test.test "Json.bool" @@ fun () ->
163
+
trip ~eq ~format:Layout Json.json " true \r\n" ~__POS__;
164
+
trip ~eq ~format:Layout Json.json "\n false " ~__POS__;
165
+
trip ~eq ~format:Layout Json.json "false" ~__POS__;
166
+
trip ~eq ~format:Indent Json.json "true" ~__POS__;
167
+
trip ~eq ~format:Indent Json.json "false" ~__POS__;
168
+
decode_error Json.json " fals " ~__POS__;
169
+
decode_error Json.json " falsee " ~__POS__;
170
+
decode_error Json.json " f " ~__POS__;
171
+
trip ~eq:Test.T.bool Json.bool " true \n " ~value:true ~__POS__;
172
+
trip ~eq:Test.T.bool Json.bool " false " ~value:false ~__POS__;
173
+
decode_error Json.bool " fals " ~__POS__;
175
174
()
176
175
177
176
let test_numbers =
178
-
Test.test "Jsont.number" @@ fun () ->
179
-
trip ~eq ~format:Layout Jsont.json " 1 " ~__POS__;
180
-
trip ~eq ~format:Layout Jsont.json " 0 \n " ~__POS__;
181
-
trip ~eq ~format:Layout Jsont.json "\n 2.5 " ~__POS__;
182
-
trip ~eq ~format:Indent Jsont.json "0";
183
-
trip ~eq ~format:Indent Jsont.json "0.5";
184
-
decode_error Jsont.json " 01 " ~__POS__;
185
-
decode_error Jsont.json " -a " ~__POS__;
186
-
decode_error Jsont.json " 1. " ~__POS__;
187
-
decode_error Jsont.json " 1.0e+ " ~__POS__;
188
-
decode_error Jsont.json " inf " ~__POS__;
189
-
decode_error Jsont.json " infinity " ~__POS__;
190
-
decode_error Jsont.json " nan " ~__POS__;
177
+
Test.test "Json.number" @@ fun () ->
178
+
trip ~eq ~format:Layout Json.json " 1 " ~__POS__;
179
+
trip ~eq ~format:Layout Json.json " 0 \n " ~__POS__;
180
+
trip ~eq ~format:Layout Json.json "\n 2.5 " ~__POS__;
181
+
trip ~eq ~format:Indent Json.json "0";
182
+
trip ~eq ~format:Indent Json.json "0.5";
183
+
decode_error Json.json " 01 " ~__POS__;
184
+
decode_error Json.json " -a " ~__POS__;
185
+
decode_error Json.json " 1. " ~__POS__;
186
+
decode_error Json.json " 1.0e+ " ~__POS__;
187
+
decode_error Json.json " inf " ~__POS__;
188
+
decode_error Json.json " infinity " ~__POS__;
189
+
decode_error Json.json " nan " ~__POS__;
191
190
let eq = Test.T.float in
192
-
trip ~eq Jsont.number " -0 " ~value:(-0.) ~__POS__;
193
-
trip ~eq Jsont.number " 0 " ~value:0. ~__POS__;
194
-
trip ~eq Jsont.number " 0E1 " ~value:0. ~__POS__;
195
-
trip ~eq Jsont.number " 0e+1 " ~value:0. ~__POS__;
196
-
trip ~eq Jsont.number " null " ~value:Float.nan ~__POS__;
197
-
encode_ok Jsont.number "null" ~value:Float.infinity ~__POS__;
198
-
encode_ok Jsont.number "null" ~value:Float.neg_infinity ~__POS__;
199
-
trip ~eq Jsont.number " 1e300 " ~value:1.e300 ~__POS__;
200
-
decode_error Jsont.number " fals " ~__POS__;
201
-
decode_error Jsont.number " 1. " ~__POS__;
202
-
decode_error Jsont.number " 1.0e+ " ~__POS__;
203
-
decode_error Jsont.number " 0E " ~__POS__;
204
-
decode_error Jsont.number " 1eE2 " ~__POS__;
191
+
trip ~eq Json.number " -0 " ~value:(-0.) ~__POS__;
192
+
trip ~eq Json.number " 0 " ~value:0. ~__POS__;
193
+
trip ~eq Json.number " 0E1 " ~value:0. ~__POS__;
194
+
trip ~eq Json.number " 0e+1 " ~value:0. ~__POS__;
195
+
trip ~eq Json.number " null " ~value:Float.nan ~__POS__;
196
+
encode_ok Json.number "null" ~value:Float.infinity ~__POS__;
197
+
encode_ok Json.number "null" ~value:Float.neg_infinity ~__POS__;
198
+
trip ~eq Json.number " 1e300 " ~value:1.e300 ~__POS__;
199
+
decode_error Json.number " fals " ~__POS__;
200
+
decode_error Json.number " 1. " ~__POS__;
201
+
decode_error Json.number " 1.0e+ " ~__POS__;
202
+
decode_error Json.number " 0E " ~__POS__;
203
+
decode_error Json.number " 1eE2 " ~__POS__;
205
204
()
206
205
207
206
let test_strings =
208
-
Test.test "Jsont.string" @@ fun () ->
209
-
trip ~eq ~format:Layout Jsont.json {| "" |} ~__POS__;
210
-
trip ~eq ~format:Layout Jsont.json " \"\\\"\" " ~__POS__;
211
-
trip ~eq ~format:Layout Jsont.json " \"\\\\\" " ~__POS__;
212
-
trip ~eq ~format:Layout Jsont.json " \"hihi\" \n " ~__POS__;
213
-
trip ~eq ~format:Layout Jsont.json " \"hi\\nhi\" \n " ~__POS__;
207
+
Test.test "Json.string" @@ fun () ->
208
+
trip ~eq ~format:Layout Json.json {| "" |} ~__POS__;
209
+
trip ~eq ~format:Layout Json.json " \"\\\"\" " ~__POS__;
210
+
trip ~eq ~format:Layout Json.json " \"\\\\\" " ~__POS__;
211
+
trip ~eq ~format:Layout Json.json " \"hihi\" \n " ~__POS__;
212
+
trip ~eq ~format:Layout Json.json " \"hi\\nhi\" \n " ~__POS__;
214
213
if Sys.backend_type <> Sys.Other "js_of_ocaml" then begin
215
-
decode_error Jsont.json "\"\\uDC01\"" ~__POS__;
216
-
decode_error Jsont.json "\"\\uDBFF\"" ~__POS__;
217
-
decode_error Jsont.json "\"\\uDBFF\\uDBFF\"" ~__POS__
214
+
decode_error Json.json "\"\\uDC01\"" ~__POS__;
215
+
decode_error Json.json "\"\\uDBFF\"" ~__POS__;
216
+
decode_error Json.json "\"\\uDBFF\\uDBFF\"" ~__POS__
218
217
end;
219
-
trip ~format:Indent Jsont.json {|""|};
220
-
trip ~format:Indent Jsont.json {|"blablabla"|};
221
-
decode_error Jsont.json "\"hi\nhi\"" ~__POS__;
222
-
decode_error Jsont.json "\n \"abla\" hi " ~__POS__;
223
-
decode_error Jsont.json "\n \"unclosed hi " ~__POS__;
224
-
trip ~eq:Test.T.string Jsont.string "\"\\ud83D\\uDc2B\"" ~value:"🐫" ~__POS__;
225
-
trip ~eq:Test.T.string Jsont.string "\"🐫 a\"" ~value:"🐫 a" ~__POS__;
226
-
decode_error Jsont.string " false " ~__POS__;
227
-
decode_error Jsont.string "1.0" ~__POS__;
218
+
trip ~format:Indent Json.json {|""|};
219
+
trip ~format:Indent Json.json {|"blablabla"|};
220
+
decode_error Json.json "\"hi\nhi\"" ~__POS__;
221
+
decode_error Json.json "\n \"abla\" hi " ~__POS__;
222
+
decode_error Json.json "\n \"unclosed hi " ~__POS__;
223
+
trip ~eq:Test.T.string Json.string "\"\\ud83D\\uDc2B\"" ~value:"🐫" ~__POS__;
224
+
trip ~eq:Test.T.string Json.string "\"🐫 a\"" ~value:"🐫 a" ~__POS__;
225
+
decode_error Json.string " false " ~__POS__;
226
+
decode_error Json.string "1.0" ~__POS__;
228
227
()
229
228
230
229
let test_option =
231
-
Test.test "Jsont.{none,some,option}" @@ fun () ->
230
+
Test.test "Json.{none,some,option}" @@ fun () ->
232
231
(* none *)
233
-
decode_error Jsont.none "2" ~__POS__;
234
-
decode_error Jsont.none "true" ~__POS__;
235
-
trip Jsont.none "null" ~value:None ~__POS__;
232
+
decode_error Json.none "2" ~__POS__;
233
+
decode_error Json.none "true" ~__POS__;
234
+
trip Json.none "null" ~value:None ~__POS__;
236
235
(* some *)
237
-
decode_error Jsont.(some bool) "null" ~__POS__;
238
-
decode_error Jsont.(some bool) "1.0" ~__POS__;
239
-
trip Jsont.(some bool) "true" ~value:(Some true) ~__POS__;
236
+
decode_error Json.(some bool) "null" ~__POS__;
237
+
decode_error Json.(some bool) "1.0" ~__POS__;
238
+
trip Json.(some bool) "true" ~value:(Some true) ~__POS__;
240
239
(* option *)
241
-
decode_error Jsont.(option bool) "1.0" ~__POS__;
242
-
decode_error Jsont.(option bool) "{}" ~__POS__;
243
-
trip Jsont.(option bool) "true" ~value:(Some true) ~__POS__;
244
-
trip Jsont.(option bool) "false" ~value:(Some false) ~__POS__;
245
-
trip Jsont.(option bool) "null" ~value:None ~__POS__;
240
+
decode_error Json.(option bool) "1.0" ~__POS__;
241
+
decode_error Json.(option bool) "{}" ~__POS__;
242
+
trip Json.(option bool) "true" ~value:(Some true) ~__POS__;
243
+
trip Json.(option bool) "false" ~value:(Some false) ~__POS__;
244
+
trip Json.(option bool) "null" ~value:None ~__POS__;
246
245
()
247
246
248
247
let test_ints =
249
-
Test.test "Jsont.{int…,uint…}" @@ fun () ->
248
+
Test.test "Json.{int…,uint…}" @@ fun () ->
250
249
(* uint8 *)
251
-
decode_error Jsont.uint8 "null" ~__POS__;
252
-
decode_error Jsont.uint8 "true" ~__POS__;
253
-
decode_error Jsont.uint8 "-1" ~__POS__;
254
-
decode_error Jsont.uint8 "256" ~__POS__;
255
-
trip Jsont.uint8 "0" ~value:0 ~__POS__;
256
-
trip Jsont.uint8 "255" ~value:255 ~__POS__;
250
+
decode_error Json.uint8 "null" ~__POS__;
251
+
decode_error Json.uint8 "true" ~__POS__;
252
+
decode_error Json.uint8 "-1" ~__POS__;
253
+
decode_error Json.uint8 "256" ~__POS__;
254
+
trip Json.uint8 "0" ~value:0 ~__POS__;
255
+
trip Json.uint8 "255" ~value:255 ~__POS__;
257
256
(* uint16 *)
258
-
decode_error Jsont.uint16 "null" ~__POS__;
259
-
decode_error Jsont.uint16 "true" ~__POS__;
260
-
decode_error Jsont.uint16 "-1" ~__POS__;
261
-
decode_error Jsont.uint16 "65536" ~__POS__;
262
-
trip Jsont.uint16 "0" ~value:0 ~__POS__;
263
-
trip Jsont.uint16 "65535" ~value:65535 ~__POS__;
257
+
decode_error Json.uint16 "null" ~__POS__;
258
+
decode_error Json.uint16 "true" ~__POS__;
259
+
decode_error Json.uint16 "-1" ~__POS__;
260
+
decode_error Json.uint16 "65536" ~__POS__;
261
+
trip Json.uint16 "0" ~value:0 ~__POS__;
262
+
trip Json.uint16 "65535" ~value:65535 ~__POS__;
264
263
(* int8 *)
265
-
decode_error Jsont.int8 "null" ~__POS__;
266
-
decode_error Jsont.int8 "true" ~__POS__;
267
-
decode_error Jsont.int8 "-129" ~__POS__;
268
-
decode_error Jsont.int8 "128" ~__POS__;
269
-
trip Jsont.int8 "-128" ~value:(-128) ~__POS__;
270
-
trip Jsont.int8 "127" ~value:127 ~__POS__;
264
+
decode_error Json.int8 "null" ~__POS__;
265
+
decode_error Json.int8 "true" ~__POS__;
266
+
decode_error Json.int8 "-129" ~__POS__;
267
+
decode_error Json.int8 "128" ~__POS__;
268
+
trip Json.int8 "-128" ~value:(-128) ~__POS__;
269
+
trip Json.int8 "127" ~value:127 ~__POS__;
271
270
(* int32 *)
272
-
decode_error Jsont.int32 "null" ~__POS__;
273
-
decode_error Jsont.int32 "true" ~__POS__;
274
-
decode_error Jsont.int32 "-2147483649" ~__POS__;
275
-
decode_error Jsont.int32 "2147483648" ~__POS__;
276
-
trip Jsont.int32 "-2147483648" ~value:Int32.min_int ~__POS__;
277
-
trip Jsont.int32 "2147483647" ~value:Int32.max_int ~__POS__;
271
+
decode_error Json.int32 "null" ~__POS__;
272
+
decode_error Json.int32 "true" ~__POS__;
273
+
decode_error Json.int32 "-2147483649" ~__POS__;
274
+
decode_error Json.int32 "2147483648" ~__POS__;
275
+
trip Json.int32 "-2147483648" ~value:Int32.min_int ~__POS__;
276
+
trip Json.int32 "2147483647" ~value:Int32.max_int ~__POS__;
278
277
(* int64 *)
279
278
let max_exact = Int64.shift_left 1L 53 in
280
279
let max_exact_next = Int64.(add max_exact 1L) in
281
280
let min_exact = Int64.shift_left 1L 53 in
282
281
let min_exact_prev = Int64.(add max_exact 1L) in
283
-
decode_error Jsont.int64 "null" ~__POS__;
284
-
decode_error Jsont.int64 "true" ~__POS__;
285
-
trip Jsont.int64 (Fmt.str "%Ld" max_exact) ~value:max_exact ~__POS__;
286
-
trip Jsont.int64 (Fmt.str "%Ld" min_exact) ~value:min_exact ~__POS__;
287
-
trip Jsont.int64
282
+
decode_error Json.int64 "null" ~__POS__;
283
+
decode_error Json.int64 "true" ~__POS__;
284
+
trip Json.int64 (Fmt.str "%Ld" max_exact) ~value:max_exact ~__POS__;
285
+
trip Json.int64 (Fmt.str "%Ld" min_exact) ~value:min_exact ~__POS__;
286
+
trip Json.int64
288
287
(Fmt.str {|"%Ld"|} max_exact_next)
289
288
~value:max_exact_next ~__POS__;
290
-
trip Jsont.int64
289
+
trip Json.int64
291
290
(Fmt.str {|"%Ld"|} min_exact_prev)
292
291
~value:min_exact_prev ~__POS__;
293
292
(* int_as_string *)
294
-
trip Jsont.int_as_string {|"2"|} ~value:2 ~__POS__;
295
-
trip Jsont.int_as_string
293
+
trip Json.int_as_string {|"2"|} ~value:2 ~__POS__;
294
+
trip Json.int_as_string
296
295
(Fmt.str {|"%d"|} Int.max_int)
297
296
~value:Int.max_int ~__POS__;
298
-
trip Jsont.int_as_string
297
+
trip Json.int_as_string
299
298
(Fmt.str {|"%d"|} Int.min_int)
300
299
~value:Int.min_int ~__POS__;
301
300
(* int64_as_string *)
302
-
trip Jsont.int64_as_string
301
+
trip Json.int64_as_string
303
302
(Fmt.str {|"%Ld"|} Int64.max_int)
304
303
~value:Int64.max_int ~__POS__;
305
-
trip Jsont.int64_as_string
304
+
trip Json.int64_as_string
306
305
(Fmt.str {|"%Ld"|} Int64.min_int)
307
306
~value:Int64.min_int ~__POS__;
308
307
()
309
308
310
309
let test_floats =
311
-
Test.test "Jsont.{any_float,float_as_hex_string}" @@ fun () ->
310
+
Test.test "Json.{any_float,float_as_hex_string}" @@ fun () ->
312
311
(* any_float *)
313
312
let jsonstr f = Fmt.str {|"%s"|} (Float.to_string f) in
314
313
let eq = Test.T.float in
315
-
decode_ok ~eq Jsont.any_float "null" ~value:Float.nan ~__POS__;
316
-
trip ~eq Jsont.any_float " -0 " ~value:(-0.) ~__POS__;
317
-
trip ~eq Jsont.any_float " 0 " ~value:0. ~__POS__;
318
-
trip ~eq Jsont.any_float " 0.5 " ~value:0.5 ~__POS__;
319
-
decode_ok ~eq Jsont.any_float (jsonstr 0.5) ~value:0.5 ~__POS__;
320
-
trip ~eq Jsont.any_float (jsonstr Float.nan) ~value:Float.nan ~__POS__;
321
-
trip ~eq Jsont.any_float (jsonstr Float.infinity) ~value:Float.infinity
314
+
decode_ok ~eq Json.any_float "null" ~value:Float.nan ~__POS__;
315
+
trip ~eq Json.any_float " -0 " ~value:(-0.) ~__POS__;
316
+
trip ~eq Json.any_float " 0 " ~value:0. ~__POS__;
317
+
trip ~eq Json.any_float " 0.5 " ~value:0.5 ~__POS__;
318
+
decode_ok ~eq Json.any_float (jsonstr 0.5) ~value:0.5 ~__POS__;
319
+
trip ~eq Json.any_float (jsonstr Float.nan) ~value:Float.nan ~__POS__;
320
+
trip ~eq Json.any_float (jsonstr Float.infinity) ~value:Float.infinity
322
321
~__POS__;
323
-
trip ~eq Jsont.any_float
322
+
trip ~eq Json.any_float
324
323
(jsonstr Float.neg_infinity)
325
324
~value:Float.neg_infinity ~__POS__;
326
325
327
326
(* float_as_hex_string *)
328
327
let jsonstr f = Fmt.str {|"%h"|} f in
329
-
let t = Jsont.float_as_hex_string in
328
+
let t = Json.float_as_hex_string in
330
329
decode_error t "null" ~__POS__;
331
330
decode_error t "1.0" ~__POS__;
332
331
trip ~eq t (jsonstr 0.5) ~value:0.5 ~__POS__;
···
336
335
()
337
336
338
337
let test_enum_and_binary_string =
339
-
Test.test "Jsont.{of_of_string,enum,binary_string}" @@ fun () ->
338
+
Test.test "Json.{of_of_string,enum,binary_string}" @@ fun () ->
340
339
(* of_string *)
341
340
let int_of_string s =
342
341
match int_of_string_opt s with
343
342
| None -> Error "Not an integer"
344
343
| Some i -> Ok i
345
344
in
346
-
let t = Jsont.of_of_string ~kind:"int" int_of_string ~enc:Int.to_string in
345
+
let t = Json.of_of_string ~kind:"int" int_of_string ~enc:Int.to_string in
347
346
trip ~eq:Test.T.int t {|"1"|} ~value:1 ~__POS__;
348
347
decode_error t {|"bla"|} ~__POS__;
349
348
(* enum *)
350
-
let enum = Jsont.enum ~kind:"heyho" [ ("hey", `Hey); ("ho", `Ho) ] in
349
+
let enum = Json.enum ~kind:"heyho" [ ("hey", `Hey); ("ho", `Ho) ] in
351
350
decode_error enum {|null|} ~__POS__;
352
351
decode_error enum {|"ha"|} ~__POS__;
353
352
decode_error enum {|"farfarfar"|} ~__POS__;
354
353
trip enum {|"hey"|} ~value:`Hey ~__POS__;
355
354
trip enum {|"ho"|} ~value:`Ho ~__POS__;
356
355
(* binary_string *)
357
-
decode_error Jsont.binary_string {|null|};
358
-
decode_error Jsont.binary_string {|"00gabb"|} ~__POS__;
359
-
decode_error Jsont.binary_string {|"00aab"|} ~__POS__;
360
-
trip Jsont.binary_string {|"00a1bb"|} ~__POS__;
361
-
trip Jsont.binary_string {|"00a1ff"|} ~value:"\x00\xa1\xff" ~__POS__;
356
+
decode_error Json.binary_string {|null|};
357
+
decode_error Json.binary_string {|"00gabb"|} ~__POS__;
358
+
decode_error Json.binary_string {|"00aab"|} ~__POS__;
359
+
trip Json.binary_string {|"00a1bb"|} ~__POS__;
360
+
trip Json.binary_string {|"00a1ff"|} ~value:"\x00\xa1\xff" ~__POS__;
362
361
()
363
362
364
363
let test_arrays =
365
-
Test.test "Jsont.{list,array,bigarray,t2,t3,t4,tn}" @@ fun () ->
364
+
Test.test "Json.{list,array,bigarray,t2,t3,t4,tn}" @@ fun () ->
366
365
let barr arr = Bigarray.Array1.of_array Int C_layout arr in
367
-
trip ~eq ~format:Layout Jsont.json " [] \n" ~__POS__;
368
-
trip ~eq ~format:Layout Jsont.json " [1, 3] \n\n" ~__POS__;
369
-
trip ~eq ~format:Layout Jsont.json " [1\n,3] \n\n" ~__POS__;
370
-
trip ~eq ~format:Layout Jsont.json " [1\n, \"a\",\n3 ] \n\n" ~__POS__;
371
-
trip ~eq ~format:Indent Jsont.json "[]" ~__POS__;
372
-
trip ~eq ~format:Indent Jsont.json "[\n 1\n]" ~__POS__;
373
-
trip ~eq ~format:Indent Jsont.json "[\n 1,\n \"bla\",\n 2\n]" ~__POS__;
374
-
decode_error Jsont.json "[1 ~__POS__;3]" ~__POS__;
375
-
decode_error Jsont.json " [1,3 " ~__POS__;
376
-
decode_error Jsont.(list number) "[1,true,3]" ~__POS__;
377
-
trip Jsont.(list int) " [ ] \n" ~value:[] ~__POS__;
378
-
trip Jsont.(list int) "[1,2,3]" ~value:[ 1; 2; 3 ] ~__POS__;
379
-
trip Jsont.(array int) " [ ] \n" ~value:[||] ~__POS__;
380
-
trip Jsont.(array int) "[1,2,3]" ~value:[| 1; 2; 3 |] ~__POS__;
381
-
trip Jsont.(bigarray Int int) " [ ] \n" ~value:(barr [||]) ~__POS__;
366
+
trip ~eq ~format:Layout Json.json " [] \n" ~__POS__;
367
+
trip ~eq ~format:Layout Json.json " [1, 3] \n\n" ~__POS__;
368
+
trip ~eq ~format:Layout Json.json " [1\n,3] \n\n" ~__POS__;
369
+
trip ~eq ~format:Layout Json.json " [1\n, \"a\",\n3 ] \n\n" ~__POS__;
370
+
trip ~eq ~format:Indent Json.json "[]" ~__POS__;
371
+
trip ~eq ~format:Indent Json.json "[\n 1\n]" ~__POS__;
372
+
trip ~eq ~format:Indent Json.json "[\n 1,\n \"bla\",\n 2\n]" ~__POS__;
373
+
decode_error Json.json "[1 ~__POS__;3]" ~__POS__;
374
+
decode_error Json.json " [1,3 " ~__POS__;
375
+
decode_error Json.(list number) "[1,true,3]" ~__POS__;
376
+
trip Json.(list int) " [ ] \n" ~value:[] ~__POS__;
377
+
trip Json.(list int) "[1,2,3]" ~value:[ 1; 2; 3 ] ~__POS__;
378
+
trip Json.(array int) " [ ] \n" ~value:[||] ~__POS__;
379
+
trip Json.(array int) "[1,2,3]" ~value:[| 1; 2; 3 |] ~__POS__;
380
+
trip Json.(bigarray Int int) " [ ] \n" ~value:(barr [||]) ~__POS__;
382
381
trip
383
-
Jsont.(bigarray Int int)
382
+
Json.(bigarray Int int)
384
383
" [1,2,3] \n"
385
384
~value:(barr [| 1; 2; 3 |])
386
385
~__POS__;
387
386
let enc = Array.get in
388
-
let t2_int = Jsont.t2 ~dec:(fun x y -> [| x; y |]) ~enc Jsont.int in
387
+
let t2_int = Json.t2 ~dec:(fun x y -> [| x; y |]) ~enc Json.int in
389
388
decode_error t2_int "[]" ~__POS__;
390
389
decode_error t2_int "[1]" ~__POS__;
391
390
trip t2_int "[1,2]" ~value:[| 1; 2 |] ~__POS__;
392
391
decode_error t2_int "[1,2,3]" ~__POS__;
393
-
let t3_int = Jsont.t3 ~dec:(fun x y z -> [| x; y; z |]) ~enc Jsont.int in
392
+
let t3_int = Json.t3 ~dec:(fun x y z -> [| x; y; z |]) ~enc Json.int in
394
393
decode_error t3_int "[]" ~__POS__;
395
394
decode_error t3_int "[1]" ~__POS__;
396
395
decode_error t3_int "[1,2]" ~__POS__;
397
396
trip t3_int "[1,2,3]" ~value:[| 1; 2; 3 |] ~__POS__;
398
397
decode_error t3_int "[1,2,3,4]" ~__POS__;
399
-
let t4_int = Jsont.t4 ~dec:(fun x y z w -> [| x; y; z; w |]) ~enc Jsont.int in
398
+
let t4_int = Json.t4 ~dec:(fun x y z w -> [| x; y; z; w |]) ~enc Json.int in
400
399
decode_error t4_int "[]" ~__POS__;
401
400
decode_error t4_int "[1]" ~__POS__;
402
401
decode_error t4_int "[1,2]" ~__POS__;
403
402
decode_error t4_int "[1,2,3]" ~__POS__;
404
403
trip t4_int "[1,2,3,4]" ~value:[| 1; 2; 3; 4 |] ~__POS__;
405
404
decode_error t4_int "[1,2,3,4,5]" ~__POS__;
406
-
let t0_int = Jsont.(tn ~n:0 int) in
407
-
let t2_int = Jsont.(tn ~n:2 int) in
405
+
let t0_int = Json.(tn ~n:0 int) in
406
+
let t2_int = Json.(tn ~n:2 int) in
408
407
trip t0_int "[]" ~value:[||] ~__POS__;
409
408
decode_error t0_int "[1]" ~__POS__;
410
409
decode_error t0_int "[1;2]" ~__POS__;
···
415
414
()
416
415
417
416
let test_objects =
418
-
Test.test "Jsont.Object.map" @@ fun () ->
419
-
trip ~eq ~format:Layout Jsont.json " {} \n" ~__POS__;
420
-
trip ~eq ~format:Layout Jsont.json {| {"a": 1} |} ~__POS__;
421
-
trip ~eq ~format:Layout Jsont.json {| {"a": 1, "b":2} |} ~__POS__;
422
-
trip ~eq ~format:Indent Jsont.json "{}" ~__POS__;
423
-
trip ~eq ~format:Indent Jsont.json "{\n \"bla\": 1\n}";
417
+
Test.test "Json.Object.map" @@ fun () ->
418
+
trip ~eq ~format:Layout Json.json " {} \n" ~__POS__;
419
+
trip ~eq ~format:Layout Json.json {| {"a": 1} |} ~__POS__;
420
+
trip ~eq ~format:Layout Json.json {| {"a": 1, "b":2} |} ~__POS__;
421
+
trip ~eq ~format:Indent Json.json "{}" ~__POS__;
422
+
trip ~eq ~format:Indent Json.json "{\n \"bla\": 1\n}";
424
423
trip ~format:Indent Item.jsont Item_data.i0_json ~value:Item_data.i0 ~__POS__;
425
424
trip ~format:Indent Item.jsont Item_data.i1_json ~value:Item_data.i1 ~__POS__;
426
425
()
427
426
428
427
let test_unknown_mems =
429
-
Test.test "Jsont.Object.*_unknown" @@ fun () ->
428
+
Test.test "Json.Object.*_unknown" @@ fun () ->
430
429
(* Skip unknowns *)
431
430
trip Unknown.skip_jsont Unknown_data.u0 ~__POS__;
432
431
trip ~lossy:true Unknown.skip_jsont Unknown_data.u1 ~__POS__;
···
442
441
()
443
442
444
443
let test_cases =
445
-
Test.test "Jsont.Object.Case" @@ fun () ->
444
+
Test.test "Json.Object.Case" @@ fun () ->
446
445
decode_error Cases.Person_top.jsont Cases_data.invalid_miss ~__POS__;
447
446
decode_error Cases.Person_top.jsont Cases_data.invalid_case ~__POS__;
448
447
decode_error Cases.Person_field.jsont Cases_data.invalid_miss ~__POS__;
···
485
484
()
486
485
487
486
let test_rec =
488
-
Test.test "Jsont.rec" @@ fun () ->
489
-
let tree_null = Tree.jsont_with_null Jsont.int in
487
+
Test.test "Json.rec" @@ fun () ->
488
+
let tree_null = Tree.jsont_with_null Json.int in
490
489
trip tree_null Tree_data.empty_null ~value:Tree_data.empty ~__POS__;
491
490
trip tree_null Tree_data.tree0_null ~value:Tree_data.tree0 ~__POS__;
492
-
let tree_cases = Tree.jsont_with_cases Jsont.int in
491
+
let tree_cases = Tree.jsont_with_cases Json.int in
493
492
trip tree_cases Tree_data.empty_cases ~value:Tree_data.empty ~__POS__;
494
493
trip tree_cases Tree_data.tree0_cases ~value:Tree_data.tree0 ~__POS__;
495
494
()
496
495
497
496
let test_zero =
498
-
Test.test "Jsont.zero" @@ fun () ->
497
+
Test.test "Json.zero" @@ fun () ->
499
498
let decode_ok = decode_ok ~eq:Test.T.unit in
500
-
decode_ok Jsont.zero "null" ~value:() ~__POS__;
501
-
decode_ok Jsont.zero "2" ~value:() ~__POS__;
502
-
decode_ok Jsont.zero {|"a"|} ~value:() ~__POS__;
503
-
decode_ok Jsont.zero {|[1]|} ~value:() ~__POS__;
504
-
decode_ok Jsont.zero {|{"bli":"bla"}|} ~value:() ~__POS__;
505
-
encode_ok Jsont.zero ~value:() "null" ~__POS__;
499
+
decode_ok Json.zero "null" ~value:() ~__POS__;
500
+
decode_ok Json.zero "2" ~value:() ~__POS__;
501
+
decode_ok Json.zero {|"a"|} ~value:() ~__POS__;
502
+
decode_ok Json.zero {|[1]|} ~value:() ~__POS__;
503
+
decode_ok Json.zero {|{"bli":"bla"}|} ~value:() ~__POS__;
504
+
encode_ok Json.zero ~value:() "null" ~__POS__;
506
505
()
507
506
508
507
let test_const =
509
-
Test.test "Jsont.const" @@ fun () ->
510
-
trip ~lossy:true Jsont.(const int 4) " {} " ~value:4 ~__POS__;
511
-
trip ~lossy:true Jsont.(const bool true) ~value:true "false" ~__POS__;
508
+
Test.test "Json.const" @@ fun () ->
509
+
trip ~lossy:true Json.(const int 4) " {} " ~value:4 ~__POS__;
510
+
trip ~lossy:true Json.(const bool true) ~value:true "false" ~__POS__;
512
511
()
513
512
514
-
let recode_int_to_string = Jsont.(recode ~dec:int string_of_int ~enc:string)
513
+
let recode_int_to_string = Json.(recode ~dec:int string_of_int ~enc:string)
515
514
516
515
let test_array_queries =
517
516
let a = "[1,[ 1, 2], 3] " in
518
-
Test.test "Jsont.{nth,*_nth,filter_map_array,fold_array}" @@ fun () ->
519
-
(* Jsont.nth *)
520
-
decode_ok Jsont.(nth 0 @@ int) a ~value:1 ~__POS__;
521
-
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
522
-
decode_ok Jsont.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
523
-
decode_error Jsont.(nth 3 @@ int) a ~__POS__;
524
-
decode_ok Jsont.(nth ~absent:3 3 @@ int) ~value:3 a ~__POS__;
525
-
decode_ok Jsont.(nth 0 @@ int) ~value:1 a ~__POS__;
526
-
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
527
-
decode_ok Jsont.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
528
-
(* Jsont.{set,update}_nth} *)
529
-
update ~format:Jsont.Layout
530
-
Jsont.(update_nth 1 @@ update_nth 1 Jsont.(const int 4))
517
+
Test.test "Json.{nth,*_nth,filter_map_array,fold_array}" @@ fun () ->
518
+
(* Json.nth *)
519
+
decode_ok Json.(nth 0 @@ int) a ~value:1 ~__POS__;
520
+
decode_ok Json.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
521
+
decode_ok Json.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
522
+
decode_error Json.(nth 3 @@ int) a ~__POS__;
523
+
decode_ok Json.(nth ~absent:3 3 @@ int) ~value:3 a ~__POS__;
524
+
decode_ok Json.(nth 0 @@ int) ~value:1 a ~__POS__;
525
+
decode_ok Json.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
526
+
decode_ok Json.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
527
+
(* Json.{set,update}_nth} *)
528
+
update ~format:Json.Layout
529
+
Json.(update_nth 1 @@ update_nth 1 Json.(const int 4))
531
530
a "[1,[ 1, 4], 3] " ~__POS__;
532
-
update ~format:Jsont.Layout
533
-
Jsont.(update_nth 1 @@ set_nth int 0 2)
531
+
update ~format:Json.Layout
532
+
Json.(update_nth 1 @@ set_nth int 0 2)
534
533
a "[1,[ 2, 2], 3] " ~__POS__;
535
-
decode_error Jsont.(update_nth 1 @@ set_nth int 2 3) a;
536
-
decode_error Jsont.(update_nth 3 int) a;
537
-
update ~format:Jsont.Layout
538
-
Jsont.(update_nth 3 ~absent:5 int)
534
+
decode_error Json.(update_nth 1 @@ set_nth int 2 3) a;
535
+
decode_error Json.(update_nth 3 int) a;
536
+
update ~format:Json.Layout
537
+
Json.(update_nth 3 ~absent:5 int)
539
538
a "[1,[ 1, 2], 3,5] ";
540
-
update ~format:Jsont.Layout
541
-
Jsont.(update_nth 1 @@ set_nth ~allow_absent:true int 3 3)
539
+
update ~format:Json.Layout
540
+
Json.(update_nth 1 @@ set_nth ~allow_absent:true int 3 3)
542
541
a "[1,[ 1, 2,0,3], 3] " ~__POS__;
543
-
update ~format:Jsont.Layout
544
-
Jsont.(
542
+
update ~format:Json.Layout
543
+
Json.(
545
544
update_nth 1
546
-
@@ set_nth ~stub:(Jsont.Json.null ()) ~allow_absent:true int 3 3)
545
+
@@ set_nth ~stub:(Json.Value.null ()) ~allow_absent:true int 3 3)
547
546
a "[1,[ 1, 2,null,3], 3] " ~__POS__;
548
-
update ~format:Jsont.Layout
549
-
Jsont.(update_nth 1 @@ update_nth 1 recode_int_to_string)
547
+
update ~format:Json.Layout
548
+
Json.(update_nth 1 @@ update_nth 1 recode_int_to_string)
550
549
a "[1,[ 1, \"2\"], 3] " ~__POS__;
551
-
update Jsont.(update_nth 1 @@ delete_nth 0) a "[1,[2],3]" ~__POS__;
550
+
update Json.(update_nth 1 @@ delete_nth 0) a "[1,[2],3]" ~__POS__;
552
551
decode_ok
553
-
Jsont.(nth 1 @@ fold_array int (fun i v acc -> (i, v) :: acc) [])
552
+
Json.(nth 1 @@ fold_array int (fun i v acc -> (i, v) :: acc) [])
554
553
a
555
554
~value:[ (1, 2); (0, 1) ]
556
555
~__POS__;
557
556
update
558
-
Jsont.(
557
+
Json.(
559
558
update_nth 1
560
559
@@ filter_map_array int int (fun _ v ->
561
560
if v mod 2 = 0 then None else Some (v - 1)))
562
561
a "[1,[0],3]" ~__POS__;
563
-
(* Jsont.delete_nth *)
564
-
update ~format:Jsont.Layout Jsont.(delete_nth 1) a "[1, 3] " ~__POS__;
565
-
decode_error Jsont.(delete_nth 3) a ~__POS__;
566
-
update ~format:Jsont.Layout
567
-
Jsont.(delete_nth ~allow_absent:true 3)
568
-
a a ~__POS__;
569
-
(* Jsont.filter_map_array *)
570
-
update ~format:Jsont.Layout
571
-
Jsont.(
572
-
filter_map_array Jsont.json Jsont.json (fun i v ->
562
+
(* Json.delete_nth *)
563
+
update ~format:Json.Layout Json.(delete_nth 1) a "[1, 3] " ~__POS__;
564
+
decode_error Json.(delete_nth 3) a ~__POS__;
565
+
update ~format:Json.Layout Json.(delete_nth ~allow_absent:true 3) a a ~__POS__;
566
+
(* Json.filter_map_array *)
567
+
update ~format:Json.Layout
568
+
Json.(
569
+
filter_map_array Json.json Json.json (fun i v ->
573
570
if i = 1 then None else Some v))
574
571
a "[1, 3] " ~__POS__;
575
-
(* Jsont.fold_array *)
572
+
(* Json.fold_array *)
576
573
decode_ok
577
-
Jsont.(nth 1 @@ fold_array int (fun i v acc -> i + v + acc) 0)
574
+
Json.(nth 1 @@ fold_array int (fun i v acc -> i + v + acc) 0)
578
575
a ~value:4 ~__POS__;
579
576
()
580
577
581
578
let test_object_queries =
582
-
Test.test "Jsont.{mem,*_mem,fold_object,filter_map_object}" @@ fun () ->
579
+
Test.test "Json.{mem,*_mem,fold_object,filter_map_object}" @@ fun () ->
583
580
let o = {| { "a" : { "b" : 1 }, "c": 2 } |} in
584
-
(* Jsont.mem *)
585
-
decode_ok Jsont.(mem "a" @@ mem "b" int) o ~value:1 ~__POS__;
586
-
decode_error Jsont.(mem "a" @@ mem "c" int) o ~__POS__;
587
-
decode_ok Jsont.(mem "a" @@ mem ~absent:3 "c" int) o ~value:3 ~__POS__;
588
-
(* Jsont.{update,set}_mem *)
589
-
update ~format:Jsont.Layout
590
-
Jsont.(update_mem "a" @@ update_mem "b" (const int 3))
581
+
(* Json.mem *)
582
+
decode_ok Json.(mem "a" @@ mem "b" int) o ~value:1 ~__POS__;
583
+
decode_error Json.(mem "a" @@ mem "c" int) o ~__POS__;
584
+
decode_ok Json.(mem "a" @@ mem ~absent:3 "c" int) o ~value:3 ~__POS__;
585
+
(* Json.{update,set}_mem *)
586
+
update ~format:Json.Layout
587
+
Json.(update_mem "a" @@ update_mem "b" (const int 3))
591
588
o {| { "a" : { "b" : 3 }, "c": 2 } |} ~__POS__;
592
-
update ~format:Jsont.Layout
593
-
Jsont.(update_mem "a" @@ update_mem "b" recode_int_to_string)
589
+
update ~format:Json.Layout
590
+
Json.(update_mem "a" @@ update_mem "b" recode_int_to_string)
594
591
o {| { "a" : { "b" : "1" }, "c": 2 } |} ~__POS__;
595
-
decode_error Jsont.(update_mem "a" @@ update_mem "c" (const int 4)) o ~__POS__;
596
-
update ~format:Jsont.Layout
597
-
Jsont.(update_mem "a" @@ update_mem "c" ~absent:4 (const int 5))
592
+
decode_error Json.(update_mem "a" @@ update_mem "c" (const int 4)) o ~__POS__;
593
+
update ~format:Json.Layout
594
+
Json.(update_mem "a" @@ update_mem "c" ~absent:4 (const int 5))
598
595
o {| { "a" : { "b" : 1 ,"c":5}, "c": 2 } |} ~__POS__;
599
-
update ~format:Jsont.Layout
600
-
Jsont.(set_mem int "a" 2)
596
+
update ~format:Json.Layout
597
+
Json.(set_mem int "a" 2)
601
598
o {| { "a" : 2, "c": 2 } |} ~__POS__;
602
-
decode_error Jsont.(set_mem int "d" 2) o ~__POS__;
603
-
update ~format:Jsont.Layout
604
-
Jsont.(set_mem ~allow_absent:true int "d" 3)
599
+
decode_error Json.(set_mem int "d" 2) o ~__POS__;
600
+
update ~format:Json.Layout
601
+
Json.(set_mem ~allow_absent:true int "d" 3)
605
602
o {| { "a" : { "b" : 1 }, "c": 2 ,"d":3} |} ~__POS__;
606
-
(* Jsont.delete_mem *)
607
-
decode_error Jsont.(update_mem "a" @@ delete_mem "c") o ~__POS__;
608
-
update ~format:Jsont.Layout
609
-
Jsont.(update_mem "a" @@ delete_mem ~allow_absent:true "c")
603
+
(* Json.delete_mem *)
604
+
decode_error Json.(update_mem "a" @@ delete_mem "c") o ~__POS__;
605
+
update ~format:Json.Layout
606
+
Json.(update_mem "a" @@ delete_mem ~allow_absent:true "c")
610
607
o o ~__POS__;
611
-
update ~format:Jsont.Layout
612
-
Jsont.(update_mem "a" @@ delete_mem "b")
608
+
update ~format:Json.Layout
609
+
Json.(update_mem "a" @@ delete_mem "b")
613
610
o {| { "a" : {}, "c": 2 } |} ~__POS__;
614
-
update ~format:Jsont.Layout Jsont.(delete_mem "a") o {| { "c": 2 } |} ~__POS__;
615
-
(* Jsont.filter_map_object *)
616
-
update ~format:Jsont.Layout
617
-
Jsont.(
618
-
filter_map_object Jsont.json Jsont.json (fun m n v ->
611
+
update ~format:Json.Layout Json.(delete_mem "a") o {| { "c": 2 } |} ~__POS__;
612
+
(* Json.filter_map_object *)
613
+
update ~format:Json.Layout
614
+
Json.(
615
+
filter_map_object Json.json Json.json (fun m n v ->
619
616
if n = "a" then None else Some ((n, m), v)))
620
617
o {| { "c": 2 } |} ~__POS__;
621
-
(* Jsont.fold *)
618
+
(* Json.fold *)
622
619
decode_ok
623
-
Jsont.(mem "a" @@ fold_object int (fun _ n i acc -> i + acc) 2)
620
+
Json.(mem "a" @@ fold_object int (fun _ n i acc -> i + acc) 2)
624
621
o ~value:3 ~__POS__;
625
622
()
626
623
627
624
let test_path_queries =
628
-
Test.test "Jsont.{path,*_path}" @@ fun () ->
625
+
Test.test "Json.{path,*_path}" @@ fun () ->
629
626
let v = {| [ 0, { "a": 1}, 2 ] |} in
630
-
(* Jsont.path *)
631
-
decode_error Jsont.(path Path.root int) v ~__POS__;
632
-
update ~format:Jsont.Layout Jsont.(path Path.root Jsont.json) v v ~__POS__;
633
-
decode_ok Jsont.(path Path.(root |> nth 1 |> mem "a") int) v ~value:1;
627
+
(* Json.path *)
628
+
decode_error Json.(path Path.root int) v ~__POS__;
629
+
update ~format:Json.Layout Json.(path Path.root Json.t) v v ~__POS__;
630
+
decode_ok Json.(path Path.(root |> nth 1 |> mem "a") int) v ~value:1;
634
631
decode_ok
635
-
Jsont.(path Path.(root |> nth 1 |> mem "b") ~absent:2 int)
632
+
Json.(path Path.(root |> nth 1 |> mem "b") ~absent:2 int)
636
633
v ~value:2 ~__POS__;
637
-
(* Jsont.{set,update}_path} *)
638
-
update ~format:Jsont.Layout Jsont.(set_path int Path.root 2) v {|2|} ~__POS__;
639
-
update ~format:Jsont.Layout
640
-
Jsont.(set_path string Path.(root |> nth 1 |> mem "a") "hey")
634
+
(* Json.{set,update}_path} *)
635
+
update ~format:Json.Layout Json.(set_path int Path.root 2) v {|2|} ~__POS__;
636
+
update ~format:Json.Layout
637
+
Json.(set_path string Path.(root |> nth 1 |> mem "a") "hey")
641
638
v {| [ 0, { "a": "hey"}, 2 ] |} ~__POS__;
642
-
update ~format:Jsont.Layout
643
-
Jsont.(
639
+
update ~format:Json.Layout
640
+
Json.(
644
641
set_path ~allow_absent:true string Path.(root |> nth 1 |> mem "b") "hey")
645
642
v {| [ 0, { "a": 1,"b":"hey"}, 2 ] |} ~__POS__;
646
-
update ~format:Jsont.Layout
647
-
Jsont.(
643
+
update ~format:Json.Layout
644
+
Json.(
648
645
update_path
649
646
Path.(root |> nth 1 |> mem "a")
650
647
(map int ~dec:succ ~enc:Fun.id))
651
648
v {| [ 0, { "a": 2}, 2 ] |} ~__POS__;
652
-
(* Jsont.delete_path *)
653
-
update ~format:Jsont.Layout
654
-
Jsont.(delete_path Path.(root |> nth 1 |> mem "a"))
649
+
(* Json.delete_path *)
650
+
update ~format:Json.Layout
651
+
Json.(delete_path Path.(root |> nth 1 |> mem "a"))
655
652
v {| [ 0, {}, 2 ] |} ~__POS__;
656
-
update ~format:Jsont.Layout
657
-
Jsont.(delete_path Path.(root |> nth 1))
653
+
update ~format:Json.Layout
654
+
Json.(delete_path Path.(root |> nth 1))
658
655
v {| [ 0, 2 ] |} ~__POS__;
659
-
update ~format:Jsont.Layout Jsont.(delete_path Path.root) v {|null|} ~__POS__;
660
-
decode_error Jsont.(delete_path Path.(root |> nth 1 |> mem "b")) v ~__POS__;
661
-
update ~format:Jsont.Layout
662
-
Jsont.(delete_path ~allow_absent:true Path.(root |> nth 1 |> mem "b"))
656
+
update ~format:Json.Layout Json.(delete_path Path.root) v {|null|} ~__POS__;
657
+
decode_error Json.(delete_path Path.(root |> nth 1 |> mem "b")) v ~__POS__;
658
+
update ~format:Json.Layout
659
+
Json.(delete_path ~allow_absent:true Path.(root |> nth 1 |> mem "b"))
663
660
v v ~__POS__;
664
661
()
665
662
+97
-97
test/codecs/test_common_samples.ml
+97
-97
test/codecs/test_common_samples.ml
···
11
11
type t = Todo | Done | Cancelled
12
12
13
13
let assoc = [ ("todo", Todo); ("done", Done); ("cancelled", Cancelled) ]
14
-
let jsont = Jsont.enum ~kind:"Status" assoc
14
+
let jsont = Json.enum ~kind:"Status" assoc
15
15
end
16
16
17
17
module Item = struct
···
23
23
let tags i = i.tags
24
24
25
25
let jsont =
26
-
Jsont.Object.map ~kind:"Item" make
27
-
|> Jsont.Object.mem "task" Jsont.string ~enc:task
28
-
|> Jsont.Object.mem "status" Status.jsont ~enc:status
29
-
|> Jsont.Object.mem "tags"
30
-
Jsont.(list string)
26
+
Json.Object.map ~kind:"Item" make
27
+
|> Json.Object.mem "task" Json.string ~enc:task
28
+
|> Json.Object.mem "status" Status.jsont ~enc:status
29
+
|> Json.Object.mem "tags"
30
+
Json.(list string)
31
31
~dec_absent:[] ~enc:tags ~enc_omit:(( = ) [])
32
-
|> Jsont.Object.finish
32
+
|> Json.Object.finish
33
33
end
34
34
35
35
module Item_data = struct
36
36
let i0 = Item.{ task = "Hey"; status = Todo; tags = [ "huhu"; "haha" ] }
37
37
38
38
let i0_json =
39
-
(* in Jsont.Indent format *)
39
+
(* in Json.Indent format *)
40
40
"{\n\
41
41
\ \"task\": \"Hey\",\n\
42
42
\ \"status\": \"todo\",\n\
···
49
49
let i1 = Item.{ task = "Ho"; status = Done; tags = [] }
50
50
51
51
let i1_json =
52
-
(* in Jsont.Indent format *)
52
+
(* in Json.Indent format *)
53
53
"{\n \"task\": \"Ho\",\n \"status\": \"done\"\n}"
54
54
end
55
55
···
62
62
let m v = v.m
63
63
64
64
let skip_jsont =
65
-
Jsont.Object.map ~kind:"unknown-skip" make
66
-
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
67
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
65
+
Json.Object.map ~kind:"unknown-skip" make
66
+
|> Json.Object.mem "m" Json.bool ~enc:m
67
+
|> Json.Object.skip_unknown |> Json.Object.finish
68
68
69
69
let error_jsont =
70
-
Jsont.Object.map ~kind:"unknown-skip" make
71
-
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
72
-
|> Jsont.Object.error_unknown |> Jsont.Object.finish
70
+
Json.Object.map ~kind:"unknown-skip" make
71
+
|> Json.Object.mem "m" Json.bool ~enc:m
72
+
|> Json.Object.error_unknown |> Json.Object.finish
73
73
74
-
let keep_jsont : (t * int String_map.t) Jsont.t =
75
-
let unknown = Jsont.Object.Mems.string_map Jsont.int in
76
-
Jsont.Object.map ~kind:"unknown-keep" (fun m imap -> (make m, imap))
77
-
|> Jsont.Object.mem "m" Jsont.bool ~enc:(fun (v, _) -> m v)
78
-
|> Jsont.Object.keep_unknown unknown ~enc:snd
79
-
|> Jsont.Object.finish
74
+
let keep_jsont : (t * int String_map.t) Json.codec =
75
+
let unknown = Json.Object.Mems.string_map Json.int in
76
+
Json.Object.map ~kind:"unknown-keep" (fun m imap -> (make m, imap))
77
+
|> Json.Object.mem "m" Json.bool ~enc:(fun (v, _) -> m v)
78
+
|> Json.Object.keep_unknown unknown ~enc:snd
79
+
|> Json.Object.finish
80
80
end
81
81
82
82
module Unknown_data = struct
···
112
112
let pseudo a = a.pseudo
113
113
114
114
let jsont =
115
-
Jsont.Object.map ~kind:"Author" make
116
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
117
-
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
118
-
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
119
-
|> Jsont.Object.finish
115
+
Json.Object.map ~kind:"Author" make
116
+
|> Json.Object.mem "name" Json.string ~enc:name
117
+
|> Json.Object.mem "book_count" Json.int ~enc:book_count
118
+
|> Json.Object.mem "pseudo" Json.string ~enc:pseudo
119
+
|> Json.Object.finish
120
120
end
121
121
122
122
module Editor = struct
···
127
127
let publisher e = e.publisher
128
128
129
129
let jsont =
130
-
Jsont.Object.map ~kind:"Editor" make
131
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
132
-
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
133
-
|> Jsont.Object.finish
130
+
Json.Object.map ~kind:"Editor" make
131
+
|> Json.Object.mem "name" Json.string ~enc:name
132
+
|> Json.Object.mem "publisher" Json.string ~enc:publisher
133
+
|> Json.Object.finish
134
134
end
135
135
136
136
type t = Author of Author.t | Editor of Editor.t
···
139
139
let editor e = Editor e
140
140
141
141
let jsont =
142
-
let case_a = Jsont.Object.Case.map "author" Author.jsont ~dec:author in
143
-
let case_e = Jsont.Object.Case.map "editor" Editor.jsont ~dec:editor in
144
-
let cases = Jsont.Object.Case.[ make case_a; make case_e ] in
142
+
let case_a = Json.Object.Case.map "author" Author.jsont ~dec:author in
143
+
let case_e = Json.Object.Case.map "editor" Editor.jsont ~dec:editor in
144
+
let cases = Json.Object.Case.[ make case_a; make case_e ] in
145
145
let enc_case = function
146
-
| Author a -> Jsont.Object.Case.value case_a a
147
-
| Editor e -> Jsont.Object.Case.value case_e e
146
+
| Author a -> Json.Object.Case.value case_a a
147
+
| Editor e -> Json.Object.Case.value case_e e
148
148
in
149
-
Jsont.Object.map ~kind:"Person" Fun.id
150
-
|> Jsont.Object.case_mem "type" Jsont.string ~tag_to_string:Fun.id
149
+
Json.Object.map ~kind:"Person" Fun.id
150
+
|> Json.Object.case_mem "type" Json.string ~tag_to_string:Fun.id
151
151
~enc:Fun.id ~enc_case cases
152
-
|> Jsont.Object.finish
152
+
|> Json.Object.finish
153
153
end
154
154
155
155
module Person_field = struct
···
161
161
let book_count a = a.book_count
162
162
163
163
let author_jsont =
164
-
Jsont.Object.map ~kind:"Author" make_author
165
-
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
166
-
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
167
-
|> Jsont.Object.finish
164
+
Json.Object.map ~kind:"Author" make_author
165
+
|> Json.Object.mem "pseudo" Json.string ~enc:pseudo
166
+
|> Json.Object.mem "book_count" Json.int ~enc:book_count
167
+
|> Json.Object.finish
168
168
169
169
type editor = { publisher : string }
170
170
···
172
172
let publisher e = e.publisher
173
173
174
174
let editor_jsont =
175
-
Jsont.Object.map ~kind:"Editor" make_editor
176
-
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
177
-
|> Jsont.Object.finish
175
+
Json.Object.map ~kind:"Editor" make_editor
176
+
|> Json.Object.mem "publisher" Json.string ~enc:publisher
177
+
|> Json.Object.finish
178
178
179
179
type type' = Author of author | Editor of editor
180
180
···
188
188
let name v = v.name
189
189
190
190
let jsont =
191
-
let case_a = Jsont.Object.Case.map "author" author_jsont ~dec:author in
192
-
let case_e = Jsont.Object.Case.map "editor" editor_jsont ~dec:editor in
193
-
let cases = Jsont.Object.Case.[ make case_a; make case_e ] in
191
+
let case_a = Json.Object.Case.map "author" author_jsont ~dec:author in
192
+
let case_e = Json.Object.Case.map "editor" editor_jsont ~dec:editor in
193
+
let cases = Json.Object.Case.[ make case_a; make case_e ] in
194
194
let enc_case = function
195
-
| Author a -> Jsont.Object.Case.value case_a a
196
-
| Editor e -> Jsont.Object.Case.value case_e e
195
+
| Author a -> Json.Object.Case.value case_a a
196
+
| Editor e -> Json.Object.Case.value case_e e
197
197
in
198
-
Jsont.Object.map ~kind:"Person" make
199
-
|> Jsont.Object.case_mem "type" ~tag_to_string:Fun.id Jsont.string
198
+
Json.Object.map ~kind:"Person" make
199
+
|> Json.Object.case_mem "type" ~tag_to_string:Fun.id Json.string
200
200
~enc:type' ~enc_case cases
201
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
202
-
|> Jsont.Object.finish
201
+
|> Json.Object.mem "name" Json.string ~enc:name
202
+
|> Json.Object.finish
203
203
end
204
204
205
205
module Keep_unknown = struct
206
206
type a = string String_map.t
207
207
208
208
let a_jsont =
209
-
let unknown = Jsont.Object.Mems.string_map Jsont.string in
210
-
Jsont.Object.map ~kind:"A" Fun.id
211
-
|> Jsont.Object.keep_unknown unknown ~enc:Fun.id
212
-
|> Jsont.Object.finish
209
+
let unknown = Json.Object.Mems.string_map Json.string in
210
+
Json.Object.map ~kind:"A" Fun.id
211
+
|> Json.Object.keep_unknown unknown ~enc:Fun.id
212
+
|> Json.Object.finish
213
213
214
214
type b = { name : string }
215
215
216
216
let name b = b.name
217
217
218
218
let b_jsont =
219
-
Jsont.Object.map ~kind:"B" (fun name -> { name })
220
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
221
-
|> Jsont.Object.error_unknown |> Jsont.Object.finish
219
+
Json.Object.map ~kind:"B" (fun name -> { name })
220
+
|> Json.Object.mem "name" Json.string ~enc:name
221
+
|> Json.Object.error_unknown |> Json.Object.finish
222
222
223
223
type type' = A of a | B of b
224
224
225
225
let a a = A a
226
226
let b b = B b
227
227
228
-
type t = { type' : type'; unknown : Jsont.json }
228
+
type t = { type' : type'; unknown : Json.t }
229
229
230
230
let make type' unknown = { type'; unknown }
231
231
let type' v = v.type'
···
235
235
match (v0.type', v1.type') with
236
236
| A a0, A a1 ->
237
237
String_map.equal String.equal a0 a1
238
-
&& Jsont.Json.equal v0.unknown v1.unknown
238
+
&& Json.Value.equal v0.unknown v1.unknown
239
239
| B b0, B b1 ->
240
-
String.equal b0.name b1.name && Jsont.Json.equal v0.unknown v1.unknown
240
+
String.equal b0.name b1.name && Json.Value.equal v0.unknown v1.unknown
241
241
| _, _ -> false
242
242
243
243
let pp ppf v = B0_std.Fmt.string ppf "<value>"
244
244
245
245
let jsont =
246
-
let case_a = Jsont.Object.Case.map "A" a_jsont ~dec:a in
247
-
let case_b = Jsont.Object.Case.map "B" b_jsont ~dec:b in
248
-
let cases = Jsont.Object.Case.[ make case_a; make case_b ] in
246
+
let case_a = Json.Object.Case.map "A" a_jsont ~dec:a in
247
+
let case_b = Json.Object.Case.map "B" b_jsont ~dec:b in
248
+
let cases = Json.Object.Case.[ make case_a; make case_b ] in
249
249
let enc_case = function
250
-
| A a -> Jsont.Object.Case.value case_a a
251
-
| B b -> Jsont.Object.Case.value case_b b
250
+
| A a -> Json.Object.Case.value case_a a
251
+
| B b -> Json.Object.Case.value case_b b
252
252
in
253
-
Jsont.Object.map ~kind:"Keep_unknown" make
254
-
|> Jsont.Object.case_mem "type" ~tag_to_string:Fun.id Jsont.string
253
+
Json.Object.map ~kind:"Keep_unknown" make
254
+
|> Json.Object.case_mem "type" ~tag_to_string:Fun.id Json.string
255
255
~enc:type' ~enc_case cases
256
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
257
-
|> Jsont.Object.finish
256
+
|> Json.Object.keep_unknown Json.json_mems ~enc:unknown
257
+
|> Json.Object.finish
258
258
end
259
259
end
260
260
···
295
295
296
296
let unknown_a_value =
297
297
let unknown =
298
-
Jsont.Json.(
298
+
Json.Value.(
299
299
object' [ mem (name "m0") (string "o"); mem (name "m1") (string "n") ])
300
300
in
301
301
Cases.Keep_unknown.make (A String_map.empty) unknown
···
308
308
309
309
let unknown_a_no_a_unknown_value =
310
310
(* Since the map should be ignored since the case object overides it *)
311
-
let unknown = Jsont.Json.object' [] in
311
+
let unknown = Json.Value.object' [] in
312
312
Cases.Keep_unknown.make (A String_map.(empty |> add "bli" "bla")) unknown
313
313
314
314
let unknown_b_value =
315
315
let unknown =
316
-
Jsont.Json.(
316
+
Json.Value.(
317
317
object' [ mem (name "m1") (string "v1"); mem (name "m2") (number 0.0) ])
318
318
in
319
319
Cases.Keep_unknown.make (B { name = "ha" }) unknown
···
340
340
let jsont_with_null t =
341
341
let rec tree =
342
342
lazy begin
343
-
let empty = Jsont.null Empty in
343
+
let empty = Json.null Empty in
344
344
let node =
345
345
let not_a_node () = failwith "not a node" in
346
346
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
347
347
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
348
348
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
349
-
Jsont.Object.map ~kind:"node" (fun l v r -> Node (l, v, r))
350
-
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
351
-
|> Jsont.Object.mem ~enc:value "value" t
352
-
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
353
-
|> Jsont.Object.finish
349
+
Json.Object.map ~kind:"node" (fun l v r -> Node (l, v, r))
350
+
|> Json.Object.mem ~enc:left "left" (Json.rec' tree)
351
+
|> Json.Object.mem ~enc:value "value" t
352
+
|> Json.Object.mem ~enc:right "right" (Json.rec' tree)
353
+
|> Json.Object.finish
354
354
in
355
355
let enc = function Empty -> empty | Node _ -> node in
356
-
Jsont.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc ()
356
+
Json.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc ()
357
357
end
358
358
in
359
359
Lazy.force tree
···
370
370
let jsont_with_cases t =
371
371
let rec tree =
372
372
lazy begin
373
-
let leaf_jsont = Jsont.Object.map Empty |> Jsont.Object.finish in
373
+
let leaf_jsont = Json.Object.map Empty |> Json.Object.finish in
374
374
let node_jsont =
375
375
let not_a_node () = failwith "not a node" in
376
376
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
377
377
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
378
378
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
379
-
Jsont.Object.map (fun l v r -> Node (l, v, r))
380
-
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
381
-
|> Jsont.Object.mem ~enc:value "value" t
382
-
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
383
-
|> Jsont.Object.finish
379
+
Json.Object.map (fun l v r -> Node (l, v, r))
380
+
|> Json.Object.mem ~enc:left "left" (Json.rec' tree)
381
+
|> Json.Object.mem ~enc:value "value" t
382
+
|> Json.Object.mem ~enc:right "right" (Json.rec' tree)
383
+
|> Json.Object.finish
384
384
in
385
-
let case_leaf = Jsont.Object.Case.map "empty" leaf_jsont ~dec:Fun.id in
386
-
let case_node = Jsont.Object.Case.map "node" node_jsont ~dec:Fun.id in
385
+
let case_leaf = Json.Object.Case.map "empty" leaf_jsont ~dec:Fun.id in
386
+
let case_node = Json.Object.Case.map "node" node_jsont ~dec:Fun.id in
387
387
let enc_case = function
388
-
| Empty as v -> Jsont.Object.Case.value case_leaf v
389
-
| Node _ as v -> Jsont.Object.Case.value case_node v
388
+
| Empty as v -> Json.Object.Case.value case_leaf v
389
+
| Node _ as v -> Json.Object.Case.value case_node v
390
390
in
391
-
let cases = Jsont.Object.Case.[ make case_leaf; make case_node ] in
392
-
Jsont.Object.map ~kind:"tree" Fun.id
393
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
394
-
|> Jsont.Object.finish
391
+
let cases = Json.Object.Case.[ make case_leaf; make case_node ] in
392
+
Json.Object.map ~kind:"tree" Fun.id
393
+
|> Json.Object.case_mem "type" Json.string ~enc:Fun.id ~enc_case cases
394
+
|> Json.Object.finish
395
395
end
396
396
in
397
397
Lazy.force tree
+8
-8
test/codecs/test_json.ml
+8
-8
test/codecs/test_json.ml
···
6
6
open B0_std
7
7
open B0_testing
8
8
9
-
(* Tests the common test suite with the Jsont.Json codec. *)
9
+
(* Tests the common test suite with the Json.Json codec. *)
10
10
11
-
(* Since the Jsont.Json codec works only on Jsont.json values we use
12
-
Jsont_bytesrw to codec JSON to Jsont.json values and then apply the
13
-
Jsont.Json codec. So the tests rely on a working Jsont_bytesrw
11
+
(* Since the Json.Json codec works only on Json.json values we use
12
+
Jsont_bytesrw to codec JSON to Json.json values and then apply the
13
+
Json.Json codec. So the tests rely on a working Jsont_bytesrw
14
14
codec *)
15
15
16
16
let decode ?layout t json =
17
-
match Jsont_bytesrw.decode_string ?layout ~locs:true Jsont.json json with
17
+
match Json.of_string ?layout ~locs:true Json.json json with
18
18
| Error _ as e -> e
19
-
| Ok json -> Jsont.Json.decode t json
19
+
| Ok json -> Json.Value.decode t json
20
20
21
21
let encode ?format t v =
22
-
match Jsont.Json.encode t v with
22
+
match Json.Value.encode t v with
23
23
| Error _ as e -> e
24
-
| Ok json -> Jsont_bytesrw.encode_string ?format Jsont.json json
24
+
| Ok json -> Json.to_string ?format Json.json json
25
25
26
26
let test_funs = { Test_common.supports_layout = true; decode; encode }
27
27
+1
-1
test/codecs/test_seriot_suite.ml
+1
-1
test/codecs/test_seriot_suite.ml
···
24
24
let name = Fpath.basename file in
25
25
let status = status_of_filename name in
26
26
let file = Fpath.to_string file in
27
-
match Jsont_bytesrw.decode_string ~file ~locs:true Jsont.json json with
27
+
match Json.of_string ~file ~locs:true Json.json json with
28
28
| Ok _ ->
29
29
if status = `Accept || status = `Indeterminate then Ok (Test.pass ())
30
30
else Fmt.error "@[<v>Test %s@,Should have been rejected:@,%s@]" name json
+70
-78
test/codecs/topojson.ml
+70
-78
test/codecs/topojson.ml
···
10
10
module Position = struct
11
11
type t = float array
12
12
13
-
let jsont = Jsont.(array ~kind:"Position" number)
13
+
let jsont = Json.(array ~kind:"Position" number)
14
14
end
15
15
16
16
module Bbox = struct
17
17
type t = float array
18
18
19
-
let jsont = Jsont.(array ~kind:"Bbox" number)
19
+
let jsont = Json.(array ~kind:"Bbox" number)
20
20
end
21
21
22
22
module Arcs = struct
23
23
type t = Position.t array array
24
24
25
-
let jsont = Jsont.(array ~kind:"Arcs" (array Position.jsont))
25
+
let jsont = Json.(array ~kind:"Arcs" (array Position.jsont))
26
26
end
27
27
28
28
module Transform = struct
···
36
36
let v2_jsont =
37
37
let dec x y = (x, y) in
38
38
let enc (x, y) i = if i = 0 then x else y in
39
-
Jsont.t2 ~dec ~enc Jsont.number
39
+
Json.t2 ~dec ~enc Json.number
40
40
41
41
let jsont =
42
-
Jsont.Object.map ~kind:"Transform" make
43
-
|> Jsont.Object.mem "scale" v2_jsont ~enc:scale
44
-
|> Jsont.Object.mem "translate" v2_jsont ~enc:translate
45
-
|> Jsont.Object.finish
42
+
Json.Object.map ~kind:"Transform" make
43
+
|> Json.Object.mem "scale" v2_jsont ~enc:scale
44
+
|> Json.Object.mem "translate" v2_jsont ~enc:translate
45
+
|> Json.Object.finish
46
46
end
47
47
48
48
module Point = struct
···
52
52
let coordinates v = v.coordinates
53
53
54
54
let jsont =
55
-
Jsont.Object.map ~kind:"Point" make
56
-
|> Jsont.Object.mem "coordinates" Position.jsont ~enc:coordinates
57
-
|> Jsont.Object.finish
55
+
Json.Object.map ~kind:"Point" make
56
+
|> Json.Object.mem "coordinates" Position.jsont ~enc:coordinates
57
+
|> Json.Object.finish
58
58
end
59
59
60
60
module Multi_point = struct
···
64
64
let coordinates v = v.coordinates
65
65
66
66
let jsont =
67
-
Jsont.Object.map ~kind:"MultiPoint" make
68
-
|> Jsont.Object.mem "coordinates"
69
-
(Jsont.list Position.jsont)
70
-
~enc:coordinates
71
-
|> Jsont.Object.finish
67
+
Json.Object.map ~kind:"MultiPoint" make
68
+
|> Json.Object.mem "coordinates" (Json.list Position.jsont) ~enc:coordinates
69
+
|> Json.Object.finish
72
70
end
73
71
74
72
module Line_string = struct
···
78
76
let arcs v = v.arcs
79
77
80
78
let jsont =
81
-
Jsont.Object.map ~kind:"LineString" make
82
-
|> Jsont.Object.mem "arcs" Jsont.(list int32) ~enc:arcs
83
-
|> Jsont.Object.finish
79
+
Json.Object.map ~kind:"LineString" make
80
+
|> Json.Object.mem "arcs" Json.(list int32) ~enc:arcs
81
+
|> Json.Object.finish
84
82
end
85
83
86
84
module Multi_line_string = struct
···
90
88
let arcs v = v.arcs
91
89
92
90
let jsont =
93
-
Jsont.Object.map ~kind:"MultiLineString" make
94
-
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
95
-
|> Jsont.Object.finish
91
+
Json.Object.map ~kind:"MultiLineString" make
92
+
|> Json.Object.mem "arcs" Json.(list (list int32)) ~enc:arcs
93
+
|> Json.Object.finish
96
94
end
97
95
98
96
module Polygon = struct
···
102
100
let arcs v = v.arcs
103
101
104
102
let jsont =
105
-
Jsont.Object.map ~kind:"Polygon" make
106
-
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
107
-
|> Jsont.Object.finish
103
+
Json.Object.map ~kind:"Polygon" make
104
+
|> Json.Object.mem "arcs" Json.(list (list int32)) ~enc:arcs
105
+
|> Json.Object.finish
108
106
end
109
107
110
108
module Multi_polygon = struct
···
114
112
let arcs v = v.arcs
115
113
116
114
let jsont =
117
-
Jsont.Object.map ~kind:"MultiPolygon" make
118
-
|> Jsont.Object.mem "arcs" Jsont.(list (list (list int32))) ~enc:arcs
119
-
|> Jsont.Object.finish
115
+
Json.Object.map ~kind:"MultiPolygon" make
116
+
|> Json.Object.mem "arcs" Json.(list (list (list int32))) ~enc:arcs
117
+
|> Json.Object.finish
120
118
end
121
119
122
120
module Geometry = struct
···
124
122
125
123
let id_jsont =
126
124
let number =
127
-
let dec = Jsont.Base.dec (fun n -> `Number n) in
128
-
let enc =
129
-
Jsont.Base.enc (function `Number n -> n | _ -> assert false)
130
-
in
131
-
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
125
+
let dec = Json.Base.dec (fun n -> `Number n) in
126
+
let enc = Json.Base.enc (function `Number n -> n | _ -> assert false) in
127
+
Json.Base.number (Json.Base.map ~enc ~dec ())
132
128
in
133
129
let string =
134
-
let dec = Jsont.Base.dec (fun n -> `String n) in
135
-
let enc =
136
-
Jsont.Base.enc (function `String n -> n | _ -> assert false)
137
-
in
138
-
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
130
+
let dec = Json.Base.dec (fun n -> `String n) in
131
+
let enc = Json.Base.enc (function `String n -> n | _ -> assert false) in
132
+
Json.Base.string (Json.Base.map ~enc ~dec ())
139
133
in
140
134
let enc = function `Number _ -> number | `String _ -> string in
141
-
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
135
+
Json.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
142
136
143
137
type t = {
144
138
type' : type';
145
139
id : id option;
146
-
properties : Jsont.json String_map.t option;
140
+
properties : Json.json String_map.t option;
147
141
bbox : Bbox.t option;
148
-
unknown : Jsont.json;
142
+
unknown : Json.t;
149
143
}
150
144
151
145
and type' =
···
172
166
let polygon v = Polygon v
173
167
let multi_polygon v = Multi_polygon v
174
168
let collection vs = Geometry_collection vs
175
-
let properties_type = Jsont.Object.as_string_map ~kind:"properties" Jsont.json
169
+
let properties_type = Json.Object.as_string_map ~kind:"properties" Json.t
176
170
177
171
let rec collection_jsont =
178
172
lazy begin
179
-
Jsont.Object.map ~kind:"GeometryCollection" Fun.id
180
-
|> Jsont.Object.mem "geometries"
181
-
(Jsont.list (Jsont.rec' jsont))
182
-
~enc:Fun.id
183
-
|> Jsont.Object.finish
173
+
Json.Object.map ~kind:"GeometryCollection" Fun.id
174
+
|> Json.Object.mem "geometries" (Json.list (Json.rec' jsont)) ~enc:Fun.id
175
+
|> Json.Object.finish
184
176
end
185
177
186
178
and jsont =
187
179
lazy begin
188
-
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec in
180
+
let case_map obj dec = Json.Object.Case.map (Json.kind obj) obj ~dec in
189
181
let case_point = case_map Point.jsont point in
190
182
let case_multi_point = case_map Multi_point.jsont multi_point in
191
183
let case_line_string = case_map Line_string.jsont line_string in
···
194
186
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
195
187
let case_coll = case_map (Lazy.force collection_jsont) collection in
196
188
let enc_case = function
197
-
| Point p -> Jsont.Object.Case.value case_point p
198
-
| Multi_point m -> Jsont.Object.Case.value case_multi_point m
199
-
| Line_string l -> Jsont.Object.Case.value case_line_string l
200
-
| Multi_line_string m -> Jsont.Object.Case.value case_multi_linestr m
201
-
| Polygon p -> Jsont.Object.Case.value case_polygon p
202
-
| Multi_polygon m -> Jsont.Object.Case.value case_multi_polygon m
203
-
| Geometry_collection gs -> Jsont.Object.Case.value case_coll gs
189
+
| Point p -> Json.Object.Case.value case_point p
190
+
| Multi_point m -> Json.Object.Case.value case_multi_point m
191
+
| Line_string l -> Json.Object.Case.value case_line_string l
192
+
| Multi_line_string m -> Json.Object.Case.value case_multi_linestr m
193
+
| Polygon p -> Json.Object.Case.value case_polygon p
194
+
| Multi_polygon m -> Json.Object.Case.value case_multi_polygon m
195
+
| Geometry_collection gs -> Json.Object.Case.value case_coll gs
204
196
and cases =
205
-
Jsont.Object.Case.
197
+
Json.Object.Case.
206
198
[
207
199
make case_point;
208
200
make case_multi_point;
···
213
205
make case_coll;
214
206
]
215
207
in
216
-
Jsont.Object.map ~kind:"Geometry" make
217
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
208
+
Json.Object.map ~kind:"Geometry" make
209
+
|> Json.Object.case_mem "type" Json.string ~enc:type' ~enc_case cases
218
210
~tag_to_string:Fun.id ~tag_compare:String.compare
219
-
|> Jsont.Object.opt_mem "id" id_jsont ~enc:id
220
-
|> Jsont.Object.opt_mem "properties" properties_type ~enc:properties
221
-
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
222
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
223
-
|> Jsont.Object.finish
211
+
|> Json.Object.opt_mem "id" id_jsont ~enc:id
212
+
|> Json.Object.opt_mem "properties" properties_type ~enc:properties
213
+
|> Json.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
214
+
|> Json.Object.keep_unknown Json.json_mems ~enc:unknown
215
+
|> Json.Object.finish
224
216
end
225
217
226
218
let jsont = Lazy.force jsont
227
219
228
220
type objects = t String_map.t
229
221
230
-
let objects_jsont = Jsont.Object.as_string_map ~kind:"objects map" jsont
222
+
let objects_jsont = Json.Object.as_string_map ~kind:"objects map" jsont
231
223
end
232
224
233
225
module Topology = struct
···
236
228
arcs : Arcs.t;
237
229
transform : Transform.t option;
238
230
bbox : Bbox.t option;
239
-
unknown : Jsont.json;
231
+
unknown : Json.t;
240
232
}
241
233
242
234
let make objects arcs transform bbox unknown =
···
250
242
251
243
let jsont =
252
244
let kind = "Topology" in
253
-
Jsont.Object.map ~kind (fun () -> make)
254
-
|> Jsont.Object.mem "type" (Jsont.enum [ (kind, ()) ]) ~enc:(Fun.const ())
255
-
|> Jsont.Object.mem "objects" Geometry.objects_jsont ~enc:objects
256
-
|> Jsont.Object.mem "arcs" Arcs.jsont ~enc:arcs
257
-
|> Jsont.Object.opt_mem "transform" Transform.jsont ~enc:transform
258
-
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
259
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
260
-
|> Jsont.Object.finish
245
+
Json.Object.map ~kind (fun () -> make)
246
+
|> Json.Object.mem "type" (Json.enum [ (kind, ()) ]) ~enc:(Fun.const ())
247
+
|> Json.Object.mem "objects" Geometry.objects_jsont ~enc:objects
248
+
|> Json.Object.mem "arcs" Arcs.jsont ~enc:arcs
249
+
|> Json.Object.opt_mem "transform" Transform.jsont ~enc:transform
250
+
|> Json.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
251
+
|> Json.Object.keep_unknown Json.json_mems ~enc:unknown
252
+
|> Json.Object.finish
261
253
end
262
254
263
255
(* Command line interface *)
···
269
261
| Ok v -> v
270
262
| Error e ->
271
263
let lines = String.split_on_char '\n' e in
272
-
Format.eprintf "@[%a @[<v>%a@]@]@." Jsont.Error.puterr ()
264
+
Format.eprintf "@[%a @[<v>%a@]@]@." Json.Error.puterr ()
273
265
(Format.pp_print_list Format.pp_print_string)
274
266
lines;
275
267
use
···
291
283
@@ fun r ->
292
284
log_if_error ~use:1
293
285
@@
294
-
let* t = Jsont_bytesrw.decode ~file ~locs Topology.jsont r in
286
+
let* t = Json.of_reader ~file ~locs Topology.jsont r in
295
287
if dec_only then Ok 0
296
288
else
297
289
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
298
-
let* () = Jsont_bytesrw.encode ~format ~eod:true Topology.jsont t w in
290
+
let* () = Json.to_writer ~format ~eod:true Topology.jsont t w in
299
291
Ok 0
300
292
301
293
open Cmdliner
···
311
303
let doc = "Preserve locations (better errors)." in
312
304
Arg.(value & flag & info [ "l"; "locs" ] ~doc)
313
305
and+ format =
314
-
let fmt = [ ("indent", Jsont.Indent); ("minify", Jsont.Minify) ] in
306
+
let fmt = [ ("indent", Json.Indent); ("minify", Json.Minify) ] in
315
307
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt) in
316
308
Arg.(
317
309
value
318
-
& opt (enum fmt) Jsont.Minify
310
+
& opt (enum fmt) Json.Minify
319
311
& info [ "f"; "format" ] ~doc ~docv:"FMT")
320
312
and+ dec_only =
321
313
let doc = "Decode only." in
+5
-5
test/codecs/trials.ml
+5
-5
test/codecs/trials.ml
···
10
10
let content msg = msg.content
11
11
let public msg = msg.public
12
12
13
-
let jsont : t Jsont.t =
14
-
Jsont.Object.map make
15
-
|> Jsont.Object.mem "content" Jsont.string ~enc:content
16
-
|> Jsont.Object.mem "public" Jsont.bool ~enc:public
17
-
|> Jsont.Object.finish
13
+
let jsont : t Json.codec =
14
+
Json.Object.map make
15
+
|> Json.Object.mem "content" Json.string ~enc:content
16
+
|> Json.Object.mem "public" Json.bool ~enc:public
17
+
|> Json.Object.finish
18
18
end
19
19
20
20
type ('ret, 'f) app =
+4
-4
test/test_codec.ml
+4
-4
test/test_codec.ml
···
2
2
introspection on a few hand-built codecs. *)
3
3
4
4
let test_kind_doc () =
5
-
let c = Json.with_doc ~kind:"port" ~doc:"TCP/UDP port" Json.int in
5
+
let c = Json.Codec.with_doc ~kind:"port" ~doc:"TCP/UDP port" Json.Codec.int in
6
6
Alcotest.(check string) "kind" "port" (Json.Codec.kind c);
7
7
Alcotest.(check string) "doc" "TCP/UDP port" (Json.Codec.doc c)
8
8
9
9
let test_kinded_sort () =
10
-
let c = Json.with_doc ~kind:"user" Json.string in
10
+
let c = Json.Codec.with_doc ~kind:"user" Json.Codec.string in
11
11
Alcotest.(check string) "kinded_sort" "user string" (Json.Codec.kinded_sort c)
12
12
13
13
let test_kinded_sort_unkinded () =
14
14
Alcotest.(check string)
15
15
"plain string" "string"
16
-
(Json.Codec.kinded_sort Json.string);
16
+
(Json.Codec.kinded_sort Json.Codec.string);
17
17
Alcotest.(check string)
18
18
"plain number" "number"
19
-
(Json.Codec.kinded_sort Json.number)
19
+
(Json.Codec.kinded_sort Json.Codec.number)
20
20
21
21
let suite =
22
22
( "codec",
+19
-16
test/test_json.ml
+19
-16
test/test_json.ml
···
5
5
1. Hand-written positive/negative cases covering the shape grammar
6
6
(string escapes, number formats, nested structures, truncation).
7
7
2. Differential property: on any string, [Json.Codec.ignore] and
8
-
[Json.Codec.Value.t] agree on Ok/Error status. [Json.Codec.ignore] is allowed
9
-
to be more permissive (accept where [Json.Codec.Value.t] errors) only at
8
+
[Json.t] agree on Ok/Error status. [Json.Codec.ignore] is allowed
9
+
to be more permissive (accept where [Json.t] errors) only at
10
10
content level -- never at structural level. Crowbar generates
11
11
random inputs and asserts the invariant. *)
12
12
13
13
let decode_ignore s = Json.of_string Json.Codec.ignore s
14
-
let decode_dom s = Json.of_string Json.Codec.Value.t s
14
+
let decode_dom s = Json.Value.of_string s
15
15
let is_ok = function Ok _ -> true | Error _ -> false
16
16
17
17
(* -- Positive cases: Json.Codec.ignore must accept all valid JSON -- *)
···
62
62
"Structurally broken" means: mismatched brackets, unclosed strings,
63
63
unclosed containers, or complete absence of a value. The skip path
64
64
is explicitly more permissive on content (numbers, escapes) and may
65
-
accept things Json.Codec.Value.t rejects. *)
65
+
accept things Json.t rejects. *)
66
66
67
67
let test_ignore_rejects_malformed name s () =
68
68
match decode_ignore s with
···
85
85
("just close bracket", "]");
86
86
]
87
87
88
-
(* -- Differential: Json.Codec.ignore and Json.Codec.Value.t on the same input --
88
+
(* -- Differential: Json.Codec.ignore and Json.t on the same input --
89
89
90
90
Expected: on all corpus files (known valid), both decode to Ok.
91
91
On a set of synthetic malformed inputs, both return Error -- or at
92
-
worst, Json.Codec.ignore accepts something Json.Codec.Value.t rejects (content
92
+
worst, Json.Codec.ignore accepts something Json.t rejects (content
93
93
permissiveness, documented). The strict structural contract says
94
-
Json.Codec.ignore MUST reject what Json.Codec.Value.t rejects at the structural
94
+
Json.Codec.ignore MUST reject what Json.t rejects at the structural
95
95
level. *)
96
96
97
97
let test_diff_valid_both_accept name s () =
···
99
99
match (ri, rj) with
100
100
| Ok _, Ok _ -> ()
101
101
| Error e, Ok _ ->
102
-
Alcotest.failf
103
-
"Json.Codec.ignore rejected but Json.Codec.Value.t accepted %s: %a" name
104
-
Json.Error.pp e
102
+
Alcotest.failf "Json.Codec.ignore rejected but Json.t accepted %s: %a"
103
+
name Json.Error.pp e
105
104
| Ok _, Error e ->
106
105
Alcotest.failf
107
-
"Json.Codec.ignore accepted but Json.Codec.Value.t rejected %s \
108
-
(content permissiveness): %a"
106
+
"Json.Codec.ignore accepted but Json.t rejected %s (content \
107
+
permissiveness): %a"
109
108
name Json.Error.pp e
110
109
| Error _, Error _ -> ()
111
110
···
125
124
semantics. Structural contract (bracket nesting, string quote
126
125
matching) is enforced; content validity (number shape, escape
127
126
correctness) is NOT. Callers needing strict content validation
128
-
should decode with Json.Codec.Value.t and discard. These cases document
127
+
should decode with Json.t and discard. These cases document
129
128
the boundary. -- *)
130
129
131
130
let permissive_cases =
···
152
151
153
152
If the simdjson corpus is present at [/tmp/jsont_corpus/*.json],
154
153
run Json.Codec.ignore over each file and assert acceptance. Also check
155
-
that Json.Codec.ignore and Json.Codec.Value.t agree (both Ok) on every file.
154
+
that Json.Codec.ignore and Json.t agree (both Ok) on every file.
156
155
Skipped silently if the corpus isn't available. *)
157
156
158
157
let read_file path =
···
180
179
| Some s -> (
181
180
(match decode_ignore s with
182
181
| Ok () -> ()
183
-
| Error e -> Alcotest.failf "ignore rejected corpus %s: %s" name (Json.Error.to_string e));
182
+
| Error e ->
183
+
Alcotest.failf "ignore rejected corpus %s: %s" name
184
+
(Json.Error.to_string e));
184
185
match decode_dom s with
185
186
| Ok _ -> ()
186
-
| Error e -> Alcotest.failf "json rejected corpus %s: %s" name (Json.Error.to_string e))
187
+
| Error e ->
188
+
Alcotest.failf "json rejected corpus %s: %s" name
189
+
(Json.Error.to_string e))
187
190
188
191
(* -- Entry point -- *)
189
192
+12
-13
test/test_tape.ml
+12
-13
test/test_tape.ml
···
5
5
let roundtrip_value name v =
6
6
let tape = Json.Tape.of_value v in
7
7
let v' = Json.Tape.to_value tape in
8
-
Alcotest.(check bool) (name ^ ": value equal") true (Json.Value.equal v v')
8
+
Alcotest.(check bool) (name ^ ": value equal") true (Json.equal v v')
9
9
10
10
let roundtrip_bytes name v =
11
11
let tape = Json.Tape.of_value v in
···
14
14
| Error e -> Alcotest.failf "%s: of_bytes error: %s" name e
15
15
| Ok tape' ->
16
16
let v' = Json.Tape.to_value tape' in
17
-
Alcotest.(check bool)
18
-
(name ^ ": bytes equal") true (Json.Value.equal v v')
17
+
Alcotest.(check bool) (name ^ ": bytes equal") true (Json.equal v v')
19
18
20
19
let v_simple () =
21
-
let n = Json.Value.name in
22
-
Json.Value.object'
20
+
let n = Json.name in
21
+
Json.object'
23
22
[
24
-
(n "a", Json.Value.int 42);
25
-
(n "b", Json.Value.string "hello");
26
-
(n "c", Json.Value.list [ Json.Value.bool true; Json.Value.null () ]);
23
+
(n "a", Json.int 42);
24
+
(n "b", Json.string "hello");
25
+
(n "c", Json.list [ Json.bool true; Json.null () ]);
27
26
]
28
27
29
28
let test_roundtrip_atoms () =
30
-
roundtrip_value "null" (Json.Value.null ());
31
-
roundtrip_value "true" (Json.Value.bool true);
32
-
roundtrip_value "false" (Json.Value.bool false);
33
-
roundtrip_value "int" (Json.Value.int 7);
34
-
roundtrip_value "string" (Json.Value.string "hello")
29
+
roundtrip_value "null" (Json.null ());
30
+
roundtrip_value "true" (Json.bool true);
31
+
roundtrip_value "false" (Json.bool false);
32
+
roundtrip_value "int" (Json.int 7);
33
+
roundtrip_value "string" (Json.string "hello")
35
34
36
35
let test_roundtrip_object () = roundtrip_value "object" (v_simple ())
37
36
let test_bytes_roundtrip () = roundtrip_bytes "object bytes" (v_simple ())
+17
-24
test/test_value.ml
+17
-24
test/test_value.ml
···
1
1
(** Tests for generic JSON values. Covers the constructors, equality, and member
2
-
lookup in {!Json.Value} (re-exported at the top level of [Json]). *)
2
+
lookup at the top level of {!Json}. *)
3
3
4
-
let v_null = Json.Value.null ()
5
-
let v_true = Json.Value.bool true
6
-
let v_false = Json.Value.bool false
7
-
let v_seven = Json.Value.int 7
8
-
let v_hello = Json.Value.string "hello"
4
+
let v_null = Json.null ()
5
+
let v_true = Json.bool true
6
+
let v_false = Json.bool false
7
+
let v_seven = Json.int 7
8
+
let v_hello = Json.string "hello"
9
9
10
10
let test_sort () =
11
-
Alcotest.(check string)
12
-
"null" "null"
13
-
(Json.Sort.to_string (Json.Value.sort v_null));
14
-
Alcotest.(check string)
15
-
"bool" "bool"
16
-
(Json.Sort.to_string (Json.Value.sort v_true));
11
+
Alcotest.(check string) "null" "null" (Json.Sort.to_string (Json.sort v_null));
12
+
Alcotest.(check string) "bool" "bool" (Json.Sort.to_string (Json.sort v_true));
17
13
Alcotest.(check string)
18
14
"number" "number"
19
-
(Json.Sort.to_string (Json.Value.sort v_seven));
15
+
(Json.Sort.to_string (Json.sort v_seven));
20
16
Alcotest.(check string)
21
17
"string" "string"
22
-
(Json.Sort.to_string (Json.Value.sort v_hello))
18
+
(Json.Sort.to_string (Json.sort v_hello))
23
19
24
20
let test_equal () =
25
-
Alcotest.(check bool) "null = null" true (Json.Value.equal v_null v_null);
26
-
Alcotest.(check bool) "true = true" true (Json.Value.equal v_true v_true);
27
-
Alcotest.(check bool) "true <> false" false (Json.Value.equal v_true v_false);
21
+
Alcotest.(check bool) "null = null" true (Json.equal v_null v_null);
22
+
Alcotest.(check bool) "true = true" true (Json.equal v_true v_true);
23
+
Alcotest.(check bool) "true <> false" false (Json.equal v_true v_false);
28
24
Alcotest.(check bool)
29
25
"hello = hello" true
30
-
(Json.Value.equal v_hello (Json.Value.string "hello"))
26
+
(Json.equal v_hello (Json.string "hello"))
31
27
32
28
let test_find_mem () =
33
-
let mems =
34
-
[ (Json.Value.name "a", v_seven); (Json.Value.name "b", v_hello) ]
35
-
in
36
-
match Json.Value.find_mem "a" mems with
29
+
let mems = [ (Json.name "a", v_seven); (Json.name "b", v_hello) ] in
30
+
match Json.find_mem "a" mems with
37
31
| None -> Alcotest.fail "expected member a"
38
-
| Some (_, v) ->
39
-
Alcotest.(check bool) "found 7" true (Json.Value.equal v v_seven)
32
+
| Some (_, v) -> Alcotest.(check bool) "found 7" true (Json.equal v v_seven)
40
33
41
34
let suite =
42
35
( "value",