Declarative JSON data manipulation for OCaml
wal, block, sse, zephyr: remove [mutable] from never-reassigned fields
Warning 69 (unused-field, mutable-never-assigned). Four independent
record fields were flagged as mutable but the code only mutates their
referents in place, never rebinds the record slot itself:
- ocaml-wal/lib/wal.ml: [t.file] (the Eio file resource; methods call
Eio.File.pwrite_all etc., the slot is set once at open time).
- ocaml-block/lib/block.ml: [Memory.state.data] (the backing bytes,
written via Bytes.blit_string; [Bytes.t] is already mutable).
- ocaml-sse/lib/sse.ml: [Parser.t.data_buf] (a Buffer.t, written via
Buffer.add_*; the slot never changes).
- ocaml-zephyr/lib/zephyr.ml: drop [mode : Read | Write] entirely —
set at open-time, read nowhere. The open_read / open_write
constructors already distinguish the two call shapes, so mode
tracking was redundant.
+2325
-2328
+12
-12
lib/bytesrw/json_bytesrw.ml
+12
-12
lib/bytesrw/json_bytesrw.ml
···
52
52
let u = Uchar.of_int u in
53
53
let b = Stdlib.Bytes.make (Uchar.utf_8_byte_length u) '\x00' in
54
54
Stdlib.(
55
-
ignore (Bytes.set_utf_8_uchar b 0 u);
55
+
Stdlib.ignore (Bytes.set_utf_8_uchar b 0 u);
56
56
Bytes.unsafe_to_string b)
57
57
58
58
(* A simple growable byte buffer used for token and whitespace
···
79
79
let[@inline] tokbuf_add_utf_8_uchar t u =
80
80
let n = Uchar.utf_8_byte_length u in
81
81
tokbuf_ensure t n;
82
-
ignore (Stdlib.Bytes.set_utf_8_uchar t.bytes t.len u : int);
82
+
Stdlib.ignore (Stdlib.Bytes.set_utf_8_uchar t.bytes t.len u : int);
83
83
t.len <- t.len + n
84
84
85
85
let[@inline] tokbuf_contents t = Stdlib.Bytes.sub_string t.bytes 0 t.len
···
152
152
153
153
let[@inline] textloc_of_pos d ~first_byte ~last_byte ~first_line_num
154
154
~first_line_byte ~last_line_num ~last_line_byte =
155
-
Loc.make ~file:d.file ~first_byte ~last_byte ~first_line_num
156
-
~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
157
158
158
let error_meta d =
159
159
let first_byte = last_byte_of d in
···
431
431
let false_uchars = [| 0x0066; 0x0061; 0x006C; 0x0073; 0x0065 |]
432
432
let true_uchars = [| 0x0074; 0x0072; 0x0075; 0x0065 |]
433
433
let null_uchars = [| 0x006E; 0x0075; 0x006C; 0x006C |]
434
-
let ascii_str us = String.init (Array.length us) (fun i -> Char.chr us.(i))
434
+
let ascii_str us = String.init (Stdlib.Array.length us) (fun i -> Char.chr us.(i))
435
435
436
436
let[@inline] is_ws u =
437
437
if u > 0x20 then false
···
634
634
| 0x007B (* { *) -> skip_json_object d
635
635
| 0x005B (* [ *) -> skip_json_array d
636
636
| 0x0022 (* DQUOTE *) -> skip_json_string d
637
-
| 0x006E (* n *) -> ignore (read_json_null d)
638
-
| 0x0074 (* t *) -> ignore (read_json_true d)
639
-
| 0x0066 (* f *) -> ignore (read_json_false d)
637
+
| 0x006E (* n *) -> Stdlib.ignore (read_json_null d)
638
+
| 0x0074 (* t *) -> Stdlib.ignore (read_json_true d)
639
+
| 0x0066 (* f *) -> Stdlib.ignore (read_json_false d)
640
640
| u when is_number_start u -> skip_json_number d
641
641
| _ -> err_not_json_value d
642
642
···
1090
1090
(* Because JSON can be out of order we don't know how to decode
1091
1091
this yet. Generic decode *)
1092
1092
let v =
1093
-
try decode d Json.json
1093
+
try decode d Json.codec
1094
1094
with Json.Error e ->
1095
1095
Json.Codec.error_push_object (error_meta d) map (name, meta) e
1096
1096
in
···
1336
1336
match e.format with
1337
1337
| Json.Minify ->
1338
1338
write_char e '[';
1339
-
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1339
+
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1340
1340
write_char e ']'
1341
1341
| Json.Layout ->
1342
1342
let meta = map.enc_meta v in
1343
1343
write_ws_before e meta;
1344
1344
write_char e '[';
1345
-
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1345
+
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1346
1346
write_char e ']';
1347
1347
write_ws_after e meta
1348
1348
| Json.Indent ->
···
1360
1360
e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[')
1361
1361
in
1362
1362
write_char e '[';
1363
-
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1363
+
Stdlib.ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1364
1364
if array_not_empty e then (
1365
1365
write_char e '\n';
1366
1366
write_indent e ~nest);
+9
-9
lib/bytesrw/json_bytesrw.mli
+9
-9
lib/bytesrw/json_bytesrw.mli
···
21
21
val decode :
22
22
?layout:bool ->
23
23
?locs:bool ->
24
-
?file:Json.Textloc.fpath ->
24
+
?file:Loc.fpath ->
25
25
'a Json.codec ->
26
26
Bytes.Reader.t ->
27
27
('a, string) result
···
31
31
- If [locs] is [true] locations are preserved in {!Json.Meta.t} values and
32
32
error messages are precisely located. Defaults to [false].
33
33
- [file] is the file path from which [r] is assumed to read. Defaults to
34
-
{!Json.Textloc.file_none}. *)
34
+
{!Loc.file_none}. *)
35
35
36
36
val decode' :
37
37
?layout:bool ->
38
38
?locs:bool ->
39
-
?file:Json.Textloc.fpath ->
39
+
?file:Loc.fpath ->
40
40
'a Json.codec ->
41
41
Bytes.Reader.t ->
42
42
('a, Json.Error.t) result
···
45
45
val decode_string :
46
46
?layout:bool ->
47
47
?locs:bool ->
48
-
?file:Json.Textloc.fpath ->
48
+
?file:Loc.fpath ->
49
49
'a Json.codec ->
50
50
string ->
51
51
('a, string) result
···
54
54
val decode_string' :
55
55
?layout:bool ->
56
56
?locs:bool ->
57
-
?file:Json.Textloc.fpath ->
57
+
?file:Loc.fpath ->
58
58
'a Json.codec ->
59
59
string ->
60
60
('a, Json.Error.t) result
···
120
120
val recode :
121
121
?layout:bool ->
122
122
?locs:bool ->
123
-
?file:Json.Textloc.fpath ->
123
+
?file:Loc.fpath ->
124
124
?buf:Bytes.t ->
125
125
?format:Json.format ->
126
126
?number_format:Json.number_format ->
···
134
134
val recode' :
135
135
?layout:bool ->
136
136
?locs:bool ->
137
-
?file:Json.Textloc.fpath ->
137
+
?file:Loc.fpath ->
138
138
?buf:Bytes.t ->
139
139
?format:Json.format ->
140
140
?number_format:Json.number_format ->
···
148
148
val recode_string :
149
149
?layout:bool ->
150
150
?locs:bool ->
151
-
?file:Json.Textloc.fpath ->
151
+
?file:Loc.fpath ->
152
152
?buf:Bytes.t ->
153
153
?format:Json.format ->
154
154
?number_format:Json.number_format ->
···
160
160
val recode_string' :
161
161
?layout:bool ->
162
162
?locs:bool ->
163
-
?file:Json.Textloc.fpath ->
163
+
?file:Loc.fpath ->
164
164
?buf:Bytes.t ->
165
165
?format:Json.format ->
166
166
?number_format:Json.number_format ->
+1280
-1323
lib/json.ml
+1280
-1323
lib/json.ml
···
6
6
module Fmt = Core.Fmt
7
7
8
8
let pp_kind = Fmt.code
9
-
let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind
10
-
let pp_name = Fmt.code
11
9
let pp_int ppf i = Fmt.code ppf (Int.to_string i)
12
10
13
11
module Meta = Loc.Meta
···
21
19
22
20
module Error = Error
23
21
24
-
(* Types *)
22
+
(* Public alias for codecs. *)
25
23
26
24
type 'a codec = 'a Codec.t
27
25
28
-
let kinded_sort = Codec.kinded_sort
29
-
let kind = Codec.kind
30
-
let doc = Codec.doc
31
-
let with_doc = Codec.with_doc
26
+
(* Generic JSON AST — lifted from the internal Value module. *)
32
27
33
-
(* Base types *)
28
+
type name = Value.name
29
+
type mem = Value.mem
30
+
type object' = Value.object'
34
31
35
-
let enc_meta_none _v = Meta.none
32
+
type t = Value.t =
33
+
| Null of unit node
34
+
| Bool of bool node
35
+
| Number of float node
36
+
| String of string node
37
+
| Array of t list node
38
+
| Object of object' node
36
39
37
-
module Base = struct
38
-
type ('a, 'b) map = ('a, 'b) Codec.base_map
40
+
type 'a cons = ?meta:Meta.t -> 'a -> t
39
41
40
-
let base_map_sort = "base map"
42
+
(* Pretty-printers *)
41
43
42
-
let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () =
43
-
let dec =
44
-
match dec with
45
-
| Some dec -> dec
46
-
| None ->
47
-
let kind = Sort.kinded' ~kind base_map_sort in
48
-
fun meta _v -> Error.no_decoder meta ~kind
49
-
in
50
-
let enc =
51
-
match enc with
52
-
| Some enc -> enc
53
-
| None ->
54
-
let kind = Sort.kinded' ~kind base_map_sort in
55
-
fun _v -> Error.no_encoder Meta.none ~kind
56
-
in
57
-
{ Codec.kind; doc; dec; enc; enc_meta }
44
+
let pp_null = Value.pp_null
45
+
let pp_bool = Value.pp_bool
46
+
let pp_string = Value.pp_string
47
+
let pp_number = Value.pp_number
48
+
let pp_number' = Value.pp_number'
49
+
let pp_json = Value.pp_json
50
+
let pp_json' = Value.pp_json'
51
+
let pp = pp_json
58
52
59
-
let id =
60
-
let dec _meta v = v and enc = Fun.id in
61
-
{ Codec.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
53
+
type number_format = Value.number_format
62
54
63
-
let ignore =
64
-
let kind = "ignore" in
65
-
let dec _meta _v = () in
66
-
let enc _v =
67
-
let kind = Sort.kinded' ~kind base_map_sort in
68
-
Error.no_encoder Meta.none ~kind
69
-
in
70
-
{ Codec.kind; doc = ""; dec; enc; enc_meta = enc_meta_none }
55
+
let default_number_format = Value.default_number_format
71
56
72
-
let null map = Codec.Null map
73
-
let bool map = Codec.Bool map
74
-
let number map = Codec.Number map
75
-
let string map = Codec.String map
76
-
let dec dec = fun _meta v -> dec v
57
+
(* Metadata and sort *)
77
58
78
-
let dec_result ?(kind = "") dec =
79
-
let kind = Sort.kinded' ~kind base_map_sort in
80
-
fun meta v ->
81
-
match dec v with Ok v -> v | Error e -> Error.for' meta ~kind e
59
+
let meta = Value.meta
60
+
let set_meta = Value.set_meta
61
+
let get_meta = Value.get_meta
62
+
let copy_layout = Value.copy_layout
63
+
let sort = Value.sort
82
64
83
-
let dec_failure ?(kind = "") dec =
84
-
let kind = Sort.kinded' ~kind base_map_sort in
85
-
fun meta v -> try dec v with Failure e -> Error.for' meta ~kind e
65
+
(* Equality and comparison *)
86
66
87
-
let enc = Fun.id
67
+
let equal = Value.equal
68
+
let compare = Value.compare
88
69
89
-
let enc_result ?(kind = "") enc =
90
-
let kind = Sort.kinded' ~kind base_map_sort in
91
-
fun v ->
92
-
match enc v with Ok v -> v | Error e -> Error.for' Meta.none ~kind e
70
+
(* Constructors *)
93
71
94
-
let enc_failure ?(kind = "") enc =
95
-
let kind = Sort.kinded' ~kind base_map_sort in
96
-
fun v -> try enc v with Failure e -> Error.for' Meta.none ~kind e
97
-
end
72
+
let null = Value.null
73
+
let bool = Value.bool
74
+
let number = Value.number
75
+
let any_float = Value.any_float
76
+
let int32 = Value.int32
77
+
let int64 = Value.int64
78
+
let int64_as_string = Value.int64_as_string
79
+
let int = Value.int
80
+
let int_as_string = Value.int_as_string
81
+
let string = Value.string
82
+
let list = Value.list
83
+
let array = Value.array
84
+
let object' = Value.object'
85
+
let empty_array = Value.empty_array
86
+
let empty_object = Value.empty_object
87
+
let option = Value.option
88
+
let name = Value.name
89
+
let mem = Value.mem
90
+
let zero = Value.zero
98
91
99
-
(* Any *)
92
+
(* Destructors / queries *)
100
93
101
-
let any ?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string
102
-
?dec_array ?dec_object ?enc () =
103
-
let enc =
104
-
match enc with
105
-
| Some enc -> enc
106
-
| None ->
107
-
let kind = Sort.kinded' ~kind "any" in
108
-
fun _v -> Error.no_encoder Meta.none ~kind
109
-
in
110
-
Codec.Any
111
-
{
112
-
kind;
113
-
doc;
114
-
dec_null;
115
-
dec_bool;
116
-
dec_number;
117
-
dec_string;
118
-
dec_array;
119
-
dec_object;
120
-
enc;
121
-
}
94
+
let find_mem = Value.find_mem
95
+
let find_mem' = Value.find_mem'
96
+
let object_names = Value.object_names
97
+
let object_names' = Value.object_names'
122
98
123
-
(* Maps and recursion *)
99
+
(* Codec combinators and low-level representation. This module re-exports
100
+
everything from [Codec] and adds the public combinator surface,
101
+
[Base]/[Array]/[Object] sub-submodules, and [Value] codecs. *)
124
102
125
-
let map ?(kind = "") ?(doc = "") ?dec ?enc dom =
126
-
let map_sort = "map" in
127
-
let dec =
128
-
match dec with
129
-
| Some dec -> dec
130
-
| None ->
131
-
let kind = Sort.kinded' ~kind map_sort in
132
-
fun _v -> Error.no_decoder Meta.none ~kind
133
-
in
134
-
let enc =
135
-
match enc with
136
-
| Some enc -> enc
137
-
| None ->
138
-
let kind = Sort.kinded' ~kind map_sort in
139
-
fun _v -> Error.no_encoder Meta.none ~kind
140
-
in
141
-
Codec.Map { kind; doc; dom; dec; enc }
103
+
module Codec = struct
104
+
include Codec
142
105
143
-
let iter ?(kind = "") ?(doc = "") ?dec ?enc dom =
144
-
let dec =
145
-
match dec with
146
-
| None -> Fun.id
147
-
| Some dec ->
148
-
fun v ->
149
-
dec v;
150
-
v
151
-
in
152
-
let enc =
153
-
match enc with
154
-
| None -> Fun.id
155
-
| Some enc ->
156
-
fun v ->
157
-
enc v;
158
-
v
159
-
in
160
-
Codec.Map { kind; doc; dom; dec; enc }
106
+
let enc_meta_none _v = Meta.none
161
107
162
-
let rec' t = Codec.Rec t
108
+
(* Base types *)
163
109
164
-
(* Nulls and options *)
110
+
module Base = struct
111
+
type ('a, 'b) map = ('a, 'b) base_map
165
112
166
-
let null ?kind ?doc v =
167
-
let dec _meta () = v and enc _meta = () in
168
-
Codec.Null (Base.map ?doc ?kind ~dec ~enc ())
113
+
let base_map_sort = "base map"
169
114
170
-
let none =
171
-
let none =
172
-
(* Can't use [Base.map] because of the value restriction. *)
173
-
let dec _meta _v = None and enc _ = () in
174
-
{ Codec.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
175
-
in
176
-
Codec.Null none
115
+
let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () =
116
+
let dec =
117
+
match dec with
118
+
| Some dec -> dec
119
+
| None ->
120
+
let kind = Sort.kinded' ~kind base_map_sort in
121
+
fun meta _v -> Error.no_decoder meta ~kind
122
+
in
123
+
let enc =
124
+
match enc with
125
+
| Some enc -> enc
126
+
| None ->
127
+
let kind = Sort.kinded' ~kind base_map_sort in
128
+
fun _v -> Error.no_encoder Meta.none ~kind
129
+
in
130
+
{ kind; doc; dec; enc; enc_meta }
177
131
178
-
let some t = map ~dec:Option.some ~enc:Option.get t
132
+
let id =
133
+
let dec _meta v = v and enc = Fun.id in
134
+
{ kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
179
135
180
-
let option : type a.
181
-
?kind:string -> ?doc:string -> a Codec.t -> a option Codec.t =
182
-
fun ?kind ?doc t ->
183
-
let some = some t in
184
-
let enc = function None -> none | Some _ -> some in
185
-
match t with
186
-
| Null _ -> any ?doc ?kind ~dec_null:none ~enc ()
187
-
| Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc ()
188
-
| Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc ()
189
-
| String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc ()
190
-
| Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc ()
191
-
| Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc ()
192
-
| Any _ | Map _ | Rec _ | Ignore ->
193
-
any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some
194
-
~dec_string:some ~dec_array:some ~dec_object:some ~enc ()
136
+
let ignore =
137
+
let kind = "ignore" in
138
+
let dec _meta _v = () in
139
+
let enc _v =
140
+
let kind = Sort.kinded' ~kind base_map_sort in
141
+
Error.no_encoder Meta.none ~kind
142
+
in
143
+
{ kind; doc = ""; dec; enc; enc_meta = enc_meta_none }
195
144
196
-
(* Booleans *)
145
+
let null map = Null map
146
+
let bool map = Bool map
147
+
let number map = Number map
148
+
let string map = String map
149
+
let dec dec = fun _meta v -> dec v
197
150
198
-
let bool = Codec.Bool Base.id
151
+
let dec_result ?(kind = "") dec =
152
+
let kind = Sort.kinded' ~kind base_map_sort in
153
+
fun meta v ->
154
+
match dec v with Ok v -> v | Error e -> Error.for' meta ~kind e
199
155
200
-
(* Numbers *)
156
+
let dec_failure ?(kind = "") dec =
157
+
let kind = Sort.kinded' ~kind base_map_sort in
158
+
fun meta v -> try dec v with Failure e -> Error.for' meta ~kind e
201
159
202
-
let[@inline] check_finite_number meta ~kind v =
203
-
if Float.is_finite v then ()
204
-
else Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null
160
+
let enc = Fun.id
205
161
206
-
let number = Codec.Number Base.id
162
+
let enc_result ?(kind = "") enc =
163
+
let kind = Sort.kinded' ~kind base_map_sort in
164
+
fun v ->
165
+
match enc v with Ok v -> v | Error e -> Error.for' Meta.none ~kind e
207
166
208
-
let any_float =
209
-
let kind = "float" in
210
-
let finite = number in
211
-
let non_finite =
212
-
let dec m v =
213
-
match Float.of_string_opt v with
214
-
| Some v -> v
215
-
| None -> Error.parse_string_number m ~kind v
216
-
in
217
-
Base.string (Base.map ~kind ~dec ~enc:Float.to_string ())
218
-
in
219
-
let enc v = if Float.is_finite v then finite else non_finite in
220
-
any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc ()
167
+
let enc_failure ?(kind = "") enc =
168
+
let kind = Sort.kinded' ~kind base_map_sort in
169
+
fun v -> try enc v with Failure e -> Error.for' Meta.none ~kind e
170
+
end
221
171
222
-
let float_as_hex_string =
223
-
let kind = "float" in
224
-
let dec meta v =
225
-
match Float.of_string_opt v with
226
-
| Some v -> v
227
-
| None -> Error.parse_string_number meta ~kind v
228
-
in
229
-
let enc v = Fmt.str "%h" v in
230
-
Base.string (Base.map ~kind ~dec ~enc ())
172
+
(* Any JSON value (RFC 8259 s. 3) *)
231
173
232
-
let uint8 =
233
-
let kind = "uint8" in
234
-
let dec meta v =
235
-
check_finite_number meta ~kind v;
236
-
if Core.Number.in_exact_uint8_range v then Int.of_float v
237
-
else Error.number_range meta ~kind v
238
-
in
239
-
let enc v =
240
-
if Core.Number.int_is_uint8 v then Int.to_float v
241
-
else Error.integer_range Meta.none ~kind v
242
-
in
243
-
Base.number (Base.map ~kind ~dec ~enc ())
174
+
let any ?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string
175
+
?dec_array ?dec_object ?enc () =
176
+
let enc =
177
+
match enc with
178
+
| Some enc -> enc
179
+
| None ->
180
+
let kind = Sort.kinded' ~kind "value" in
181
+
fun _v -> Error.no_encoder Meta.none ~kind
182
+
in
183
+
Any
184
+
{
185
+
kind;
186
+
doc;
187
+
dec_null;
188
+
dec_bool;
189
+
dec_number;
190
+
dec_string;
191
+
dec_array;
192
+
dec_object;
193
+
enc;
194
+
}
244
195
245
-
let uint16 =
246
-
let kind = "uint16" in
247
-
let dec meta v =
248
-
check_finite_number meta ~kind v;
249
-
if Core.Number.in_exact_uint16_range v then Int.of_float v
250
-
else Error.number_range meta ~kind v
251
-
in
252
-
let enc v =
253
-
if Core.Number.int_is_uint16 v then Int.to_float v
254
-
else Error.integer_range Meta.none ~kind v
255
-
in
256
-
Base.number (Base.map ~kind ~dec ~enc ())
196
+
(* Maps and recursion *)
257
197
258
-
let int8 =
259
-
let kind = "int8" in
260
-
let dec meta v =
261
-
check_finite_number meta ~kind v;
262
-
if Core.Number.in_exact_int8_range v then Int.of_float v
263
-
else Error.number_range meta ~kind v
264
-
in
265
-
let enc v =
266
-
if Core.Number.int_is_int8 v then Int.to_float v
267
-
else Error.integer_range Meta.none ~kind v
268
-
in
269
-
Base.number (Base.map ~kind ~dec ~enc ())
198
+
let map ?(kind = "") ?(doc = "") ?dec ?enc dom =
199
+
let map_sort = "map" in
200
+
let dec =
201
+
match dec with
202
+
| Some dec -> dec
203
+
| None ->
204
+
let kind = Sort.kinded' ~kind map_sort in
205
+
fun _v -> Error.no_decoder Meta.none ~kind
206
+
in
207
+
let enc =
208
+
match enc with
209
+
| Some enc -> enc
210
+
| None ->
211
+
let kind = Sort.kinded' ~kind map_sort in
212
+
fun _v -> Error.no_encoder Meta.none ~kind
213
+
in
214
+
Map { kind; doc; dom; dec; enc }
270
215
271
-
let int16 =
272
-
let kind = "int16" in
273
-
let dec meta v =
274
-
check_finite_number meta ~kind v;
275
-
if Core.Number.in_exact_int16_range v then Int.of_float v
276
-
else Error.number_range meta ~kind v
277
-
in
278
-
let enc v =
279
-
if Core.Number.int_is_int16 v then Int.to_float v
280
-
else Error.integer_range Meta.none ~kind v
281
-
in
282
-
Base.number (Base.map ~kind ~dec ~enc ())
216
+
let iter ?(kind = "") ?(doc = "") ?dec ?enc dom =
217
+
let dec =
218
+
match dec with
219
+
| None -> Fun.id
220
+
| Some dec ->
221
+
fun v ->
222
+
dec v;
223
+
v
224
+
in
225
+
let enc =
226
+
match enc with
227
+
| None -> Fun.id
228
+
| Some enc ->
229
+
fun v ->
230
+
enc v;
231
+
v
232
+
in
233
+
Map { kind; doc; dom; dec; enc }
283
234
284
-
let int32 =
285
-
let kind = "int32" in
286
-
let dec meta v =
287
-
check_finite_number meta ~kind v;
288
-
if Core.Number.in_exact_int32_range v then Int32.of_float v
289
-
else Error.number_range meta ~kind v
290
-
in
291
-
let enc =
292
-
Int32.to_float
293
-
(* Everything always fits *)
294
-
in
295
-
Base.number (Base.map ~kind ~dec ~enc ())
235
+
let rec' t = Rec t
296
236
297
-
let int64_as_string =
298
-
let kind = "int64" in
299
-
let dec meta v =
300
-
match Int64.of_string_opt v with
301
-
| Some v -> v
302
-
| None -> Error.parse_string_number meta ~kind v
303
-
in
304
-
Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ())
237
+
(* Nulls and options *)
305
238
306
-
let int64_number =
307
-
(* Usage by [int64] entails there's no need to test for nan or check
308
-
range on encoding. *)
309
-
let kind = "int64" in
310
-
let dec meta v =
311
-
if Core.Number.in_exact_int64_range v then Int64.of_float v
312
-
else Error.number_range meta ~kind v
313
-
in
314
-
Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ())
239
+
let null ?kind ?doc v =
240
+
let dec _meta () = v and enc _meta = () in
241
+
Null (Base.map ?doc ?kind ~dec ~enc ())
315
242
316
-
let int64 =
317
-
let dec_number = int64_number and dec_string = int64_as_string in
318
-
let enc v =
319
-
if Core.Number.can_store_exact_int64 v then int64_number
320
-
else int64_as_string
321
-
in
322
-
any ~kind:"int64" ~dec_number ~dec_string ~enc ()
243
+
let none =
244
+
let none =
245
+
let dec _meta _v = None and enc _ = () in
246
+
{ kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
247
+
in
248
+
Null none
323
249
324
-
let int_as_string =
325
-
let kind = "OCaml int" in
326
-
let dec meta v =
327
-
match int_of_string_opt v with
328
-
| Some v -> v
329
-
| None -> Error.parse_string_number meta ~kind v
330
-
in
331
-
Base.string (Base.map ~kind ~dec ~enc:Int.to_string ())
250
+
let some t = map ~dec:Option.some ~enc:Option.get t
332
251
333
-
let int_number =
334
-
(* Usage by [int] entails there's no need to test for nan or check range on
335
-
encoding. *)
336
-
let kind = "OCaml int" in
337
-
let dec meta v =
338
-
if Core.Number.in_exact_int_range v then Int.of_float v
339
-
else Error.number_range meta ~kind v
340
-
in
341
-
Base.number (Base.map ~kind ~dec ~enc:Int.to_float ())
252
+
let option : type a. ?kind:string -> ?doc:string -> a t -> a option t =
253
+
fun ?kind ?doc t ->
254
+
let some = some t in
255
+
let enc = function None -> none | Some _ -> some in
256
+
match t with
257
+
| Null _ -> any ?doc ?kind ~dec_null:none ~enc ()
258
+
| Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc ()
259
+
| Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc ()
260
+
| String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc ()
261
+
| Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc ()
262
+
| Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc ()
263
+
| Any _ | Map _ | Rec _ | Ignore ->
264
+
any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some
265
+
~dec_string:some ~dec_array:some ~dec_object:some ~enc ()
342
266
343
-
let int =
344
-
let enc v =
345
-
if Core.Number.can_store_exact_int v then int_number else int_as_string
346
-
in
347
-
let dec_number = int_number and dec_string = int_as_string in
348
-
any ~kind:"OCaml int" ~dec_number ~dec_string ~enc ()
267
+
(* Booleans *)
349
268
350
-
(* String and enums *)
269
+
let bool = Bool Base.id
351
270
352
-
let string = Codec.String Base.id
271
+
(* Numbers *)
353
272
354
-
let of_of_string ?kind ?doc ?enc of_string =
355
-
let dec = Base.dec_result ?kind of_string in
356
-
let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in
357
-
Base.string (Base.map ?kind ?doc ?enc ~dec ())
273
+
let[@inline] check_finite_number meta ~kind v =
274
+
if Float.is_finite v then ()
275
+
else Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null
358
276
359
-
let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc =
360
-
let kind = Sort.kinded' ~kind "enum" in
361
-
let dec_map =
362
-
let add m (k, v) = Codec.String_map.add k v m in
363
-
let m = List.fold_left add Codec.String_map.empty assoc in
364
-
fun k -> Codec.String_map.find_opt k m
365
-
in
366
-
let enc_map =
367
-
let module M = Map.Make (struct
368
-
type t = a
277
+
let number = Number Base.id
369
278
370
-
let compare = cmp
371
-
end) in
372
-
let add m (k, v) = M.add v k m in
373
-
let m = List.fold_left add M.empty assoc in
374
-
fun v -> M.find_opt v m
375
-
in
376
-
let dec meta s =
377
-
match dec_map s with
378
-
| Some v -> v
379
-
| None ->
380
-
let kind = Sort.kinded ~kind String in
381
-
let pp_kind ppf () = Fmt.pf ppf "%a value" Codec.pp_kind kind in
382
-
Error.msgf meta "%a" (Fmt.out_of_dom ~pp_kind ()) (s, List.map fst assoc)
383
-
in
384
-
let enc v =
385
-
match enc_map v with
386
-
| Some s -> s
387
-
| None ->
388
-
Error.msgf Meta.none "Encode %a: unknown enum value" Codec.pp_kind kind
389
-
in
390
-
Base.string (Base.map ~kind ?doc ~dec ~enc ())
279
+
let any_float =
280
+
let kind = "float" in
281
+
let finite = number in
282
+
let non_finite =
283
+
let dec m v =
284
+
match Float.of_string_opt v with
285
+
| Some v -> v
286
+
| None -> Error.parse_string_number m ~kind v
287
+
in
288
+
Base.string (Base.map ~kind ~dec ~enc:Float.to_string ())
289
+
in
290
+
let enc v = if Float.is_finite v then finite else non_finite in
291
+
any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc ()
391
292
392
-
let binary_string =
393
-
let kind = "hex" in
394
-
let kind' = Sort.kinded ~kind String in
395
-
let dec = Base.dec_result ~kind:kind' Core.binary_string_of_hex in
396
-
let enc = Base.enc Core.binary_string_to_hex in
397
-
Base.string (Base.map ~kind ~dec ~enc ())
398
-
399
-
(* Arrays and tuples *)
400
-
401
-
module Array = struct
402
-
type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) Codec.array_map
403
-
404
-
type ('array, 'elt) enc = {
405
-
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
406
-
}
407
-
408
-
let array_kind kind = Sort.kinded ~kind Sort.Array
409
-
let default_skip _i _builder = false
293
+
let float_as_hex_string =
294
+
let kind = "float" in
295
+
let dec meta v =
296
+
match Float.of_string_opt v with
297
+
| Some v -> v
298
+
| None -> Error.parse_string_number meta ~kind v
299
+
in
300
+
let enc v = Fmt.str "%h" v in
301
+
Base.string (Base.map ~kind ~dec ~enc ())
410
302
411
-
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish
412
-
?enc ?(enc_meta = enc_meta_none) elt =
413
-
let dec_empty =
414
-
match dec_empty with
415
-
| Some dec_empty -> dec_empty
416
-
| None -> fun () -> Error.no_decoder Meta.none ~kind:(array_kind kind)
303
+
let uint8 =
304
+
let kind = "uint8" in
305
+
let dec meta v =
306
+
check_finite_number meta ~kind v;
307
+
if Core.Number.in_exact_uint8_range v then Int.of_float v
308
+
else Error.number_range meta ~kind v
417
309
in
418
-
let dec_skip = Option.value ~default:default_skip dec_skip in
419
-
let dec_add =
420
-
match dec_add with
421
-
| Some dec_add -> dec_add
422
-
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
310
+
let enc v =
311
+
if Core.Number.int_is_uint8 v then Int.to_float v
312
+
else Error.integer_range Meta.none ~kind v
423
313
in
424
-
let dec_finish =
425
-
match dec_finish with
426
-
| Some dec_finish -> dec_finish
427
-
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
314
+
Base.number (Base.map ~kind ~dec ~enc ())
315
+
316
+
let uint16 =
317
+
let kind = "uint16" in
318
+
let dec meta v =
319
+
check_finite_number meta ~kind v;
320
+
if Core.Number.in_exact_uint16_range v then Int.of_float v
321
+
else Error.number_range meta ~kind v
428
322
in
429
-
let enc =
430
-
match enc with
431
-
| Some { enc } -> enc
432
-
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind)
323
+
let enc v =
324
+
if Core.Number.int_is_uint16 v then Int.to_float v
325
+
else Error.integer_range Meta.none ~kind v
433
326
in
434
-
{
435
-
Codec.kind;
436
-
doc;
437
-
elt;
438
-
dec_empty;
439
-
dec_add;
440
-
dec_skip;
441
-
dec_finish;
442
-
enc;
443
-
enc_meta;
444
-
}
327
+
Base.number (Base.map ~kind ~dec ~enc ())
445
328
446
-
let list_enc f acc l =
447
-
let rec loop f acc i = function
448
-
| [] -> acc
449
-
| v :: l -> loop f (f acc i v) (i + 1) l
329
+
let int8 =
330
+
let kind = "int8" in
331
+
let dec meta v =
332
+
check_finite_number meta ~kind v;
333
+
if Core.Number.in_exact_int8_range v then Int.of_float v
334
+
else Error.number_range meta ~kind v
450
335
in
451
-
loop f acc 0 l
452
-
453
-
let list_map ?kind ?doc ?dec_skip elt =
454
-
let dec_empty () = [] in
455
-
let dec_add _i v l = v :: l in
456
-
let dec_finish _meta _len l = List.rev l in
457
-
let enc = { enc = list_enc } in
458
-
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
459
-
460
-
type 'a array_builder = 'a Core.Rarray.t
461
-
462
-
let array_enc f acc a =
463
-
let acc = ref acc in
464
-
for i = 0 to Array.length a - 1 do
465
-
acc := f !acc i (Array.unsafe_get a i)
466
-
done;
467
-
!acc
468
-
469
-
let array_map ?kind ?doc ?dec_skip elt =
470
-
let dec_empty () = Core.Rarray.empty () in
471
-
let dec_add _i v a = Core.Rarray.add_last v a in
472
-
let dec_finish _meta _len a = Core.Rarray.to_array a in
473
-
let enc = { enc = array_enc } in
474
-
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
336
+
let enc v =
337
+
if Core.Number.int_is_int8 v then Int.to_float v
338
+
else Error.integer_range Meta.none ~kind v
339
+
in
340
+
Base.number (Base.map ~kind ~dec ~enc ())
475
341
476
-
type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Core.Rbigarray1.t
342
+
let int16 =
343
+
let kind = "int16" in
344
+
let dec meta v =
345
+
check_finite_number meta ~kind v;
346
+
if Core.Number.in_exact_int16_range v then Int.of_float v
347
+
else Error.number_range meta ~kind v
348
+
in
349
+
let enc v =
350
+
if Core.Number.int_is_int16 v then Int.to_float v
351
+
else Error.integer_range Meta.none ~kind v
352
+
in
353
+
Base.number (Base.map ~kind ~dec ~enc ())
477
354
478
-
let bigarray_map ?kind ?doc ?dec_skip k l elt =
479
-
let dec_empty _meta = Core.Rbigarray1.empty k l in
480
-
let dec_add _i v a = Core.Rbigarray1.add_last v a in
481
-
let dec_finish _meta _len a = Core.Rbigarray1.to_bigarray a in
482
-
let enc f acc a =
483
-
let acc = ref acc in
484
-
for i = 0 to Bigarray.Array1.dim a - 1 do
485
-
acc := f !acc i (Bigarray.Array1.unsafe_get a i)
486
-
done;
487
-
!acc
355
+
let int32 =
356
+
let kind = "int32" in
357
+
let dec meta v =
358
+
check_finite_number meta ~kind v;
359
+
if Core.Number.in_exact_int32_range v then Int32.of_float v
360
+
else Error.number_range meta ~kind v
488
361
in
489
-
let enc = { enc } in
490
-
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
362
+
let enc = Int32.to_float in
363
+
Base.number (Base.map ~kind ~dec ~enc ())
491
364
492
-
let array map = Codec.Array map
365
+
let int64_as_string =
366
+
let kind = "int64" in
367
+
let dec meta v =
368
+
match Int64.of_string_opt v with
369
+
| Some v -> v
370
+
| None -> Error.parse_string_number meta ~kind v
371
+
in
372
+
Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ())
493
373
494
-
let stub_elt =
495
-
Codec.Map
496
-
{
497
-
kind = "";
498
-
doc = "";
499
-
dom = Base.(null id);
500
-
enc = (fun _ -> assert false);
501
-
dec = (fun _ -> assert false);
502
-
}
374
+
let int64_number =
375
+
let kind = "int64" in
376
+
let dec meta v =
377
+
if Core.Number.in_exact_int64_range v then Int64.of_float v
378
+
else Error.number_range meta ~kind v
379
+
in
380
+
Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ())
503
381
504
-
let ignore =
505
-
let kind = "ignore" in
506
-
let kind' = Sort.kinded ~kind Array in
507
-
let dec_empty () = () and dec_add _i _v () = () in
508
-
let dec_skip _i () = true and dec_finish _meta _len () = () in
509
-
let enc =
510
-
{ enc = (fun _ _ () -> Error.no_encoder Meta.none ~kind:kind') }
382
+
let int64 =
383
+
let dec_number = int64_number and dec_string = int64_as_string in
384
+
let enc v =
385
+
if Core.Number.can_store_exact_int64 v then int64_number
386
+
else int64_as_string
511
387
in
512
-
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
388
+
any ~kind:"int64" ~dec_number ~dec_string ~enc ()
513
389
514
-
let zero =
515
-
let dec_empty () = () and dec_add _i _v () = () in
516
-
let dec_skip _i () = true and dec_finish _meta _len () = () in
517
-
let enc = { enc = (fun _ acc () -> acc) } in
518
-
let kind = "zero" in
519
-
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
520
-
end
390
+
let int_as_string =
391
+
let kind = "OCaml int" in
392
+
let dec meta v =
393
+
match int_of_string_opt v with
394
+
| Some v -> v
395
+
| None -> Error.parse_string_number meta ~kind v
396
+
in
397
+
Base.string (Base.map ~kind ~dec ~enc:Int.to_string ())
521
398
522
-
let list ?kind ?doc t = Codec.Array (Array.list_map ?kind ?doc t)
523
-
let array ?kind ?doc t = Codec.Array (Array.array_map ?kind ?doc t)
399
+
let int_number =
400
+
let kind = "OCaml int" in
401
+
let dec meta v =
402
+
if Core.Number.in_exact_int_range v then Int.of_float v
403
+
else Error.number_range meta ~kind v
404
+
in
405
+
Base.number (Base.map ~kind ~dec ~enc:Int.to_float ())
524
406
525
-
let array_as_string_map ?kind ?doc ~key t =
526
-
let dec_empty () = Codec.String_map.empty in
527
-
let dec_add _i elt acc = Codec.String_map.add (key elt) elt acc in
528
-
let dec_finish _meta _len acc = acc in
529
-
let enc f acc m =
530
-
let i = ref (-1) in
531
-
Codec.String_map.fold
532
-
(fun _ elt acc ->
533
-
incr i;
534
-
f acc !i elt)
535
-
m acc
536
-
in
537
-
let enc = Array.{ enc } in
538
-
let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in
539
-
Codec.Array map
407
+
let int =
408
+
let enc v =
409
+
if Core.Number.can_store_exact_int v then int_number else int_as_string
410
+
in
411
+
let dec_number = int_number and dec_string = int_as_string in
412
+
any ~kind:"OCaml int" ~dec_number ~dec_string ~enc ()
540
413
541
-
let bigarray ?kind ?doc k t =
542
-
Codec.Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t)
414
+
(* Strings and enums *)
543
415
544
-
let tuple_no_decoder ~kind meta =
545
-
Error.no_decoder meta ~kind:(Sort.kinded' ~kind "tuple")
416
+
let string = String Base.id
546
417
547
-
let tuple_no_encoder ~kind =
548
-
Error.no_encoder Meta.none ~kind:(Sort.kinded' ~kind "tuple")
418
+
let of_of_string ?kind ?doc ?enc of_string =
419
+
let dec = Base.dec_result ?kind of_string in
420
+
let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in
421
+
Base.string (Base.map ?kind ?doc ?enc ~dec ())
549
422
550
-
let error_tuple_size meta kind ~exp fnd =
551
-
Error.msgf meta "Expected %a elements in %a but found %a" pp_int exp pp_kind
552
-
(Sort.kinded' ~kind "tuple")
553
-
pp_int fnd
423
+
let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc =
424
+
let kind = Sort.kinded' ~kind "enum" in
425
+
let dec_map =
426
+
let add m (k, v) = String_map.add k v m in
427
+
let m = List.fold_left add String_map.empty assoc in
428
+
fun k -> String_map.find_opt k m
429
+
in
430
+
let enc_map =
431
+
let module M = Map.Make (struct
432
+
type t = a
554
433
555
-
let t2 ?(kind = "") ?doc ?dec ?enc t =
556
-
let size = 2 in
557
-
let dec =
558
-
match dec with
559
-
| None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta
560
-
| Some dec -> fun _meta v0 v1 -> dec v0 v1
561
-
in
562
-
let dec_empty () = [] in
563
-
let dec_add _i v acc = v :: acc in
564
-
let dec_finish meta _len = function
565
-
| [ v1; v0 ] -> dec meta v0 v1
566
-
| l -> error_tuple_size meta kind ~exp:size (List.length l)
567
-
in
568
-
let enc =
569
-
match enc with
570
-
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
571
-
| Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1)
572
-
in
573
-
let enc = { Array.enc } in
574
-
Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
434
+
let compare = cmp
435
+
end) in
436
+
let add m (k, v) = M.add v k m in
437
+
let m = List.fold_left add M.empty assoc in
438
+
fun v -> M.find_opt v m
439
+
in
440
+
let dec meta s =
441
+
match dec_map s with
442
+
| Some v -> v
443
+
| None ->
444
+
let kind = Sort.kinded ~kind String in
445
+
let pp_kind ppf () = Fmt.pf ppf "%a value" pp_code kind in
446
+
Error.msgf meta "%a" (Fmt.out_of_dom ~pp_kind ()) (s, List.map fst assoc)
447
+
in
448
+
let enc v =
449
+
match enc_map v with
450
+
| Some s -> s
451
+
| None -> Error.msgf Meta.none "Encode %a: unknown enum value" pp_code kind
452
+
in
453
+
Base.string (Base.map ~kind ?doc ~dec ~enc ())
575
454
576
-
let t3 ?(kind = "") ?doc ?dec ?enc t =
577
-
let size = 3 in
578
-
let dec =
579
-
match dec with
580
-
| None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta
581
-
| Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2
582
-
in
583
-
let dec_empty () = [] in
584
-
let dec_add _i v acc = v :: acc in
585
-
let dec_finish meta _len = function
586
-
| [ v2; v1; v0 ] -> dec meta v0 v1 v2
587
-
| l -> error_tuple_size meta kind ~exp:size (List.length l)
588
-
in
589
-
let enc =
590
-
match enc with
591
-
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
592
-
| Some enc ->
593
-
fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)
594
-
in
595
-
let enc = { Array.enc } in
596
-
Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
455
+
let binary_string =
456
+
let kind = "hex" in
457
+
let kind' = Sort.kinded ~kind String in
458
+
let dec = Base.dec_result ~kind:kind' Core.binary_string_of_hex in
459
+
let enc = Base.enc Core.binary_string_to_hex in
460
+
Base.string (Base.map ~kind ~dec ~enc ())
597
461
598
-
let t4 ?(kind = "") ?doc ?dec ?enc t =
599
-
let size = 4 in
600
-
let dec =
601
-
match dec with
602
-
| None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta
603
-
| Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3
604
-
in
605
-
let dec_empty () = [] in
606
-
let dec_add _i v acc = v :: acc in
607
-
let dec_finish meta _len = function
608
-
| [ v3; v2; v1; v0 ] -> dec meta v0 v1 v2 v3
609
-
| l -> error_tuple_size meta kind ~exp:size (List.length l)
610
-
in
611
-
let enc =
612
-
match enc with
613
-
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
614
-
| Some enc ->
615
-
fun f acc v ->
616
-
f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3)
617
-
in
618
-
let enc = { Array.enc } in
619
-
Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
462
+
(* Arrays and tuples *)
620
463
621
-
let tn ?(kind = "") ?doc ~n elt =
622
-
let dec_empty () = Core.Rarray.empty () in
623
-
let dec_add _i v a = Core.Rarray.add_last v a in
624
-
let dec_finish meta _len a =
625
-
let len = Core.Rarray.length a in
626
-
if len <> n then error_tuple_size meta kind ~exp:n len
627
-
else Core.Rarray.to_array a
628
-
in
629
-
let enc = { Array.enc = Array.array_enc } in
630
-
Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt)
464
+
module Array = struct
465
+
type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) array_map
631
466
632
-
(* Objects *)
467
+
type ('array, 'elt) enc = {
468
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
469
+
}
633
470
634
-
module Object = struct
635
-
open Codec
471
+
let array_kind kind = Sort.kinded ~kind Sort.Array
472
+
let default_skip _i _builder = false
636
473
637
-
(* Maps *)
474
+
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish
475
+
?enc ?(enc_meta = enc_meta_none) elt =
476
+
let dec_empty =
477
+
match dec_empty with
478
+
| Some dec_empty -> dec_empty
479
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(array_kind kind)
480
+
in
481
+
let dec_skip = Option.value ~default:default_skip dec_skip in
482
+
let dec_add =
483
+
match dec_add with
484
+
| Some dec_add -> dec_add
485
+
| None ->
486
+
fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
487
+
in
488
+
let dec_finish =
489
+
match dec_finish with
490
+
| Some dec_finish -> dec_finish
491
+
| None ->
492
+
fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
493
+
in
494
+
let enc =
495
+
match enc with
496
+
| Some { enc } -> enc
497
+
| None ->
498
+
fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind)
499
+
in
500
+
{
501
+
kind;
502
+
doc;
503
+
elt;
504
+
dec_empty;
505
+
dec_add;
506
+
dec_skip;
507
+
dec_finish;
508
+
enc;
509
+
enc_meta;
510
+
}
638
511
639
-
type ('o, 'dec) map = ('o, 'dec) object_map
512
+
let list_enc f acc l =
513
+
let rec loop f acc i = function
514
+
| [] -> acc
515
+
| v :: l -> loop f (f acc i v) (i + 1) l
516
+
in
517
+
loop f acc 0 l
640
518
641
-
let default_shape = Object_basic Unknown_skip
519
+
let list_map ?kind ?doc ?dec_skip elt =
520
+
let dec_empty () = [] in
521
+
let dec_add _i v l = v :: l in
522
+
let dec_finish _meta _len l = List.rev l in
523
+
let enc = { enc = list_enc } in
524
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
642
525
643
-
let raw_map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec =
644
-
{
645
-
kind;
646
-
doc;
647
-
dec;
648
-
mem_decs = String_map.empty;
649
-
mem_encs = [];
650
-
enc_meta;
651
-
shape = default_shape;
652
-
}
526
+
type 'a array_builder = 'a Core.Rarray.t
653
527
654
-
let map ?kind ?doc dec = raw_map ?kind ?doc (Dec_fun dec)
528
+
let array_enc f acc a =
529
+
let acc = ref acc in
530
+
for i = 0 to Stdlib.Array.length a - 1 do
531
+
acc := f !acc i (Stdlib.Array.unsafe_get a i)
532
+
done;
533
+
!acc
655
534
656
-
let map' ?kind ?doc ?enc_meta dec =
657
-
raw_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg))
658
-
659
-
let enc_only ?(kind = "") ?doc ?enc_meta () =
660
-
let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in
661
-
map' ~kind ?doc ?enc_meta dec
662
-
663
-
let check_name_unicity m =
664
-
let add n kind = function
665
-
| None -> Some kind
666
-
| Some kind' ->
667
-
let ks k = Sort.or_kind ~kind Object in
668
-
let k0 = ks kind and k1 = ks kind' in
669
-
invalid_arg
670
-
@@
671
-
if String.equal k0 k1 then
672
-
Fmt.str "member %s defined twice in %s" n k0
673
-
else Fmt.str "member %s defined both in %s and %s" n k0 k1
674
-
in
675
-
let rec loop : type o dec.
676
-
string String_map.t -> (o, dec) object_map -> unit =
677
-
fun names m ->
678
-
let add_name names n = String_map.update n (add n m.kind) names in
679
-
let add_mem_enc names (Mem_enc m) = add_name names m.name in
680
-
let names = List.fold_left add_mem_enc names m.mem_encs in
681
-
match m.shape with
682
-
| Object_basic _ -> ()
683
-
| Object_cases (u, cases) ->
684
-
let names = add_name names cases.tag.name in
685
-
let check_case (Case c) = loop names c.object_map in
686
-
List.iter check_case cases.cases
687
-
in
688
-
loop String_map.empty m
535
+
let array_map ?kind ?doc ?dec_skip elt =
536
+
let dec_empty () = Core.Rarray.empty () in
537
+
let dec_add _i v a = Core.Rarray.add_last v a in
538
+
let dec_finish _meta _len a = Core.Rarray.to_array a in
539
+
let enc = { enc = array_enc } in
540
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
689
541
690
-
let finish mems =
691
-
let () = check_name_unicity mems in
692
-
Object { mems with mem_encs = List.rev mems.mem_encs }
542
+
type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Core.Rbigarray1.t
693
543
694
-
let get_object_map = function
695
-
| Object map -> map
696
-
| _ -> invalid_arg "Not an object"
544
+
let bigarray_map ?kind ?doc ?dec_skip k l elt =
545
+
let dec_empty _meta = Core.Rbigarray1.empty k l in
546
+
let dec_add _i v a = Core.Rbigarray1.add_last v a in
547
+
let dec_finish _meta _len a = Core.Rbigarray1.to_bigarray a in
548
+
let enc f acc a =
549
+
let acc = ref acc in
550
+
for i = 0 to Bigarray.Array1.dim a - 1 do
551
+
acc := f !acc i (Bigarray.Array1.unsafe_get a i)
552
+
done;
553
+
!acc
554
+
in
555
+
let enc = { enc } in
556
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
697
557
698
-
(* Members *)
558
+
let array map = Array map
699
559
700
-
module Mem = struct
701
-
type ('o, 'a) map = ('o, 'a) Codec.mem_map
560
+
let stub_elt =
561
+
Map
562
+
{
563
+
kind = "";
564
+
doc = "";
565
+
dom = Base.(null id);
566
+
enc = (fun _ -> assert false);
567
+
dec = (fun _ -> assert false);
568
+
}
702
569
703
-
let no_enc name =
704
-
fun _v -> Error.msgf Meta.none "No encoder for member %a" pp_code name
705
-
706
-
let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' =
707
-
let id = Type.Id.make () in
708
-
let enc = match enc with None -> no_enc name | Some enc -> enc in
709
-
let enc_omit =
710
-
match enc_omit with None -> Fun.const false | Some omit -> omit
570
+
let ignore =
571
+
let kind = "ignore" in
572
+
let kind' = Sort.kinded ~kind Array in
573
+
let dec_empty () = () and dec_add _i _v () = () in
574
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
575
+
let enc =
576
+
{ enc = (fun _ _ () -> Error.no_encoder Meta.none ~kind:kind') }
711
577
in
712
-
{ name; doc; type'; id; dec_absent; enc; enc_omit }
578
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
713
579
714
-
let app object_map mm =
715
-
let mem_decs = String_map.add mm.name (Mem_dec mm) object_map.mem_decs in
716
-
let mem_encs = Mem_enc mm :: object_map.mem_encs in
717
-
let dec = Dec_app (object_map.dec, mm.id) in
718
-
{ object_map with dec; mem_decs; mem_encs }
580
+
let zero =
581
+
let dec_empty () = () and dec_add _i _v () = () in
582
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
583
+
let enc = { enc = (fun _ acc () -> acc) } in
584
+
let kind = "zero" in
585
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
719
586
end
720
587
721
-
let mem ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map =
722
-
let mmap = Mem.map ~doc ?dec_absent ?enc ?enc_omit name type' in
723
-
let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in
724
-
let mem_encs = Mem_enc mmap :: map.mem_encs in
725
-
let dec = Dec_app (map.dec, mmap.id) in
726
-
{ map with dec; mem_decs; mem_encs }
588
+
let list ?kind ?doc t = Array (Array.list_map ?kind ?doc t)
589
+
let array ?kind ?doc t = Array (Array.array_map ?kind ?doc t)
727
590
728
-
let opt_mem ?doc ?enc:e name dom map =
729
-
let dec = Option.some and enc = Option.get in
730
-
let some = Map { kind = ""; doc = ""; dom; dec; enc } in
731
-
mem ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map
591
+
let array_as_string_map ?kind ?doc ~key t =
592
+
let dec_empty () = String_map.empty in
593
+
let dec_add _i elt acc = String_map.add (key elt) elt acc in
594
+
let dec_finish _meta _len acc = acc in
595
+
let enc f acc m =
596
+
let i = ref (-1) in
597
+
String_map.fold
598
+
(fun _ elt acc ->
599
+
incr i;
600
+
f acc !i elt)
601
+
m acc
602
+
in
603
+
let enc = Array.{ enc } in
604
+
let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in
605
+
Array map
732
606
733
-
(* Case objects *)
607
+
let bigarray ?kind ?doc k t =
608
+
Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t)
734
609
735
-
module Case = struct
736
-
type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map
737
-
type ('cases, 'tag) t = ('cases, 'tag) case
738
-
type ('cases, 'tag) value = ('cases, 'tag) case_value
610
+
let tuple_no_decoder ~kind meta =
611
+
Error.no_decoder meta ~kind:(Sort.kinded' ~kind "tuple")
739
612
740
-
let no_dec _ = Error.msgf Meta.none "No decoder for case"
613
+
let tuple_no_encoder ~kind =
614
+
Error.no_encoder Meta.none ~kind:(Sort.kinded' ~kind "tuple")
741
615
742
-
let map ?(dec = no_dec) tag obj =
743
-
{ tag; object_map = get_object_map obj; dec }
616
+
let error_tuple_size meta kind ~exp fnd =
617
+
Error.msgf meta "Expected %a elements in %a but found %a" pp_int exp pp_kind
618
+
(Sort.kinded' ~kind "tuple")
619
+
pp_int fnd
744
620
745
-
let map_tag c = c.tag
746
-
let make c = Case c
747
-
let tag (Case c) = map_tag c
748
-
let value c v = Case_value (c, v)
749
-
end
621
+
let t2 ?(kind = "") ?doc ?dec ?enc t =
622
+
let size = 2 in
623
+
let dec =
624
+
match dec with
625
+
| None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta
626
+
| Some dec -> fun _meta v0 v1 -> dec v0 v1
627
+
in
628
+
let dec_empty () = [] in
629
+
let dec_add _i v acc = v :: acc in
630
+
let dec_finish meta _len = function
631
+
| [ v1; v0 ] -> dec meta v0 v1
632
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
633
+
in
634
+
let enc =
635
+
match enc with
636
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
637
+
| Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1)
638
+
in
639
+
let enc = { Array.enc } in
640
+
Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
750
641
751
-
let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string =
752
-
match map.shape with
753
-
| Object_cases _ -> invalid_arg "Multiple calls to Json.Object.case_mem"
754
-
| _ -> (
755
-
match dec_absent with
756
-
| None -> ()
757
-
| Some tag ->
758
-
(* Check that we have a case definition for it *)
759
-
let equal_t (Case case) = tag_compare case.tag tag = 0 in
760
-
if not (List.exists equal_t cases) then
761
-
let tag =
762
-
match tag_to_string with
763
-
| None -> ""
764
-
| Some tag_to_string -> " " ^ tag_to_string tag
765
-
in
766
-
invalid_arg ("No case for dec_absent case member value" ^ tag))
642
+
let t3 ?(kind = "") ?doc ?dec ?enc t =
643
+
let size = 3 in
644
+
let dec =
645
+
match dec with
646
+
| None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta
647
+
| Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2
648
+
in
649
+
let dec_empty () = [] in
650
+
let dec_add _i v acc = v :: acc in
651
+
let dec_finish meta _len = function
652
+
| [ v2; v1; v0 ] -> dec meta v0 v1 v2
653
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
654
+
in
655
+
let enc =
656
+
match enc with
657
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
658
+
| Some enc ->
659
+
fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)
660
+
in
661
+
let enc = { Array.enc } in
662
+
Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
767
663
768
-
let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit =
769
-
let id = Type.Id.make () in
770
-
let enc t =
771
-
t
772
-
(* N.B. this fact may be used by encoders. *)
664
+
let t4 ?(kind = "") ?doc ?dec ?enc t =
665
+
let size = 4 in
666
+
let dec =
667
+
match dec with
668
+
| None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta
669
+
| Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3
773
670
in
774
-
let enc_omit =
775
-
match enc_omit with None -> Fun.const false | Some omit -> omit
671
+
let dec_empty () = [] in
672
+
let dec_add _i v acc = v :: acc in
673
+
let dec_finish meta _len = function
674
+
| [ v3; v2; v1; v0 ] -> dec meta v0 v1 v2 v3
675
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
776
676
in
777
-
{ name; doc; type'; id; dec_absent; enc; enc_omit }
677
+
let enc =
678
+
match enc with
679
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
680
+
| Some enc ->
681
+
fun f acc v ->
682
+
f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3)
683
+
in
684
+
let enc = { Array.enc } in
685
+
Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
778
686
779
-
let case_mem ?doc ?(tag_compare = Stdlib.compare) ?tag_to_string ?dec_absent
780
-
?enc ?enc_omit ?enc_case name type' cases map =
781
-
let () = check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string in
782
-
let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in
783
-
let enc = match enc with None -> Mem.no_enc name | Some e -> e in
784
-
let enc_case =
785
-
match enc_case with
786
-
| Some enc_case -> enc_case
787
-
| None ->
788
-
fun _case ->
789
-
Error.msgf Meta.none "No case encoder for member %a" pp_code name
687
+
let tn ?(kind = "") ?doc ~n elt =
688
+
let dec_empty () = Core.Rarray.empty () in
689
+
let dec_add _i v a = Core.Rarray.add_last v a in
690
+
let dec_finish meta _len a =
691
+
let len = Core.Rarray.length a in
692
+
if len <> n then error_tuple_size meta kind ~exp:n len
693
+
else Core.Rarray.to_array a
790
694
in
791
-
let id = Type.Id.make () in
792
-
let cases = { tag; tag_compare; tag_to_string; id; cases; enc; enc_case } in
793
-
let dec = Dec_app (map.dec, id) in
794
-
{ map with dec; shape = Object_cases (None, cases) }
695
+
let enc = { Array.enc = Array.array_enc } in
696
+
Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt)
795
697
796
-
(* Unknown members *)
698
+
(* Objects *)
797
699
798
-
module Mems = struct
799
-
type ('mems, 'a) enc = {
800
-
enc :
801
-
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
802
-
}
700
+
module Object = struct
701
+
(* Maps *)
803
702
804
-
type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map
703
+
type ('o, 'dec) map = ('o, 'dec) object_map
805
704
806
-
let mems_kind kind = Sort.kinded' ~kind "members map"
705
+
let default_shape = Object_basic Unknown_skip
807
706
808
-
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish ?enc
809
-
mems_type =
810
-
let dec_empty =
811
-
match dec_empty with
812
-
| Some dec_empty -> dec_empty
813
-
| None -> fun () -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
814
-
in
815
-
let dec_add =
816
-
match dec_add with
817
-
| Some dec_add -> dec_add
818
-
| None ->
819
-
fun _ _ _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
820
-
in
821
-
let dec_finish =
822
-
match dec_finish with
823
-
| Some dec_finish -> dec_finish
824
-
| None -> fun _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
825
-
in
826
-
let enc =
827
-
match enc with
828
-
| Some { enc } -> enc
829
-
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(mems_kind kind)
830
-
in
831
-
let id = Type.Id.make () in
832
-
{ kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc }
707
+
let raw_map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec =
708
+
{
709
+
kind;
710
+
doc;
711
+
dec;
712
+
mem_decs = String_map.empty;
713
+
mem_encs = [];
714
+
enc_meta;
715
+
shape = default_shape;
716
+
}
833
717
834
-
let string_map ?kind ?doc type' =
835
-
let dec_empty () = String_map.empty in
836
-
let dec_add _meta n v mems = String_map.add n v mems in
837
-
let dec_finish _meta mems = mems in
838
-
let enc f mems acc =
839
-
String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc
840
-
in
841
-
map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{ enc }
842
-
end
718
+
let map ?kind ?doc dec = raw_map ?kind ?doc (Dec_fun dec)
843
719
844
-
let set_shape_unknown_mems shape u =
845
-
match shape with
846
-
| Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _) ->
847
-
invalid_arg "Json.Object.keep_unknown already called on object"
848
-
| Object_basic _ -> Object_basic u
849
-
| Object_cases (_, cases) -> Object_cases (Some u, cases)
720
+
let map' ?kind ?doc ?enc_meta dec =
721
+
raw_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg))
850
722
851
-
let skip_unknown map =
852
-
{ map with shape = set_shape_unknown_mems map.shape Unknown_skip }
723
+
let enc_only ?(kind = "") ?doc ?enc_meta () =
724
+
let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in
725
+
map' ~kind ?doc ?enc_meta dec
853
726
854
-
let error_unknown map =
855
-
{ map with shape = set_shape_unknown_mems map.shape Unknown_error }
727
+
let check_name_unicity m =
728
+
let add n kind = function
729
+
| None -> Some kind
730
+
| Some kind' ->
731
+
let ks _k = Sort.or_kind ~kind Object in
732
+
let k0 = ks kind and k1 = ks kind' in
733
+
invalid_arg
734
+
@@
735
+
if String.equal k0 k1 then
736
+
Fmt.str "member %s defined twice in %s" n k0
737
+
else Fmt.str "member %s defined both in %s and %s" n k0 k1
738
+
in
739
+
let rec loop : type o dec.
740
+
string String_map.t -> (o, dec) object_map -> unit =
741
+
fun names m ->
742
+
let add_name names n = String_map.update n (add n m.kind) names in
743
+
let add_mem_enc names (Mem_enc m) = add_name names m.name in
744
+
let names = List.fold_left add_mem_enc names m.mem_encs in
745
+
match m.shape with
746
+
| Object_basic _ -> ()
747
+
| Object_cases (_u, cases) ->
748
+
let names = add_name names cases.tag.name in
749
+
let check_case (Case c) = loop names c.object_map in
750
+
List.iter check_case cases.cases
751
+
in
752
+
loop String_map.empty m
856
753
857
-
let mems_noenc (mems : (_, _, _) mems_map) _o =
858
-
let kind = Sort.kinded' ~kind:mems.kind "members" in
859
-
Error.no_encoder Meta.none ~kind
754
+
let finish mems =
755
+
let () = check_name_unicity mems in
756
+
Object { mems with mem_encs = List.rev mems.mem_encs }
860
757
861
-
let keep_unknown ?enc mems (map : ('o, 'dec) object_map) =
862
-
let enc = match enc with None -> mems_noenc mems | Some enc -> enc in
863
-
let dec = Dec_app (map.dec, mems.id) in
864
-
let unknown = Unknown_keep (mems, enc) in
865
-
{ map with dec; shape = set_shape_unknown_mems map.shape unknown }
758
+
let get_object_map = function
759
+
| Object map -> map
760
+
| _ -> invalid_arg "Not an object"
866
761
867
-
let zero = finish (map ~kind:"zero" ())
762
+
(* Members *)
868
763
869
-
let as_string_map ?kind ?doc t =
870
-
map ?kind ?doc Fun.id
871
-
|> keep_unknown (Mems.string_map t) ~enc:Fun.id
872
-
|> finish
873
-
end
764
+
module Mem = struct
765
+
type ('o, 'a) map = ('o, 'a) mem_map
874
766
875
-
(* Ignoring
767
+
let no_enc name =
768
+
fun _v -> Error.msgf Meta.none "No encoder for member %a" pp_code name
876
769
877
-
[ignore] uses the dedicated [Codec.Ignore] constructor so the bytesrw
878
-
decoder can skip-parse the value (no token buffers, no float parsing,
879
-
no DOM allocation). *)
770
+
let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' =
771
+
let id = Type.Id.make () in
772
+
let enc = match enc with None -> no_enc name | Some enc -> enc in
773
+
let enc_omit =
774
+
match enc_omit with None -> Fun.const false | Some omit -> omit
775
+
in
776
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
880
777
881
-
let ignore : unit codec = Codec.Ignore
778
+
let app object_map mm =
779
+
let mem_decs =
780
+
String_map.add mm.name (Mem_dec mm) object_map.mem_decs
781
+
in
782
+
let mem_encs = Mem_enc mm :: object_map.mem_encs in
783
+
let dec = Dec_app (object_map.dec, mm.id) in
784
+
{ object_map with dec; mem_decs; mem_encs }
785
+
end
882
786
883
-
let zero =
884
-
let kind = "zero" in
885
-
let null = null () and dec_bool = Codec.Bool Base.ignore in
886
-
let dec_number = Codec.Number Base.ignore in
887
-
let dec_string = Codec.String Base.ignore in
888
-
let dec_array = Array.ignore and dec_object = Object.zero in
889
-
let enc () = null in
890
-
any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array
891
-
~dec_object ~enc ()
787
+
let mem ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map =
788
+
let mmap = Mem.map ~doc ?dec_absent ?enc ?enc_omit name type' in
789
+
let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in
790
+
let mem_encs = Mem_enc mmap :: map.mem_encs in
791
+
let dec = Dec_app (map.dec, mmap.id) in
792
+
{ map with dec; mem_decs; mem_encs }
892
793
893
-
let todo ?(kind = "") ?doc ?dec_stub () =
894
-
let dec =
895
-
match dec_stub with
896
-
| Some v -> Fun.const v
897
-
| None -> fun _v -> Error.decode_todo Meta.none ~kind_opt:kind
898
-
in
899
-
let enc _v = Error.encode_todo Meta.none ~kind_opt:kind in
900
-
map ~kind ?doc ~dec ~enc ignore
794
+
let opt_mem ?doc ?enc:e name dom map =
795
+
let dec = Option.some and enc = Option.get in
796
+
let some = Map { kind = ""; doc = ""; dom; dec; enc } in
797
+
mem ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map
901
798
902
-
(* Generic JSON. AST type and pure value operations live in Value; this
903
-
module re-exposes the fields that json.mli keeps at the top level. *)
799
+
(* Case objects *)
904
800
905
-
type name = Value.name
906
-
type mem = Value.mem
907
-
type object' = Value.object'
801
+
module Case = struct
802
+
type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map
803
+
type ('cases, 'tag) t = ('cases, 'tag) case
804
+
type ('cases, 'tag) value = ('cases, 'tag) case_value
908
805
909
-
type t = Value.t =
910
-
| Null of unit node
911
-
| Bool of bool node
912
-
| Number of float node
913
-
| String of string node
914
-
| Array of t list node
915
-
| Object of object' node
806
+
let no_dec _ = Error.msgf Meta.none "No decoder for case"
916
807
917
-
let pp_null = Value.pp_null
918
-
let pp_bool = Value.pp_bool
919
-
let pp_string = Value.pp_string
920
-
let pp_number = Value.pp_number
921
-
let pp_number' = Value.pp_number'
922
-
let pp_json = Value.pp_json
923
-
let pp_json' = Value.pp_json'
924
-
let pp = pp_json
808
+
let map ?(dec = no_dec) tag obj =
809
+
{ tag; object_map = get_object_map obj; dec }
925
810
926
-
type number_format = Value.number_format
811
+
let map_tag c = c.tag
812
+
let make c = Case c
813
+
let tag (Case c) = map_tag c
814
+
let value c v = Case_value (c, v)
815
+
end
927
816
928
-
let default_number_format = Value.default_number_format
817
+
let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string =
818
+
match map.shape with
819
+
| Object_cases _ -> invalid_arg "Multiple calls to Json.Object.case_mem"
820
+
| _ -> (
821
+
match dec_absent with
822
+
| None -> ()
823
+
| Some tag ->
824
+
let equal_t (Case case) = tag_compare case.tag tag = 0 in
825
+
if not (List.exists equal_t cases) then
826
+
let tag =
827
+
match tag_to_string with
828
+
| None -> ""
829
+
| Some tag_to_string -> " " ^ tag_to_string tag
830
+
in
831
+
invalid_arg ("No case for dec_absent case member value" ^ tag))
929
832
930
-
(* Generic JSON *)
833
+
let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit =
834
+
let id = Type.Id.make () in
835
+
let enc t = t in
836
+
let enc_omit =
837
+
match enc_omit with None -> Fun.const false | Some omit -> omit
838
+
in
839
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
931
840
932
-
module Value = struct
933
-
(* Local AST alias. Inside this module [open Codec] below shadows the
934
-
outer [t] with [Codec.t] (the codec GADT), so we preserve the AST
935
-
type under a name that isn't redefined. *)
936
-
type json = t
937
-
type 'a cons = ?meta:Meta.t -> 'a -> json
841
+
let case_mem ?doc ?(tag_compare = Stdlib.compare) ?tag_to_string ?dec_absent
842
+
?enc ?enc_omit ?enc_case name type' cases map =
843
+
let () =
844
+
check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string
845
+
in
846
+
let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in
847
+
let enc = match enc with None -> Mem.no_enc name | Some e -> e in
848
+
let enc_case =
849
+
match enc_case with
850
+
| Some enc_case -> enc_case
851
+
| None ->
852
+
fun _case ->
853
+
Error.msgf Meta.none "No case encoder for member %a" pp_code name
854
+
in
855
+
let id = Type.Id.make () in
856
+
let cases =
857
+
{ tag; tag_compare; tag_to_string; id; cases; enc; enc_case }
858
+
in
859
+
let dec = Dec_app (map.dec, id) in
860
+
{ map with dec; shape = Object_cases (None, cases) }
938
861
939
-
let meta = function
940
-
| Null (_, m) -> m
941
-
| Bool (_, m) -> m
942
-
| Number (_, m) -> m
943
-
| String (_, m) -> m
944
-
| Array (_, m) -> m
945
-
| Object (_, m) -> m
862
+
(* Unknown members *)
946
863
947
-
let set_meta m = function
948
-
| Null (v, _) -> Null (v, m)
949
-
| Bool (v, _) -> Bool (v, m)
950
-
| Number (v, _) -> Number (v, m)
951
-
| String (v, _) -> String (v, m)
952
-
| Array (v, _) -> Array (v, m)
953
-
| Object (v, _) -> Object (v, m)
864
+
module Mems = struct
865
+
type ('mems, 'a) enc = {
866
+
enc :
867
+
'acc.
868
+
(Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
869
+
}
954
870
955
-
let get_meta = meta
956
-
let copy_layout v ~dst = set_meta (Meta.copy_ws (meta v) ~dst:(meta dst)) dst
871
+
type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map
957
872
958
-
let sort = function
959
-
| Null _ -> Sort.Null
960
-
| Bool _ -> Sort.Bool
961
-
| Number _ -> Sort.Number
962
-
| String _ -> Sort.String
963
-
| Array _ -> Sort.Array
964
-
| Object _ -> Sort.Object
873
+
let mems_kind kind = Sort.kinded' ~kind "members map"
965
874
966
-
let rec compare (j0 : t) (j1 : t) =
967
-
match (j0, j1) with
968
-
| Null ((), _), Null ((), _) -> 0
969
-
| Null _, _ -> -1
970
-
| _, Null _ -> 1
971
-
| Bool (b0, _), Bool (b1, _) -> Bool.compare b0 b1
972
-
| Bool _, _ -> -1
973
-
| _, Bool _ -> 1
974
-
| Number (f0, _), Number (f1, _) -> Float.compare f0 f1
975
-
| Number _, _ -> -1
976
-
| _, Number _ -> 1
977
-
| String (s0, _), String (s1, _) -> String.compare s0 s1
978
-
| String _, _ -> -1
979
-
| _, String _ -> 1
980
-
| Array (a0, _), Array (a1, _) -> List.compare compare a0 a1
981
-
| Array _, _ -> -1
982
-
| _, Array _ -> 1
983
-
| Object (o0, _), Object (o1, _) ->
984
-
let order_mem ((n0, _), _) ((n1, _), _) = String.compare n0 n1 in
985
-
let compare_mem ((n0, _), j0) ((n1, _), j1) =
986
-
let c = String.compare n0 n1 in
987
-
if c = 0 then compare j0 j1 else c
875
+
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish ?enc
876
+
mems_type =
877
+
let dec_empty =
878
+
match dec_empty with
879
+
| Some dec_empty -> dec_empty
880
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
881
+
in
882
+
let dec_add =
883
+
match dec_add with
884
+
| Some dec_add -> dec_add
885
+
| None ->
886
+
fun _ _ _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
887
+
in
888
+
let dec_finish =
889
+
match dec_finish with
890
+
| Some dec_finish -> dec_finish
891
+
| None -> fun _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
892
+
in
893
+
let enc =
894
+
match enc with
895
+
| Some { enc } -> enc
896
+
| None ->
897
+
fun _ _ _ -> Error.no_encoder Meta.none ~kind:(mems_kind kind)
988
898
in
989
-
List.compare compare_mem (List.sort order_mem o0)
990
-
(List.sort order_mem o1)
899
+
let id = Type.Id.make () in
900
+
{ kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc }
991
901
992
-
let equal j0 j1 = compare j0 j1 = 0
993
-
let pp = pp_json
902
+
let string_map ?kind ?doc type' =
903
+
let dec_empty () = String_map.empty in
904
+
let dec_add _meta n v mems = String_map.add n v mems in
905
+
let dec_finish _meta mems = mems in
906
+
let enc f mems acc =
907
+
String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc
908
+
in
909
+
map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{ enc }
910
+
end
994
911
995
-
(* Nulls and options *)
912
+
let set_shape_unknown_mems shape u =
913
+
match shape with
914
+
| Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _)
915
+
->
916
+
invalid_arg "Json.Object.keep_unknown already called on object"
917
+
| Object_basic _ -> Object_basic u
918
+
| Object_cases (_, cases) -> Object_cases (Some u, cases)
996
919
997
-
let null' = Null ((), Meta.none)
998
-
let null ?(meta = Meta.none) () = Null ((), meta)
999
-
let option c ?meta = function None -> null ?meta () | Some v -> c ?meta v
920
+
let skip_unknown map =
921
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_skip }
1000
922
1001
-
(* Booleans *)
923
+
let error_unknown map =
924
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_error }
1002
925
1003
-
let bool ?(meta = Meta.none) b = Bool (b, meta)
926
+
let mems_noenc (mems : (_, _, _) mems_map) _o =
927
+
let kind = Sort.kinded' ~kind:mems.kind "members" in
928
+
Error.no_encoder Meta.none ~kind
1004
929
1005
-
(* Numbers *)
930
+
let keep_unknown ?enc mems (map : ('o, 'dec) object_map) =
931
+
let enc = match enc with None -> mems_noenc mems | Some enc -> enc in
932
+
let dec = Dec_app (map.dec, mems.id) in
933
+
let unknown = Unknown_keep (mems, enc) in
934
+
{ map with dec; shape = set_shape_unknown_mems map.shape unknown }
1006
935
1007
-
let number ?(meta = Meta.none) n = Number (n, meta)
936
+
let zero = finish (map ~kind:"zero" ())
1008
937
1009
-
let any_float ?(meta = Meta.none) v =
1010
-
if Float.is_finite v then Number (v, meta)
1011
-
else String (Float.to_string v, meta)
938
+
let as_string_map ?kind ?doc t =
939
+
map ?kind ?doc Fun.id
940
+
|> keep_unknown (Mems.string_map t) ~enc:Fun.id
941
+
|> finish
942
+
end
1012
943
1013
-
let int32 ?(meta = Meta.none) v = Number (Int32.to_float v, meta)
1014
-
let int64_as_string ?(meta = Meta.none) v = String (Int64.to_string v, meta)
944
+
(* Ignoring *)
1015
945
1016
-
let int64 ?(meta = Meta.none) v =
1017
-
if Core.Number.can_store_exact_int64 v then Number (Int64.to_float v, meta)
1018
-
else String (Int64.to_string v, meta)
946
+
let ignore : unit t = Ignore
1019
947
1020
-
let int_as_string ?(meta = Meta.none) i = String (Int.to_string i, meta)
948
+
let zero =
949
+
let kind = "zero" in
950
+
let null = null () and dec_bool = Bool Base.ignore in
951
+
let dec_number = Number Base.ignore in
952
+
let dec_string = String Base.ignore in
953
+
let dec_array = Array.ignore and dec_object = Object.zero in
954
+
let enc () = null in
955
+
any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array
956
+
~dec_object ~enc ()
1021
957
1022
-
let int ?(meta = Meta.none) v =
1023
-
if Core.Number.can_store_exact_int v then Number (Int.to_float v, meta)
1024
-
else String (Int.to_string v, meta)
958
+
let todo ?(kind = "") ?doc ?dec_stub () =
959
+
let dec =
960
+
match dec_stub with
961
+
| Some v -> Fun.const v
962
+
| None -> fun _v -> Error.decode_todo Meta.none ~kind_opt:kind
963
+
in
964
+
let enc _v = Error.encode_todo Meta.none ~kind_opt:kind in
965
+
map ~kind ?doc ~dec ~enc ignore
1025
966
1026
-
(* Strings *)
967
+
(* Generic-AST codecs. These preserve the AST shape when (de)coding. *)
1027
968
1028
-
let string ?(meta = Meta.none) s = String (s, meta)
969
+
module Value = struct
970
+
(* Build codecs that map to / from the generic [Value.t] AST. *)
1029
971
1030
-
(* Arrays *)
972
+
let null =
973
+
let dec meta () = Value.null ~meta () in
974
+
let enc = function
975
+
| (Value.Null _ : Value.t) -> ()
976
+
| j -> Error.sort (Value.meta j) ~exp:Sort.Null ~fnd:(Value.sort j)
977
+
in
978
+
Null (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1031
979
1032
-
let list ?(meta = Meta.none) l = Array (l, meta)
1033
-
let array ?(meta = Meta.none) a = Array (Stdlib.Array.to_list a, meta)
1034
-
let empty_array = list []
980
+
let bool =
981
+
let dec meta b = Value.bool ~meta b in
982
+
let enc = function
983
+
| (Value.Bool (b, _) : Value.t) -> b
984
+
| j -> Error.sort (Value.meta j) ~exp:Sort.Bool ~fnd:(Value.sort j)
985
+
in
986
+
Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1035
987
1036
-
(* Objects *)
988
+
let number =
989
+
let dec meta n = Value.number ~meta n in
990
+
let enc = function
991
+
| (Value.Number (n, _) : Value.t) -> n
992
+
| j -> Error.sort (Value.meta j) ~exp:Sort.Number ~fnd:(Value.sort j)
993
+
in
994
+
Number (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1037
995
1038
-
let name ?(meta = Meta.none) n = (n, meta)
1039
-
let mem n v = (n, v)
1040
-
let object' ?(meta = Meta.none) mems = Object (mems, meta)
1041
-
let empty_object = object' []
996
+
let string =
997
+
let dec meta s = Value.string ~meta s in
998
+
let enc = function
999
+
| (Value.String (s, _) : Value.t) -> s
1000
+
| j -> Error.sort (Value.meta j) ~exp:Sort.String ~fnd:(Value.sort j)
1001
+
in
1002
+
String (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1042
1003
1043
-
let rec find_mem n = function
1044
-
| [] -> None
1045
-
| (((n', _), _) as m) :: ms ->
1046
-
if String.equal n n' then Some m else find_mem n ms
1004
+
let t, array, mems, object' =
1005
+
let rec elt = Rec any
1006
+
and array_map =
1007
+
lazy
1008
+
begin
1009
+
let dec_empty () = [] in
1010
+
let dec_add _i v a = v :: a in
1011
+
let dec_finish meta _len a = Value.list ~meta (List.rev a) in
1012
+
let enc f acc = function
1013
+
| (Value.Array (a, _) : Value.t) -> Array.list_enc f acc a
1014
+
| j ->
1015
+
Error.sort (Value.meta j) ~exp:Sort.Array
1016
+
~fnd:(Value.sort j)
1017
+
in
1018
+
let enc = { Array.enc } in
1019
+
Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Value.meta
1020
+
elt
1021
+
end
1022
+
and array = lazy (Array.array (Lazy.force array_map))
1023
+
and mems =
1024
+
lazy
1025
+
begin
1026
+
let dec_empty () = [] in
1027
+
let dec_add meta n v mems = ((n, meta), v) :: mems in
1028
+
let dec_finish _meta mems = List.rev mems in
1029
+
let enc f l a =
1030
+
List.fold_left (fun a ((n, m), v) -> f m n v a) a l
1031
+
in
1032
+
let enc = { Object.Mems.enc } in
1033
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc elt
1034
+
end
1035
+
and object' =
1036
+
lazy
1037
+
begin
1038
+
let enc_meta = function
1039
+
| (Value.Object (_, meta) : Value.t) -> meta
1040
+
| j ->
1041
+
Error.sort (Value.meta j) ~exp:Sort.Object
1042
+
~fnd:(Value.sort j)
1043
+
in
1044
+
let enc = function
1045
+
| (Value.Object (mems, _) : Value.t) -> mems
1046
+
| j ->
1047
+
Error.sort (Value.meta j) ~exp:Sort.Object
1048
+
~fnd:(Value.sort j)
1049
+
in
1050
+
let dec meta mems : Value.t = Value.Object (mems, meta) in
1051
+
Object.map' dec ~enc_meta
1052
+
|> Object.keep_unknown (Lazy.force mems) ~enc
1053
+
|> Object.finish
1054
+
end
1055
+
and any =
1056
+
lazy
1057
+
begin
1058
+
let value_array = Lazy.force array in
1059
+
let value_object = Lazy.force object' in
1060
+
let enc (v : Value.t) =
1061
+
match v with
1062
+
| Value.Null _ -> null
1063
+
| Value.Bool _ -> bool
1064
+
| Value.Number _ -> number
1065
+
| Value.String _ -> string
1066
+
| Value.Array _ -> value_array
1067
+
| Value.Object _ -> value_object
1068
+
in
1069
+
Any
1070
+
{
1071
+
kind = "json";
1072
+
doc = "";
1073
+
dec_null = Some null;
1074
+
dec_bool = Some bool;
1075
+
dec_number = Some number;
1076
+
dec_string = Some string;
1077
+
dec_array = Some value_array;
1078
+
dec_object = Some value_object;
1079
+
enc;
1080
+
}
1081
+
end
1082
+
in
1083
+
(Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object')
1047
1084
1048
-
let find_mem' (n, _) ms = find_mem n ms
1049
-
let object_names mems = List.map (fun ((n, _), _) -> n) mems
1050
-
let object_names' mems = List.map fst mems
1085
+
let _ = mems
1086
+
(* The [mems] re-binding below is the real public [mems]; the closed-over
1087
+
one above is used internally by [t]. *)
1051
1088
1052
-
(* Zero *)
1089
+
let mems =
1090
+
let dec_empty () = [] in
1091
+
let dec_add meta name v mems = ((name, meta), v) :: mems in
1092
+
let dec_finish meta mems : Value.t = Value.Object (List.rev mems, meta) in
1093
+
let enc f j acc =
1094
+
match j with
1095
+
| (Value.Object (ms, _) : Value.t) ->
1096
+
List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms
1097
+
| j ->
1098
+
Error.sort (Value.meta j) ~exp:Sort.Object ~fnd:(Value.sort j)
1099
+
in
1100
+
let enc = { Object.Mems.enc } in
1101
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc t
1102
+
end
1053
1103
1054
-
let zero ?meta j =
1055
-
match sort j with
1056
-
| Null -> null ?meta ()
1057
-
| Bool -> bool ?meta false
1058
-
| Number -> number ?meta 0.
1059
-
| String -> string ?meta ""
1060
-
| Array -> list ?meta []
1061
-
| Object -> object' ?meta []
1104
+
(* Decode / encode between generic JSON and typed values using a codec.
1105
+
[decode_exn] / [encode_exn] raise [Error]; thin wrappers return results. *)
1062
1106
1063
-
(* Converting *)
1064
-
1065
-
open Codec
1066
-
1067
-
let error_sort ~exp j = Error.sort (meta j) ~exp ~fnd:(sort j)
1107
+
let error_sort ~exp j =
1108
+
Error.sort (Value.meta j) ~exp ~fnd:(Value.sort j)
1068
1109
1069
1110
let error_type t fnd =
1070
-
Error.kinded_sort (meta fnd) ~exp:(kinded_sort t) ~fnd:(sort fnd)
1111
+
Error.kinded_sort (Value.meta fnd) ~exp:(kinded_sort t)
1112
+
~fnd:(Value.sort fnd)
1071
1113
1072
1114
let find_all_unexpected ~mem_decs mems =
1073
1115
let unexpected (((n, _) as nm), _v) =
1074
-
match Codec.String_map.find_opt n mem_decs with
1116
+
match String_map.find_opt n mem_decs with
1075
1117
| None -> Some nm
1076
1118
| Some _ -> None
1077
1119
in
1078
1120
List.filter_map unexpected mems
1079
1121
1080
-
(* Decoding *)
1081
-
1082
-
let rec decode : type a. a Codec.t -> json -> a =
1122
+
let rec decode_exn : type a. a t -> Value.t -> a =
1083
1123
fun t j ->
1084
1124
match t with
1085
1125
| Null map -> (
1086
-
match j with Null (n, meta) -> map.dec meta n | j -> error_type t j)
1126
+
match (j : Value.t) with
1127
+
| Value.Null (n, meta) -> map.dec meta n
1128
+
| j -> error_type t j)
1087
1129
| Bool map -> (
1088
-
match j with Bool (b, meta) -> map.dec meta b | j -> error_type t j)
1130
+
match (j : Value.t) with
1131
+
| Value.Bool (b, meta) -> map.dec meta b
1132
+
| j -> error_type t j)
1089
1133
| Number map -> (
1090
-
match j with
1091
-
| Number (n, meta) -> map.dec meta n
1092
-
| Null (_, meta) -> map.dec meta Float.nan
1134
+
match (j : Value.t) with
1135
+
| Value.Number (n, meta) -> map.dec meta n
1136
+
| Value.Null (_, meta) -> map.dec meta Float.nan
1093
1137
| j -> error_type t j)
1094
1138
| String map -> (
1095
-
match j with String (s, meta) -> map.dec meta s | j -> error_type t j)
1139
+
match (j : Value.t) with
1140
+
| Value.String (s, meta) -> map.dec meta s
1141
+
| j -> error_type t j)
1096
1142
| Array map -> (
1097
-
match j with
1098
-
| Array (vs, meta) -> decode_array map meta vs
1143
+
match (j : Value.t) with
1144
+
| Value.Array (vs, meta) -> decode_array map meta vs
1099
1145
| j -> error_type t j)
1100
1146
| Object map -> (
1101
-
match j with
1102
-
| Object (mems, meta) -> decode_object map meta mems
1147
+
match (j : Value.t) with
1148
+
| Value.Object (mems, meta) -> decode_object map meta mems
1103
1149
| j -> error_type t j)
1104
-
| Map map -> map.dec (decode map.dom j)
1150
+
| Map map -> map.dec (decode_exn map.dom j)
1105
1151
| Any map -> decode_any t map j
1106
-
| Rec t -> decode (Lazy.force t) j
1152
+
| Rec t -> decode_exn (Lazy.force t) j
1107
1153
| Ignore -> ()
1108
1154
1109
1155
and decode_array : type a elt b.
1110
-
(a, elt, b) array_map -> Meta.t -> json list -> a =
1156
+
(a, elt, b) array_map -> Meta.t -> Value.t list -> a =
1111
1157
fun map meta vs ->
1112
1158
let rec next (map : (a, elt, b) array_map) meta b i = function
1113
1159
| [] -> map.dec_finish meta i b
1114
1160
| v :: vs ->
1115
1161
let b =
1116
1162
try
1117
-
if map.dec_skip i b then b else map.dec_add i (decode map.elt v) b
1118
-
with Error e -> Codec.error_push_array meta map (i, get_meta v) e
1163
+
if map.dec_skip i b then b
1164
+
else map.dec_add i (decode_exn map.elt v) b
1165
+
with Error e ->
1166
+
error_push_array meta map (i, Value.get_meta v) e
1119
1167
in
1120
1168
next map meta b (i + 1) vs
1121
1169
in
1122
1170
next map meta (map.dec_empty ()) 0 vs
1123
1171
1124
-
and decode_object : type o. (o, o) Object.map -> Meta.t -> object' -> o =
1172
+
and decode_object : type o.
1173
+
(o, o) object_map -> Meta.t -> Value.object' -> o =
1125
1174
fun map meta mems ->
1126
1175
let dict = Dict.empty in
1127
1176
let umems = Unknown_mems None in
···
1130
1179
mems
1131
1180
1132
1181
and decode_object_map : type o.
1133
-
(o, o) Object.map ->
1182
+
(o, o) object_map ->
1134
1183
Meta.t ->
1135
1184
unknown_mems_option ->
1136
1185
mem_dec String_map.t ->
1137
1186
mem_dec String_map.t ->
1138
1187
Dict.t ->
1139
-
object' ->
1188
+
Value.object' ->
1140
1189
Dict.t =
1141
1190
fun map meta umems mem_miss mem_decs dict mems ->
1142
1191
let u _ _ _ = assert false in
···
1145
1194
match map.shape with
1146
1195
| Object_cases (umems', cases) ->
1147
1196
let umems' = Unknown_mems umems' in
1148
-
let umems, dict = Codec.override_unknown_mems ~by:umems umems' dict in
1197
+
let umems, dict = override_unknown_mems ~by:umems umems' dict in
1149
1198
decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems
1150
1199
| Object_basic umems' -> (
1151
1200
let umems' = Unknown_mems (Some umems') in
1152
-
let umems, dict = Codec.override_unknown_mems ~by:umems umems' dict in
1201
+
let umems, dict = override_unknown_mems ~by:umems umems' dict in
1153
1202
match umems with
1154
1203
| Unknown_mems (Some Unknown_skip | None) ->
1155
1204
let umems = Unknown_skip in
···
1168
1217
mem_dec String_map.t ->
1169
1218
mem_dec String_map.t ->
1170
1219
Dict.t ->
1171
-
object' ->
1220
+
Value.object' ->
1172
1221
Dict.t =
1173
1222
fun map meta umems umap mem_miss mem_decs dict -> function
1174
-
| [] -> Codec.finish_object_decode map meta umems umap mem_miss dict
1223
+
| [] -> finish_object_decode map meta umems umap mem_miss dict
1175
1224
| (((n, nmeta) as nm), v) :: mems -> (
1176
1225
match String_map.find_opt n mem_decs with
1177
1226
| Some (Mem_dec m) ->
1178
1227
let dict =
1179
-
try Dict.add m.id (decode m.type' v) dict
1180
-
with Error e -> Codec.error_push_object meta map nm e
1228
+
try Dict.add m.id (decode_exn m.type' v) dict
1229
+
with Error e -> error_push_object meta map nm e
1181
1230
in
1182
1231
let mem_miss = String_map.remove n mem_miss in
1183
1232
decode_object_basic map meta umems umap mem_miss mem_decs dict mems
···
1188
1237
mems
1189
1238
| Unknown_error ->
1190
1239
let fnd = nm :: find_all_unexpected ~mem_decs mems in
1191
-
Codec.unexpected_mems_error meta map ~fnd
1240
+
unexpected_mems_error meta map ~fnd
1192
1241
| Unknown_keep (umap', _) ->
1193
1242
let umap =
1194
-
try umap'.dec_add nmeta n (decode umap'.mems_type v) umap
1195
-
with Error e -> Codec.error_push_object meta map nm e
1243
+
try umap'.dec_add nmeta n (decode_exn umap'.mems_type v) umap
1244
+
with Error e -> error_push_object meta map nm e
1196
1245
in
1197
1246
decode_object_basic map meta umems umap mem_miss mem_decs dict
1198
1247
mems))
1199
1248
1200
-
and decode_object_cases : type o cs t.
1249
+
and decode_object_cases : type o cs tg.
1201
1250
(o, o) object_map ->
1202
1251
Meta.t ->
1203
1252
unknown_mems_option ->
1204
-
(o, cs, t) object_cases ->
1253
+
(o, cs, tg) object_cases ->
1205
1254
mem_dec String_map.t ->
1206
1255
mem_dec String_map.t ->
1207
1256
Dict.t ->
1208
-
object' ->
1209
-
object' ->
1257
+
Value.object' ->
1258
+
Value.object' ->
1210
1259
Dict.t =
1211
1260
fun map meta umems cases mem_miss mem_decs dict delay mems ->
1212
1261
let decode_case_tag map meta tag delay mems =
1213
1262
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
1214
1263
match List.find_opt eq_tag cases.cases with
1215
-
| None -> Codec.unexpected_case_tag_error meta map cases tag
1264
+
| None -> unexpected_case_tag_error meta map cases tag
1216
1265
| Some (Case case) ->
1217
1266
let mems = List.rev_append delay mems in
1218
1267
let dict =
···
1228
1277
match cases.tag.dec_absent with
1229
1278
| Some tag -> decode_case_tag map meta tag delay []
1230
1279
| None ->
1231
-
let kinded_sort = Codec.object_kinded_sort map in
1280
+
let kinded_sort = object_kinded_sort map in
1232
1281
Error.missing_mems meta ~kinded_sort ~exp:[ cases.tag.name ]
1233
1282
~fnd:(List.map (fun ((n, _), _) -> n) delay))
1234
1283
| ((((n, meta) as nm), v) as mem) :: mems -> (
1235
1284
if n = cases.tag.name then
1236
1285
let tag =
1237
-
try decode cases.tag.type' v
1238
-
with Error e -> Codec.error_push_object meta map nm e
1286
+
try decode_exn cases.tag.type' v
1287
+
with Error e -> error_push_object meta map nm e
1239
1288
in
1240
1289
decode_case_tag map meta tag delay mems
1241
1290
else
···
1246
1295
delay mems
1247
1296
| Some (Mem_dec m) ->
1248
1297
let dict =
1249
-
try Dict.add m.id (decode m.type' v) dict
1250
-
with Error e -> Codec.error_push_object meta map nm e
1298
+
try Dict.add m.id (decode_exn m.type' v) dict
1299
+
with Error e -> error_push_object meta map nm e
1251
1300
in
1252
1301
let mem_miss = String_map.remove n mem_miss in
1253
1302
decode_object_cases map meta umems cases mem_miss mem_decs dict
1254
1303
delay mems)
1255
1304
1256
-
and decode_any : type a. a Codec.t -> a any_map -> json -> a =
1305
+
and decode_any : type a. a t -> a any_map -> Value.t -> a =
1257
1306
fun t map j ->
1258
1307
let dec t map j =
1259
-
match map with Some t -> decode t j | None -> error_type t j
1308
+
match map with Some t -> decode_exn t j | None -> error_type t j
1260
1309
in
1261
-
match j with
1262
-
| Null _ -> dec t map.dec_null j
1263
-
| Bool _ -> dec t map.dec_bool j
1264
-
| Number _ -> dec t map.dec_number j
1265
-
| String _ -> dec t map.dec_string j
1266
-
| Array _ -> dec t map.dec_array j
1267
-
| Object _ -> dec t map.dec_object j
1310
+
match (j : Value.t) with
1311
+
| Value.Null _ -> dec t map.dec_null j
1312
+
| Value.Bool _ -> dec t map.dec_bool j
1313
+
| Value.Number _ -> dec t map.dec_number j
1314
+
| Value.String _ -> dec t map.dec_string j
1315
+
| Value.Array _ -> dec t map.dec_array j
1316
+
| Value.Object _ -> dec t map.dec_object j
1268
1317
1269
-
let dec = decode
1270
-
let decode' t j = try Ok (decode t j) with Error e -> Result.Error e
1318
+
let decode' t j = try Ok (decode_exn t j) with Error e -> Result.Error e
1271
1319
let decode t j = Result.map_error Error.to_string (decode' t j)
1272
1320
1273
1321
(* Encode *)
1274
1322
1275
-
let rec encode : type a. a Codec.t -> a -> json =
1323
+
let rec encode_exn : type a. a t -> a -> Value.t =
1276
1324
fun t v ->
1277
1325
match t with
1278
-
| Null map -> null ~meta:(map.enc_meta v) (map.enc v)
1279
-
| Bool map -> bool ~meta:(map.enc_meta v) (map.enc v)
1280
-
| Number map -> number ~meta:(map.enc_meta v) (map.enc v)
1281
-
| String map -> string ~meta:(map.enc_meta v) (map.enc v)
1326
+
| Null map -> Value.null ~meta:(map.enc_meta v) (map.enc v)
1327
+
| Bool map -> Value.bool ~meta:(map.enc_meta v) (map.enc v)
1328
+
| Number map -> Value.number ~meta:(map.enc_meta v) (map.enc v)
1329
+
| String map -> Value.string ~meta:(map.enc_meta v) (map.enc v)
1282
1330
| Array map ->
1283
1331
let enc map acc i elt =
1284
-
try encode map.elt elt :: acc
1285
-
with Error e ->
1286
-
Codec.error_push_array Meta.none map (i, Meta.none) e
1332
+
try encode_exn map.elt elt :: acc
1333
+
with Error e -> error_push_array Meta.none map (i, Meta.none) e
1287
1334
in
1288
-
list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v))
1335
+
Value.list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v))
1289
1336
| Object map ->
1290
1337
let mems = encode_object map ~do_unknown:true v [] in
1291
-
Object (List.rev mems, map.enc_meta v)
1292
-
| Any map -> encode (map.enc v) v
1293
-
| Map map -> encode map.dom (map.enc v)
1294
-
| Rec t -> encode (Lazy.force t) v
1338
+
Value.Object (List.rev mems, map.enc_meta v)
1339
+
| Any map -> encode_exn (map.enc v) v
1340
+
| Map map -> encode_exn map.dom (map.enc v)
1341
+
| Rec t -> encode_exn (Lazy.force t) v
1295
1342
| Ignore -> Error.no_encoder Meta.none ~kind:"ignore"
1296
1343
1297
-
and encode_object : type o dec.
1298
-
(o, o) object_map -> do_unknown:bool -> o -> object' -> object' =
1344
+
and encode_object : type o.
1345
+
(o, o) object_map ->
1346
+
do_unknown:bool ->
1347
+
o ->
1348
+
Value.object' ->
1349
+
Value.object' =
1299
1350
fun map ~do_unknown o obj ->
1300
1351
let encode_mem map obj (Mem_enc mmap) =
1301
1352
try
1302
1353
let v = mmap.enc o in
1303
1354
if mmap.enc_omit v then obj
1304
-
else ((mmap.name, Meta.none), encode mmap.type' v) :: obj
1305
-
with Error e ->
1306
-
Codec.error_push_object Meta.none map (mmap.name, Meta.none) e
1355
+
else ((mmap.name, Meta.none), encode_exn mmap.type' v) :: obj
1356
+
with Error e -> error_push_object Meta.none map (mmap.name, Meta.none) e
1307
1357
in
1308
1358
let obj = List.fold_left (encode_mem map) obj map.mem_encs in
1309
1359
match map.shape with
···
1316
1366
let n = (cases.tag.name, Meta.none) in
1317
1367
try
1318
1368
if cases.tag.enc_omit case.tag then obj
1319
-
else (n, encode cases.tag.type' case.tag) :: obj
1320
-
with Error e -> Codec.error_push_object Meta.none map n e
1369
+
else (n, encode_exn cases.tag.type' case.tag) :: obj
1370
+
with Error e -> error_push_object Meta.none map n e
1321
1371
in
1322
1372
match u with
1323
1373
| Some (Unknown_keep (umap, enc)) ->
1324
-
(* Less T.R. but feels nicer to encode unknowns at the end *)
1325
1374
let obj = encode_object case.object_map ~do_unknown:false c obj in
1326
1375
encode_unknown_mems map umap (enc o) obj
1327
1376
| _ -> encode_object case.object_map ~do_unknown c obj)
1328
1377
1329
-
and encode_unknown_mems : type o dec mems a builder.
1378
+
and encode_unknown_mems : type o mems a builder.
1330
1379
(o, o) object_map ->
1331
1380
(mems, a, builder) mems_map ->
1332
1381
mems ->
1333
-
object' ->
1334
-
object' =
1382
+
Value.object' ->
1383
+
Value.object' =
1335
1384
fun map umap mems obj ->
1336
1385
let encode_mem map meta name v obj =
1337
1386
let n = (name, meta) in
1338
1387
let v =
1339
-
try encode umap.mems_type v
1340
-
with Error e -> Codec.error_push_object Meta.none map n e
1388
+
try encode_exn umap.mems_type v
1389
+
with Error e -> error_push_object Meta.none map n e
1341
1390
in
1342
1391
(n, v) :: obj
1343
1392
in
1344
1393
umap.enc (encode_mem map) mems obj
1345
1394
1346
-
let enc = encode
1347
-
let encode' t v = try Ok (encode t v) with Error e -> Result.Error e
1395
+
let encode' t v = try Ok (encode_exn t v) with Error e -> Result.Error e
1348
1396
let encode t v = Result.map_error Error.to_string (encode' t v)
1349
1397
1350
-
(* Recode *)
1398
+
(* Recode: decode then encode. [update_exn] raises [Error]. *)
1351
1399
1352
-
let update t v = enc t (dec t v)
1353
-
let recode' t v = try Ok (update t v) with Error e -> Result.Error e
1400
+
let update_exn t v = encode_exn t (decode_exn t v)
1401
+
let recode' t v = try Ok (update_exn t v) with Error e -> Result.Error e
1354
1402
let recode t v = Result.map_error Error.to_string (recode' t v)
1355
-
end
1403
+
let update_of_t t v = update_exn t v
1356
1404
1357
-
let json_null =
1358
-
let dec meta () = Value.null ~meta () in
1359
-
let enc = function
1360
-
| Null ((), _) -> ()
1361
-
| j -> Value.error_sort ~exp:Sort.Null j
1362
-
in
1363
-
Codec.Null (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1405
+
(* Queries and updates *)
1364
1406
1365
-
let json_bool =
1366
-
let dec meta b = Value.bool ~meta b in
1367
-
let enc = function
1368
-
| Bool (b, _) -> b
1369
-
| j -> Value.error_sort ~exp:Sort.Bool j
1370
-
in
1371
-
Codec.Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1407
+
let const t v =
1408
+
let const _ = v in
1409
+
let dec = map ~dec:const ignore in
1410
+
let enc = map ~enc:const t in
1411
+
let enc _v = enc in
1412
+
any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec
1413
+
~dec_array:dec ~dec_object:dec ~enc ()
1372
1414
1373
-
let json_number =
1374
-
let dec meta n = Value.number ~meta n in
1375
-
let enc = function
1376
-
| Number (n, _) -> n
1377
-
| j -> Value.error_sort ~exp:Sort.Number j
1378
-
in
1379
-
Codec.Number (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1415
+
let recode ~dec:dom f ~enc =
1416
+
let m = map ~dec:f dom in
1417
+
let enc _v = enc in
1418
+
any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m
1419
+
~dec_object:m ~enc ()
1380
1420
1381
-
let json_string =
1382
-
let dec meta s = Value.string ~meta s in
1383
-
let enc = function
1384
-
| String (s, _) -> s
1385
-
| j -> Value.error_sort ~exp:Sort.String j
1386
-
in
1387
-
Codec.String (Base.map ~dec ~enc ~enc_meta:Value.meta ())
1421
+
let update t =
1422
+
let dec v = update_exn t v in
1423
+
Map { kind = ""; doc = ""; dom = Value.t; dec; enc = Fun.id }
1388
1424
1389
-
let json, json_array, mem_list, json_object =
1390
-
let rec elt = Codec.Rec any
1391
-
and array_map =
1392
-
lazy begin
1393
-
let dec_empty () = [] in
1394
-
let dec_add _i v a = v :: a in
1395
-
let dec_finish meta _len a = Value.list ~meta (List.rev a) in
1396
-
let enc f acc = function
1397
-
| Array (a, _) -> Array.list_enc f acc a
1398
-
| j -> Value.error_sort ~exp:Sort.Array j
1399
-
in
1400
-
let enc = { Array.enc } in
1401
-
Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Value.meta elt
1402
-
end
1403
-
and array = lazy (Array.array (Lazy.force array_map))
1404
-
and mems =
1405
-
lazy begin
1406
-
let dec_empty () = [] in
1407
-
let dec_add meta n v mems = ((n, meta), v) :: mems in
1408
-
let dec_finish _meta mems = List.rev mems in
1409
-
let enc f l a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
1410
-
let enc = { Object.Mems.enc } in
1411
-
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc elt
1412
-
end
1413
-
and object' =
1414
-
lazy begin
1415
-
let enc_meta = function
1416
-
| Object (_, meta) -> meta
1417
-
| j -> Value.error_sort ~exp:Sort.Object j
1418
-
in
1419
-
let enc = function
1420
-
| Object (mems, _) -> mems
1421
-
| j -> Value.error_sort ~exp:Sort.Object j
1422
-
in
1423
-
let dec meta mems = Object (mems, meta) in
1424
-
Object.map' dec ~enc_meta
1425
-
|> Object.keep_unknown (Lazy.force mems) ~enc
1426
-
|> Object.finish
1427
-
end
1428
-
and any =
1429
-
lazy begin
1430
-
let json_array = Lazy.force array in
1431
-
let json_object = Lazy.force object' in
1432
-
let enc = function
1433
-
| Null _ -> json_null
1434
-
| Bool _ -> json_bool
1435
-
| Number _ -> json_number
1436
-
| String _ -> json_string
1437
-
| Array _ -> json_array
1438
-
| Object _ -> json_object
1439
-
in
1440
-
Codec.Any
1441
-
{
1442
-
kind = "json";
1443
-
doc = "";
1444
-
dec_null = Some json_null;
1445
-
dec_bool = Some json_bool;
1446
-
dec_number = Some json_number;
1447
-
dec_string = Some json_string;
1448
-
dec_array = Some json_array;
1449
-
dec_object = Some json_object;
1450
-
enc;
1451
-
}
1452
-
end
1453
-
in
1454
-
(Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object')
1425
+
(* Array queries *)
1455
1426
1456
-
let json_mems =
1457
-
let dec_empty () = [] in
1458
-
let dec_add meta name v mems = ((name, meta), v) :: mems in
1459
-
let dec_finish meta mems = Object (List.rev mems, meta) in
1460
-
let enc f j acc =
1461
-
match j with
1462
-
| Object (ms, _) ->
1463
-
List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms
1464
-
| j -> Value.error_sort ~exp:Sort.Object j
1465
-
in
1466
-
let enc = { Object.Mems.enc } in
1467
-
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
1427
+
let rec list_repeat n v l =
1428
+
if n <= 0 then l else list_repeat (n - 1) v (v :: l)
1468
1429
1469
-
(* Queries and updates *)
1430
+
let nth ?absent n t =
1431
+
let dec_empty () = None in
1432
+
let dec_skip i _v = i <> n in
1433
+
let dec_add _i v _acc = Some v in
1434
+
let dec_finish meta len v =
1435
+
match v with
1436
+
| Some v -> v
1437
+
| None -> (
1438
+
match absent with
1439
+
| Some v -> v
1440
+
| None -> Error.index_out_of_range meta ~n ~len)
1441
+
in
1442
+
let enc f acc v = f acc 0 v in
1443
+
let enc = { Array.enc } in
1444
+
Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t)
1470
1445
1471
-
(* val app : ('a -> 'b) t -> 'a t -> 'b codec
1472
-
val product : 'a t -> 'b codec -> ('a * 'b) t
1473
-
val bind : 'a t -> ('a -> 'b t) -> 'b codec
1474
-
val map : ('a -> 'b) -> 'a t -> 'b codec *)
1475
-
1476
-
let const t v =
1477
-
let const _ = v in
1478
-
let dec = map ~dec:const ignore in
1479
-
let enc = map ~enc:const t in
1480
-
let enc _v = enc in
1481
-
any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec ~dec_array:dec
1482
-
~dec_object:dec ~enc ()
1483
-
1484
-
let recode ~dec:dom f ~enc =
1485
-
let m = map ~dec:f dom in
1486
-
let enc _v = enc in
1487
-
any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m
1488
-
~dec_object:m ~enc ()
1489
-
1490
-
let update t =
1491
-
let dec v = Value.update t v in
1492
-
Codec.Map { kind = ""; doc = ""; dom = json; dec; enc = Fun.id }
1493
-
1494
-
(* Array queries *)
1446
+
let update_nth ?stub ?absent n t =
1447
+
let update_elt n t v = Value.copy_layout v ~dst:(update_exn t v) in
1448
+
let rec update_array ~seen n t i acc = function
1449
+
| v :: vs when i = n ->
1450
+
let elt = update_elt (i, Value.meta v) t v in
1451
+
update_array ~seen:true n t (i + 1) (elt :: acc) vs
1452
+
| v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs
1453
+
| [] when seen -> Either.Right (List.rev acc)
1454
+
| [] -> Either.Left (acc, i)
1455
+
in
1456
+
let do_update ?stub ?absent n t j =
1457
+
match (j : Value.t) with
1458
+
| Value.Array (vs, meta) -> begin
1459
+
match update_array ~seen:false n t 0 [] vs with
1460
+
| Either.Right elts -> (Value.Array (elts, meta) : Value.t)
1461
+
| Either.Left (acc, len) -> (
1462
+
match absent with
1463
+
| None -> Error.index_out_of_range meta ~n ~len
1464
+
| Some absent ->
1465
+
let elt = encode_exn t absent in
1466
+
let stub =
1467
+
match stub with None -> Value.zero elt | Some j -> j
1468
+
in
1469
+
Value.Array
1470
+
(List.rev (elt :: list_repeat (n - len) stub acc), meta))
1471
+
end
1472
+
| j -> error_sort ~exp:Sort.Array j
1473
+
in
1474
+
let dec = do_update ?stub ?absent n t in
1475
+
let enc j = j in
1476
+
map ~dec ~enc Value.t
1495
1477
1496
-
let rec list_repeat n v l = if n <= 0 then l else list_repeat (n - 1) v (v :: l)
1478
+
let set_nth ?stub ?(allow_absent = false) t n v =
1479
+
let absent = if allow_absent then Some v else None in
1480
+
update_nth ?stub ?absent n (const t v)
1497
1481
1498
-
let nth ?absent n t =
1499
-
let dec_empty () = None in
1500
-
let dec_skip i _v = i <> n in
1501
-
let dec_add _i v _acc = Some v in
1502
-
let dec_finish meta len v =
1503
-
match v with
1504
-
| Some v -> v
1505
-
| None -> (
1506
-
match absent with
1507
-
| Some v -> v
1508
-
| None -> Error.index_out_of_range meta ~n ~len)
1509
-
in
1510
-
let enc f acc v = f acc 0 v in
1511
-
let enc = { Array.enc } in
1512
-
Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t)
1482
+
let delete_nth ?(allow_absent = false) n =
1483
+
let dec_empty () = [] in
1484
+
let dec_add i v a = if i = n then a else v :: a in
1485
+
let dec_finish meta len a =
1486
+
if n < len || allow_absent then Value.list ~meta (List.rev a)
1487
+
else Error.index_out_of_range meta ~n ~len
1488
+
in
1489
+
let enc f acc = function
1490
+
| (Value.Array (a, _) : Value.t) -> Array.list_enc f acc a
1491
+
| j -> error_sort ~exp:Sort.Array j
1492
+
in
1493
+
let enc_meta j = Value.meta j in
1494
+
let enc = { Array.enc } in
1495
+
Array.array
1496
+
(Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t)
1513
1497
1514
-
let update_nth ?stub ?absent n t =
1515
-
let update_elt n t v = Value.copy_layout v ~dst:(Value.update t v) in
1516
-
let rec update_array ~seen n t i acc = function
1517
-
| v :: vs when i = n ->
1518
-
let elt = update_elt (i, Value.meta v) t v in
1519
-
update_array ~seen:true n t (i + 1) (elt :: acc) vs
1520
-
| v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs
1521
-
| [] when seen -> Either.Right (List.rev acc)
1522
-
| [] -> Either.Left (acc, i)
1523
-
in
1524
-
let update ?stub ?absent n t j =
1525
-
match j with
1526
-
| Array (vs, meta) ->
1527
-
begin match update_array ~seen:false n t 0 [] vs with
1528
-
| Either.Right elts -> Array (elts, meta)
1529
-
| Either.Left (acc, len) -> (
1530
-
match absent with
1531
-
| None -> Error.index_out_of_range meta ~n ~len
1532
-
| Some absent ->
1533
-
let elt = Value.enc t absent in
1534
-
let stub =
1535
-
match stub with None -> Value.zero elt | Some j -> j
1536
-
in
1537
-
Array (List.rev (elt :: list_repeat (n - len) stub acc), meta))
1538
-
end
1539
-
| j -> Value.error_sort ~exp:Sort.Array j
1540
-
in
1541
-
let dec = update ?stub ?absent n t in
1542
-
let enc j = j in
1543
-
map ~dec ~enc json
1498
+
let filter_map_array a b f =
1499
+
let dec_empty () = [] in
1500
+
let dec_add i v acc =
1501
+
match f i (decode_exn a v) with
1502
+
| None -> acc
1503
+
| Some v' -> encode_exn b v' :: acc
1504
+
in
1505
+
let dec_finish meta _len acc = Value.list ~meta (List.rev acc) in
1506
+
let enc f acc = function
1507
+
| (Value.Array (a, _) : Value.t) -> Array.list_enc f acc a
1508
+
| j -> error_sort ~exp:Sort.Array j
1509
+
in
1510
+
let enc = { Array.enc } in
1511
+
let enc_meta j = Value.meta j in
1512
+
Array.array
1513
+
(Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t)
1544
1514
1545
-
let set_nth ?stub ?(allow_absent = false) t n v =
1546
-
let absent = if allow_absent then Some v else None in
1547
-
update_nth ?stub ?absent n (const t v)
1515
+
let fold_array t f acc =
1516
+
let dec_empty () = acc in
1517
+
let dec_add = f in
1518
+
let dec_finish _meta _len acc = acc in
1519
+
let enc _f acc _a = acc in
1520
+
let enc = { Array.enc } in
1521
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t)
1548
1522
1549
-
let delete_nth ?(allow_absent = false) n =
1550
-
let dec_empty () = [] in
1551
-
let dec_add i v a = if i = n then a else v :: a in
1552
-
let dec_finish meta len a =
1553
-
if n < len || allow_absent then Value.list ~meta (List.rev a)
1554
-
else Error.index_out_of_range meta ~n ~len
1555
-
in
1556
-
let enc f acc = function
1557
-
| Array (a, _) -> Array.list_enc f acc a
1558
-
| j -> Value.error_sort ~exp:Sort.Array j
1559
-
in
1560
-
let enc_meta j = Value.meta j in
1561
-
let enc = { Array.enc } in
1562
-
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
1523
+
(* Object queries *)
1563
1524
1564
-
let filter_map_array a b f =
1565
-
let dec_empty () = [] in
1566
-
let dec_add i v acc =
1567
-
match f i (Value.dec a v) with
1568
-
| None -> acc
1569
-
| Some v' -> Value.enc b v' :: acc
1570
-
in
1571
-
let dec_finish meta _len acc = Value.list ~meta (List.rev acc) in
1572
-
let enc f acc = function
1573
-
| Array (a, _) -> Array.list_enc f acc a
1574
-
| j -> Value.error_sort ~exp:Sort.Array j
1575
-
in
1576
-
let enc = { Array.enc } in
1577
-
let enc_meta j = Value.meta j in
1578
-
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
1525
+
let mem ?absent name t =
1526
+
Object.map Fun.id
1527
+
|> Object.mem name t ~enc:Fun.id ?dec_absent:absent
1528
+
|> Object.finish
1579
1529
1580
-
let fold_array t f acc =
1581
-
let dec_empty () = acc in
1582
-
let dec_add = f in
1583
-
let dec_finish _meta _len acc = acc in
1584
-
let enc _f acc _a = acc in
1585
-
let enc = { Array.enc } in
1586
-
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t)
1530
+
let update_mem ?absent name t =
1531
+
let update_mem n t v = (n, Value.copy_layout v ~dst:(update_exn t v)) in
1532
+
let rec update_object ~seen name t acc = function
1533
+
| (((name', _) as n), v) :: mems when String.equal name name' ->
1534
+
update_object ~seen:true name t (update_mem n t v :: acc) mems
1535
+
| mem :: mems -> update_object ~seen name t (mem :: acc) mems
1536
+
| [] when seen -> Either.Right (List.rev acc)
1537
+
| [] -> Either.Left acc
1538
+
in
1539
+
let do_update ?absent name t = function
1540
+
| (Value.Object (mems, meta) : Value.t) ->
1541
+
let mems =
1542
+
match update_object ~seen:false name t [] mems with
1543
+
| Either.Right mems -> mems
1544
+
| Either.Left acc -> (
1545
+
match absent with
1546
+
| None ->
1547
+
let fnd = Value.object_names mems in
1548
+
Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
1549
+
| Some absent ->
1550
+
let m = ((name, Meta.none), encode_exn t absent) in
1551
+
List.rev (m :: acc))
1552
+
in
1553
+
(Value.Object (mems, meta) : Value.t)
1554
+
| j -> error_sort ~exp:Sort.Object j
1555
+
in
1556
+
let dec = do_update ?absent name t in
1557
+
let enc j = j in
1558
+
map ~dec ~enc Value.t
1587
1559
1588
-
(* Object queries *)
1560
+
let set_mem ?(allow_absent = false) t name v =
1561
+
let absent = if allow_absent then Some v else None in
1562
+
update_mem ?absent name (const t v)
1589
1563
1590
-
let mem ?absent name t =
1591
-
Object.map Fun.id
1592
-
|> Object.mem name t ~enc:Fun.id ?dec_absent:absent
1593
-
|> Object.finish
1564
+
let update_value_object ~name ~dec_add ~dec_finish =
1565
+
let mems =
1566
+
let dec_empty () = (false, []) in
1567
+
let enc f (_, l) a =
1568
+
List.fold_left (fun a ((n, m), v) -> f m n v a) a l
1569
+
in
1570
+
let enc = { Object.Mems.enc } in
1571
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc Value.t
1572
+
in
1573
+
let enc_meta = function
1574
+
| (Value.Object (_, meta) : Value.t) -> meta
1575
+
| j -> error_sort ~exp:Sort.Object j
1576
+
in
1577
+
let enc = function
1578
+
| (Value.Object (mems, _) : Value.t) -> (false, mems)
1579
+
| j -> error_sort ~exp:Sort.Object j
1580
+
in
1581
+
let dec meta (ok, mems) : Value.t =
1582
+
let fnd = Value.object_names mems in
1583
+
if not ok then Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
1584
+
else Value.Object (List.rev mems, meta)
1585
+
in
1586
+
Object.map' dec ~enc_meta
1587
+
|> Object.keep_unknown mems ~enc
1588
+
|> Object.finish
1594
1589
1595
-
let update_mem ?absent name t =
1596
-
let update_mem n t v = (n, Value.copy_layout v ~dst:(Value.update t v)) in
1597
-
let rec update_object ~seen name t acc = function
1598
-
| (((name', _) as n), v) :: mems when String.equal name name' ->
1599
-
update_object ~seen:true name t (update_mem n t v :: acc) mems
1600
-
| mem :: mems -> update_object ~seen name t (mem :: acc) mems
1601
-
| [] when seen -> Either.Right (List.rev acc)
1602
-
| [] -> Either.Left acc
1603
-
in
1604
-
let update ?absent name t = function
1605
-
| Object (mems, meta) ->
1606
-
let mems =
1607
-
match update_object ~seen:false name t [] mems with
1608
-
| Either.Right mems -> mems
1609
-
| Either.Left acc -> (
1610
-
match absent with
1611
-
| None ->
1612
-
let fnd = Value.object_names mems in
1613
-
Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
1614
-
| Some absent ->
1615
-
let m = ((name, Meta.none), Value.enc t absent) in
1616
-
List.rev (m :: acc))
1617
-
in
1618
-
Object (mems, meta)
1619
-
| j -> Value.error_sort ~exp:Sort.Object j
1620
-
in
1621
-
let update = update ?absent name t in
1622
-
let enc j = j in
1623
-
map ~dec:update ~enc json
1590
+
let delete_mem ?(allow_absent = false) name =
1591
+
let dec_add meta n v (ok, mems) =
1592
+
if n = name then (true, mems) else (ok, ((n, meta), v) :: mems)
1593
+
in
1594
+
let dec_finish _meta ((ok, ms) as a) =
1595
+
if allow_absent then (true, ms) else a
1596
+
in
1597
+
update_value_object ~name ~dec_add ~dec_finish
1624
1598
1625
-
let set_mem ?(allow_absent = false) t name v =
1626
-
let absent = if allow_absent then Some v else None in
1627
-
update_mem ?absent name (const t v)
1599
+
let fold_object t f acc =
1600
+
let mems =
1601
+
let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in
1602
+
let enc _f _ acc = acc in
1603
+
Object.Mems.map t ~dec_empty ~dec_add ~dec_finish
1604
+
~enc:{ Object.Mems.enc }
1605
+
in
1606
+
Object.map Fun.id
1607
+
|> Object.keep_unknown mems ~enc:Fun.id
1608
+
|> Object.finish
1628
1609
1629
-
let update_json_object ~name ~dec_add ~dec_finish =
1630
-
let mems =
1631
-
let dec_empty () = (false, []) in
1632
-
let enc f (_, l) a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
1633
-
let enc = { Object.Mems.enc } in
1634
-
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
1635
-
in
1636
-
let enc_meta = function
1637
-
| Object (_, meta) -> meta
1638
-
| j -> Value.error_sort ~exp:Sort.Object j
1639
-
in
1640
-
let enc = function
1641
-
| Object (mems, _) -> (false, mems)
1642
-
| j -> Value.error_sort ~exp:Sort.Object j
1643
-
in
1644
-
let dec meta (ok, mems) =
1645
-
let fnd = Value.object_names mems in
1646
-
if not ok then Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
1647
-
else Object (List.rev mems, meta)
1648
-
in
1649
-
Object.map' dec ~enc_meta |> Object.keep_unknown mems ~enc |> Object.finish
1610
+
let filter_map_object a b f =
1611
+
let dec_add meta n v (_, mems) =
1612
+
match f meta n (decode_exn a v) with
1613
+
| None -> (true, mems)
1614
+
| Some (n', v') -> (true, (n', encode_exn b v') :: mems)
1615
+
in
1616
+
let dec_finish _meta acc = acc in
1617
+
update_value_object ~name:"" ~dec_add ~dec_finish
1650
1618
1651
-
let delete_mem ?(allow_absent = false) name =
1652
-
let dec_add meta n v (ok, mems) =
1653
-
if n = name then (true, mems) else (ok, ((n, meta), v) :: mems)
1654
-
in
1655
-
let dec_finish _meta ((ok, ms) as a) =
1656
-
if allow_absent then (true, ms) else a
1657
-
in
1658
-
update_json_object ~name ~dec_add ~dec_finish
1619
+
(* Index queries *)
1659
1620
1660
-
let fold_object t f acc =
1661
-
let mems =
1662
-
let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in
1663
-
let enc f _ acc = acc in
1664
-
Object.Mems.map t ~dec_empty ~dec_add ~dec_finish ~enc:{ Object.Mems.enc }
1665
-
in
1666
-
Object.map Fun.id |> Object.keep_unknown mems ~enc:Fun.id |> Object.finish
1621
+
let index ?absent i t =
1622
+
match (i : Path.index) with
1623
+
| Path.Nth (n, _) -> nth ?absent n t
1624
+
| Path.Mem (n, _) -> mem ?absent n t
1667
1625
1668
-
let filter_map_object a b f =
1669
-
let dec_add meta n v (_, mems) =
1670
-
match f meta n (Value.dec a v) with
1671
-
| None -> (true, mems)
1672
-
| Some (n', v') -> (true, (n', Value.enc b v') :: mems)
1673
-
in
1674
-
let dec_finish _meta acc = acc in
1675
-
update_json_object ~name:"" (* irrelevant *) ~dec_add ~dec_finish
1626
+
let set_index ?allow_absent t i v =
1627
+
match (i : Path.index) with
1628
+
| Path.Nth (n, _) -> set_nth ?allow_absent t n v
1629
+
| Path.Mem (n, _) -> set_mem ?allow_absent t n v
1676
1630
1677
-
(* Index queries *)
1631
+
let update_index ?stub ?absent i t =
1632
+
match (i : Path.index) with
1633
+
| Path.Nth (n, _) -> update_nth ?stub ?absent n t
1634
+
| Path.Mem (n, _) -> update_mem ?absent n t
1678
1635
1679
-
let index ?absent i t =
1680
-
match i with
1681
-
| Path.Nth (n, _) -> nth ?absent n t
1682
-
| Path.Mem (n, _) -> mem ?absent n t
1636
+
let delete_index ?allow_absent = function
1637
+
| Path.Nth (n, _) -> delete_nth ?allow_absent n
1638
+
| Path.Mem (n, _) -> delete_mem ?allow_absent n
1683
1639
1684
-
let set_index ?allow_absent t i v =
1685
-
match i with
1686
-
| Path.Nth (n, _) -> set_nth ?allow_absent t n v
1687
-
| Path.Mem (n, _) -> set_mem ?allow_absent t n v
1640
+
(* Path queries *)
1688
1641
1689
-
let update_index ?stub ?absent i t =
1690
-
match i with
1691
-
| Path.Nth (n, _) -> update_nth ?stub ?absent n t
1692
-
| Path.Mem (n, _) -> update_mem ?absent n t
1642
+
let path ?absent p q =
1643
+
List.fold_left (fun q i -> index ?absent i q) q (Path.rev_indices p)
1693
1644
1694
-
let delete_index ?allow_absent = function
1695
-
| Path.Nth (n, _) -> delete_nth ?allow_absent n
1696
-
| Path.Mem (n, _) -> delete_mem ?allow_absent n
1645
+
let update_path ?stub ?absent p t =
1646
+
match Path.rev_indices p with
1647
+
| [] -> update t
1648
+
| i :: is -> (
1649
+
match absent with
1650
+
| None ->
1651
+
let u t i = update_index i t in
1652
+
List.fold_left u (update_index i t) is
1653
+
| Some absent -> (
1654
+
let rec loop absent t = function
1655
+
| Path.Nth (n, _) :: is ->
1656
+
loop Value.empty_array (update_nth ~absent n t) is
1657
+
| Path.Mem (n, _) :: is ->
1658
+
loop Value.empty_object (update_mem ~absent n t) is
1659
+
| [] -> t
1660
+
in
1661
+
match i with
1662
+
| Path.Nth (n, _) ->
1663
+
loop Value.empty_array (update_nth ?stub ~absent n t) is
1664
+
| Path.Mem (n, _) ->
1665
+
loop Value.empty_object (update_mem ~absent n t) is))
1697
1666
1698
-
(* Path queries *)
1667
+
let null_value : Value.t = Value.Null ((), Meta.none)
1699
1668
1700
-
let path ?absent p q =
1701
-
List.fold_left (fun q i -> index ?absent i q) q (Path.rev_indices p)
1669
+
let delete_path ?allow_absent p =
1670
+
match Path.rev_indices p with
1671
+
| [] -> recode ~dec:ignore (fun () -> null_value) ~enc:Value.t
1672
+
| i :: is ->
1673
+
let upd del i = update_index i del in
1674
+
List.fold_left upd (delete_index ?allow_absent i) is
1702
1675
1703
-
let update_path ?stub ?absent p t =
1704
-
match Path.rev_indices p with
1705
-
| [] -> update t
1706
-
| i :: is -> (
1707
-
match absent with
1708
-
| None ->
1709
-
let update t i = update_index i t in
1710
-
List.fold_left update (update_index i t) is
1711
-
| Some absent -> (
1712
-
let rec loop absent t = function
1713
-
| Path.Nth (n, _) :: is ->
1714
-
loop Value.empty_array (update_nth ~absent n t) is
1715
-
| Path.Mem (n, _) :: is ->
1716
-
loop Value.empty_object (update_mem ~absent n t) is
1717
-
| [] -> t
1718
-
in
1719
-
match i with
1720
-
| Path.Nth (n, _) ->
1721
-
loop Value.empty_array (update_nth ?stub ~absent n t) is
1722
-
| Path.Mem (n, _) ->
1723
-
loop Value.empty_object (update_mem ~absent n t) is))
1676
+
let set_path ?stub ?(allow_absent = false) t p v =
1677
+
match Path.rev_indices p with
1678
+
| [] ->
1679
+
recode ~dec:ignore (fun () -> encode_exn t v) ~enc:Value.t
1680
+
| i :: is ->
1681
+
let absent = if allow_absent then Some v else None in
1682
+
update_path ?stub ?absent p (const t v)
1683
+
end
1724
1684
1725
-
let delete_path ?allow_absent p =
1726
-
match Path.rev_indices p with
1727
-
| [] -> recode ~dec:ignore (fun () -> Value.null') ~enc:json
1728
-
| i :: is ->
1729
-
let upd del i = update_index i del in
1730
-
List.fold_left upd (delete_index ?allow_absent i) is
1685
+
(* Top-level wrappers over generic-value decode / encode / recode / update. *)
1731
1686
1732
-
let set_path ?stub ?(allow_absent = false) t p v =
1733
-
match Path.rev_indices p with
1734
-
| [] -> recode ~dec:ignore (fun () -> Value.enc t v) ~enc:json
1735
-
| i :: is ->
1736
-
let absent = if allow_absent then Some v else None in
1737
-
update_path ?stub ?absent p (const t v)
1687
+
let decode t j = Codec.decode t j
1688
+
let decode' t j = Codec.decode' t j
1689
+
let encode t v = Codec.encode t v
1690
+
let encode' t v = Codec.encode' t v
1691
+
let recode t v = Codec.recode t v
1692
+
let recode' t v = Codec.recode' t v
1693
+
let update t v = Codec.update_of_t t v
1694
+
let error_sort = Codec.error_sort
1695
+
let error_type = Codec.error_type
1738
1696
1739
1697
(* Formatting *)
1740
1698
···
1742
1700
1743
1701
let pp_value ?number_format t () =
1744
1702
fun ppf v ->
1745
-
match Value.encode t v with
1703
+
match encode t v with
1746
1704
| Ok j -> pp_json' ?number_format () ppf j
1747
1705
| Error e -> pp_string ppf e
1748
1706
1749
-
(* Low-level representation *)
1707
+
(* Tape *)
1750
1708
1751
-
module Codec = Codec
1752
1709
module Tape = Tape
+1021
-984
lib/json.mli
+1021
-984
lib/json.mli
···
15
15
Some of the decoding maps may be lossy or creative which leads to JSON
16
16
queries and transforms.
17
17
18
+
The combinator vocabulary follows
19
+
{{:https://www.rfc-editor.org/rfc/rfc8259}RFC 8259} (STD 90, the JSON
20
+
Data Interchange Format) and
21
+
{{:https://www.ecma-international.org/publications-and-standards/standards/ecma-404/}
22
+
ECMA-404}: a JSON {e value} is [null], [true]/[false] (literal names
23
+
grouped as booleans here), a {e number}, a {e string}, an {e array}
24
+
of values, or an {e object} -- a collection of {e members}, each a
25
+
name/value pair. {!Codec.number} decodes to OCaml [float] because
26
+
RFC 8259 § 6 identifies IEEE 754 binary64 as the interoperability
27
+
baseline for the number grammar.
28
+
18
29
Read the {{!page-index.quick_start}quick start} and the
19
30
{{!page-cookbook}cookbook}. *)
20
31
21
32
(** {1:preliminaries Preliminaries} *)
22
-
23
-
(** The type for formatters of values of type ['a]. *)
24
33
25
34
module Meta = Loc.Meta
26
35
(** Node metadata (source location + surrounding whitespace). *)
···
80
89
(** JSON error contexts. *)
81
90
module Context : sig
82
91
type index = string node * Path.index
83
-
(** The type for context indices. The {{!Json.kinded_sort}kinded sort} of an
84
-
array or object and its index. *)
92
+
(** The type for context indices. The kinded sort of an array or object and
93
+
its index. *)
85
94
86
95
type t = index list
87
96
(** The type for erroring contexts. The first element indexes the root JSON
···
95
104
96
105
val push_array : string node -> int node -> t -> t
97
106
(** [push_array kinded_sort n ctx] wraps [ctx] as the [n]th element of an
98
-
array of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
107
+
array of kinded sort [kinded_sort]. *)
99
108
100
109
val push_object : string node -> string node -> t -> t
101
110
(** [push_object kinded_sort n ctx] wraps [ctx] as the member named [n] of
102
-
an object of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
111
+
an object of kinded sort [kinded_sort]. *)
103
112
end
104
113
105
114
type t = Context.t * Meta.t * kind
···
127
136
128
137
val push_array : string node -> int node -> t -> 'a
129
138
(** [push_array kinded_sort n e] contextualises [e] as an error in the [n]th
130
-
element of an array of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
139
+
element of an array of kinded sort [kinded_sort]. *)
131
140
132
141
val push_object : string node -> string node -> t -> 'a
133
142
(** [push_object kinded_sort n e] contextualises [e] as an error in the member
134
-
[n] of an object of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
143
+
[n] of an object of kinded sort [kinded_sort]. *)
135
144
136
145
val adjust_context :
137
146
first_byte:Loc.byte_pos ->
···
171
180
exception Error of Error.t
172
181
(** The exception raised on map errors. *)
173
182
174
-
(** {1:types Types} *)
183
+
(** {1:types Generic JSON values}
184
+
185
+
The AST for JSON values is exposed at the top level of this module. Each
186
+
constructor carries its source metadata as an {{!Meta}[Meta.t]} node. *)
187
+
188
+
type name = string node
189
+
(** The type for JSON member names. *)
190
+
191
+
type mem = name * t
192
+
(** The type for generic JSON object members. *)
193
+
194
+
and object' = mem list
195
+
(** The type for generic JSON objects. *)
196
+
197
+
(** The type for generic JSON values. *)
198
+
and t = Value.t =
199
+
| Null of unit node
200
+
| Bool of bool node
201
+
| Number of float node
202
+
(** Encoders must use [Null] if float is {{!Float.is_finite}not finite}.
203
+
*)
204
+
| String of string node
205
+
| Array of t list node
206
+
| Object of object' node (** *)
175
207
176
208
type 'a codec = 'a Codec.t
177
209
(** The type for JSON types.
···
179
211
A value of this type represents a subset of JSON values mapped to a subset
180
212
of values of type ['a] and vice versa. *)
181
213
182
-
val kinded_sort : 'a codec -> string
183
-
(** [kinded_sort t] is a human readable string describing the JSON values typed
184
-
by [t]. This combines the kind of the map with the {{!Sort}sort}(s) of JSON
185
-
value mapped by [t]. For example if [t] is an object map and the kind
186
-
specified for the {{!Object.val-map}map} is ["T"] then this is ["T object"],
187
-
if the kind is empty this is simply ["object"]. See also {!Sort.kinded}. *)
214
+
(** {1:constructors Value constructors}
188
215
189
-
val kind : 'a codec -> string
190
-
(** [kind t] is the [kind] of the underlying map. If the kind is an empty string
191
-
this falls back to mention the {{!Sort}sort}. For example if [t] is an
192
-
object map and the kind specified for the {{!Object.val-map}map} is ["T"]
193
-
then this is ["T"], if the kind is empty then this is ["object"]. See also
194
-
{!Sort.or_kind}. *)
216
+
Construct generic JSON {!t} values. Each constructor accepts an optional
217
+
[meta] (defaults to {!Meta.none}). *)
195
218
196
-
val doc : 'a codec -> string
197
-
(** [doc t] is a documentation string for the JSON values typed by [t]. *)
219
+
type 'a cons = ?meta:Meta.t -> 'a -> t
220
+
(** The type for constructing JSON values from an OCaml value of type ['a]. *)
198
221
199
-
val with_doc : ?kind:string -> ?doc:string -> 'a codec -> 'a codec
200
-
(** [with_doc ?kind ?doc t] is [t] with its {!doc} or {!kind} updated to the
201
-
corresponding values if specified. *)
222
+
val null : unit cons
223
+
(** [null ()] is [Null ((), meta)]. *)
202
224
203
-
(** {1:base Base types}
225
+
val bool : bool cons
226
+
(** [bool b] is [Bool (b, meta)]. *)
204
227
205
-
Read the {{!page-cookbook.base_types}cookbook} on base types. *)
228
+
val number : float cons
229
+
(** [number n] is [Number (n, meta)]. *)
206
230
207
-
(** Mapping JSON base types. *)
208
-
module Base : sig
209
-
(** {1:maps Maps} *)
231
+
val any_float : float cons
232
+
(** [any_float v] is [number v] if {{!Float.is_finite}[Float.is_finite v]} and
233
+
[string (Float.to_string v)] otherwise. See {!Codec.any_float}. *)
210
234
211
-
type ('a, 'b) map
212
-
(** The type for mapping JSON values of type ['a] to values of type ['b]. *)
235
+
val int32 : int32 cons
236
+
(** [int32 i] is [i] as a JSON number. *)
213
237
214
-
val map :
215
-
?kind:string ->
216
-
?doc:string ->
217
-
?dec:(Meta.t -> 'a -> 'b) ->
218
-
?enc:('b -> 'a) ->
219
-
?enc_meta:('b -> Meta.t) ->
220
-
unit ->
221
-
('a, 'b) map
222
-
(** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types represented
223
-
by value of type ['a] to values of type ['b] with:
224
-
- [kind] names the entities represented by the map and [doc] documents
225
-
them. Both default to [""].
226
-
- [dec] is used to decode values of type ['a] to values of type ['b]. Can
227
-
be omitted if the map is only used for encoding, the default
228
-
unconditionally errors.
229
-
- [enc] is used to encode values of type ['b] to values of type ['a]. Can
230
-
be omitted if the map is only used for decoding, the default
231
-
unconditionally errors.
232
-
- [enc_meta] is used to recover JSON metadata (source text layout
233
-
information) from a value to encode. The default unconditionnaly returns
234
-
{!Json.Meta.none}.
238
+
val int64 : int64 cons
239
+
(** [int64 i] is [i] as a JSON number or a JSON string if not in the range
240
+
\[-2{^ 53};2{^ 53}\]. See also {!int64_as_string}. *)
235
241
236
-
{{!decenc}These functions} can be used to quickly devise [dec] and [enc]
237
-
functions from standard OCaml conversion interfaces. *)
242
+
val int64_as_string : int64 cons
243
+
(** [int64_as_string i] is [i] as a JSON string. See also {!int64}. *)
238
244
239
-
val id : ('a, 'a) map
240
-
(** [id] is the identity map. *)
245
+
val int : int cons
246
+
(** [int i] is [i] as a JSON number or a JSON string if not in the range
247
+
\[-2{^ 53};2{^ 53}\]. See also {!int_as_string}. *)
241
248
242
-
val ignore : ('a, unit) map
243
-
(** [ignore] is the ignoring map. It ignores decodes and errors on encodes. *)
249
+
val int_as_string : int cons
250
+
(** [int_as_string i] is [i] as a JSON string. See also {!int}. *)
244
251
245
-
(** {2:types JSON types} *)
252
+
val string : string cons
253
+
(** [string s] is [String (s, meta)]. *)
246
254
247
-
val null : (unit, 'a) map -> 'a codec
248
-
(** [null map] maps with [map] JSON nulls represented by [()] to values of
249
-
type ['a]. See also {!Json.null}. *)
255
+
val list : t list cons
256
+
(** [list l] is [Array (l, meta)]. *)
250
257
251
-
val bool : (bool, 'a) map -> 'a codec
252
-
(** [bool map] maps with [map] JSON booleans represented by [bool] values to
253
-
values of type ['a]. See also {!Json.bool}. *)
258
+
val array : t array cons
259
+
(** [array a] is [Array (Array.to_list a, meta)]. See also {!list}. *)
254
260
255
-
val number : (float, 'a) map -> 'a codec
256
-
(** [number map] maps with [map] JSON nulls or numbers represented by [float]
257
-
values to values of type ['a]. The [float] representation decodes JSON
258
-
nulls to {!Float.nan} and lossily encodes any
259
-
{{!Float.is_finite}non-finite} to JSON null
260
-
({{!page-cookbook.non_finite_numbers}explanation}). See also
261
-
{!Json.number}. *)
261
+
val object' : mem list cons
262
+
(** [object' mems] is [Object (mems, meta)]. *)
262
263
263
-
val string : (string, 'a) map -> 'a codec
264
-
(** [string map] maps with [map] {e unescaped} JSON strings represented by
265
-
UTF-8 encoded [string] values to values of type ['a]. See also
266
-
{!Json.string}. *)
264
+
val empty_array : t
265
+
(** [empty_array] is an empty JSON array with {!Meta.none}. *)
267
266
268
-
(** {1:decenc Decoding and encoding functions}
267
+
val empty_object : t
268
+
(** [empty_object] is an empty JSON object with {!Meta.none}. *)
269
269
270
-
These function create suitable [dec] and [enc] functions to give to
271
-
{!val-map} from standard OCaml conversion interfaces. See also
272
-
{!Json.of_of_string}. *)
270
+
val option : 'a cons -> 'a option cons
271
+
(** [option c] constructs [Some v] values with [c v] and [None] ones with
272
+
{!val-null}. *)
273
273
274
-
val dec : ('a -> 'b) -> Meta.t -> 'a -> 'b
275
-
(** [dec f] is a decoding function from [f]. This assumes [f] never fails. *)
274
+
val name : ?meta:Meta.t -> string -> name
275
+
(** [name ?meta n] is [(n, meta)]. [meta] defaults to {!Meta.none}. *)
276
276
277
-
val dec_result :
278
-
?kind:string -> ('a -> ('b, string) result) -> Meta.t -> 'a -> 'b
279
-
(** [dec f] is a decoding function from [f]. [Error _] values are given to
280
-
{!Error.msg}, prefixed by [kind:] (if specified). *)
277
+
val mem : name -> t -> mem
278
+
(** [mem n v] is [(n, v)]. *)
281
279
282
-
val dec_failure : ?kind:string -> ('a -> 'b) -> Meta.t -> 'a -> 'b
283
-
(** [dec f] is a decoding function from [f]. [Failure _] exceptions are
284
-
catched and given to {!Error.msg}, prefixed by [kind:] (if specified). *)
280
+
val zero : ?meta:Meta.t -> t -> t
281
+
(** [zero j] is a stub value of the sort value of [j]. The stub value is the
282
+
"natural" zero: null, false, 0, empty string, empty array, empty object. *)
285
283
286
-
val enc : ('b -> 'a) -> 'b -> 'a
287
-
(** [enc f] is an encoding function from [f]. This assumes [f] never fails. *)
284
+
(** {1:destructors Value destructors and queries} *)
288
285
289
-
val enc_result : ?kind:string -> ('b -> ('a, string) result) -> 'b -> 'a
290
-
(** [enc_result f] is an encoding function from [f]. [Error _] values are
291
-
given to {!Error.msg}, prefixed by [kind:] (if specified). *)
286
+
val find_mem : string -> mem list -> mem option
287
+
(** [find_mem n ms] finds the first member whose name matches [n] in [ms]. *)
292
288
293
-
val enc_failure : ?kind:string -> ('b -> 'a) -> 'b -> 'a
294
-
(** [enc_failure f] is an encoding function from [f]. [Failure _] exceptions
295
-
are catched and given to {!Error.msg}, prefixed by [kind:] (if specified).
296
-
*)
297
-
end
289
+
val find_mem' : name -> mem list -> mem option
290
+
(** [find_mem' n ms] is [find_mem (fst n) ms]. *)
298
291
299
-
(** {2:option Nulls and options}
292
+
val object_names : mem list -> string list
293
+
(** [object_names ms] are the names of [ms]. *)
300
294
301
-
Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *)
295
+
val object_names' : mem list -> name list
296
+
(** [object_names' ms] are the names of [ms] as {!name} nodes. *)
302
297
303
-
val null : ?kind:string -> ?doc:string -> 'a -> 'a codec
304
-
(** [null v] maps JSON nulls to [v]. On encodes any value of type ['a] is
305
-
encoded by null. [doc] and [kind] are given to the underlying
306
-
{!Base.type-map}. See also {!Base.null}. *)
298
+
val meta : t -> Meta.t
299
+
(** [meta v] is the metadata of value [v]. *)
307
300
308
-
val none : 'a option codec
309
-
(** [none] maps JSON nulls to [None]. *)
301
+
val set_meta : Meta.t -> t -> t
302
+
(** [set_meta m v] replaces [v]'s meta with [m]. *)
310
303
311
-
val some : 'a codec -> 'a option codec
312
-
(** [some t] maps JSON like [t] does but wraps results in [Some]. Encoding fails
313
-
if the value is [None]. *)
304
+
val get_meta : t -> Meta.t
305
+
(** [get_meta v] is {!meta}. *)
314
306
315
-
val option : ?kind:string -> ?doc:string -> 'a codec -> 'a option codec
316
-
(** [option t] maps JSON nulls to [None] and other values by [t]. [doc] and
317
-
[kind] are given to the underlying {!val-any} map. *)
307
+
val copy_layout : t -> dst:t -> t
308
+
(** [copy_layout src ~dst] copies the layout of [src] and sets it on [dst]
309
+
using {!Meta.copy_ws}. *)
318
310
319
-
(** {2:booleans Booleans} *)
311
+
val sort : t -> Sort.t
312
+
(** [sort v] is the sort of value [v]. *)
320
313
321
-
val bool : bool codec
322
-
(** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *)
314
+
(** {1:compare Equality and ordering} *)
323
315
324
-
(** {2:numbers Numbers}
316
+
val equal : t -> t -> bool
317
+
(** [equal j0 j1] is {!compare}[ j0 j1 = 0]. *)
325
318
326
-
Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON numbers and
327
-
their many pitfalls. *)
319
+
val compare : t -> t -> int
320
+
(** [compare j0 j1] is a total order on JSON values:
321
+
- Floating point values are compared with {!Float.compare}, this means NaN
322
+
values are equal.
323
+
- Strings are compared byte wise.
324
+
- Objects members are sorted before being compared.
325
+
- {!Meta.t} values are ignored. *)
328
326
329
-
val number : float codec
330
-
(** [number] maps JSON nulls or numbers to [float] values. On decodes JSON null
331
-
is mapped to {!Float.nan}. On encodes any {{!Float.is_finite}non-finite}
332
-
float is lossily mapped to JSON null
333
-
({{!page-cookbook.non_finite_numbers}explanation}). See also {!Base.number},
334
-
{!any_float} and the integer combinators below. *)
327
+
val pp : t Fmt.t
328
+
(** [pp] is {!pp_json}. *)
335
329
336
-
val any_float : float codec
337
-
(** [any_float] is a lossless representation for IEEE 754 doubles. It maps
338
-
{{!Float.is_finite}non-finite} floats by the JSON strings defined by
339
-
{!Float.to_string}. This contrasts with {!val-number} which maps them to
340
-
JSON null values ({{!page-cookbook.non_finite_numbers}explanation}). Note
341
-
that on decodes this still maps JSON nulls to {!Float.nan} and any
342
-
successful string decode of {!Float.of_string_opt} (so numbers can also be
343
-
written as strings). See also {!val-number}.
330
+
(** {1:decode_generic Decode, encode and recode}
344
331
345
-
{b Warning.} [any_float] should only be used between parties that have
346
-
agreed on such an encoding. To maximize interoperability you should use the
347
-
lossy {!val-number} map. *)
332
+
Convert between generic JSON values {!t} and typed values via a
333
+
{{!codec}codec}. *)
348
334
349
-
val float_as_hex_string : float codec
350
-
(** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex
351
-
notation to float values. On encodes strings this uses the ["%h"] format
352
-
string. On decodes it accepts anything sucessfully decoded by
353
-
{!Float.of_string_opt}. *)
335
+
val decode : 'a codec -> t -> ('a, string) result
336
+
(** [decode t j] decodes a value from the generic JSON [j] according to codec
337
+
[t]. *)
354
338
355
-
val uint8 : int codec
356
-
(** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers are
357
-
sucessfully decoded if after truncation they can be represented on the
358
-
\[0;255\] range. Encoding errors if the integer is out of range.*)
339
+
val decode' : 'a codec -> t -> ('a, Error.t) result
340
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
359
341
360
-
val uint16 : int codec
361
-
(** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers are
362
-
sucessfully decoded if after truncation they can be represented on the
363
-
\[0;65535\] range. Encoding errors if the integer is out of range.*)
342
+
val encode : 'a codec -> 'a -> (t, string) result
343
+
(** [encode t v] encodes a generic JSON value for [v] according to codec [t]. *)
364
344
365
-
val int8 : int codec
366
-
(** [int8] maps JSON numbers to 8-bit integers. JSON numbers are sucessfully
367
-
decoded if after truncation they can be represented on the \[-128;127\]
368
-
range. Encoding errors if the integer is out of range.*)
345
+
val encode' : 'a codec -> 'a -> (t, Error.t) result
346
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
369
347
370
-
val int16 : int codec
371
-
(** [int16] maps JSON numbers to 16-bit integers. JSON numbers are sucessfully
372
-
decoded if after truncation they can be represented on the \[-32768;32767\]
373
-
range. Encoding errors if the integer is out of range. *)
348
+
val recode : 'a codec -> t -> (t, string) result
349
+
(** [recode t v] decodes [v] with [t] and encodes it with [t]. *)
374
350
375
-
val int32 : int32 codec
376
-
(** [int32] maps JSON numbers to 32-bit integers. JSON numbers are sucessfully
377
-
decoded if after truncation they can be represented on the [int32] range,
378
-
otherwise the decoder errors. *)
351
+
val recode' : 'a codec -> t -> (t, Error.t) result
352
+
(** [recode'] is like {!val-recode} but preserves the error structure. *)
379
353
380
-
val int64 : int64 codec
381
-
(** [int64] maps truncated JSON numbers or JSON strings to 64-bit integers.
382
-
- JSON numbers are sucessfully decoded if after truncation they can be
383
-
represented on the [int64] range, otherwise the decoder errors. [int64]
384
-
values are encoded as JSON numbers if the integer is in the
385
-
\[-2{^ 53};2{^ 53}\] range.
386
-
- JSON strings are decoded using {!int_of_string_opt}, this allows binary,
387
-
octal, decimal and hex syntaxes and errors on overflow and syntax errors.
388
-
[int64] values are encoded as JSON strings with {!Int64.to_string} when
389
-
the integer is outside the \[-2{^ 53};2{^ 53}\] range. *)
354
+
val update : 'a codec -> t -> t
355
+
(** [update] is like {!val-recode} but raises {!Json.exception-Error}. *)
390
356
391
-
val int64_as_string : int64 codec
392
-
(** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this uses
393
-
{!Int64.of_string_opt} which allows binary, octal, decimal and hex syntaxes
394
-
and errors on overflow and syntax errors. On encodes uses
395
-
{!Int64.to_string}. *)
357
+
val error_sort : exp:Sort.t -> t -> 'a
358
+
(** [error_sort ~exp fnd] errors when sort [exp] was expected but generic JSON
359
+
[fnd] was found. *)
396
360
397
-
val int : int codec
398
-
(** [int] maps truncated JSON numbers or JSON strings to [int] values.
399
-
- JSON numbers are sucessfully decoded if after truncation they can be
400
-
represented on the [int] range, otherwise the decoder errors. [int] values
401
-
are encoded as JSON numbers if the integer is in the \[-2{^ 53};2{^ 53}\]
402
-
range.
403
-
- JSON strings are decoded using {!int_of_string_opt}, this allows binary,
404
-
octal, decimal and hex syntaxes and errors on overflow and syntax errors.
405
-
[int] values are encoded as JSON strings with {!Int.to_string} when the
406
-
integer is outside the \[-2{^ 53};2{^ 53}\] range
361
+
val error_type : 'a codec -> t -> 'a
362
+
(** [error_type t fnd] errors when the type expected by [t] does not match
363
+
[fnd]. *)
364
+
365
+
(** {1:formatting Formatting} *)
366
+
367
+
(** The type for specifying JSON encoding formatting. See for example
368
+
{!Json_bytesrw.val-encode}. *)
369
+
type format =
370
+
| Minify (** Compact. No whitespace, no newlines. *)
371
+
| Indent (** Indented output (not necessarily pretty). *)
372
+
| Layout (** Follow {!Meta} layout information. *)
373
+
374
+
type number_format = (float -> unit, Format.formatter, unit) Stdlib.format
375
+
(** The type for JSON number formatters. *)
376
+
377
+
val default_number_format : number_format
378
+
(** [default_number_format] is ["%.17g"]. This number formats ensures that
379
+
finite floating point values can be interchanged without loss of precision.
380
+
*)
381
+
382
+
val pp_null : unit Fmt.t
383
+
(** [pp_null] formats a JSON null. *)
384
+
385
+
val pp_bool : bool Fmt.t
386
+
(** [pp_bool] formats a JSON bool. *)
407
387
408
-
{b Warning.} The behaviour of this function is platform dependent, it
409
-
depends on the value of {!Sys.int_size}. *)
388
+
val pp_number : float Fmt.t
389
+
(** [pp_number] formats a JSON number of a JSON null if the float is not finite.
390
+
Uses the {!default_number_format}. *)
410
391
411
-
val int_as_string : int codec
412
-
(** [int_as_string] maps JSON strings to [int] values. On decodes this uses
413
-
{!int_of_string_opt} which allows binary, octal, decimal and hex syntaxes
414
-
and errors on overflow and syntax errors. On encodes uses {!Int.to_string}.
392
+
val pp_number' : number_format -> float Fmt.t
393
+
(** [pp_number' fmt] is like {!pp_number} but uses [fmt] to format the number.
394
+
*)
415
395
416
-
{b Warning.} The behaviour of this function is platform dependent, it
417
-
depends on the value of {!Sys.int_size}. *)
396
+
val pp_string : string Fmt.t
397
+
(** [pp_string] formats a JSON string (quoted and escaped). Assumes the string
398
+
is valid UTF-8. *)
418
399
419
-
(** {2:enums Strings and enums}
400
+
val pp_json : t Fmt.t
401
+
(** [pp_json] formats JSON, see {!pp_json'}. *)
420
402
421
-
Read the {{!page-cookbook.transform_strings}cookbook} on transforming
422
-
strings. *)
403
+
val pp_json' : ?number_format:number_format -> unit -> t Fmt.t
404
+
(** [pp_json'] formats JSON like {!pp_json} with a configurable [number_format].
405
+
The output is indented but may be more compact than an [Indent] JSON encoder
406
+
does (arrays may be output on one line if they fit, etc). Non-finite numbers
407
+
print as JSON nulls; strings are assumed to be valid UTF-8. *)
423
408
424
-
val string : string codec
425
-
(** [string] maps unescaped JSON strings to UTF-8 encoded [string] values. See
426
-
also {!Base.string}.
409
+
val pp_value : ?number_format:number_format -> 'a codec -> unit -> 'a Fmt.t
410
+
(** [pp_value t ()] formats the JSON representation of values as described by
411
+
[t] by encoding it with {!val-encode} and formatting it with {!pp_json'}.
412
+
If the encoding of the value errors a JSON string with the error message is
413
+
formatted. This means that {!pp_value} should always format valid JSON
414
+
text. *)
427
415
428
-
{b Warning.} Encoders assume OCaml [string]s have been checked for UTF-8
429
-
validity. *)
416
+
(** {1:codec Codec combinators}
430
417
431
-
val of_of_string :
432
-
?kind:string ->
433
-
?doc:string ->
434
-
?enc:('a -> string) ->
435
-
(string -> ('a, string) result) ->
436
-
'a codec
437
-
(** [of_of_string of_string] maps JSON string with a {{!Base.type-map}base map}
438
-
using [of_string] for decoding and [enc] for encoding. See the
439
-
{{!page-cookbook.transform_strings}cookbook}. *)
418
+
Codec combinators describe how OCaml values map to and from JSON values.
419
+
Most users open {!Codec} to build codecs:
420
+
{[ let open Json.Codec in … ]} *)
440
421
441
-
val enum :
442
-
?cmp:('a -> 'a -> int) ->
443
-
?kind:string ->
444
-
?doc:string ->
445
-
(string * 'a) list ->
446
-
'a codec
447
-
(** [enum assoc] maps JSON strings member of the [assoc] list to the
448
-
corresponding OCaml value and vice versa in log(n). [cmp] is used to compare
449
-
the OCaml values, it defaults to {!Stdlib.compare}. Decoding and encoding
450
-
errors on strings or values not part of [assoc]. *)
422
+
(** Codec combinators and the low-level codec representation. *)
423
+
module Codec : sig
424
+
(** {1:types Types} *)
451
425
452
-
val binary_string : string codec
453
-
(** [binary_string] maps JSON strings made of an even number of hexdecimal
454
-
US-ASCII upper or lower case digits to the corresponding byte sequence. On
455
-
encoding uses only lower case hexadecimal digits to encode the byte
456
-
sequence. *)
426
+
type value := t
427
+
(** Destructive alias: inside this module, [value] refers to the outer
428
+
{!Json.t} AST (so the codec type [t] below can shadow the AST without
429
+
losing access to it). *)
457
430
458
-
(** {1:arrays Arrays and tuples}
431
+
type 'a t = 'a Codec.t
432
+
(** The type for JSON types (codecs). *)
459
433
460
-
Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays and see
461
-
also {{!array_queries}array queries and updates}. *)
434
+
val kinded_sort : 'a t -> string
435
+
(** [kinded_sort t] is a human readable string describing the JSON values
436
+
typed by [t]. This combines the kind of the map with the {{!Sort}sort}(s)
437
+
of JSON value mapped by [t]. For example if [t] is an object map and the
438
+
kind specified for the {{!Object.val-map}map} is ["T"] then this is
439
+
["T object"], if the kind is empty this is simply ["object"]. See also
440
+
{!Sort.kinded}. *)
462
441
463
-
(** Mapping JSON arrays. *)
464
-
module Array : sig
465
-
(** {1:maps Maps} *)
442
+
val kind : 'a t -> string
443
+
(** [kind t] is the [kind] of the underlying map. If the kind is an empty
444
+
string this falls back to mention the {{!Sort}sort}. For example if [t]
445
+
is an object map and the kind specified for the {{!Object.val-map}map} is
446
+
["T"] then this is ["T"], if the kind is empty then this is ["object"].
447
+
See also {!Sort.or_kind}. *)
466
448
467
-
type ('array, 'elt) enc = {
468
-
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
469
-
}
470
-
(** The type for specifying array encoding functions. A function to fold over
471
-
the elements of type ['elt] of the array of type ['array]. *)
449
+
val doc : 'a t -> string
450
+
(** [doc t] is a documentation string for the JSON values typed by [t]. *)
472
451
473
-
type ('array, 'elt, 'builder) map
474
-
(** The type for mapping JSON arrays with elements of type ['elt] to arrays of
475
-
type ['array] using values of type ['builder] to build them. *)
452
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
453
+
(** [with_doc ?kind ?doc t] is [t] with its {!doc} or {!kind} updated to the
454
+
corresponding values if specified. *)
476
455
477
-
val map :
478
-
?kind:string ->
479
-
?doc:string ->
480
-
?dec_empty:(unit -> 'builder) ->
481
-
?dec_skip:(int -> 'builder -> bool) ->
482
-
?dec_add:(int -> 'elt -> 'builder -> 'builder) ->
483
-
?dec_finish:(Meta.t -> int -> 'builder -> 'array) ->
484
-
?enc:('array, 'elt) enc ->
485
-
?enc_meta:('array -> Meta.t) ->
486
-
'elt codec ->
487
-
('array, 'elt, 'builder) map
488
-
(** [map elt] maps JSON arrays of type ['elt] to arrays of type ['array] built
489
-
with type ['builder].
490
-
- [kind] names the entities represented by the map and [doc] documents
491
-
them. Both default to [""].
492
-
- [dec_empty ()] is used to create a builder for the empty array. Can be
493
-
omitted if the map is only used for encoding, the default
494
-
unconditionally errors.
495
-
- [dec_skip i b] is used to skip the [i]th index of the JSON array. If
496
-
[true], the element is not decoded with [elt] and not added with
497
-
[dec_add] but skipped. The default always returns [false].
498
-
- [dec_add i v] is used to add the [i]th JSON element [v] $ decoded by
499
-
[elt] to the builder [b]. Can be omitted if the map is only used for
500
-
encoding, the default unconditionally errors.
501
-
- [dec_finish b] converts the builder to the final array. Can be omitted
502
-
if the map is only used for encoding, the default unconditionally
503
-
errors.
504
-
- [enc.enc f acc a] folds over the elements of array [a] in increasing
505
-
order with [f] and starting with [acc]. This function is used to encode
506
-
[a] to a JSON array. Can be omitted if the map is only used for
507
-
decoding, the default unconditionally errors.
508
-
- [enc_meta a] is the metadata to use for encoding [v] to a JSON array.
509
-
Default returns {!Meta.none}. *)
456
+
(** {1:base Base types}
510
457
511
-
val list_map :
512
-
?kind:string ->
513
-
?doc:string ->
514
-
?dec_skip:(int -> 'a list -> bool) ->
515
-
'a codec ->
516
-
('a list, 'a, 'a list) map
517
-
(** [list_map elt] maps JSON arrays with elements of type [elt] to [list]
518
-
values. See also {!Json.list}. *)
458
+
Read the {{!page-cookbook.base_types}cookbook} on base types. *)
519
459
520
-
type 'a array_builder
521
-
(** The type for array builders. *)
460
+
(** Mapping JSON base types. *)
461
+
module Base : sig
462
+
(** {1:maps Maps} *)
522
463
523
-
val array_map :
524
-
?kind:string ->
525
-
?doc:string ->
526
-
?dec_skip:(int -> 'a array_builder -> bool) ->
527
-
'a codec ->
528
-
('a array, 'a, 'a array_builder) map
529
-
(** [array_map elt] maps JSON arrays with elements of type [elt] to [array]
530
-
values. See also {!Json.array}. *)
464
+
type ('a, 'b) map
465
+
(** The type for mapping JSON values of type ['a] to values of type ['b]. *)
531
466
532
-
type ('a, 'b, 'c) bigarray_builder
533
-
(** The type for bigarray_builders. *)
467
+
val map :
468
+
?kind:string ->
469
+
?doc:string ->
470
+
?dec:(Meta.t -> 'a -> 'b) ->
471
+
?enc:('b -> 'a) ->
472
+
?enc_meta:('b -> Meta.t) ->
473
+
unit ->
474
+
('a, 'b) map
475
+
(** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types represented
476
+
by value of type ['a] to values of type ['b] with:
477
+
- [kind] names the entities represented by the map and [doc] documents
478
+
them. Both default to [""].
479
+
- [dec] is used to decode values of type ['a] to values of type ['b].
480
+
Can be omitted if the map is only used for encoding, the default
481
+
unconditionally errors.
482
+
- [enc] is used to encode values of type ['b] to values of type ['a].
483
+
Can be omitted if the map is only used for decoding, the default
484
+
unconditionally errors.
485
+
- [enc_meta] is used to recover JSON metadata (source text layout
486
+
information) from a value to encode. The default unconditionnaly
487
+
returns {!Json.Meta.none}.
534
488
535
-
val bigarray_map :
536
-
?kind:string ->
537
-
?doc:string ->
538
-
?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) ->
539
-
('a, 'b) Bigarray.kind ->
540
-
'c Bigarray.layout ->
541
-
'a codec ->
542
-
(('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map
543
-
(** [bigarray k l elt] maps JSON arrays with elements of type [elt] to
544
-
bigarray values of kind [k] and layout [l]. See also {!Json.bigarray}. *)
489
+
{{!decenc}These functions} can be used to quickly devise [dec] and [enc]
490
+
functions from standard OCaml conversion interfaces. *)
545
491
546
-
(** {1:types JSON types} *)
492
+
val id : ('a, 'a) map
493
+
(** [id] is the identity map. *)
547
494
548
-
val array : ('a, _, _) map -> 'a codec
549
-
(** [array map] maps with [map] JSON arrays to values of type ['a]. See the
550
-
the {{!section-arrays}array combinators}. *)
495
+
val ignore : ('a, unit) map
496
+
(** [ignore] is the ignoring map. It ignores decodes and errors on encodes.
497
+
*)
551
498
552
-
val ignore : unit codec
553
-
(** [ignore] ignores JSON arrays on decoding and errors on encoding. *)
499
+
(** {2:types JSON types} *)
554
500
555
-
val zero : unit codec
556
-
(** [zero] ignores JSON arrays on decoding and encodes an empty array. *)
557
-
end
501
+
val null : (unit, 'a) map -> 'a t
502
+
(** [null map] maps with [map] JSON nulls represented by [()] to values of
503
+
type ['a]. See also {!Codec.null}. *)
558
504
559
-
val list : ?kind:string -> ?doc:string -> 'a codec -> 'a list codec
560
-
(** [list t] maps JSON arrays of type [t] to [list] values. See also
561
-
{!Array.list_map}. *)
505
+
val bool : (bool, 'a) map -> 'a t
506
+
(** [bool map] maps with [map] JSON booleans represented by [bool] values to
507
+
values of type ['a]. See also {!Codec.bool}. *)
562
508
563
-
val array : ?kind:string -> ?doc:string -> 'a codec -> 'a array codec
564
-
(** [array t] maps JSON arrays of type [t] to [array] values. See also
565
-
{!Array.array_map}. *)
509
+
val number : (float, 'a) map -> 'a t
510
+
(** [number map] maps with [map] JSON nulls or numbers represented by
511
+
[float] values to values of type ['a]. The [float] representation
512
+
decodes JSON nulls to {!Float.nan} and lossily encodes any
513
+
{{!Float.is_finite}non-finite} to JSON null
514
+
({{!page-cookbook.non_finite_numbers}explanation}). See also
515
+
{!Codec.number}. *)
566
516
567
-
val array_as_string_map :
568
-
?kind:string ->
569
-
?doc:string ->
570
-
key:('a -> string) ->
571
-
'a codec ->
572
-
'a Map.Make(String).t codec
573
-
(** [array_as_string_map ~key t] maps JSON array elements of type [t] to string
574
-
maps by indexing them with [key]. If two elements have the same [key] the
575
-
element with the greatest index takes over. Elements of the map are encoded
576
-
to a JSON array in (binary) key order. *)
517
+
val string : (string, 'a) map -> 'a t
518
+
(** [string map] maps with [map] {e unescaped} JSON strings represented by
519
+
UTF-8 encoded [string] values to values of type ['a]. See also
520
+
{!Codec.string}. *)
577
521
578
-
val bigarray :
579
-
?kind:string ->
580
-
?doc:string ->
581
-
('a, 'b) Bigarray.kind ->
582
-
'a codec ->
583
-
('a, 'b, Bigarray.c_layout) Bigarray.Array1.t codec
584
-
(** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t] values.
585
-
See also {!Array.bigarray_map}. *)
522
+
(** {1:decenc Decoding and encoding functions}
586
523
587
-
val t2 :
588
-
?kind:string ->
589
-
?doc:string ->
590
-
?dec:('a -> 'a -> 't2) ->
591
-
?enc:('t2 -> int -> 'a) ->
592
-
'a codec ->
593
-
't2 codec
594
-
(** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type [t] to
595
-
value of type ['t2]. Decodes error if there are more elements. [enc v i]
596
-
must return the zero-based [i]th element. *)
524
+
These function create suitable [dec] and [enc] functions to give to
525
+
{!val-map} from standard OCaml conversion interfaces. See also
526
+
{!Codec.of_of_string}. *)
597
527
598
-
val t3 :
599
-
?kind:string ->
600
-
?doc:string ->
601
-
?dec:('a -> 'a -> 'a -> 't3) ->
602
-
?enc:('t3 -> int -> 'a) ->
603
-
'a codec ->
604
-
't3 codec
605
-
(** [t3] is like {!t2} but for 3 elements. *)
528
+
val dec : ('a -> 'b) -> Meta.t -> 'a -> 'b
529
+
(** [dec f] is a decoding function from [f]. This assumes [f] never fails.
530
+
*)
606
531
607
-
val t4 :
608
-
?kind:string ->
609
-
?doc:string ->
610
-
?dec:('a -> 'a -> 'a -> 'a -> 't4) ->
611
-
?enc:('t4 -> int -> 'a) ->
612
-
'a codec ->
613
-
't4 codec
614
-
(** [t4] is like {!t2} but for 4 elements. *)
532
+
val dec_result :
533
+
?kind:string -> ('a -> ('b, string) result) -> Meta.t -> 'a -> 'b
534
+
(** [dec f] is a decoding function from [f]. [Error _] values are given to
535
+
{!Error.msg}, prefixed by [kind:] (if specified). *)
615
536
616
-
val tn : ?kind:string -> ?doc:string -> n:int -> 'a codec -> 'a array codec
617
-
(** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to [array]
618
-
values. This is {!val-array} limited by [n]. *)
537
+
val dec_failure : ?kind:string -> ('a -> 'b) -> Meta.t -> 'a -> 'b
538
+
(** [dec f] is a decoding function from [f]. [Failure _] exceptions are
539
+
catched and given to {!Error.msg}, prefixed by [kind:] (if specified).
540
+
*)
619
541
620
-
(** {1:objects Objects}
542
+
val enc : ('b -> 'a) -> 'b -> 'a
543
+
(** [enc f] is an encoding function from [f]. This assumes [f] never fails.
544
+
*)
621
545
622
-
Read the {{!page-cookbook.dealing_with_objects}cookbook} on objects. See a
623
-
{{!page-cookbook.objects_as_records}simple example}. See also
624
-
{{!object_queries}object queries and updates}. *)
546
+
val enc_result : ?kind:string -> ('b -> ('a, string) result) -> 'b -> 'a
547
+
(** [enc_result f] is an encoding function from [f]. [Error _] values are
548
+
given to {!Error.msg}, prefixed by [kind:] (if specified). *)
625
549
626
-
(** Mapping JSON objects. *)
627
-
module Object : sig
628
-
(** {1:maps Maps} *)
550
+
val enc_failure : ?kind:string -> ('b -> 'a) -> 'b -> 'a
551
+
(** [enc_failure f] is an encoding function from [f]. [Failure _] exceptions
552
+
are catched and given to {!Error.msg}, prefixed by [kind:] (if
553
+
specified). *)
554
+
end
629
555
630
-
type ('o, 'dec) map
631
-
(** The type for mapping JSON objects to values of type ['o]. The ['dec] type
632
-
is used to construct ['o] from members see {!val-mem}. *)
556
+
(** {2:option Nulls and options}
633
557
634
-
val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
635
-
(** [map dec] is an empty JSON object decoded by function [dec].
636
-
- [kind] names the entities represented by the map and [doc] documents
637
-
them. Both default to [""].
638
-
- [dec] is a constructor eventually returning a value of type ['o] to be
639
-
saturated with calls to {!val-mem}, {!val-case_mem} or
640
-
{!val-keep_unknown}. This is needed for decoding. Use {!enc_only} if the
641
-
result is only used for encoding. *)
558
+
Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *)
642
559
643
-
val map' :
644
-
?kind:string ->
645
-
?doc:string ->
646
-
?enc_meta:('o -> Meta.t) ->
647
-
(Meta.t -> 'dec) ->
648
-
('o, 'dec) map
649
-
(** [map' dec] is like {!val-map} except you get the object's decoding metdata
650
-
in [dec] and [enc_meta] is used to recover it on encoding. *)
560
+
val null : ?kind:string -> ?doc:string -> 'a -> 'a t
561
+
(** [null v] maps JSON nulls to [v]. On encodes any value of type ['a] is
562
+
encoded by null. [doc] and [kind] are given to the underlying
563
+
{!Base.type-map}. See also {!Base.null}. *)
651
564
652
-
val enc_only :
653
-
?kind:string ->
654
-
?doc:string ->
655
-
?enc_meta:('o -> Meta.t) ->
656
-
unit ->
657
-
('o, 'a) map
658
-
(** [enc_only ()] is like {!val-map'} but can only be used for encoding. *)
565
+
val none : 'a option t
566
+
(** [none] maps JSON nulls to [None]. *)
659
567
660
-
val finish : ('o, 'o) map -> 'o codec
661
-
(** [finish map] is a JSON type for objects mapped by [map]. Raises
662
-
[Invalid_argument] if [map] describes a member name more than once. *)
568
+
val some : 'a t -> 'a option t
569
+
(** [some t] maps JSON like [t] does but wraps results in [Some]. Encoding
570
+
fails if the value is [None]. *)
663
571
664
-
(** {1:mems Members} *)
572
+
val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t
573
+
(** [option t] maps JSON nulls to [None] and other values by [t]. [doc] and
574
+
[kind] are given to the underlying {!val-any} map. *)
665
575
666
-
(** Member maps.
576
+
(** {2:booleans Booleans} *)
667
577
668
-
Usually it's better to use {!Json.Object.mem} or {!Json.Object.opt_mem}
669
-
directly. But this may be useful in certain abstraction contexts. *)
670
-
module Mem : sig
671
-
type ('o, 'dec) object_map := ('o, 'dec) map
578
+
val bool : bool t
579
+
(** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *)
672
580
673
-
type ('o, 'a) map
674
-
(** The type for mapping a member object to a value ['a] stored in an OCaml
675
-
value of type ['o]. *)
581
+
(** {2:numbers Numbers}
676
582
677
-
val map :
678
-
?doc:string ->
679
-
?dec_absent:'a ->
680
-
?enc:('o -> 'a) ->
681
-
?enc_omit:('a -> bool) ->
682
-
string ->
683
-
'a codec ->
684
-
('o, 'a) map
685
-
(** See {!Json.Object.mem}. *)
583
+
Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON numbers
584
+
and their many pitfalls. *)
686
585
687
-
val app : ('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map
688
-
(** [app map mmap] applies the member map [mmap] to the contructor of the
689
-
object map [map]. In turn this adds the [mmap] member definition to the
690
-
object described by [map]. *)
691
-
end
586
+
val number : float t
587
+
(** [number] maps JSON nulls or numbers to [float] values. On decodes JSON
588
+
null is mapped to {!Float.nan}. On encodes any {{!Float.is_finite}non-
589
+
finite} float is lossily mapped to JSON null
590
+
({{!page-cookbook.non_finite_numbers}explanation}). See also
591
+
{!Base.number}, {!any_float} and the integer combinators below. *)
692
592
693
-
val mem :
694
-
?doc:string ->
695
-
?dec_absent:'a ->
696
-
?enc:('o -> 'a) ->
697
-
?enc_omit:('a -> bool) ->
698
-
string ->
699
-
'a codec ->
700
-
('o, 'a -> 'b) map ->
701
-
('o, 'b) map
702
-
(** [mem name t map] is a member named [name] of type [t] for an object of
703
-
type ['o] being constructed by [map].
704
-
- [doc] is a documentation string for the member. Defaults to [""].
705
-
- [dec_absent], if specified, is the value used for the decoding direction
706
-
when the member named [name] is missing. If unspecified decoding errors
707
-
when the member is absent. See also {!opt_mem} and
708
-
{{!page-cookbook.optional_members}this example}.
709
-
- [enc] is used to project the member's value from the object
710
-
representation ['o] for encoding to JSON with [t]. It can be omitted if
711
-
the result is only used for decoding.
712
-
- [enc_omit] is for the encoding direction. If the member value returned
713
-
by [enc] returns [true] on [enc_omit], the member is omited in the
714
-
encoded JSON object. Defaults to [Fun.const false]. See also {!opt_mem}
715
-
and {{!page-cookbook.optional_members}this example}. *)
593
+
val any_float : float t
594
+
(** [any_float] is a lossless representation for IEEE 754 doubles. It maps
595
+
{{!Float.is_finite}non-finite} floats by the JSON strings defined by
596
+
{!Float.to_string}. This contrasts with {!val-number} which maps them to
597
+
JSON null values ({{!page-cookbook.non_finite_numbers}explanation}). Note
598
+
that on decodes this still maps JSON nulls to {!Float.nan} and any
599
+
successful string decode of {!Float.of_string_opt} (so numbers can also
600
+
be written as strings). See also {!val-number}.
716
601
717
-
val opt_mem :
718
-
?doc:string ->
719
-
?enc:('o -> 'a option) ->
720
-
string ->
721
-
'a codec ->
722
-
('o, 'a option -> 'b) map ->
723
-
('o, 'b) map
724
-
(** [opt_mem name t map] is:
725
-
{[
726
-
let dec_absent = None and enc_omit = Option.is_none in
727
-
Json.Object.mem name (Json.some t) map ~dec_absent ~enc_omit
728
-
]}
729
-
A shortcut to represent optional members of type ['a] with ['a option]
730
-
values. *)
602
+
{b Warning.} [any_float] should only be used between parties that have
603
+
agreed on such an encoding. To maximize interoperability you should use
604
+
the lossy {!val-number} map. *)
731
605
732
-
(** {1:cases Case objects}
606
+
val float_as_hex_string : float t
607
+
(** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex
608
+
notation to float values. On encodes strings this uses the ["%h"] format
609
+
string. On decodes it accepts anything sucessfully decoded by
610
+
{!Float.of_string_opt}. *)
733
611
734
-
Read the {{!page-cookbook.cases}cookbook} on case objects. *)
612
+
val uint8 : int t
613
+
(** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers are
614
+
sucessfully decoded if after truncation they can be represented on the
615
+
\[0;255\] range. Encoding errors if the integer is out of range. *)
735
616
736
-
(** Case objects.
617
+
val uint16 : int t
618
+
(** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers are
619
+
sucessfully decoded if after truncation they can be represented on the
620
+
\[0;65535\] range. Encoding errors if the integer is out of range. *)
737
621
738
-
Case objects are used to describe objects whose members depend on the tag
739
-
value of a distinguished case member. See an
740
-
{{!page-cookbook.cases}example}. *)
741
-
module Case : sig
742
-
(** {1:maps Maps} *)
622
+
val int8 : int t
623
+
(** [int8] maps JSON numbers to 8-bit integers. JSON numbers are sucessfully
624
+
decoded if after truncation they can be represented on the \[-128;127\]
625
+
range. Encoding errors if the integer is out of range. *)
743
626
744
-
type 'a codec := 'a codec
627
+
val int16 : int t
628
+
(** [int16] maps JSON numbers to 16-bit integers. JSON numbers are sucessfully
629
+
decoded if after truncation they can be represented on the
630
+
\[-32768;32767\] range. Encoding errors if the integer is out of range. *)
745
631
746
-
type ('cases, 'case, 'tag) map
747
-
(** The type for mapping a case object represented by ['case] belonging to a
748
-
common type represented by ['cases] depending on the value of a case
749
-
member of type ['tag]. *)
632
+
val int32 : int32 t
633
+
(** [int32] maps JSON numbers to 32-bit integers. JSON numbers are sucessfully
634
+
decoded if after truncation they can be represented on the [int32] range,
635
+
otherwise the decoder errors. *)
750
636
751
-
val map :
752
-
?dec:('case -> 'cases) -> 'tag -> 'case codec -> ('cases, 'case, 'tag) map
753
-
(** [map ~dec v obj] defines the object map [obj] as being the case for the
754
-
tag value [v] of the case member. [dec] indicates how to inject the
755
-
object case into the type common to all cases.
637
+
val int64 : int64 t
638
+
(** [int64] maps truncated JSON numbers or JSON strings to 64-bit integers.
639
+
- JSON numbers are sucessfully decoded if after truncation they can be
640
+
represented on the [int64] range, otherwise the decoder errors. [int64]
641
+
values are encoded as JSON numbers if the integer is in the
642
+
\[-2{^ 53};2{^ 53}\] range.
643
+
- JSON strings are decoded using {!int_of_string_opt}, this allows
644
+
binary, octal, decimal and hex syntaxes and errors on overflow and
645
+
syntax errors. [int64] values are encoded as JSON strings with
646
+
{!Int64.to_string} when the integer is outside the
647
+
\[-2{^ 53};2{^ 53}\] range. *)
756
648
757
-
Raises [Invalid_argument] if [obj] is not a direct result of {!finish},
758
-
that is if [obj] does not describe an object. *)
649
+
val int64_as_string : int64 t
650
+
(** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this
651
+
uses {!Int64.of_string_opt} which allows binary, octal, decimal and hex
652
+
syntaxes and errors on overflow and syntax errors. On encodes uses
653
+
{!Int64.to_string}. *)
759
654
760
-
val map_tag : ('cases, 'case, 'tag) map -> 'tag
761
-
(** [map_tag m] is [m]'s tag. *)
655
+
val int : int t
656
+
(** [int] maps truncated JSON numbers or JSON strings to [int] values.
657
+
- JSON numbers are sucessfully decoded if after truncation they can be
658
+
represented on the [int] range, otherwise the decoder errors. [int]
659
+
values are encoded as JSON numbers if the integer is in the
660
+
\[-2{^ 53};2{^ 53}\] range.
661
+
- JSON strings are decoded using {!int_of_string_opt}, this allows
662
+
binary, octal, decimal and hex syntaxes and errors on overflow and
663
+
syntax errors. [int] values are encoded as JSON strings with
664
+
{!Int.to_string} when the integer is outside the
665
+
\[-2{^ 53};2{^ 53}\] range
762
666
763
-
(** {1:cases Cases} *)
667
+
{b Warning.} The behaviour of this function is platform dependent, it
668
+
depends on the value of {!Sys.int_size}. *)
764
669
765
-
type ('cases, 'tag) t
766
-
(** The type for a case of the type ['cases]. This is {!type-map} with its
767
-
['case] representation hidden. *)
670
+
val int_as_string : int t
671
+
(** [int_as_string] maps JSON strings to [int] values. On decodes this uses
672
+
{!int_of_string_opt} which allows binary, octal, decimal and hex syntaxes
673
+
and errors on overflow and syntax errors. On encodes uses
674
+
{!Int.to_string}.
768
675
769
-
val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t
770
-
(** [make map] is [map] as a case. *)
676
+
{b Warning.} The behaviour of this function is platform dependent, it
677
+
depends on the value of {!Sys.int_size}. *)
771
678
772
-
val tag : ('cases, 'tag) t -> 'tag
773
-
(** [tag c] is the tag of [c]. *)
679
+
(** {2:enums Strings and enums}
774
680
775
-
(** {1:case Case values} *)
681
+
Read the {{!page-cookbook.transform_strings}cookbook} on transforming
682
+
strings. *)
776
683
777
-
type ('cases, 'tag) value
778
-
(** The type for case values. This holds a case value and its case map
779
-
{!type-map}. Use {!val-value} to construct them. *)
684
+
val string : string t
685
+
(** [string] maps unescaped JSON strings to UTF-8 encoded [string] values.
686
+
See also {!Base.string}.
780
687
781
-
val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value
782
-
(** [value map v] is a case value [v] described by [map]. *)
783
-
end
688
+
{b Warning.} Encoders assume OCaml [string]s have been checked for UTF-8
689
+
validity. *)
784
690
785
-
val case_mem :
691
+
val of_of_string :
692
+
?kind:string ->
786
693
?doc:string ->
787
-
?tag_compare:('tag -> 'tag -> int) ->
788
-
?tag_to_string:('tag -> string) ->
789
-
?dec_absent:'tag ->
790
-
?enc:('o -> 'cases) ->
791
-
?enc_omit:('tag -> bool) ->
792
-
?enc_case:('cases -> ('cases, 'tag) Case.value) ->
793
-
string ->
794
-
'tag codec ->
795
-
('cases, 'tag) Case.t list ->
796
-
('o, 'cases -> 'a) map ->
797
-
('o, 'a) map
798
-
(** [case_mem name t cases map] is mostly like {!val-mem} except the member
799
-
[name] selects an object representation according to the member value of
800
-
type [t]:
801
-
- [doc] is a documentation string for the member. Defaults to [""].
802
-
- [tag_compare] is used to compare tags. Defaults to {!Stdlib.compare}
803
-
- [tag_to_string] is used to stringify tags for improving error reporting.
804
-
- [dec_absent], if specified, is the case value used for the decoding
805
-
direction when the case member named [name] is missing. If unspecified
806
-
decoding errors when the member is absent.
807
-
- [enc] is used to project the value in which cases are stored from the
808
-
object representation ['o] for encoding to JSON. It can be omitted if
809
-
the result is only used for decoding.
810
-
- [enc_case] determines the actual case value from the value returned by
811
-
[enc].
812
-
- [enc_omit] is used on the tag of the case returned by [enc_case] to
813
-
determine if the case member can be ommited in the encoded JSON object
814
-
- [cases] enumerates all the cases, it is needed for decoding.
694
+
?enc:('a -> string) ->
695
+
(string -> ('a, string) result) ->
696
+
'a t
697
+
(** [of_of_string of_string] maps JSON string with a {{!Base.type-map}base
698
+
map} using [of_string] for decoding and [enc] for encoding. See the
699
+
{{!page-cookbook.transform_strings}cookbook}. *)
815
700
816
-
The names of the members of each case must be disjoint from [name] or
817
-
those of [map] otherwise [Invalid_argument] is raised on {!finish}. Raises
818
-
[Invalid_argument] if [case_mem] was already called on map. *)
701
+
val enum :
702
+
?cmp:('a -> 'a -> int) ->
703
+
?kind:string ->
704
+
?doc:string ->
705
+
(string * 'a) list ->
706
+
'a t
707
+
(** [enum assoc] maps JSON strings member of the [assoc] list to the
708
+
corresponding OCaml value and vice versa in log(n). [cmp] is used to
709
+
compare the OCaml values, it defaults to {!Stdlib.compare}. Decoding and
710
+
encoding errors on strings or values not part of [assoc]. *)
819
711
820
-
(** {1:unknown_members Unknown members}
712
+
val binary_string : string t
713
+
(** [binary_string] maps JSON strings made of an even number of hexdecimal
714
+
US-ASCII upper or lower case digits to the corresponding byte sequence.
715
+
On encoding uses only lower case hexadecimal digits to encode the byte
716
+
sequence. *)
821
717
822
-
Read the {{!page-cookbook.unknown_members}cookbook} on unknown object
823
-
members.
718
+
(** {1:arrays Arrays and tuples}
824
719
825
-
On {{!cases}case objects} each individual case has its own behaviour
826
-
unless the combinators are used on the case object map in which case it
827
-
overrides the behaviour of cases. For those cases that use {!keep_unknown}
828
-
they will get the result of an empty builder in their decoding function
829
-
and the encoder is ignored on encode. *)
720
+
Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays. *)
830
721
831
-
(** Uniform members. *)
832
-
module Mems : sig
722
+
(** Mapping JSON arrays. *)
723
+
module Array : sig
833
724
(** {1:maps Maps} *)
834
725
835
-
type 'a codec := 'a codec
836
-
837
-
type ('mems, 'a) enc = {
838
-
enc :
839
-
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
726
+
type ('array, 'elt) enc = {
727
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
840
728
}
841
-
(** The type for specifying unknown members encoding function. A function to
842
-
fold over unknown members of uniform type ['a] stored in a value of type
843
-
['mems]. *)
729
+
(** The type for specifying array encoding functions. A function to fold
730
+
over the elements of type ['elt] of the array of type ['array]. *)
844
731
845
-
type ('mems, 'a, 'builder) map
846
-
(** The type for mapping members of uniform type ['a] to values of type
847
-
['mems] using a builder of type ['builder]. *)
732
+
type ('array, 'elt, 'builder) map
733
+
(** The type for mapping JSON arrays with elements of type ['elt] to arrays
734
+
of type ['array] using values of type ['builder] to build them. *)
848
735
849
736
val map :
850
737
?kind:string ->
851
738
?doc:string ->
852
739
?dec_empty:(unit -> 'builder) ->
853
-
?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) ->
854
-
?dec_finish:(Meta.t -> 'builder -> 'mems) ->
855
-
?enc:('mems, 'a) enc ->
856
-
'a codec ->
857
-
('mems, 'a, 'builder) map
858
-
(** [map type'] maps unknown members of uniform type ['a] to values of type
859
-
['mems] built with type ['builder].
860
-
- [kind] names the entities represented by the map and [doc] documents
861
-
them. Both default to [""].
862
-
- [dec_empty] is used to create a builder for the members. Can be
863
-
omitted if the map is only used for encoding, the default
864
-
unconditionally errors.
865
-
- [dec_add meta name v b] is used to add a member named [name] with meta
866
-
[meta] with member value [v] to builder [b]. Can be omitted if the map
867
-
is only used for encoding, the default unconditionally errors.
868
-
- [dec_finish meta b] converts the builder to the final members value.
869
-
[meta] is the metadata of the object in which they were found. Can be
870
-
omitted if the map is only used for encoding, the default
871
-
unconditionally errors.
872
-
- [enc f mems acc] folds over the elements of [mems] starting with
873
-
[acc]. This function is used to encode the members. Can be omitted if
874
-
the map is only used for decoding, the default unconditionally errors.
740
+
?dec_skip:(int -> 'builder -> bool) ->
741
+
?dec_add:(int -> 'elt -> 'builder -> 'builder) ->
742
+
?dec_finish:(Meta.t -> int -> 'builder -> 'array) ->
743
+
?enc:('array, 'elt) enc ->
744
+
?enc_meta:('array -> Meta.t) ->
745
+
'elt t ->
746
+
('array, 'elt, 'builder) map
747
+
(** [map elt] maps JSON arrays of type ['elt] to arrays of type ['array]
748
+
built with type ['builder]. See the {!Json.Codec.Array} documentation
749
+
for argument descriptions. *)
750
+
751
+
val list_map :
752
+
?kind:string ->
753
+
?doc:string ->
754
+
?dec_skip:(int -> 'a list -> bool) ->
755
+
'a t ->
756
+
('a list, 'a, 'a list) map
757
+
(** [list_map elt] maps JSON arrays with elements of type [elt] to [list]
758
+
values. See also {!Codec.list}. *)
759
+
760
+
type 'a array_builder
761
+
(** The type for array builders. *)
762
+
763
+
val array_map :
764
+
?kind:string ->
765
+
?doc:string ->
766
+
?dec_skip:(int -> 'a array_builder -> bool) ->
767
+
'a t ->
768
+
('a array, 'a, 'a array_builder) map
769
+
(** [array_map elt] maps JSON arrays with elements of type [elt] to [array]
770
+
values. See also {!Codec.array}. *)
875
771
876
-
See {!keep_unknown}. *)
772
+
type ('a, 'b, 'c) bigarray_builder
773
+
(** The type for bigarray_builders. *)
877
774
878
-
val string_map :
775
+
val bigarray_map :
879
776
?kind:string ->
880
777
?doc:string ->
881
-
'a codec ->
882
-
('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map
883
-
(** [string_map t] collects unknown member by name and types their values
884
-
with [t]. See {!keep_unknown} and {!as_string_map}. *)
778
+
?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) ->
779
+
('a, 'b) Bigarray.kind ->
780
+
'c Bigarray.layout ->
781
+
'a t ->
782
+
(('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map
783
+
(** [bigarray k l elt] maps JSON arrays with elements of type [elt] to
784
+
bigarray values of kind [k] and layout [l]. See also {!Codec.bigarray}.
785
+
*)
786
+
787
+
(** {1:types JSON types} *)
788
+
789
+
val array : ('a, _, _) map -> 'a t
790
+
(** [array map] maps with [map] JSON arrays to values of type ['a]. See the
791
+
the {{!section-arrays}array combinators}. *)
792
+
793
+
val ignore : unit t
794
+
(** [ignore] ignores JSON arrays on decoding and errors on encoding. *)
795
+
796
+
val zero : unit t
797
+
(** [zero] ignores JSON arrays on decoding and encodes an empty array. *)
885
798
end
886
799
887
-
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
888
-
(** [skip_unknown map] makes [map] skip unknown members. This is the default,
889
-
no need to specify it. Raises [Invalid_argument] if {!keep_unknown} was
890
-
already specified on [map]. *)
800
+
val list : ?kind:string -> ?doc:string -> 'a t -> 'a list t
801
+
(** [list t] maps JSON arrays of type [t] to [list] values. See also
802
+
{!Array.list_map}. *)
891
803
892
-
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
893
-
(** [error_unknown map] makes [map] error on unknown members. Raises
894
-
[Invalid_argument] if {!keep_unknown} was already specified on [map]. See
895
-
{{!page-cookbook.erroring}this example}. *)
804
+
val array : ?kind:string -> ?doc:string -> 'a t -> 'a array t
805
+
(** [array t] maps JSON arrays of type [t] to [array] values. See also
806
+
{!Array.array_map}. *)
896
807
897
-
val keep_unknown :
898
-
?enc:('o -> 'mems) ->
899
-
('mems, _, _) Mems.map ->
900
-
('o, 'mems -> 'a) map ->
901
-
('o, 'a) map
902
-
(** [keep_unknown mems map] makes [map] keep unknown member with [mems].
903
-
Raises [Invalid_argument] if {!keep_unknown} was already specified on
904
-
[map]. See this {{!page-cookbook.keeping}this example}, {!Mems.string_map}
905
-
and {!Json.json_mems}. *)
808
+
val array_as_string_map :
809
+
?kind:string ->
810
+
?doc:string ->
811
+
key:('a -> string) ->
812
+
'a t ->
813
+
'a Map.Make(String).t t
814
+
(** [array_as_string_map ~key t] maps JSON array elements of type [t] to
815
+
string maps by indexing them with [key]. If two elements have the same
816
+
[key] the element with the greatest index takes over. Elements of the
817
+
map are encoded to a JSON array in (binary) key order. *)
906
818
907
-
(** {1:types JSON types} *)
819
+
val bigarray :
820
+
?kind:string ->
821
+
?doc:string ->
822
+
('a, 'b) Bigarray.kind ->
823
+
'a t ->
824
+
('a, 'b, Bigarray.c_layout) Bigarray.Array1.t t
825
+
(** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t]
826
+
values. See also {!Array.bigarray_map}. *)
908
827
909
-
val as_string_map :
828
+
val t2 :
910
829
?kind:string ->
911
830
?doc:string ->
912
-
'a codec ->
913
-
'a Stdlib.Map.Make(String).t codec
914
-
(** [as_string_map t] maps object to key-value maps of type [t]. See also
915
-
{!Mems.string_map} and {!Json.json_mems}. *)
831
+
?dec:('a -> 'a -> 't2) ->
832
+
?enc:('t2 -> int -> 'a) ->
833
+
'a t ->
834
+
't2 t
835
+
(** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type [t] to
836
+
value of type ['t2]. Decodes error if there are more elements. [enc v i]
837
+
must return the zero-based [i]th element. *)
916
838
917
-
val zero : unit codec
918
-
(** [zero] ignores JSON objects on decoding and encodes an empty object. *)
919
-
end
839
+
val t3 :
840
+
?kind:string ->
841
+
?doc:string ->
842
+
?dec:('a -> 'a -> 'a -> 't3) ->
843
+
?enc:('t3 -> int -> 'a) ->
844
+
'a t ->
845
+
't3 t
846
+
(** [t3] is like {!t2} but for 3 elements. *)
920
847
921
-
(** {1:any Any} *)
848
+
val t4 :
849
+
?kind:string ->
850
+
?doc:string ->
851
+
?dec:('a -> 'a -> 'a -> 'a -> 't4) ->
852
+
?enc:('t4 -> int -> 'a) ->
853
+
'a t ->
854
+
't4 t
855
+
(** [t4] is like {!t2} but for 4 elements. *)
922
856
923
-
val any :
924
-
?kind:string ->
925
-
?doc:string ->
926
-
?dec_null:'a codec ->
927
-
?dec_bool:'a codec ->
928
-
?dec_number:'a codec ->
929
-
?dec_string:'a codec ->
930
-
?dec_array:'a codec ->
931
-
?dec_object:'a codec ->
932
-
?enc:('a -> 'a codec) ->
933
-
unit ->
934
-
'a codec
935
-
(** [any ()] maps subsets of JSON value of different sorts to values of type
936
-
['a]. The unspecified cases are not part of the subset and error on
937
-
decoding. [enc] selects the type to use on encoding and errors if omitted.
938
-
[kind] names the entities represented by the type and [doc] documents them,
939
-
both defaults to [""]. *)
857
+
val tn : ?kind:string -> ?doc:string -> n:int -> 'a t -> 'a array t
858
+
(** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to [array]
859
+
values. This is {!val-array} limited by [n]. *)
940
860
941
-
(** {1:maps Maps & recursion} *)
861
+
(** {1:objects Objects}
942
862
943
-
val map :
944
-
?kind:string ->
945
-
?doc:string ->
946
-
?dec:('a -> 'b) ->
947
-
?enc:('b -> 'a) ->
948
-
'a codec ->
949
-
'b codec
950
-
(** [map t] changes the type of [t] from ['a] to ['b].
951
-
- [kind] names the entities represented by the type and [doc] documents
952
-
them, both default to [""].
953
-
- [dec] decodes values of type ['a] to values of type ['b]. Can be omitted
954
-
if the result is only used for encoding. The default errors.
955
-
- [enc] encodes values of type ['b] to values of type ['a]. Can be omitted
956
-
if the result is only used for decoding. The default errors.
863
+
Read the {{!page-cookbook.dealing_with_objects}cookbook} on objects. *)
957
864
958
-
For mapping base types use {!Json.Base.map}. *)
865
+
(** Mapping JSON objects. *)
866
+
module Object : sig
867
+
(** {1:maps Maps} *)
959
868
960
-
val iter :
961
-
?kind:string ->
962
-
?doc:string ->
963
-
?dec:('a -> unit) ->
964
-
?enc:('a -> unit) ->
965
-
'a codec ->
966
-
'a codec
967
-
(** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding but
968
-
otherwise behaves like [t] does. Typically [dec] can be used to further
969
-
assert the shape of the decoded value and {!Error.msgf} if it hasn't the
970
-
right shape. [iter] can also be used as a tracing facility for debugging. *)
869
+
type ('o, 'dec) map
870
+
(** The type for mapping JSON objects to values of type ['o]. The ['dec]
871
+
type is used to construct ['o] from members see {!val-mem}. *)
971
872
972
-
val rec' : 'a codec Lazy.t -> 'a codec
973
-
(** [rec'] maps recursive JSON values. See the
974
-
{{!page-cookbook.recursion} cookbook}. *)
873
+
val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
874
+
(** [map dec] is an empty JSON object decoded by function [dec].
875
+
- [kind] names the entities represented by the map and [doc] documents
876
+
them. Both default to [""].
877
+
- [dec] is a constructor eventually returning a value of type ['o] to
878
+
be saturated with calls to {!val-mem}, {!val-case_mem} or
879
+
{!val-keep_unknown}. This is needed for decoding. Use {!enc_only} if
880
+
the result is only used for encoding. *)
975
881
976
-
(** {1:ignoring Ignoring} *)
882
+
val map' :
883
+
?kind:string ->
884
+
?doc:string ->
885
+
?enc_meta:('o -> Meta.t) ->
886
+
(Meta.t -> 'dec) ->
887
+
('o, 'dec) map
888
+
(** [map' dec] is like {!val-map} except you get the object's decoding
889
+
metdata in [dec] and [enc_meta] is used to recover it on encoding. *)
977
890
978
-
val ignore : unit codec
979
-
(** [ignore] lossily maps all JSON values to [()] on decoding and errors on
980
-
encoding. See also {!const}.
891
+
val enc_only :
892
+
?kind:string ->
893
+
?doc:string ->
894
+
?enc_meta:('o -> Meta.t) ->
895
+
unit ->
896
+
('o, 'a) map
897
+
(** [enc_only ()] is like {!val-map'} but can only be used for encoding. *)
981
898
982
-
The bytesrw decoder dispatches [ignore] to a skip-parse fast path that
983
-
advances past the value without materialising strings, numbers or nested
984
-
DOM. The fast path matches {{:https://simdjson.org}simdjson}'s On-Demand
985
-
semantics: it enforces the structural contract (bracket nesting, quote
986
-
matching, well-formed literal tokens) but does {b not} validate the content
987
-
of ignored values. Concretely:
899
+
val finish : ('o, 'o) map -> 'o t
900
+
(** [finish map] is a JSON type for objects mapped by [map]. Raises
901
+
[Invalid_argument] if [map] describes a member name more than once. *)
988
902
989
-
- Malformed number shapes like [1..2], [+5], [1eE2] pass through.
990
-
- Unrecognised escape characters ([\\z]) and short [\\u] sequences pass
991
-
through.
992
-
- UTF-8 in string content is {b not} validated while skipping (multibyte
993
-
sequences are skipped as-is).
903
+
(** {1:mems Members} *)
994
904
995
-
Callers needing strict content validation should decode with {!json} and
996
-
discard the result rather than reaching for [ignore]. *)
905
+
(** Member maps.
997
906
998
-
val zero : unit codec
999
-
(** [zero] lossily maps all JSON values to [()] on decoding and encodes JSON
1000
-
nulls. *)
907
+
Usually it's better to use {!Json.Codec.Object.mem} or
908
+
{!Json.Codec.Object.opt_mem} directly. But this may be useful in
909
+
certain abstraction contexts. *)
910
+
module Mem : sig
911
+
type ('o, 'dec) object_map := ('o, 'dec) map
1001
912
1002
-
val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a codec
1003
-
(** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if specified (errors
1004
-
otherwise) and errors on encoding. *)
913
+
type ('o, 'a) map
914
+
(** The type for mapping a member object to a value ['a] stored in an
915
+
OCaml value of type ['o]. *)
1005
916
1006
-
(** {1:generic_json Generic JSON} *)
917
+
val map :
918
+
?doc:string ->
919
+
?dec_absent:'a ->
920
+
?enc:('o -> 'a) ->
921
+
?enc_omit:('a -> bool) ->
922
+
string ->
923
+
'a codec ->
924
+
('o, 'a) map
925
+
(** See {!Json.Codec.Object.mem}. *)
1007
926
1008
-
type name = string node
1009
-
(** The type for JSON member names. *)
927
+
val app :
928
+
('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map
929
+
(** [app map mmap] applies the member map [mmap] to the contructor of
930
+
the object map [map]. In turn this adds the [mmap] member definition
931
+
to the object described by [map]. *)
932
+
end
1010
933
1011
-
type mem = name * t
1012
-
(** The type for generic JSON object members. *)
934
+
val mem :
935
+
?doc:string ->
936
+
?dec_absent:'a ->
937
+
?enc:('o -> 'a) ->
938
+
?enc_omit:('a -> bool) ->
939
+
string ->
940
+
'a codec ->
941
+
('o, 'a -> 'b) map ->
942
+
('o, 'b) map
943
+
(** [mem name t map] is a member named [name] of type [t] for an object of
944
+
type ['o] being constructed by [map].
945
+
- [doc] is a documentation string for the member. Defaults to [""].
946
+
- [dec_absent], if specified, is the value used for the decoding
947
+
direction when the member named [name] is missing. If unspecified
948
+
decoding errors when the member is absent.
949
+
- [enc] is used to project the member's value from the object
950
+
representation ['o] for encoding to JSON with [t]. It can be omitted
951
+
if the result is only used for decoding.
952
+
- [enc_omit] is for the encoding direction. If the member value
953
+
returned by [enc] returns [true] on [enc_omit], the member is omited
954
+
in the encoded JSON object. Defaults to [Fun.const false]. *)
1013
955
1014
-
and object' = mem list
1015
-
(** The type for generic JSON objects. *)
956
+
val opt_mem :
957
+
?doc:string ->
958
+
?enc:('o -> 'a option) ->
959
+
string ->
960
+
'a codec ->
961
+
('o, 'a option -> 'b) map ->
962
+
('o, 'b) map
963
+
(** [opt_mem name t map] is:
964
+
{[
965
+
let dec_absent = None and enc_omit = Option.is_none in
966
+
Json.Codec.Object.mem name (Json.Codec.some t) map ~dec_absent ~enc_omit
967
+
]} *)
1016
968
1017
-
(** The type for generic JSON values. *)
1018
-
and t = Value.t =
1019
-
| Null of unit node
1020
-
| Bool of bool node
1021
-
| Number of float node
1022
-
(** Encoders must use [Null] if float is {{!Float.is_finite}not finite}.
1023
-
*)
1024
-
| String of string node
1025
-
| Array of t list node
1026
-
| Object of object' node (** *)
969
+
(** {1:cases Case objects}
1027
970
1028
-
val pp : t Fmt.t
1029
-
(** [pp] is {!pp_json}. *)
971
+
Read the {{!page-cookbook.cases}cookbook} on case objects. *)
1030
972
1031
-
(** Generic JSON values. *)
1032
-
module Value : sig
1033
-
(** {1:json JSON values} *)
973
+
(** Case objects. *)
974
+
module Case : sig
975
+
(** {1:maps Maps} *)
1034
976
1035
-
type 'a cons = ?meta:Meta.t -> 'a -> t
1036
-
(** The type for constructing JSON values from an OCaml value of type ['a].
1037
-
[meta] defaults to {!Meta.none}. *)
977
+
type 'a codec := 'a codec
1038
978
1039
-
val meta : t -> Meta.t
1040
-
(** [meta v] is the metadata of value [v]. *)
979
+
type ('cases, 'case, 'tag) map
980
+
(** The type for mapping a case object. *)
1041
981
1042
-
val set_meta : Meta.t -> t -> t
1043
-
(** [set_meta m v] replaces [v]'s meta with [m]. *)
982
+
val map :
983
+
?dec:('case -> 'cases) ->
984
+
'tag ->
985
+
'case codec ->
986
+
('cases, 'case, 'tag) map
987
+
(** [map ~dec v obj] defines the object map [obj] as being the case for
988
+
the tag value [v] of the case member. [dec] indicates how to inject
989
+
the object case into the type common to all cases.
1044
990
1045
-
val copy_layout : t -> dst:t -> t
1046
-
(** [copy_layout src ~dst] copies the layout of [src] and sets it on [dst]
1047
-
using {!Meta.copy_ws}. *)
991
+
Raises [Invalid_argument] if [obj] is not a direct result of
992
+
{!finish}, that is if [obj] does not describe an object. *)
1048
993
1049
-
val sort : t -> Sort.t
1050
-
(** [sort v] is the sort of value [v]. *)
994
+
val map_tag : ('cases, 'case, 'tag) map -> 'tag
995
+
(** [map_tag m] is [m]'s tag. *)
1051
996
1052
-
val zero : t cons
1053
-
(** [zero j] is a stub value of the sort value of [j]. The stub value is the
1054
-
“natural” zero: null, false, 0, empty string, empty array, empty object.
1055
-
*)
997
+
(** {1:cases Cases} *)
1056
998
1057
-
val equal : t -> t -> bool
1058
-
(** [equal j0 j1] is {!compare}[ j0 j1 = 0]. *)
999
+
type ('cases, 'tag) t
1000
+
(** The type for a case of the type ['cases]. *)
1059
1001
1060
-
val compare : t -> t -> int
1061
-
(** [compare j0 j1] is a total order on JSON values:
1062
-
- Floating point values are compared with {!Float.compare}, this means NaN
1063
-
values are equal.
1064
-
- Strings are compared byte wise.
1065
-
- Objects members are sorted before being compared.
1066
-
- {!Meta.t} values are ignored. *)
1002
+
val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t
1003
+
(** [make map] is [map] as a case. *)
1067
1004
1068
-
val pp : t Fmt.t
1069
-
(** See {!Json.pp_json}. *)
1005
+
val tag : ('cases, 'tag) t -> 'tag
1006
+
(** [tag c] is the tag of [c]. *)
1070
1007
1071
-
(** {2:null Nulls and options} *)
1008
+
(** {1:case Case values} *)
1072
1009
1073
-
val null : unit cons
1074
-
(** [null] is [Null (unit, meta)]. *)
1010
+
type ('cases, 'tag) value
1011
+
(** The type for case values. *)
1075
1012
1076
-
val option : 'a cons -> 'a option cons
1077
-
(** [option c] constructs [Some v] values with [c v] and [None] ones with
1078
-
{!val-null}. *)
1013
+
val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value
1014
+
(** [value map v] is a case value [v] described by [map]. *)
1015
+
end
1079
1016
1080
-
(** {2:bool Booleans} *)
1017
+
val case_mem :
1018
+
?doc:string ->
1019
+
?tag_compare:('tag -> 'tag -> int) ->
1020
+
?tag_to_string:('tag -> string) ->
1021
+
?dec_absent:'tag ->
1022
+
?enc:('o -> 'cases) ->
1023
+
?enc_omit:('tag -> bool) ->
1024
+
?enc_case:('cases -> ('cases, 'tag) Case.value) ->
1025
+
string ->
1026
+
'tag codec ->
1027
+
('cases, 'tag) Case.t list ->
1028
+
('o, 'cases -> 'a) map ->
1029
+
('o, 'a) map
1030
+
(** [case_mem name t cases map] is mostly like {!val-mem} except the member
1031
+
[name] selects an object representation according to the member value
1032
+
of type [t]. See {!Json.Codec.Object.case_mem} for details. *)
1081
1033
1082
-
val bool : bool cons
1083
-
(** [bool b] is [Bool (b, meta)]. *)
1034
+
(** {1:unknown_members Unknown members}
1084
1035
1085
-
(** {2:numbers Numbers} *)
1036
+
Read the {{!page-cookbook.unknown_members}cookbook}. *)
1086
1037
1087
-
val number : float cons
1088
-
(** [number n] is [Number (n, meta)]. *)
1038
+
(** Uniform members. *)
1039
+
module Mems : sig
1040
+
(** {1:maps Maps} *)
1089
1041
1090
-
val any_float : float cons
1091
-
(** [any_float v] is [number v] if {!Float.is_finite}[ v] is [true] and
1092
-
[string (Float.to_string v)] otherwise. See {!Json.any_float}. *)
1042
+
type 'a codec := 'a codec
1093
1043
1094
-
val int32 : int32 cons
1095
-
(** [int32] is [i] as a JSON number. *)
1044
+
type ('mems, 'a) enc = {
1045
+
enc :
1046
+
'acc.
1047
+
(Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
1048
+
}
1049
+
(** The type for specifying unknown members encoding function. *)
1096
1050
1097
-
val int64 : int64 cons
1098
-
(** [int64 i] is [i] as a JSON number or a JSON string if not in the range
1099
-
\[-2{^ 53};2{^ 53}\]. See also {!int64_as_string}. *)
1051
+
type ('mems, 'a, 'builder) map
1052
+
(** The type for mapping members of uniform type ['a] to values of type
1053
+
['mems] using a builder of type ['builder]. *)
1100
1054
1101
-
val int64_as_string : int64 cons
1102
-
(** [int64_as_string i] is [i] as a JSON string. See also {!int64}. *)
1055
+
val map :
1056
+
?kind:string ->
1057
+
?doc:string ->
1058
+
?dec_empty:(unit -> 'builder) ->
1059
+
?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) ->
1060
+
?dec_finish:(Meta.t -> 'builder -> 'mems) ->
1061
+
?enc:('mems, 'a) enc ->
1062
+
'a codec ->
1063
+
('mems, 'a, 'builder) map
1064
+
(** [map type'] maps unknown members of uniform type ['a] to values of
1065
+
type ['mems] built with type ['builder]. *)
1103
1066
1104
-
val int : int cons
1105
-
(** [int] is [i] as a JSON number or a JSON string if not in the range
1106
-
\[-2{^ 53};2{^ 53}\]. See also {!int_as_string}. *)
1067
+
val string_map :
1068
+
?kind:string ->
1069
+
?doc:string ->
1070
+
'a codec ->
1071
+
('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map
1072
+
(** [string_map t] collects unknown member by name and types their values
1073
+
with [t]. *)
1074
+
end
1107
1075
1108
-
val int_as_string : int cons
1109
-
(** [int_as_string i] is [i] as a JSON string. See also {!int}. *)
1076
+
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
1077
+
(** [skip_unknown map] makes [map] skip unknown members. *)
1110
1078
1111
-
(** {2:strings Strings} *)
1079
+
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
1080
+
(** [error_unknown map] makes [map] error on unknown members. *)
1112
1081
1113
-
val string : string cons
1114
-
(** [string s] is [String (s, meta)]. *)
1082
+
val keep_unknown :
1083
+
?enc:('o -> 'mems) ->
1084
+
('mems, _, _) Mems.map ->
1085
+
('o, 'mems -> 'a) map ->
1086
+
('o, 'a) map
1087
+
(** [keep_unknown mems map] makes [map] keep unknown member with [mems]. *)
1115
1088
1116
-
(** {2:arrays Arrays} *)
1089
+
(** {1:types JSON types} *)
1117
1090
1118
-
val list : t list cons
1119
-
(** [list l] is [Array (l, meta)]. *)
1091
+
val as_string_map :
1092
+
?kind:string ->
1093
+
?doc:string ->
1094
+
'a codec ->
1095
+
'a Stdlib.Map.Make(String).t codec
1096
+
(** [as_string_map t] maps object to key-value maps of type [t]. *)
1120
1097
1121
-
val array : t array cons
1122
-
(** [array l] is [Array (Array.to_list a, meta)]. See also {!list}. *)
1098
+
val zero : unit codec
1099
+
(** [zero] ignores JSON objects on decoding and encodes an empty object. *)
1100
+
end
1123
1101
1124
-
(** {2:objects Objects} *)
1102
+
(** {1:any Any value}
1125
1103
1126
-
val name : ?meta:Meta.t -> string -> name
1127
-
(** [name ?meta n] is [(n, meta)]. [meta] defaults to {!Meta.none}. *)
1104
+
Per {{:https://www.rfc-editor.org/rfc/rfc8259#section-3}RFC 8259 § 3},
1105
+
a JSON {e value} is one of [null], [true]/[false], a number, a string,
1106
+
an array, or an object. *)
1128
1107
1129
-
val mem : name -> t -> mem
1130
-
(** [mem n v] is [(n, v)]. [meta] defaults to {!Meta.none}. *)
1108
+
val any :
1109
+
?kind:string ->
1110
+
?doc:string ->
1111
+
?dec_null:'a t ->
1112
+
?dec_bool:'a t ->
1113
+
?dec_number:'a t ->
1114
+
?dec_string:'a t ->
1115
+
?dec_array:'a t ->
1116
+
?dec_object:'a t ->
1117
+
?enc:('a -> 'a t) ->
1118
+
unit ->
1119
+
'a t
1120
+
(** [any ()] maps subsets of JSON values of different
1121
+
{{:https://www.rfc-editor.org/rfc/rfc8259#section-3}sorts} to values of
1122
+
type ['a]. *)
1131
1123
1132
-
val object' : object' cons
1133
-
(** [object o] is [Object (o, meta)]. *)
1124
+
(** {1:maps Maps & recursion} *)
1134
1125
1135
-
val find_mem : string -> object' -> mem option
1136
-
(** [find_mem n ms] find the first member whose name matches [n] in [ms]. *)
1126
+
val map :
1127
+
?kind:string ->
1128
+
?doc:string ->
1129
+
?dec:('a -> 'b) ->
1130
+
?enc:('b -> 'a) ->
1131
+
'a t ->
1132
+
'b t
1133
+
(** [map t] changes the type of [t] from ['a] to ['b]. For mapping base types
1134
+
use {!Base.map}. *)
1137
1135
1138
-
val find_mem' : name -> object' -> mem option
1139
-
(** [find_mem n ms] is [find_mem (fst n) ms]. *)
1136
+
val iter :
1137
+
?kind:string ->
1138
+
?doc:string ->
1139
+
?dec:('a -> unit) ->
1140
+
?enc:('a -> unit) ->
1141
+
'a t ->
1142
+
'a t
1143
+
(** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding but
1144
+
otherwise behaves like [t] does. *)
1140
1145
1141
-
val object_names : object' -> string list
1142
-
(** [object_names ms] are the names of [ms]. *)
1146
+
val rec' : 'a t Lazy.t -> 'a t
1147
+
(** [rec'] maps recursive JSON values. *)
1143
1148
1144
-
val object_names' : object' -> name list
1145
-
(** [object_names ms] are the names of [ms]. *)
1149
+
(** {1:ignoring Ignoring} *)
1146
1150
1147
-
(** {1:decode Decode} *)
1151
+
val ignore : unit t
1152
+
(** [ignore] lossily maps all JSON values to [()] on decoding and errors on
1153
+
encoding. *)
1148
1154
1149
-
val decode : 'a codec -> t -> ('a, string) result
1150
-
(** [decode t j] decodes a value from the generic JSON [j] according to type
1151
-
[t]. *)
1155
+
val zero : unit t
1156
+
(** [zero] lossily maps all JSON values to [()] on decoding and encodes JSON
1157
+
nulls. *)
1152
1158
1153
-
val decode' : 'a codec -> t -> ('a, Error.t) result
1154
-
(** [decode'] is like {!val-decode} but preserves the error structure. *)
1159
+
val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a t
1160
+
(** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if specified
1161
+
(errors otherwise) and errors on encoding. *)
1162
+
1163
+
(** {1:generic_ast Generic AST codecs}
1164
+
1165
+
Codecs that preserve the generic {!value} AST. *)
1166
+
1167
+
module Value : sig
1168
+
val t : value t
1169
+
(** [t] maps any JSON value to its generic representation. Use {!val-any}
1170
+
with [dec_*] arguments to restrict to a subset of sorts. *)
1171
+
1172
+
val null : value t
1173
+
(** [null] decodes JSON nulls to {!Null} and encodes {!Null} values. *)
1174
+
1175
+
val bool : value t
1176
+
(** [bool] decodes JSON booleans to {!Bool} and encodes {!Bool} values. *)
1177
+
1178
+
val number : value t
1179
+
(** [number] decodes JSON numbers to {!Number} and encodes {!Number}
1180
+
values. *)
1181
+
1182
+
val string : value t
1183
+
(** [string] decodes JSON strings to {!String} and encodes {!String}
1184
+
values. *)
1185
+
1186
+
val array : value t
1187
+
(** [array] decodes JSON arrays to {!Array} and encodes {!Array} values. *)
1188
+
1189
+
val object' : value t
1190
+
(** [object'] decodes JSON objects to {!Object} and encodes {!Object}
1191
+
values. *)
1155
1192
1156
-
(** {1:encode Encode} *)
1193
+
val mems : (value, value, mem list) Object.Mems.map
1194
+
(** [mems] is a {!Object.Mems.map} for the generic {!mem list} type. *)
1195
+
end
1196
+
1197
+
(** {1:low Low-level representation}
1198
+
1199
+
The following re-exports the low-level codec GADT that backs {!t}. This
1200
+
representation may change even between minor versions of the library. *)
1201
+
1202
+
module String_map : module type of Map.Make (String)
1203
+
(** A [Map.Make(String)] instance used by the low-level representation. *)
1157
1204
1158
-
val encode : 'a codec -> 'a -> (t, string) result
1159
-
(** [encode t v] encodes a generic JSON value for [v] according to type [t].
1160
-
*)
1205
+
type ('ret, 'f) dec_fun = ('ret, 'f) Codec.dec_fun =
1206
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
1207
+
| Dec_app :
1208
+
('ret, 'a -> 'b) dec_fun * 'a Type.Id.t
1209
+
-> ('ret, 'b) dec_fun (** *)
1210
+
(** The type for decoding functions. *)
1161
1211
1162
-
val encode' : 'a codec -> 'a -> (t, Error.t) result
1163
-
(** [encode'] is like {!val-encode} but preserves the error structure. *)
1212
+
type ('a, 'b) base_map = ('a, 'b) Codec.base_map = {
1213
+
kind : string;
1214
+
doc : string;
1215
+
dec : Meta.t -> 'a -> 'b;
1216
+
enc : 'b -> 'a;
1217
+
enc_meta : 'b -> Meta.t;
1218
+
}
1219
+
(** The type for mapping JSON base values. *)
1164
1220
1165
-
(** {1:recode Recode} *)
1221
+
type ('array, 'elt, 'builder) array_map =
1222
+
('array, 'elt, 'builder) Codec.array_map
1223
+
(** The type for mapping JSON arrays. *)
1166
1224
1167
-
val recode : 'a codec -> t -> (t, string) result
1168
-
(** [recode t v] decodes [v] with [t] and encodes it with [t]. *)
1225
+
type ('o, 'dec) object_map = ('o, 'dec) Codec.object_map
1226
+
(** The type for mapping JSON objects. *)
1169
1227
1170
-
val recode' : 'a codec -> t -> (t, Error.t) result
1171
-
(** [recode'] is like {!val-recode} but preserves the error structure. *)
1228
+
type mem_dec = Codec.mem_dec
1229
+
(** The type for member maps in decoding position. *)
1172
1230
1173
-
val update : 'a codec -> t -> t
1174
-
(** [update] is like {!val-recode} but raises {!Json.exception-Error}. *)
1231
+
type 'o mem_enc = 'o Codec.mem_enc
1232
+
(** The type for member maps in encoding position. *)
1175
1233
1176
-
(** {1:errors Errors} *)
1234
+
type ('o, 'a) mem_map = ('o, 'a) Codec.mem_map
1235
+
(** The type for mapping a JSON member. *)
1177
1236
1178
-
val error_sort : exp:Sort.t -> t -> 'a
1179
-
(** [error_sort ~exp fnd] errors when sort [exp] was expected but generic JSON
1180
-
[fnd] was found. *)
1237
+
type 'o object_shape = 'o Codec.object_shape
1238
+
(** The type for object shapes. *)
1181
1239
1182
-
val error_type : 'a codec -> t -> 'a
1183
-
(** [error_type t fnd] errors when the type expected by [t] does not match
1184
-
[fnd]. *)
1185
-
end
1240
+
type ('o, 'mems, 'builder) unknown_mems =
1241
+
('o, 'mems, 'builder) Codec.unknown_mems =
1242
+
| Unknown_skip : ('o, unit, unit) unknown_mems
1243
+
| Unknown_error : ('o, unit, unit) unknown_mems
1244
+
| Unknown_keep :
1245
+
('mems, 'a, 'builder) Codec.mems_map * ('o -> 'mems)
1246
+
-> ('o, 'mems, 'builder) unknown_mems
1247
+
(** The type for specifying decoding behaviour on unknown JSON object
1248
+
members. *)
1186
1249
1187
-
val json : t codec
1188
-
(** [json] maps any JSON value to its generic representation. *)
1250
+
type ('mems, 'a, 'builder) mems_map = ('mems, 'a, 'builder) Codec.mems_map
1251
+
(** The type for gathering unknown JSON members. *)
1189
1252
1190
-
val json_null : t codec
1191
-
(** [json_null] maps JSON nulls to their generic representation. *)
1253
+
type ('o, 'cases, 'tag) object_cases = ('o, 'cases, 'tag) Codec.object_cases
1254
+
(** The type for object cases. *)
1192
1255
1193
-
val json_bool : t codec
1194
-
(** [json_bool] maps JSON booleans to their generic representation. *)
1256
+
type ('cases, 'case, 'tag) case_map = ('cases, 'case, 'tag) Codec.case_map
1257
+
(** The type for an object case. *)
1195
1258
1196
-
val json_number : t codec
1197
-
(** [json_number] maps JSON nulls or numbers
1198
-
({{!page-cookbook.non_finite_numbers}explanation}) to their generic
1199
-
representation. *)
1259
+
type ('cases, 'tag) case_value = ('cases, 'tag) Codec.case_value
1260
+
(** The type for case values. *)
1200
1261
1201
-
val json_string : t codec
1202
-
(** [json_string] represents JSON strings by their generic representation. *)
1262
+
type ('cases, 'tag) case = ('cases, 'tag) Codec.case
1263
+
(** The type for hiding the concrete type of a case. *)
1203
1264
1204
-
val json_array : t codec
1205
-
(** [json_array] represents JSON arrays by their generic representation. *)
1265
+
type 'a any_map = 'a Codec.any_map
1266
+
(** The type for mapping JSON values with multiple sorts. *)
1206
1267
1207
-
val json_object : t codec
1208
-
(** [json_object] represents JSON objects by their generic representation. *)
1268
+
type ('a, 'b) map = ('a, 'b) Codec.map
1269
+
(** The type for mapping JSON types of type ['a] to a JSON type of type ['b].
1270
+
*)
1209
1271
1210
-
val json_mems : (t, t, mem list) Object.Mems.map
1211
-
(** [json_mems] is a members map collecting unknown members into a generic JSON
1212
-
object. See {{!page-cookbook.keeping}this example}. *)
1272
+
val array_kinded_sort : ('a, 'elt, 'builder) array_map -> string
1273
+
(** [array_kinded_sort map] is like {!kinded_sort} but acts directly on the
1274
+
array [map]. *)
1213
1275
1214
-
(** {1:queries Queries and updates}
1276
+
val object_kinded_sort : ('o, 'dec) object_map -> string
1277
+
(** [object_kinded_sort map] is like {!kinded_sort} but acts directly on the
1278
+
object [map]. *)
1215
1279
1216
-
Queries are lossy or aggregating decodes. Updates decode to {!type-json}
1217
-
values but transform the data along the way. They allow to process JSON data
1218
-
without having to fully model it (see the update example in the
1219
-
{{!page-index.quick_start}quick start}). *)
1280
+
val pp_kind : string Fmt.t
1281
+
(** [pp_kind] formats kinds. *)
1220
1282
1221
-
val const : 'a codec -> 'a -> 'a codec
1222
-
(** [const t v] maps any JSON value to [v] on decodes and unconditionally
1223
-
encodes [v] with [t]. *)
1283
+
val error_push_array :
1284
+
Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a
1285
+
(** [error_push_array] contextualises an error within an array. *)
1224
1286
1225
-
val recode : dec:'a codec -> ('a -> 'b) -> enc:'b codec -> 'b codec
1226
-
(** [recode ~dec f ~enc] maps on decodes like [dec] does followed by [f] and on
1227
-
encodes uses [enc]. This can be used to change the JSON sort of value. For
1228
-
example:
1229
-
{[
1230
-
recode ~dec:int (fun _ i -> string_of_int s) ~enc:string
1231
-
]}
1232
-
decodes an integer but encodes the integer as a string. *)
1287
+
val error_push_object :
1288
+
Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a
1289
+
(** [error_push_object] contextualises an error within an object. *)
1233
1290
1234
-
val update : 'a codec -> t codec
1235
-
(** [update t] decodes any JSON with [t] and directly encodes it back with [t]
1236
-
to yield the decode result. Encodes any JSON like {!val-json} does. *)
1291
+
val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b
1292
+
(** [type_error meta ~exp ~fnd] errors. *)
1237
1293
1238
-
(** {2:array_queries Arrays} *)
1294
+
val missing_mems_error :
1295
+
Meta.t ->
1296
+
('o, 'o) object_map ->
1297
+
exp:mem_dec String_map.t ->
1298
+
fnd:string list ->
1299
+
'a
1300
+
(** [missing_mems_error] errors when expected members are missing. *)
1239
1301
1240
-
val nth : ?absent:'a -> int -> 'a codec -> 'a codec
1241
-
(** [nth n t] decodes the [n]th index of a JSON array with [t]. Other indices
1242
-
are skipped. The decode errors if there is no such index unless [absent] is
1243
-
specified in which case this value is returned. Encodes a singleton array.
1244
-
*)
1302
+
val unexpected_mems_error :
1303
+
Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a
1304
+
(** [unexpected_mems_error] errors on unexpected members. *)
1245
1305
1246
-
val set_nth : ?stub:t -> ?allow_absent:bool -> 'a codec -> int -> 'a -> t codec
1247
-
(** [set_nth t n v] on decodes sets the [n]th value of a JSON array to [v]
1248
-
encoded by [t]. Other indices are left untouched. Errors if there is no such
1249
-
index unless [~allow_absent:true] is specified in which case the index is
1250
-
created preceeded by as many [stub] indices as needed. [stub] defaults to
1251
-
{!Json.zero} applied to the value [v] encoded by [t] (i.e. the "natural
1252
-
zero" of [v]'s encoding sort). Encodes like {!json_array} does. *)
1306
+
val unexpected_case_tag_error :
1307
+
Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases -> 'tag -> 'a
1308
+
(** [unexpected_case_tag_error] errors when a case tag has no matching case.
1309
+
*)
1253
1310
1254
-
val update_nth : ?stub:t -> ?absent:'a -> int -> 'a codec -> t codec
1255
-
(** [update_nth n t] on decode recodes the [n]th value of a JSON array with [t].
1256
-
Errors if there is no such index unless [absent] is specified in which case
1257
-
the index is created with [absent], encoded with [t] and preceeded by as
1258
-
many [stub] values as needed. [stub] defaults to {!Json.zero} applied to the
1259
-
recode. Encodes like {!json_array} does. *)
1311
+
val object_meta_arg : Meta.t Type.Id.t
1312
+
(** [object_meta_arg] is used to thread an object's {!Meta.t} through decode.
1313
+
*)
1260
1314
1261
-
val delete_nth : ?allow_absent:bool -> int -> t codec
1262
-
(** [delete_nth n] drops the [n]th index of a JSON array on both decode and
1263
-
encodes. Other indices are left untouched. Errors if there is no such index
1264
-
unless [~allow_absent:true] is specified in which case the data is left
1265
-
untouched. *)
1315
+
(** Heterogeneous dictionaries. *)
1316
+
module Dict : sig
1317
+
type binding = Codec.Dict.binding =
1318
+
| B : 'a Type.Id.t * 'a -> binding
1266
1319
1267
-
val filter_map_array :
1268
-
'a codec -> 'b codec -> (int -> 'a -> 'b option) -> t codec
1269
-
(** [filter_map_array a b f] maps the [a] elements of a JSON array with [f] to
1270
-
[b] elements or deletes them on [None]. Encodes generic JSON arrays like
1271
-
{!json_array} does. *)
1320
+
type t = Codec.Dict.t
1272
1321
1273
-
val fold_array : 'a codec -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b codec
1274
-
(** [fold_array t f acc] fold [f] over the [t] elements of a JSON array starting
1275
-
with [acc]. Encodes an empty JSON array. *)
1322
+
val empty : t
1323
+
val mem : 'a Type.Id.t -> t -> bool
1324
+
val add : 'a Type.Id.t -> 'a -> t -> t
1325
+
val remove : 'a Type.Id.t -> t -> t
1326
+
val find : 'a Type.Id.t -> t -> 'a option
1327
+
end
1276
1328
1277
-
(** {2:object_queries Objects} *)
1329
+
val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f
1330
+
(** [apply_dict dec dict] applies [dict] to [f]. *)
1278
1331
1279
-
val mem : ?absent:'a -> string -> 'a codec -> 'a codec
1280
-
(** [mem name t] decodes the member named [name] of a JSON object with [t].
1281
-
Other members are skipped. The decode errors if there is no such member
1282
-
unless [absent] is specified in which case this value is returned. Encodes
1283
-
an object with a single [name] member. *)
1332
+
type unknown_mems_option = Codec.unknown_mems_option =
1333
+
| Unknown_mems :
1334
+
('o, 'mems, 'builder) unknown_mems option
1335
+
-> unknown_mems_option
1284
1336
1285
-
val set_mem : ?allow_absent:bool -> 'a codec -> string -> 'a -> t codec
1286
-
(** [set_mem t name v] sets the member value of [name] of a [JSON] object to an
1287
-
encoding of [v] with [t]. This happens both on decodes and encodes. Errors
1288
-
if there is no such member unless [allow_absent:true] is specified in which
1289
-
case a member is added to the object. *)
1337
+
val override_unknown_mems :
1338
+
by:unknown_mems_option ->
1339
+
unknown_mems_option ->
1340
+
Dict.t ->
1341
+
unknown_mems_option * Dict.t
1342
+
(** [override_unknown_mems] performs unknown member overriding. *)
1290
1343
1291
-
val update_mem : ?absent:'a -> string -> 'a codec -> t codec
1292
-
(** [update_mem name t] recodes the member value of [name] of a JSON object with
1293
-
[t]. This happens both on decodes and encodes. Errors if there is no such
1294
-
member unless [absent] is specified in which case a member with this value
1295
-
encoded with [t] is added to the object. *)
1344
+
val finish_object_decode :
1345
+
('o, 'o) object_map ->
1346
+
Meta.t ->
1347
+
('p, 'mems, 'builder) unknown_mems ->
1348
+
'builder ->
1349
+
mem_dec String_map.t ->
1350
+
Dict.t ->
1351
+
Dict.t
1352
+
(** [finish_object_decode] finishes an object map decode. *)
1296
1353
1297
-
val delete_mem : ?allow_absent:bool -> string -> t codec
1298
-
(** [delete_mem name] deletes the member named [name] of a JSON object on
1299
-
decode. Other members are left untouched. The decode errors if there is no
1300
-
such member unless [~allow_absent:true] is specified in which case the data
1301
-
is left untouched. Encodes generic JSON objects like {!json_object} does. *)
1354
+
val pp_code : string Fmt.t
1355
+
(** [pp_code] formats strings like code (in bold). *)
1302
1356
1303
-
val filter_map_object :
1304
-
'a codec ->
1305
-
'b codec ->
1306
-
(Meta.t -> string -> 'a -> (name * 'b) option) ->
1307
-
t codec
1308
-
(** [filter_map_object a b f] maps the [a] members of a JSON object with [f] to
1309
-
[(n, b)] members or deletes them on [None]. The meta given to [f] is the
1310
-
meta of the member name. Encodes generic JSON arrays like {!json_object}
1311
-
does. *)
1357
+
(** {1:queries Queries and updates}
1312
1358
1313
-
val fold_object :
1314
-
'a codec -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b codec
1315
-
(** [fold_object t f acc] folds [f] over the [t] members of a JSON object
1316
-
starting with [acc]. Encodes an empty JSON object. *)
1359
+
Queries are lossy or aggregating decodes. Updates yield codecs that
1360
+
decode to generic {!value} values but transform the data along the way.
1361
+
They allow to process JSON data without having to fully model it. *)
1317
1362
1318
-
(** {2:index_queries Indices} *)
1363
+
val const : 'a t -> 'a -> 'a t
1364
+
(** [const t v] maps any JSON value to [v] on decodes and unconditionally
1365
+
encodes [v] with [t]. *)
1319
1366
1320
-
val index : ?absent:'a -> Path.index -> 'a codec -> 'a codec
1321
-
(** [index] uses {!val-nth} or {!val-mem} on the given index. *)
1367
+
val recode : dec:'a t -> ('a -> 'b) -> enc:'b t -> 'b t
1368
+
(** [recode ~dec f ~enc] maps on decodes like [dec] does followed by [f] and
1369
+
on encodes uses [enc]. *)
1322
1370
1323
-
val set_index : ?allow_absent:bool -> 'a codec -> Path.index -> 'a -> t codec
1324
-
(** [set_index] uses {!set_nth} or {!set_mem} on the given index. *)
1371
+
val update : 'a t -> value t
1372
+
(** [update t] decodes any JSON with [t] and directly encodes it back with
1373
+
[t] to yield the decode result. *)
1325
1374
1326
-
val update_index : ?stub:t -> ?absent:'a -> Path.index -> 'a codec -> t codec
1327
-
(** [update_index] uses {!update_nth} or {!update_mem} on the given index. *)
1375
+
(** {2:array_queries Arrays} *)
1328
1376
1329
-
val delete_index : ?allow_absent:bool -> Path.index -> t codec
1330
-
(** [delete_index] uses {!delete_nth} or {!delete_mem} on the given index. *)
1377
+
val nth : ?absent:'a -> int -> 'a t -> 'a t
1378
+
(** [nth n t] decodes the [n]th index of a JSON array with [t]. *)
1331
1379
1332
-
(** {2:path_queries Paths} *)
1380
+
val set_nth :
1381
+
?stub:value -> ?allow_absent:bool -> 'a t -> int -> 'a -> value t
1382
+
(** [set_nth t n v] on decodes sets the [n]th value to [v]. *)
1333
1383
1334
-
val path : ?absent:'a -> Path.t -> 'a codec -> 'a codec
1335
-
(** [path p t] {{!index}decodes} with [t] on the last index of [p]. If [p] is
1336
-
{!Path.root} this is [t]. *)
1384
+
val update_nth : ?stub:value -> ?absent:'a -> int -> 'a t -> value t
1385
+
(** [update_nth n t] recodes the [n]th value of a JSON array with [t]. *)
1337
1386
1338
-
val set_path :
1339
-
?stub:t -> ?allow_absent:bool -> 'a codec -> Path.t -> 'a -> t codec
1340
-
(** [set_path t p v] {{!set_index}sets} the last index of [p]. If [p] is
1341
-
{!Path.root} this encodes [v] with [t]. *)
1387
+
val delete_nth : ?allow_absent:bool -> int -> value t
1388
+
(** [delete_nth n] drops the [n]th index of a JSON array. *)
1342
1389
1343
-
val update_path : ?stub:t -> ?absent:'a -> Path.t -> 'a codec -> t codec
1344
-
(** [update_path p t] {{!update_index}updates} the last index of [p] with [t].
1345
-
On the root path this is [t]. *)
1390
+
val filter_map_array :
1391
+
'a t -> 'b t -> (int -> 'a -> 'b option) -> value t
1392
+
(** [filter_map_array a b f] maps the [a] elements with [f] to [b] elements
1393
+
or deletes them on [None]. *)
1346
1394
1347
-
val delete_path : ?allow_absent:bool -> Path.t -> t codec
1348
-
(** [delete_path p] {{!delete_index}deletes} the last index of [p]. If [p] is
1349
-
{!Path.root} this is {!Json.val-null}. *)
1395
+
val fold_array : 'a t -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b t
1396
+
(** [fold_array t f acc] folds [f] over the [t] elements of a JSON array. *)
1350
1397
1351
-
(** {1:fmt Formatting} *)
1398
+
(** {2:object_queries Objects} *)
1352
1399
1353
-
(** The type for specifying JSON encoding formatting. See for example
1354
-
{!Json_bytesrw.val-encode}. *)
1355
-
type format =
1356
-
| Minify (** Compact. No whitespace, no newlines. *)
1357
-
| Indent (** Indented output (not necessarily pretty). *)
1358
-
| Layout (** Follow {!Meta} layout information. *)
1400
+
val mem : ?absent:'a -> string -> 'a t -> 'a t
1401
+
(** [mem name t] decodes the member named [name] of a JSON object with [t].
1402
+
*)
1359
1403
1360
-
type number_format = (float -> unit, Format.formatter, unit) Stdlib.format
1361
-
(** The type for JSON number formatters. *)
1404
+
val set_mem : ?allow_absent:bool -> 'a t -> string -> 'a -> value t
1405
+
(** [set_mem t name v] sets the member value of [name] to an encoding of
1406
+
[v]. *)
1362
1407
1363
-
val default_number_format : number_format
1364
-
(** [default_number_format] is ["%.17g"]. This number formats ensures that
1365
-
finite floating point values can be interchanged without loss of precision.
1366
-
*)
1408
+
val update_mem : ?absent:'a -> string -> 'a t -> value t
1409
+
(** [update_mem name t] recodes the member value of [name]. *)
1367
1410
1368
-
val pp_null : unit Fmt.t
1369
-
(** [pp_null] formats a JSON null. *)
1411
+
val delete_mem : ?allow_absent:bool -> string -> value t
1412
+
(** [delete_mem name] deletes the member named [name]. *)
1370
1413
1371
-
val pp_bool : bool Fmt.t
1372
-
(** [pp_bool] formats a JSON bool. *)
1414
+
val filter_map_object :
1415
+
'a t -> 'b t -> (Meta.t -> string -> 'a -> (name * 'b) option) -> value t
1416
+
(** [filter_map_object a b f] maps the [a] members with [f] to [(n, b)]
1417
+
members or deletes them on [None]. *)
1373
1418
1374
-
val pp_number : float Fmt.t
1375
-
(** [pp_number] formats a JSON number of a JSON null if the float is not finite.
1376
-
Uses the {!default_number_format}. *)
1419
+
val fold_object :
1420
+
'a t -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b t
1421
+
(** [fold_object t f acc] folds [f] over the [t] members of a JSON object.
1422
+
*)
1377
1423
1378
-
val pp_number' : number_format -> float Fmt.t
1379
-
(** [pp_number' fmt] is like {!pp_number} but uses [fmt] to format the number.
1380
-
*)
1424
+
(** {2:index_queries Indices} *)
1381
1425
1382
-
val pp_string : string Fmt.t
1383
-
(** [pp_string] formats a JSON string (quoted and escaped). Assumes the string
1384
-
is valid UTF-8. *)
1426
+
val index : ?absent:'a -> Path.index -> 'a t -> 'a t
1427
+
(** [index] uses {!val-nth} or {!val-mem} on the given index. *)
1385
1428
1386
-
val pp_json : t Fmt.t
1387
-
(** [pp_json] formats JSON, see {!pp_json'}. *)
1429
+
val set_index :
1430
+
?allow_absent:bool -> 'a t -> Path.index -> 'a -> value t
1431
+
(** [set_index] uses {!set_nth} or {!set_mem} on the given index. *)
1388
1432
1389
-
val pp_json' : ?number_format:number_format -> unit -> t Fmt.t
1390
-
(** [pp_json'] formats JSON like {!pp_json} with a configurable [number_format].
1391
-
The output is indented but may be more compact than an [Indent] JSON encoder
1392
-
does (arrays may be output on one line if they fit, etc). Non-finite numbers
1393
-
print as JSON nulls; strings are assumed to be valid UTF-8. *)
1433
+
val update_index :
1434
+
?stub:value -> ?absent:'a -> Path.index -> 'a t -> value t
1435
+
(** [update_index] uses {!update_nth} or {!update_mem}. *)
1394
1436
1395
-
val pp_value : ?number_format:number_format -> 'a codec -> unit -> 'a Fmt.t
1396
-
(** [pp_value t ()] formats the JSON representation of values as described by
1397
-
[t] by encoding it with {!Json.val-encode} and formatting it with
1398
-
{!pp_json'}. If the encoding of the value errors a JSON string with the
1399
-
error message is formatted. This means that {!pp_value} should always format
1400
-
valid JSON text. *)
1437
+
val delete_index : ?allow_absent:bool -> Path.index -> value t
1438
+
(** [delete_index] uses {!delete_nth} or {!delete_mem}. *)
1401
1439
1402
-
(** {1:low Low-level representation} *)
1440
+
(** {2:path_queries Paths} *)
1403
1441
1404
-
module Codec = Codec
1405
-
(** Low level codec representation (unstable).
1442
+
val path : ?absent:'a -> Path.t -> 'a t -> 'a t
1443
+
(** [path p t] decodes with [t] on the last index of [p]. *)
1406
1444
1407
-
This representation may change even between minor versions of the library.
1408
-
It can be used to devise new processors on JSON types.
1445
+
val set_path :
1446
+
?stub:value -> ?allow_absent:bool -> 'a t -> Path.t -> 'a -> value t
1447
+
(** [set_path t p v] sets the last index of [p]. *)
1409
1448
1410
-
Processors should be ready to catch the {!Json.exception-Error} exception
1411
-
when they invoke functional members of the representation.
1449
+
val update_path :
1450
+
?stub:value -> ?absent:'a -> Path.t -> 'a t -> value t
1451
+
(** [update_path p t] updates the last index of [p] with [t]. *)
1412
1452
1413
-
Processors should make sure they interpret mappings correctly. In
1414
-
particular:
1415
-
- The [Number] case represents the sets of JSON numbers and nulls.
1453
+
val delete_path : ?allow_absent:bool -> Path.t -> value t
1454
+
(** [delete_path p] deletes the last index of [p]. *)
1455
+
end
1416
1456
1417
-
See the source of {!Json.decode'} and {!Json.encode'} for a simple example
1418
-
on how to process this representation. The
1419
-
{{:https://erratique.ch/repos/jsont/tree/paper}paper} in the Json source
1420
-
repository may also help to understand this menagerie of types. *)
1457
+
(** {1:tape Tape} *)
1421
1458
1422
1459
module Tape = Tape
1423
1460
(** Simdjson-compatible tape format. A columnar representation of a JSON value