Declarative JSON data manipulation for OCaml
ocaml-json: rename package jsont -> json
Directory ocaml-jsont -> ocaml-json. Library name jsont -> json,
jsont.bytesrw -> json.bytesrw, jsont.brr -> json.brr. Module renames:
Jsont -> Json, Jsont_base -> Json_base, Jsont_bytesrw -> Json_bytesrw,
Jsont_brr -> Json_brr. The internal type alias ['a jsont := 'a t] used
in sub-module signatures was renamed to ['a codec := 'a t] to avoid
clashing with the [json] value type now exposed at the top level.
+10486
+34
CHANGES.md
+34
CHANGES.md
···
1
+
v0.2.0 2025-07-25 Zagreb
2
+
------------------------
3
+
4
+
- Fix `Jsont_bytesrw.{encode,encode'}`. Do not write the `eod` slice if
5
+
`eod:false` is specified. Thanks to Benjamin Nguyen-Van-Yen for
6
+
the report and the fix (#8).
7
+
- Fix `Jsont.zero` failing encodes rather than encoding `null` as
8
+
advertised. Thanks to Adrián Montesinos González for the report (#6).
9
+
- Add `Jsont.Error.expected` to help format error messages.
10
+
- Add `Jsont.with_doc` to update kind and doc strings of existing JSON
11
+
types.
12
+
- Add `Jsont.Object.Case.{tag,map_tag}` to access a case and case map tags.
13
+
- Fix `META` file. Really export all requires and
14
+
remove uneeded `bytesrw` dependency from `jsont` library.
15
+
16
+
v0.1.1 2024-12-06 La Forclaz (VS)
17
+
---------------------------------
18
+
19
+
- `Jsont.Object.Mems.map` make encoding and decoding optional. Like
20
+
in every other map.
21
+
- `Jsont.Array.map` make encoding and decoding optional. Like
22
+
in every other map.
23
+
- `Jsont_bytesrw.encode` change the default buffer size
24
+
to match the one hinted by the writer rather than
25
+
`Bytesrw.Bytes.Slice.io_buffer_size`.
26
+
- `jsont.{bytesrw,brr}` export all requires.
27
+
- `jsont` tool remove spurious dependency on `b0.std` (#2).
28
+
29
+
v0.1.0 2024-11-29 Zagreb
30
+
------------------------
31
+
32
+
First release.
33
+
34
+
Supported by a grant from the OCaml Software Foundation.
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2024 The jsont programmers
4
+
5
+
Permission to use, copy, modify, and/or distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
10
+
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11
+
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
12
+
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13
+
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
14
+
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE.
+70
README.md
+70
README.md
···
1
+
Jsont – Declarative JSON data manipulation for OCaml
2
+
====================================================
3
+
4
+
Jsont is an OCaml library for declarative JSON data manipulation. It
5
+
provides:
6
+
7
+
- Combinators for describing JSON data using the OCaml values of your
8
+
choice. The descriptions can be used by generic functions to
9
+
decode, encode, query and update JSON data without having to
10
+
construct a generic JSON representation.
11
+
- A JSON codec with optional text location tracking and layout
12
+
preservation. The codec is compatible with effect-based concurrency.
13
+
14
+
The descriptions are independent from the codec and can be used by
15
+
third-party processors or codecs.
16
+
17
+
Jsont is distributed under the ISC license. It has no dependencies.
18
+
The codec is optional and depends on the [`bytesrw`] library. The JavaScript
19
+
support is optional and depends on the [`brr`] library.
20
+
21
+
Homepage: <https://erratique.ch/software/jsont/>
22
+
23
+
[`bytesrw`]: https://erratique.ch/software/bytesrw
24
+
[`brr`]: https://erratique.ch/software/brr
25
+
26
+
## Installation
27
+
28
+
Jsont can be installed with `opam`:
29
+
30
+
opam install jsont
31
+
opam install jsont bytesrw # For the optional codec support
32
+
opam install jsont brr # For the optional JavaScript support
33
+
opam install jsont bytesrw cmdliner # For the jsont tool
34
+
35
+
## Documentation
36
+
37
+
The documentation can be consulted [online] or via `odig doc jsont`.
38
+
39
+
Questions are welcome but better asked on the [OCaml forum] than on the
40
+
issue tracker.
41
+
42
+
[online]: https://erratique.ch/software/jsont/doc
43
+
[OCaml forum]: https://discuss.ocaml.org/
44
+
45
+
## Examples
46
+
47
+
A few examples can be found in the [documentation][online] and in the
48
+
[test](test/) directory. The [`test/topojson.ml`],
49
+
[`test/geojson.ml`], [`test/json_rpc.ml`], show use of the library on
50
+
concrete JSON data formats.
51
+
52
+
[`test/topojson.ml`]: test/topojson.ml
53
+
[`test/geojson.ml`]: test/geojson.ml
54
+
[`test/json_rpc.ml`]: test/json_rpc.ml
55
+
56
+
## Paper & technique
57
+
58
+
If you want to understand the *finally tagged* technique used by the
59
+
library, the [`paper/soup.ml`] source implements the abridged version
60
+
of the underlying data type used in [the paper].
61
+
62
+
[the paper]: paper/
63
+
[`paper/soup.ml`]: paper/soup.ml
64
+
65
+
## Acknowledgments
66
+
67
+
A grant from the [OCaml Software Foundation] helped to bring the first
68
+
public release of `jsont`.
69
+
70
+
[OCaml Software Foundation]: http://ocaml-sf.org/
+27
dune-project
+27
dune-project
···
1
+
(lang dune 3.21)
2
+
3
+
(name json)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source (tangled gazagnaire.org/ocaml-jsont))
8
+
(license ISC)
9
+
(authors "Daniel Bünzli")
10
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
11
+
12
+
(package
13
+
(name json)
14
+
(synopsis "Declarative JSON data manipulation for OCaml")
15
+
(tags (org:blacksun codec json format))
16
+
(description
17
+
"Json is a library for describing JSON data declaratively. Descriptions
18
+
can be used to decode, encode, query, and update JSON values without
19
+
constructing an intermediate representation. The bytesrw codec offers
20
+
optional text-location tracking and layout preservation and is
21
+
compatible with effect-based concurrency.")
22
+
(depends
23
+
(ocaml (>= 4.14))
24
+
(dune (>= 3.21))
25
+
(bytesrw (>= 0.1.0))
26
+
(alcotest :with-test)
27
+
(odoc :with-doc)))
+38
json.opam
+38
json.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Declarative JSON data manipulation for OCaml"
4
+
description: """
5
+
Json is a library for describing JSON data declaratively. Descriptions
6
+
can be used to decode, encode, query, and update JSON values without
7
+
constructing an intermediate representation. The bytesrw codec offers
8
+
optional text-location tracking and layout preservation and is
9
+
compatible with effect-based concurrency."""
10
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
11
+
authors: ["Daniel Bünzli"]
12
+
license: "ISC"
13
+
tags: ["org:blacksun" "codec" "json" "format"]
14
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-jsont"
15
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-jsont/issues"
16
+
depends: [
17
+
"ocaml" {>= "4.14"}
18
+
"dune" {>= "3.21" & >= "3.21"}
19
+
"bytesrw" {>= "0.1.0"}
20
+
"alcotest" {with-test}
21
+
"odoc" {with-doc}
22
+
]
23
+
build: [
24
+
["dune" "subst"] {dev}
25
+
[
26
+
"dune"
27
+
"build"
28
+
"-p"
29
+
name
30
+
"-j"
31
+
jobs
32
+
"@install"
33
+
"@runtest" {with-test}
34
+
"@doc" {with-doc}
35
+
]
36
+
]
37
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-jsont"
38
+
x-maintenance-intent: ["(latest)"]
+6
lib/brr/dune
+6
lib/brr/dune
+369
lib/brr/json_brr.ml
+369
lib/brr/json_brr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Json.Repr
7
+
8
+
(* Converting between Json.Error.t and Jv.Error.t values *)
9
+
10
+
let error_to_jv_error e = Jv.Error.v (Jstr.of_string (Json.Error.to_string e))
11
+
12
+
let jv_error_to_error e =
13
+
let ctx = Json.Error.Context.empty and meta = Json.Meta.none in
14
+
Json.Error.make_msg ctx meta (Jstr.to_string (Jv.Error.message e))
15
+
16
+
(* Browser JSON codec *)
17
+
18
+
let indent = Jstr.v " "
19
+
let json = Jv.get Jv.global "JSON"
20
+
let json_parse s = Jv.call json "parse" [| Jv.of_jstr s |]
21
+
22
+
let json_stringify ~format v =
23
+
let args =
24
+
match format with
25
+
| Json.Minify -> [| v |]
26
+
| Json.Indent | Json.Layout -> [| v; Jv.null; Jv.of_jstr indent |]
27
+
in
28
+
Jv.to_jstr (Jv.call json "stringify" args)
29
+
30
+
(* Computing the sort of a Jv.t value *)
31
+
32
+
let type_bool = Jstr.v "boolean"
33
+
let type_object = Jstr.v "object"
34
+
let type_number = Jstr.v "number"
35
+
let type_string = Jstr.v "string"
36
+
let type_array = Jv.get Jv.global "Array"
37
+
38
+
let jv_sort jv =
39
+
if Jv.is_null jv then Json.Sort.Null
40
+
else
41
+
let t = Jv.typeof jv in
42
+
if Jstr.equal t type_bool then Json.Sort.Bool
43
+
else if Jstr.equal t type_number then Json.Sort.Number
44
+
else if Jstr.equal t type_string then Json.Sort.String
45
+
else if Jstr.equal t type_object then
46
+
if Jv.is_array jv then Json.Sort.Array else Json.Sort.Object
47
+
else
48
+
Json.Error.msgf Json.Meta.none "Not a JSON value: %s" (Jstr.to_string t)
49
+
50
+
(* Getting the members of a Jv.t object in various ways *)
51
+
52
+
let jv_mem_names jv = Jv.call (Jv.get Jv.global "Object") "keys" [| jv |]
53
+
let jv_mem_name_list jv = Jv.to_list Jv.to_string (jv_mem_names jv)
54
+
55
+
let jv_mem_name_map : Jv.t -> Jstr.t String_map.t =
56
+
fun jv ->
57
+
(* The map maps OCaml strings their corresponding JavaScript string *)
58
+
let rec loop ns i max m =
59
+
if i > max then m
60
+
else
61
+
let n = Jv.Jarray.get ns i in
62
+
loop ns (i + 1) max (String_map.add (Jv.to_string n) (Jv.to_jstr n) m)
63
+
in
64
+
let ns = jv_mem_names jv in
65
+
loop ns 0 (Jv.Jarray.length ns - 1) String_map.empty
66
+
67
+
(* Decoding *)
68
+
69
+
let error_push_array map i e =
70
+
Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e
71
+
72
+
let error_push_object map n e =
73
+
Json.Repr.error_push_object Json.Meta.none map (n, Json.Meta.none) e
74
+
75
+
let type_error t ~fnd = Json.Repr.type_error Json.Meta.none t ~fnd
76
+
77
+
let find_all_unexpected ~mem_decs mems =
78
+
let unexpected (n, _jname) =
79
+
match String_map.find_opt n mem_decs with
80
+
| None -> Some (n, Json.Meta.none)
81
+
| Some _ -> None
82
+
in
83
+
List.filter_map unexpected mems
84
+
85
+
let rec decode : type a. a Json.Repr.t -> Jv.t -> a =
86
+
fun t jv ->
87
+
match t with
88
+
| Null map -> (
89
+
match jv_sort jv with
90
+
| Null -> map.dec Json.Meta.none ()
91
+
| fnd -> type_error t ~fnd)
92
+
| Bool map -> (
93
+
match jv_sort jv with
94
+
| Bool -> map.dec Json.Meta.none (Jv.to_bool jv)
95
+
| fnd -> type_error t ~fnd)
96
+
| Number map -> (
97
+
match jv_sort jv with
98
+
| Number -> map.dec Json.Meta.none (Jv.to_float jv)
99
+
| Null -> map.dec Json.Meta.none Float.nan
100
+
| fnd -> type_error t ~fnd)
101
+
| String map -> (
102
+
match jv_sort jv with
103
+
| String -> map.dec Json.Meta.none (Jv.to_string jv)
104
+
| fnd -> type_error t ~fnd)
105
+
| Array map -> (
106
+
match jv_sort jv with
107
+
| Array -> decode_array map jv
108
+
| fnd -> type_error t ~fnd)
109
+
| Object map -> (
110
+
match jv_sort jv with
111
+
| Object -> decode_object map jv
112
+
| fnd -> type_error t ~fnd)
113
+
| Map map -> map.dec (decode map.dom jv)
114
+
| Any map -> decode_any t map jv
115
+
| Rec t -> decode (Lazy.force t) jv
116
+
117
+
and decode_array : type a e b. (a, e, b) array_map -> Jv.t -> a =
118
+
fun map jv ->
119
+
let len = Jv.Jarray.length jv in
120
+
let b = ref (map.dec_empty ()) in
121
+
for i = 0 to len - 1 do
122
+
try
123
+
if map.dec_skip i !b then ()
124
+
else b := map.dec_add i (decode map.elt (Jv.Jarray.get jv i)) !b
125
+
with Json.Error e -> error_push_array map i e
126
+
done;
127
+
map.dec_finish Json.Meta.none len !b
128
+
129
+
and decode_object : type o. (o, o) object_map -> Jv.t -> o =
130
+
fun map jv ->
131
+
let names = jv_mem_name_map jv in
132
+
let umems = Unknown_mems None in
133
+
let dict = decode_object_map map umems String_map.empty Dict.empty names jv in
134
+
apply_dict map.dec dict
135
+
136
+
and decode_object_map : type o.
137
+
(o, o) object_map ->
138
+
unknown_mems_option ->
139
+
mem_dec String_map.t ->
140
+
Dict.t ->
141
+
Jstr.t String_map.t ->
142
+
Jv.t ->
143
+
Dict.t =
144
+
fun map umems mem_decs dict names jv ->
145
+
let u _ _ _ =
146
+
assert false
147
+
(* They should be disjoint by contruction *)
148
+
in
149
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
150
+
match map.shape with
151
+
| Object_cases (umems', cases) ->
152
+
let umems' = Unknown_mems umems' in
153
+
let umems, dict =
154
+
Json.Repr.override_unknown_mems ~by:umems umems' dict
155
+
in
156
+
decode_object_cases map umems cases mem_decs dict names jv
157
+
| Object_basic umems' -> (
158
+
let umems' = Unknown_mems (Some umems') in
159
+
let umems, dict =
160
+
Json.Repr.override_unknown_mems ~by:umems umems' dict
161
+
in
162
+
match umems with
163
+
| Unknown_mems (Some Unknown_skip | None) ->
164
+
let u = Unknown_skip in
165
+
decode_object_basic map u () mem_decs dict
166
+
(String_map.bindings names)
167
+
jv
168
+
| Unknown_mems (Some (Unknown_error as u)) ->
169
+
decode_object_basic map u () mem_decs dict
170
+
(String_map.bindings names)
171
+
jv
172
+
| Unknown_mems (Some (Unknown_keep (umap, _) as u)) ->
173
+
let umap = umap.dec_empty () and names = String_map.bindings names in
174
+
decode_object_basic map u umap mem_decs dict names jv)
175
+
176
+
and decode_object_basic : type o p m b.
177
+
(o, o) object_map ->
178
+
(p, m, b) unknown_mems ->
179
+
b ->
180
+
mem_dec String_map.t ->
181
+
Dict.t ->
182
+
(string * Jstr.t) list ->
183
+
Jv.t ->
184
+
Dict.t =
185
+
fun map umems umap mem_decs dict names jv ->
186
+
match names with
187
+
| [] ->
188
+
Json.Repr.finish_object_decode map Json.Meta.none umems umap mem_decs
189
+
dict
190
+
| (n, jname) :: names -> (
191
+
match String_map.find_opt n mem_decs with
192
+
| Some (Mem_dec m) ->
193
+
let dict =
194
+
try Dict.add m.id (decode m.type' (Jv.get' jv jname)) dict
195
+
with Json.Error e -> error_push_object map n e
196
+
in
197
+
let mem_decs = String_map.remove n mem_decs in
198
+
decode_object_basic map umems umap mem_decs dict names jv
199
+
| None -> (
200
+
match umems with
201
+
| Unknown_skip ->
202
+
decode_object_basic map umems umap mem_decs dict names jv
203
+
| Unknown_error ->
204
+
let fnd =
205
+
(n, Json.Meta.none) :: find_all_unexpected ~mem_decs names
206
+
in
207
+
Json.Repr.unexpected_mems_error Json.Meta.none map ~fnd
208
+
| Unknown_keep (mmap, _) ->
209
+
let umap =
210
+
let v =
211
+
try decode mmap.mems_type (Jv.get' jv jname)
212
+
with Json.Error e -> error_push_object map n e
213
+
in
214
+
mmap.dec_add Json.Meta.none n v umap
215
+
in
216
+
decode_object_basic map umems umap mem_decs dict names jv))
217
+
218
+
and decode_object_cases : type o cs t.
219
+
(o, o) object_map ->
220
+
unknown_mems_option ->
221
+
(o, cs, t) object_cases ->
222
+
mem_dec String_map.t ->
223
+
Dict.t ->
224
+
Jstr.t String_map.t ->
225
+
Jv.t ->
226
+
Dict.t =
227
+
fun map umems cases mem_decs dict names jv ->
228
+
let decode_case_tag tag =
229
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
230
+
match List.find_opt eq_tag cases.cases with
231
+
| None -> Json.Repr.unexpected_case_tag_error Json.Meta.none map cases tag
232
+
| Some (Case case) ->
233
+
let mems = String_map.remove cases.tag.name names in
234
+
let dict =
235
+
decode_object_map case.object_map umems mem_decs dict mems jv
236
+
in
237
+
Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
238
+
in
239
+
match String_map.find_opt cases.tag.name names with
240
+
| Some jname -> (
241
+
try decode_case_tag (decode cases.tag.type' (Jv.get' jv jname))
242
+
with Json.Error e -> error_push_object map cases.tag.name e)
243
+
| None -> (
244
+
match cases.tag.dec_absent with
245
+
| Some tag -> decode_case_tag tag
246
+
| None ->
247
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
248
+
let fnd = jv_mem_name_list jv in
249
+
Json.Repr.missing_mems_error Json.Meta.none map ~exp ~fnd)
250
+
251
+
and decode_any : type a. a t -> a any_map -> Jv.t -> a =
252
+
fun t map jv ->
253
+
let case t map sort jv =
254
+
match map with Some t -> decode t jv | None -> type_error t ~fnd:sort
255
+
in
256
+
match jv_sort jv with
257
+
| Null as s -> case t map.dec_null s jv
258
+
| Bool as s -> case t map.dec_bool s jv
259
+
| Number as s -> case t map.dec_number s jv
260
+
| String as s -> case t map.dec_string s jv
261
+
| Array as s -> case t map.dec_array s jv
262
+
| Object as s -> case t map.dec_object s jv
263
+
264
+
let decode t jv = decode (Json.Repr.of_t t) jv
265
+
let decode_jv' t jv = try Ok (decode t jv) with Json.Error e -> Error e
266
+
let decode_jv t jv = Result.map_error error_to_jv_error (decode_jv' t jv)
267
+
268
+
let decode' t s =
269
+
try Ok (decode t (json_parse s)) with
270
+
| Jv.Error e -> Error (jv_error_to_error e)
271
+
| Json.Error e -> Error e
272
+
273
+
let decode t json = Result.map_error error_to_jv_error (decode' t json)
274
+
275
+
(* Encoding *)
276
+
277
+
let rec encode : type a. a t -> a -> Jv.t =
278
+
fun t v ->
279
+
match t with
280
+
| Null map ->
281
+
map.enc v;
282
+
Jv.null
283
+
| Bool map -> Jv.of_bool (map.enc v)
284
+
| Number map -> Jv.of_float (map.enc v)
285
+
| String map -> Jv.of_string (map.enc v)
286
+
| Array map ->
287
+
let add map a i vi =
288
+
try
289
+
Jv.Jarray.set a i (encode map.elt vi);
290
+
a
291
+
with Json.Error e -> error_push_array map i e
292
+
in
293
+
map.enc (add map) (Jv.Jarray.create 0) v
294
+
| Object map -> encode_object map ~do_unknown:true v (Jv.obj [||])
295
+
| Any map -> encode (map.enc v) v
296
+
| Map map -> encode map.dom (map.enc v)
297
+
| Rec t -> encode (Lazy.force t) v
298
+
299
+
and encode_object : type o.
300
+
(o, o) Json.Repr.object_map -> do_unknown:bool -> o -> Jv.t -> Jv.t =
301
+
fun map ~do_unknown o jv ->
302
+
let encode_mem map o jv (Mem_enc mmap) =
303
+
try
304
+
let v = mmap.enc o in
305
+
if mmap.enc_omit v then jv
306
+
else (
307
+
Jv.set' jv (Jstr.of_string mmap.name) (encode mmap.type' v);
308
+
jv)
309
+
with Json.Error e -> error_push_object map mmap.name e
310
+
in
311
+
let jv = List.fold_left (encode_mem map o) jv map.mem_encs in
312
+
match map.shape with
313
+
| Object_basic (Unknown_keep (umap, enc)) when do_unknown ->
314
+
encode_unknown_mems map umap (enc o) jv
315
+
| Object_basic _ -> jv
316
+
| Object_cases (u, cases) -> (
317
+
let (Case_value (case, v)) = cases.enc_case (cases.enc o) in
318
+
let jv =
319
+
try
320
+
if cases.tag.enc_omit case.tag then jv
321
+
else
322
+
let tag = encode cases.tag.type' case.tag in
323
+
Jv.set' jv (Jstr.of_string cases.tag.name) tag;
324
+
jv
325
+
with Json.Error e -> error_push_object map cases.tag.name e
326
+
in
327
+
match u with
328
+
| Some (Unknown_keep (umap, enc)) ->
329
+
(* Feels nicer to encode unknowns at the end *)
330
+
let jv = encode_object case.object_map ~do_unknown:false v jv in
331
+
encode_unknown_mems map umap (enc o) jv
332
+
| _ -> encode_object case.object_map ~do_unknown v jv)
333
+
334
+
and encode_unknown_mems : type o mems a builder.
335
+
(o, o) object_map -> (mems, a, builder) mems_map -> mems -> Jv.t -> Jv.t =
336
+
fun map umap mems jv ->
337
+
let encode_mem map meta name v jv =
338
+
try
339
+
Jv.set' jv (Jstr.of_string name) (encode umap.mems_type v);
340
+
jv
341
+
with Json.Error e -> error_push_object map name e
342
+
in
343
+
umap.enc (encode_mem map) mems jv
344
+
345
+
let encode t v = encode (Json.Repr.of_t t) v
346
+
let encode_jv' t v = try Ok (encode t v) with Json.Error e -> Error e
347
+
let encode_jv t v = Result.map_error error_to_jv_error (encode_jv' t v)
348
+
349
+
let encode' ?(format = Json.Minify) t v =
350
+
try Ok (json_stringify ~format (encode t v)) with
351
+
| Jv.Error e -> Error (jv_error_to_error e)
352
+
| Json.Error e -> Error e
353
+
354
+
let encode ?format t v =
355
+
Result.map_error error_to_jv_error (encode' ?format t v)
356
+
357
+
(* Recode *)
358
+
359
+
let recode ?format t s =
360
+
match decode t s with Error _ as e -> e | Ok v -> encode ?format t v
361
+
362
+
let recode' ?format t s =
363
+
match decode' t s with Error _ as e -> e | Ok v -> encode' ?format t v
364
+
365
+
let recode_jv t jv =
366
+
match decode_jv t jv with Error _ as e -> e | Ok v -> encode_jv t v
367
+
368
+
let recode_jv' t s =
369
+
match decode_jv' t s with Error _ as e -> e | Ok v -> encode_jv' t v
+68
lib/brr/json_brr.mli
+68
lib/brr/json_brr.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JavaScript support.
7
+
8
+
{b Note.} These functions incur a bit of overhead but should work fast
9
+
enough for medium sized structures. Get in touch if you run into problems,
10
+
some improvements may be possible.
11
+
12
+
The JSON functions use JavaScript's
13
+
{{:https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Global_Objects/JSON/parse}
14
+
[JSON.parse]} and
15
+
{{:https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify}
16
+
[JSON.stringify]} to convert to JavaScript values which are then converted
17
+
with {!decode_jv} and {!encode_jv}. Parse locations and layout preservation
18
+
are unsupported. *)
19
+
20
+
(** {1:decode Decode} *)
21
+
22
+
val decode : 'a Json.t -> Jstr.t -> ('a, Jv.Error.t) result
23
+
(** [decode t s] decodes the JSON data [s] according to [t]. *)
24
+
25
+
val decode' : 'a Json.t -> Jstr.t -> ('a, Json.Error.t) result
26
+
(** [decode' t s] is like {!val-decode} but preserves the error structure. *)
27
+
28
+
val decode_jv : 'a Json.t -> Jv.t -> ('a, Jv.Error.t) result
29
+
(** [decode_jv t v] decodes the JavaScript value [v] according to [t]. *)
30
+
31
+
val decode_jv' : 'a Json.t -> Jv.t -> ('a, Json.Error.t) result
32
+
(** [decode_jv'] is like {!decode_jv'} but preserves the error structure. *)
33
+
34
+
(** {1:encode Encode} *)
35
+
36
+
val encode :
37
+
?format:Json.format -> 'a Json.t -> 'a -> (Jstr.t, Jv.Error.t) result
38
+
(** [encode t v] encodes [v] to JSON according to [t]. [format] specifies how
39
+
the JSON is formatted, defaults to {!Json.Minify}. The {!Json.Layout}
40
+
format is unsupported, {!Json.Indent} is used instead. *)
41
+
42
+
val encode' :
43
+
?format:Json.format -> 'a Json.t -> 'a -> (Jstr.t, Json.Error.t) result
44
+
(** [encode'] is like {!val-encode} but preserves the error structure. [format]
45
+
specifies how the JSON is formatted, defaults to {!Json.Minify}. The
46
+
{!Json.Layout} format is unsupported, {!Json.Indent} is used instead. *)
47
+
48
+
val encode_jv : 'a Json.t -> 'a -> (Jv.t, Jv.Error.t) result
49
+
(** [encode_jv t v] encodes [v] to a JavaScript value according to [t]. *)
50
+
51
+
val encode_jv' : 'a Json.t -> 'a -> (Jv.t, Json.Error.t) result
52
+
(** [encode_jv'] is like {!val-encode_jv} but preserves the error structure. *)
53
+
54
+
(** {1:recode Recode} *)
55
+
56
+
val recode :
57
+
?format:Json.format -> 'a Json.t -> Jstr.t -> (Jstr.t, Jv.Error.t) result
58
+
(** [recode] is {!val-decode} followed by {!val-encode}. *)
59
+
60
+
val recode' :
61
+
?format:Json.format -> 'a Json.t -> Jstr.t -> (Jstr.t, Json.Error.t) result
62
+
(** [recode] is {!val-decode'} followed by {!val-encode'}. *)
63
+
64
+
val recode_jv : 'a Json.t -> Jv.t -> (Jv.t, Jv.Error.t) result
65
+
(** [recode] is {!val-decode} followed by {!val-encode}. *)
66
+
67
+
val recode_jv' : 'a Json.t -> Jv.t -> (Jv.t, Json.Error.t) result
68
+
(** [recode] is {!val-decode_jv'} followed by {!encode_jv'}. *)
+5
lib/bytesrw/dune
+5
lib/bytesrw/dune
+1303
lib/bytesrw/json_bytesrw.ml
+1303
lib/bytesrw/json_bytesrw.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Bytesrw
7
+
open Json.Repr
8
+
9
+
(* XXX add these things to Stdlib.Uchar *)
10
+
11
+
let uchar_max_utf_8_byte_length = 4
12
+
13
+
let[@inline] uchar_utf_8_byte_decode_length = function
14
+
| '\x00' .. '\x7F' -> 1
15
+
| '\x80' .. '\xC1' -> 0
16
+
| '\xC2' .. '\xDF' -> 2
17
+
| '\xE0' .. '\xEF' -> 3
18
+
| '\xF0' .. '\xF4' -> 4
19
+
| _ -> 0
20
+
21
+
(* Character classes *)
22
+
23
+
let[@inline] is_digit u = 0x0030 (* 0 *) <= u && u <= 0x0039 (* 9 *)
24
+
let[@inline] is_number_start u = is_digit u || u = 0x002D (* - *)
25
+
let[@inline] is_surrogate u = 0xD800 <= u && u <= 0xDFFF
26
+
let[@inline] is_hi_surrogate u = 0xD800 <= u && u <= 0xDBFF
27
+
let[@inline] is_lo_surrogate u = 0xDC00 <= u && u <= 0xDFFF
28
+
29
+
let[@inline] is_control u =
30
+
(0x0000 <= u && u <= 0x001F)
31
+
(* C0 control characters *)
32
+
|| u = 0x007F
33
+
(* Delete *)
34
+
|| (0x0080 <= u && u <= 0x009F)
35
+
(* C1 control characters *)
36
+
|| u = 0x2028
37
+
(* Line separator *) || u = 0x2029
38
+
(* Paragraph separator *) || u = 0x200E
39
+
(* left-to-right mark *) || u = 0x200F (* right-to-left mark *)
40
+
41
+
let sot = 0x1A0000 (* start of text U+10FFFF + 1 *)
42
+
let eot = 0x1A0001 (* end of text U+10FFFF + 2 *)
43
+
let pp_code = Json.Repr.pp_code
44
+
45
+
let pp_quchar ppf u =
46
+
pp_code ppf
47
+
@@
48
+
if u = sot then "start of text"
49
+
else if u = eot then "end of text"
50
+
else if is_control u || is_surrogate u then Printf.sprintf "U+%04X" u
51
+
else
52
+
let u = Uchar.of_int u in
53
+
let b = Stdlib.Bytes.make (Uchar.utf_8_byte_length u) '\x00' in
54
+
Stdlib.(
55
+
ignore (Bytes.set_utf_8_uchar b 0 u);
56
+
Bytes.unsafe_to_string b)
57
+
58
+
(* Decoder *)
59
+
60
+
type decoder = {
61
+
file : string;
62
+
meta_none : Json.Meta.t; (* A meta with just [file] therein. *)
63
+
locs : bool; (* [true] if text locations should be computed. *)
64
+
layout : bool; (* [true] if text layout should be kept. *)
65
+
reader : Bytes.Reader.t; (* The source of bytes. *)
66
+
mutable i : Stdlib.Bytes.t; (* Current input slice. *)
67
+
mutable i_max : int; (* Maximum byte index in [i]. *)
68
+
mutable i_next : int; (* Next byte index to read in [i]. *)
69
+
mutable overlap : Stdlib.Bytes.t; (* Buffer for overlapping decodes. *)
70
+
mutable u : int; (* Current Unicode scalar value or sot or eot. *)
71
+
mutable byte_count : int; (* Global byte count. *)
72
+
mutable line : int; (* Current line number. *)
73
+
mutable line_start : int; (* Current line global byte position. *)
74
+
token : Buffer.t;
75
+
ws : Buffer.t; (* Bufferizes whitespace when layout is [true]. *)
76
+
}
77
+
78
+
let make_decoder ?(locs = false) ?(layout = false) ?(file = "-") reader =
79
+
let overlap = Stdlib.Bytes.create uchar_max_utf_8_byte_length in
80
+
let token = Buffer.create 255 and ws = Buffer.create 255 in
81
+
let meta_none = Json.Meta.make (Json.Textloc.(set_file none) file) in
82
+
{
83
+
file;
84
+
meta_none;
85
+
locs;
86
+
layout;
87
+
reader;
88
+
i = overlap (* overwritten by initial refill *);
89
+
i_max = 0;
90
+
i_next = 1 (* triggers an initial refill *);
91
+
overlap;
92
+
u = sot;
93
+
byte_count = 0;
94
+
line = 1;
95
+
line_start = 0;
96
+
token;
97
+
ws;
98
+
}
99
+
100
+
(* Decoder positions *)
101
+
102
+
let[@inline] get_line_pos d = (d.line, d.line_start)
103
+
104
+
let get_last_byte d =
105
+
if d.u <= 0x7F then d.byte_count - 1
106
+
else if d.u = sot || d.u = eot then d.byte_count
107
+
else
108
+
(* On multi-bytes uchars we want to point on the first byte. *)
109
+
d.byte_count - Uchar.utf_8_byte_length (Uchar.of_int d.u)
110
+
111
+
(* Decoder errors *)
112
+
113
+
let error_meta d =
114
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
115
+
let last_byte = first_byte and last_line = first_line in
116
+
Json.Meta.make
117
+
@@ Json.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
118
+
~last_line
119
+
120
+
let error_meta_to_current ~first_byte ~first_line d =
121
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
122
+
Json.Meta.make
123
+
@@ Json.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
124
+
~last_line
125
+
126
+
let err_here d fmt = Json.Error.msgf (error_meta d) fmt
127
+
128
+
let err_to_here ~first_byte ~first_line d fmt =
129
+
Json.Error.msgf (error_meta_to_current ~first_byte ~first_line d) fmt
130
+
131
+
let err_malformed_utf_8 d =
132
+
if d.i_next > d.i_max then
133
+
err_here d "UTF-8 decoding error: unexpected end of bytes"
134
+
else
135
+
err_here d "UTF-8 decoding error: invalid byte %a" pp_code
136
+
(Printf.sprintf "%x02x" (Bytes.get_uint8 d.i d.i_next))
137
+
138
+
let err_exp d = err_here d "Expected %a but found %a"
139
+
let err_exp_while d = err_here d "Expected %a while parsing %a but found %a"
140
+
let err_exp_eot d = err_exp d pp_quchar eot pp_quchar d.u
141
+
let err_not_json_value d = err_exp d pp_code "JSON value" pp_quchar d.u
142
+
143
+
let current_json_sort d =
144
+
match d.u with
145
+
| 0x0066 (* f *) | 0x0074 (* t *) -> Json.Sort.Bool
146
+
| 0x006E (* n *) -> Json.Sort.Null
147
+
| 0x007B (* { *) -> Json.Sort.Object
148
+
| 0x005B (* [ *) -> Json.Sort.Array
149
+
| 0x0022 (* DQUOTE *) -> Json.Sort.String
150
+
| u when is_number_start u -> Json.Sort.Number
151
+
| _ -> err_not_json_value d
152
+
153
+
let type_error d t =
154
+
Json.Repr.type_error (error_meta d) t ~fnd:(current_json_sort d)
155
+
156
+
(* Errors for constants *)
157
+
158
+
let err_exp_in_const ~first_byte ~first_line d ~exp ~fnd ~const =
159
+
err_to_here ~first_byte ~first_line d
160
+
"Expected %a while parsing %a but found: %a" pp_quchar exp pp_code const
161
+
pp_quchar fnd
162
+
163
+
(* Errors for numbers *)
164
+
165
+
let err_float_parse meta tok =
166
+
Json.Error.msgf meta "Could not parse %S to a %a" tok pp_code "float"
167
+
168
+
let err_exp_digit d =
169
+
err_exp_while d pp_code "decimal digit" pp_code "number" pp_quchar d.u
170
+
171
+
(* Errors for strings *)
172
+
173
+
let err_exp_hex_digit d =
174
+
err_exp_while d pp_code "hex digit" pp_code "character escape" pp_quchar d.u
175
+
176
+
let err_exp_lo_surrogate d u =
177
+
err_exp_while d pp_code "low surrogate" pp_code "character escape" pp_quchar u
178
+
179
+
let err_unpaired_lo_surrogate d u =
180
+
err_here d "Unpaired low surrogate %a in %a" pp_quchar u pp_code "string"
181
+
182
+
let err_unpaired_hi_surrogate d u =
183
+
err_here d "Unpaired high surrogate %a in %a" pp_quchar u pp_code "string"
184
+
185
+
let err_exp_esc ~first_byte ~first_line d u =
186
+
err_to_here ~first_byte ~first_line d "Expected %a while parsing %a found %a"
187
+
pp_code "escape character" pp_code "escape" pp_quchar u
188
+
189
+
let err_unclosed_string ~first_byte ~first_line d =
190
+
err_to_here ~first_byte ~first_line d "Unclosed %a" pp_code "string"
191
+
192
+
let err_illegal_ctrl_char ~first_byte ~first_line d =
193
+
err_to_here ~first_byte ~first_line d "Illegal control character %a in %a"
194
+
pp_quchar d.u pp_code "string"
195
+
196
+
(* Errors for arrays *)
197
+
198
+
let err_exp_comma_or_eoa d ~fnd =
199
+
err_here d "Expected %a or %a after %a but found %a" pp_code "," pp_code "]"
200
+
pp_code "array element" pp_quchar fnd
201
+
202
+
let err_unclosed_array d = err_here d "Unclosed %a" pp_code "array"
203
+
204
+
let err_exp_comma_or_eoo d =
205
+
err_here d "Expected %a or %a after %a but found: %a" pp_code "," pp_code "}"
206
+
pp_code "object member" pp_quchar d.u
207
+
208
+
(* Errors for objects *)
209
+
210
+
let err_exp_mem d =
211
+
err_here d "Expected %a but found %a" pp_code "object member" pp_quchar d.u
212
+
213
+
let err_exp_mem_or_eoo d =
214
+
err_here d "Expected: %a or %a but found %a" pp_code "object member" pp_code
215
+
"}" pp_quchar d.u
216
+
217
+
let err_exp_colon d =
218
+
err_here d "Expected %a after %a but found %a" pp_code ":" pp_code
219
+
"member name" pp_quchar d.u
220
+
221
+
let err_unclosed_object d (map : ('o, 'o) Json.Repr.object_map) =
222
+
err_here d "Unclosed %a" Json.Repr.pp_kind
223
+
(Json.Repr.object_map_kinded_sort map)
224
+
225
+
(* Decode next character in d.u *)
226
+
227
+
let[@inline] is_eoslice d = d.i_next > d.i_max
228
+
let[@inline] is_eod d = d.i_max = -1 (* Only happens on Slice.eod *)
229
+
let[@inline] available d = d.i_max - d.i_next + 1
230
+
231
+
let[@inline] set_slice d slice =
232
+
d.i <- Bytes.Slice.bytes slice;
233
+
d.i_next <- Bytes.Slice.first slice;
234
+
d.i_max <- d.i_next + Bytes.Slice.length slice - 1
235
+
236
+
let rec setup_overlap d start need =
237
+
match need with
238
+
| 0 ->
239
+
let slice =
240
+
match available d with
241
+
| 0 -> Bytes.Reader.read d.reader
242
+
| length -> Bytes.Slice.make d.i ~first:d.i_next ~length
243
+
in
244
+
d.i <- d.overlap;
245
+
d.i_next <- 0;
246
+
d.i_max <- start;
247
+
slice
248
+
| need ->
249
+
if is_eoslice d then set_slice d (Bytes.Reader.read d.reader);
250
+
if is_eod d then (
251
+
d.byte_count <- d.byte_count - start;
252
+
err_malformed_utf_8 d);
253
+
let available = available d in
254
+
let take = Int.min need available in
255
+
for i = 0 to take - 1 do
256
+
Bytes.set d.overlap (start + i) (Bytes.get d.i (d.i_next + i))
257
+
done;
258
+
d.i_next <- d.i_next + take;
259
+
d.byte_count <- d.byte_count + take;
260
+
setup_overlap d (start + take) (need - take)
261
+
262
+
let rec nextc d =
263
+
let a = available d in
264
+
if a <= 0 then
265
+
if is_eod d then d.u <- eot
266
+
else (
267
+
set_slice d (Bytes.Reader.read d.reader);
268
+
nextc d)
269
+
else
270
+
let b = Bytes.get d.i d.i_next in
271
+
if a < uchar_max_utf_8_byte_length && a < uchar_utf_8_byte_decode_length b
272
+
then begin
273
+
let s = setup_overlap d 0 (uchar_utf_8_byte_decode_length b) in
274
+
nextc d;
275
+
set_slice d s
276
+
end
277
+
else
278
+
d.u <-
279
+
(match b with
280
+
| ('\x00' .. '\x09' | '\x0B' | '\x0E' .. '\x7F') as u ->
281
+
(* ASCII fast path *)
282
+
d.i_next <- d.i_next + 1;
283
+
d.byte_count <- d.byte_count + 1;
284
+
Char.code u
285
+
| '\x0D' (* CR *) ->
286
+
d.i_next <- d.i_next + 1;
287
+
d.byte_count <- d.byte_count + 1;
288
+
d.line_start <- d.byte_count;
289
+
d.line <- d.line + 1;
290
+
0x000D
291
+
| '\x0A' (* LF *) ->
292
+
d.i_next <- d.i_next + 1;
293
+
d.byte_count <- d.byte_count + 1;
294
+
d.line_start <- d.byte_count;
295
+
if d.u <> 0x000D then d.line <- d.line + 1;
296
+
0x000A
297
+
| _ ->
298
+
let udec = Bytes.get_utf_8_uchar d.i d.i_next in
299
+
if not (Uchar.utf_decode_is_valid udec) then err_malformed_utf_8 d
300
+
else
301
+
let u = Uchar.to_int (Uchar.utf_decode_uchar udec) in
302
+
let ulen = Uchar.utf_decode_length udec in
303
+
d.i_next <- d.i_next + ulen;
304
+
d.byte_count <- d.byte_count + ulen;
305
+
u)
306
+
307
+
(* Decoder tokenizer *)
308
+
309
+
let[@inline] token_clear d = Buffer.clear d.token
310
+
311
+
let[@inline] token_pop d =
312
+
let t = Buffer.contents d.token in
313
+
token_clear d;
314
+
t
315
+
316
+
let[@inline] token_add d u =
317
+
if u <= 0x7F then Buffer.add_char d.token (Char.unsafe_chr u)
318
+
else Buffer.add_utf_8_uchar d.token (Uchar.unsafe_of_int u)
319
+
320
+
let[@inline] accept d =
321
+
token_add d d.u;
322
+
nextc d
323
+
324
+
let token_pop_float d ~meta =
325
+
let token = token_pop d in
326
+
match float_of_string_opt token with
327
+
| Some f -> f
328
+
| None -> err_float_parse meta token (* likely [assert false] *)
329
+
330
+
(* Decoder layout and position tracking *)
331
+
332
+
let[@inline] ws_pop d =
333
+
if not d.layout then ""
334
+
else
335
+
let t = Buffer.contents d.ws in
336
+
Buffer.clear d.ws;
337
+
t
338
+
339
+
let textloc_to_current ~first_byte ~first_line d =
340
+
if not d.locs then Json.Textloc.none
341
+
else
342
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
343
+
Json.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
344
+
~last_line
345
+
346
+
let textloc_prev_ascii_char ~first_byte ~first_line d =
347
+
(* N.B. when we call that the line doesn't move and the char was on
348
+
a single byte *)
349
+
if not d.locs then Json.Textloc.none
350
+
else
351
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
352
+
let last_byte = last_byte - 1 in
353
+
Json.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
354
+
~last_line
355
+
356
+
let meta_make d ?ws_before ?ws_after textloc =
357
+
if (not d.locs) && not d.layout then d.meta_none
358
+
else Json.Meta.make ?ws_before ?ws_after textloc
359
+
360
+
(* Decoding *)
361
+
362
+
let false_uchars = [| 0x0066; 0x0061; 0x006C; 0x0073; 0x0065 |]
363
+
let true_uchars = [| 0x0074; 0x0072; 0x0075; 0x0065 |]
364
+
let null_uchars = [| 0x006E; 0x0075; 0x006C; 0x006C |]
365
+
let ascii_str us = String.init (Array.length us) (fun i -> Char.chr us.(i))
366
+
367
+
let[@inline] is_ws u =
368
+
if u > 0x20 then false
369
+
else
370
+
match Char.unsafe_chr u with ' ' | '\t' | '\r' | '\n' -> true | _ -> false
371
+
372
+
let[@inline] read_ws d =
373
+
while is_ws d.u do
374
+
if d.layout then Buffer.add_char d.ws (Char.unsafe_chr d.u);
375
+
nextc d
376
+
done
377
+
378
+
let read_json_const d const =
379
+
(* First character was checked. *)
380
+
let ws_before = ws_pop d in
381
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
382
+
for i = 1 to Array.length const - 1 do
383
+
nextc d;
384
+
if not (Int.equal d.u const.(i)) then
385
+
err_exp_in_const ~first_byte ~first_line d ~exp:const.(i) ~fnd:d.u
386
+
~const:(ascii_str const)
387
+
done;
388
+
let textloc = textloc_to_current d ~first_byte ~first_line in
389
+
let ws_after =
390
+
nextc d;
391
+
read_ws d;
392
+
ws_pop d
393
+
in
394
+
meta_make d ~ws_before ~ws_after textloc
395
+
396
+
let[@inline] read_json_false d = read_json_const d false_uchars
397
+
let[@inline] read_json_true d = read_json_const d true_uchars
398
+
let[@inline] read_json_null d = read_json_const d null_uchars
399
+
400
+
let read_json_number d =
401
+
(* [is_number_start d.u] = true *)
402
+
let[@inline] read_digits d =
403
+
while is_digit d.u do
404
+
accept d
405
+
done
406
+
in
407
+
let[@inline] read_int d =
408
+
match d.u with
409
+
| 0x0030 (* 0 *) -> accept d
410
+
| u when is_digit u ->
411
+
accept d;
412
+
read_digits d
413
+
| u -> err_exp_digit d
414
+
in
415
+
let[@inline] read_opt_frac d =
416
+
match d.u with
417
+
| 0x002E (* . *) ->
418
+
accept d;
419
+
if is_digit d.u then read_digits d else err_exp_digit d
420
+
| _ -> ()
421
+
in
422
+
let[@inline] read_opt_exp d =
423
+
match d.u with
424
+
| 0x0065 (* e *) | 0x0045 (* E *) ->
425
+
token_add d d.u;
426
+
nextc d;
427
+
(match d.u with
428
+
| 0x002D (* - *) | 0x002B (* + *) ->
429
+
token_add d d.u;
430
+
nextc d
431
+
| _ -> ());
432
+
if is_digit d.u then read_digits d else err_exp_digit d
433
+
| _ -> ()
434
+
in
435
+
let first_byte = get_last_byte d in
436
+
let first_line = get_line_pos d in
437
+
let ws_before = ws_pop d in
438
+
token_clear d;
439
+
if d.u = 0x002D (* - *) then accept d;
440
+
read_int d;
441
+
read_opt_frac d;
442
+
read_opt_exp d;
443
+
let textloc = textloc_prev_ascii_char d ~first_byte ~first_line in
444
+
let ws_after =
445
+
read_ws d;
446
+
ws_pop d
447
+
in
448
+
meta_make d ~ws_before ~ws_after textloc
449
+
450
+
let read_json_string d =
451
+
(* d.u is 0x0022 *)
452
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
453
+
let rec read_uescape d hi uc count =
454
+
if count > 0 then
455
+
match d.u with
456
+
| u when 0x0030 <= u && u <= 0x0039 ->
457
+
nextc d;
458
+
read_uescape d hi ((uc * 16) + u - 0x30) (count - 1)
459
+
| u when 0x0041 <= u && u <= 0x0046 ->
460
+
nextc d;
461
+
read_uescape d hi ((uc * 16) + u - 0x37) (count - 1)
462
+
| u when 0x0061 <= u && u <= 0x0066 ->
463
+
nextc d;
464
+
read_uescape d hi ((uc * 16) + u - 0x57) (count - 1)
465
+
| u -> err_exp_hex_digit d
466
+
else
467
+
match hi with
468
+
| Some hi ->
469
+
(* combine high and low surrogate. *)
470
+
if not (is_lo_surrogate uc) then err_exp_lo_surrogate d uc
471
+
else
472
+
let u = (((hi land 0x3FF) lsl 10) lor (uc land 0x3FF)) + 0x10000 in
473
+
token_add d u
474
+
| None ->
475
+
if not (is_surrogate uc) then token_add d uc
476
+
else if uc > 0xDBFF then err_unpaired_lo_surrogate d uc
477
+
else if d.u <> 0x005C (* \ *) then err_unpaired_hi_surrogate d uc
478
+
else (
479
+
nextc d;
480
+
if d.u <> 0x0075 (* u *) then err_unpaired_hi_surrogate d uc
481
+
else (
482
+
nextc d;
483
+
read_uescape d (Some uc) 0 4))
484
+
in
485
+
let read_escape d =
486
+
match d.u with
487
+
| 0x0022 (* DQUOTE *) | 0x005C (* \ *) | 0x002F (* / *) -> accept d
488
+
| 0x0062 (* b *) ->
489
+
token_add d 0x0008 (* backspace *);
490
+
nextc d
491
+
| 0x0066 (* f *) ->
492
+
token_add d 0x000C (* form feed *);
493
+
nextc d
494
+
| 0x006E (* n *) ->
495
+
token_add d 0x000A (* line feed *);
496
+
nextc d
497
+
| 0x0072 (* r *) ->
498
+
token_add d 0x000D (* carriage return *);
499
+
nextc d
500
+
| 0x0074 (* t *) ->
501
+
token_add d 0x0009 (* tab *);
502
+
nextc d
503
+
| 0x0075 (* u *) ->
504
+
nextc d;
505
+
read_uescape d None 0 4
506
+
| u -> err_exp_esc ~first_byte ~first_line d u
507
+
in
508
+
let rec loop d =
509
+
match d.u with
510
+
| 0x005C (* \ *) ->
511
+
nextc d;
512
+
read_escape d;
513
+
loop d
514
+
| 0x0022 (* DQUOTE *) -> ()
515
+
| u when u = eot -> err_unclosed_string ~first_byte ~first_line d
516
+
| u when 0x0000 <= u && u <= 0x001F ->
517
+
err_illegal_ctrl_char ~first_byte ~first_line d
518
+
| u ->
519
+
accept d;
520
+
loop d
521
+
in
522
+
let ws_before = ws_pop d in
523
+
nextc d;
524
+
token_clear d;
525
+
loop d;
526
+
let textloc = textloc_to_current d ~first_byte ~first_line in
527
+
let ws_after =
528
+
nextc d;
529
+
read_ws d;
530
+
ws_pop d
531
+
in
532
+
meta_make d ~ws_before ~ws_after textloc
533
+
534
+
let read_json_name d =
535
+
let meta = read_json_string d in
536
+
if d.u = 0x003A (* : *) then (
537
+
nextc d;
538
+
meta)
539
+
else err_exp_colon d
540
+
541
+
let read_json_mem_sep d =
542
+
if d.u = 0x007D (* } *) then ()
543
+
else if d.u = 0x002C (* , *) then (
544
+
nextc d;
545
+
read_ws d;
546
+
if d.u <> 0x0022 then err_exp_mem d)
547
+
else err_exp_comma_or_eoo d
548
+
549
+
let rec decode : type a. decoder -> a t -> a =
550
+
fun d t ->
551
+
match
552
+
read_ws d;
553
+
t
554
+
with
555
+
| Null map -> (
556
+
match d.u with
557
+
| 0x006E (* n *) -> map.dec (read_json_null d) ()
558
+
| _ -> type_error d t)
559
+
| Bool map -> (
560
+
match d.u with
561
+
| 0x0066 (* f *) -> map.dec (read_json_false d) false
562
+
| 0x0074 (* t *) -> map.dec (read_json_true d) true
563
+
| _ -> type_error d t)
564
+
| Number map -> (
565
+
match d.u with
566
+
| u when is_number_start u ->
567
+
let meta = read_json_number d in
568
+
map.dec meta (token_pop_float d ~meta)
569
+
| 0x006E (* n *) -> map.dec (read_json_null d) Float.nan
570
+
| _ -> type_error d t)
571
+
| String map -> (
572
+
match d.u with
573
+
| 0x0022 (* DQUOTE *) ->
574
+
let meta = read_json_string d in
575
+
map.dec meta (token_pop d)
576
+
| _ -> type_error d t)
577
+
| Array map -> (
578
+
match d.u with
579
+
| 0x005B (* [ *) -> decode_array d map
580
+
| _ -> type_error d t)
581
+
| Object map -> (
582
+
match d.u with
583
+
| 0x007B (* { *) -> decode_object d map
584
+
| _ -> type_error d t)
585
+
| Map map -> map.dec (decode d map.dom)
586
+
| Any map -> decode_any d t map
587
+
| Rec t -> decode d (Lazy.force t)
588
+
589
+
and decode_array : type a elt b. decoder -> (a, elt, b) array_map -> a =
590
+
fun d map ->
591
+
let ws_before = ws_pop d in
592
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
593
+
let b, len =
594
+
match
595
+
nextc d;
596
+
read_ws d;
597
+
d.u
598
+
with
599
+
| 0x005D (* ] *) -> (map.dec_empty (), 0)
600
+
| _ -> (
601
+
let b = ref (map.dec_empty ()) in
602
+
let i = ref 0 in
603
+
let next = ref true in
604
+
try
605
+
while !next do
606
+
begin
607
+
let first_byte = get_last_byte d
608
+
and first_line = get_line_pos d in
609
+
try
610
+
if map.dec_skip !i !b then decode d (of_t Json.ignore)
611
+
else b := map.dec_add !i (decode d map.elt) !b
612
+
with Json.Error e ->
613
+
let imeta = error_meta_to_current ~first_byte ~first_line d in
614
+
Json.Repr.error_push_array (error_meta d) map (!i, imeta) e
615
+
end;
616
+
incr i;
617
+
match
618
+
read_ws d;
619
+
d.u
620
+
with
621
+
| 0x005D (* ] *) -> next := false
622
+
| 0x002C (* , *) ->
623
+
nextc d;
624
+
read_ws d
625
+
| u when u = eot -> err_unclosed_array d
626
+
| fnd -> err_exp_comma_or_eoa d ~fnd
627
+
done;
628
+
(!b, !i)
629
+
with Json.Error e ->
630
+
Json.Error.adjust_context ~first_byte ~first_line e)
631
+
in
632
+
let textloc = textloc_to_current d ~first_byte ~first_line in
633
+
let ws_after =
634
+
nextc d;
635
+
read_ws d;
636
+
ws_pop d
637
+
in
638
+
let meta = meta_make d ~ws_before ~ws_after textloc in
639
+
map.dec_finish meta len b
640
+
641
+
and decode_object : type a. decoder -> (a, a) object_map -> a =
642
+
fun d map ->
643
+
let ws_before = ws_pop d in
644
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
645
+
let dict =
646
+
try
647
+
nextc d;
648
+
read_ws d;
649
+
decode_object_map d map (Unknown_mems None) String_map.empty
650
+
String_map.empty [] Dict.empty
651
+
with
652
+
| Json.Error (ctx, meta, k) when Json.Error.Context.is_empty ctx ->
653
+
let meta =
654
+
(* This is for when Json.Repr.finish_object_decode raises. *)
655
+
if Json.Textloc.is_none (Json.Meta.textloc meta) then
656
+
error_meta_to_current d ~first_byte ~first_line
657
+
else meta
658
+
in
659
+
Json.Error.raise ctx meta k
660
+
| Json.Error e -> Json.Error.adjust_context ~first_byte ~first_line e
661
+
in
662
+
let textloc = textloc_to_current d ~first_byte ~first_line in
663
+
let ws_after =
664
+
nextc d;
665
+
read_ws d;
666
+
ws_pop d
667
+
in
668
+
let meta = meta_make d ~ws_before ~ws_after textloc in
669
+
let dict = Dict.add Json.Repr.object_meta_arg meta dict in
670
+
Json.Repr.apply_dict map.dec dict
671
+
672
+
and decode_object_delayed : type o.
673
+
decoder ->
674
+
(o, o) object_map ->
675
+
mem_dec String_map.t ->
676
+
mem_dec String_map.t ->
677
+
Json.object' ->
678
+
Dict.t ->
679
+
mem_dec String_map.t * Json.object' * Dict.t =
680
+
fun d map mem_miss mem_decs delay dict ->
681
+
let rec loop d map mem_miss mem_decs rem_delay dict = function
682
+
| [] -> (mem_miss, rem_delay, dict)
683
+
| ((((name, meta) as nm), v) as mem) :: delay -> (
684
+
match String_map.find_opt name mem_decs with
685
+
| None -> loop d map mem_miss mem_decs (mem :: rem_delay) dict delay
686
+
| Some (Mem_dec m) ->
687
+
let dict =
688
+
try
689
+
let t = Json.Repr.unsafe_to_t m.type' in
690
+
let v =
691
+
match Json.Json.decode' t v with
692
+
| Ok v -> v
693
+
| Error e -> raise_notrace (Json.Error e)
694
+
in
695
+
Dict.add m.id v dict
696
+
with Json.Error e ->
697
+
Json.Repr.error_push_object (error_meta d) map nm e
698
+
in
699
+
let mem_miss = String_map.remove name mem_miss in
700
+
loop d map mem_miss mem_decs rem_delay dict delay)
701
+
in
702
+
loop d map mem_miss mem_decs [] dict delay
703
+
704
+
and decode_object_map : type o.
705
+
decoder ->
706
+
(o, o) object_map ->
707
+
unknown_mems_option ->
708
+
mem_dec String_map.t ->
709
+
mem_dec String_map.t ->
710
+
Json.object' ->
711
+
Dict.t ->
712
+
Dict.t =
713
+
fun d map umems mem_miss mem_decs delay dict ->
714
+
let u n _ _ = assert false in
715
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
716
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
717
+
match map.shape with
718
+
| Object_cases (umems', cases) ->
719
+
let umems' = Unknown_mems umems' in
720
+
let umems, dict =
721
+
Json.Repr.override_unknown_mems ~by:umems umems' dict
722
+
in
723
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
724
+
| Object_basic umems' -> (
725
+
let mem_miss, delay, dict =
726
+
decode_object_delayed d map mem_miss mem_decs delay dict
727
+
in
728
+
let umems' = Unknown_mems (Some umems') in
729
+
let umems, dict =
730
+
Json.Repr.override_unknown_mems ~by:umems umems' dict
731
+
in
732
+
match umems with
733
+
| Unknown_mems (Some Unknown_skip | None) ->
734
+
decode_object_basic d map Unknown_skip () mem_miss mem_decs dict
735
+
| Unknown_mems (Some (Unknown_error as u)) ->
736
+
if delay = [] then
737
+
decode_object_basic d map u () mem_miss mem_decs dict
738
+
else
739
+
let fnd = List.map fst delay in
740
+
Json.Repr.unexpected_mems_error (error_meta d) map ~fnd
741
+
| Unknown_mems (Some (Unknown_keep (umap, _) as u)) ->
742
+
let add_delay umems (((n, meta) as nm), v) =
743
+
try
744
+
let t = Json.Repr.unsafe_to_t umap.mems_type in
745
+
let v =
746
+
match Json.Json.decode' t v with
747
+
| Ok v -> v
748
+
| Error e -> raise_notrace (Json.Error e)
749
+
in
750
+
umap.dec_add meta n v umems
751
+
with Json.Error e ->
752
+
Json.Repr.error_push_object (error_meta d) map nm e
753
+
in
754
+
let umems = List.fold_left add_delay (umap.dec_empty ()) delay in
755
+
decode_object_basic d map u umems mem_miss mem_decs dict)
756
+
757
+
and decode_object_basic : type o p mems builder.
758
+
decoder ->
759
+
(o, o) object_map ->
760
+
(p, mems, builder) unknown_mems ->
761
+
builder ->
762
+
mem_dec String_map.t ->
763
+
mem_dec String_map.t ->
764
+
Dict.t ->
765
+
Dict.t =
766
+
fun d map u umap mem_miss mem_decs dict ->
767
+
match d.u with
768
+
| 0x007D (* } *) ->
769
+
let meta =
770
+
d.meta_none
771
+
(* we add a correct one in decode_object *)
772
+
in
773
+
Json.Repr.finish_object_decode map meta u umap mem_miss dict
774
+
| 0x0022 ->
775
+
let meta = read_json_name d in
776
+
let name = token_pop d in
777
+
begin match String_map.find_opt name mem_decs with
778
+
| Some (Mem_dec mem) ->
779
+
let mem_miss = String_map.remove name mem_miss in
780
+
let dict =
781
+
try Dict.add mem.id (decode d mem.type') dict
782
+
with Json.Error e ->
783
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
784
+
in
785
+
read_json_mem_sep d;
786
+
decode_object_basic d map u umap mem_miss mem_decs dict
787
+
| None -> (
788
+
match u with
789
+
| Unknown_skip ->
790
+
let () =
791
+
try decode d (Json.Repr.of_t Json.ignore)
792
+
with Json.Error e ->
793
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
794
+
in
795
+
read_json_mem_sep d;
796
+
decode_object_basic d map u umap mem_miss mem_decs dict
797
+
| Unknown_error ->
798
+
let fnd = [ (name, meta) ] in
799
+
Json.Repr.unexpected_mems_error (error_meta d) map ~fnd
800
+
| Unknown_keep (umap', _) ->
801
+
let umap =
802
+
try umap'.dec_add meta name (decode d umap'.mems_type) umap
803
+
with Json.Error e ->
804
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
805
+
in
806
+
read_json_mem_sep d;
807
+
decode_object_basic d map u umap mem_miss mem_decs dict)
808
+
end
809
+
| u when u = eot -> err_unclosed_object d map
810
+
| fnd -> err_exp_mem_or_eoo d
811
+
812
+
and decode_object_case : type o cases tag.
813
+
decoder ->
814
+
(o, o) object_map ->
815
+
unknown_mems_option ->
816
+
(o, cases, tag) object_cases ->
817
+
mem_dec String_map.t ->
818
+
mem_dec String_map.t ->
819
+
Json.object' ->
820
+
Dict.t ->
821
+
Dict.t =
822
+
fun d map umems cases mem_miss mem_decs delay dict ->
823
+
let decode_case_tag ~sep map umems cases mem_miss mem_decs nmeta tag delay =
824
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
825
+
match List.find_opt eq_tag cases.cases with
826
+
| None -> (
827
+
try Json.Repr.unexpected_case_tag_error (error_meta d) map cases tag
828
+
with Json.Error e ->
829
+
Json.Repr.error_push_object (error_meta d) map
830
+
(cases.tag.name, nmeta) e)
831
+
| Some (Case case) ->
832
+
if sep then read_json_mem_sep d;
833
+
let dict =
834
+
decode_object_map d case.object_map umems mem_miss mem_decs delay dict
835
+
in
836
+
Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
837
+
in
838
+
match d.u with
839
+
| 0x007D (* } *) -> (
840
+
match cases.tag.dec_absent with
841
+
| Some tag ->
842
+
decode_case_tag ~sep:false map umems cases mem_miss mem_decs
843
+
d.meta_none tag delay
844
+
| None ->
845
+
let fnd = List.map (fun ((n, _), _) -> n) delay in
846
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
847
+
Json.Repr.missing_mems_error (error_meta d) map ~exp ~fnd)
848
+
| 0x0022 ->
849
+
let meta = read_json_name d in
850
+
let name = token_pop d in
851
+
if String.equal name cases.tag.name then
852
+
let tag =
853
+
try decode d cases.tag.type'
854
+
with Json.Error e ->
855
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
856
+
in
857
+
decode_case_tag ~sep:true map umems cases mem_miss mem_decs meta tag
858
+
delay
859
+
else
860
+
begin match String_map.find_opt name mem_decs with
861
+
| Some (Mem_dec mem) ->
862
+
let mem_miss = String_map.remove name mem_miss in
863
+
let dict =
864
+
try Dict.add mem.id (decode d mem.type') dict
865
+
with Json.Error e ->
866
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
867
+
in
868
+
read_json_mem_sep d;
869
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
870
+
| None ->
871
+
(* Because JSON can be out of order we don't know how to decode
872
+
this yet. Generic decode *)
873
+
let v =
874
+
try decode d (Json.Repr.of_t Json.json)
875
+
with Json.Error e ->
876
+
Json.Repr.error_push_object (error_meta d) map (name, meta) e
877
+
in
878
+
let delay = ((name, meta), v) :: delay in
879
+
read_json_mem_sep d;
880
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
881
+
end
882
+
| u when u = eot -> err_unclosed_object d map
883
+
| fnd -> err_exp_mem_or_eoo d
884
+
885
+
and decode_any : type a. decoder -> a t -> a any_map -> a =
886
+
fun d t map ->
887
+
let case d t map =
888
+
match map with None -> type_error d t | Some t -> decode d t
889
+
in
890
+
match d.u with
891
+
| 0x006E (* n *) -> case d t map.dec_null
892
+
| 0x0066 (* f *) | 0x0074 (* t *) -> case d t map.dec_bool
893
+
| 0x0022 (* DQUOTE *) -> case d t map.dec_string
894
+
| 0x005B (* [ *) -> case d t map.dec_array
895
+
| 0x007B (* { *) -> case d t map.dec_object
896
+
| u when is_number_start u -> case d t map.dec_number
897
+
| _ -> err_not_json_value d
898
+
899
+
let decode' ?layout ?locs ?file t reader =
900
+
try
901
+
let d = make_decoder ?layout ?locs ?file reader in
902
+
let v =
903
+
nextc d;
904
+
decode d (Json.Repr.of_t t)
905
+
in
906
+
if d.u <> eot then err_exp_eot d else Ok v
907
+
with Json.Error e -> Error e
908
+
909
+
let decode ?layout ?locs ?file t reader =
910
+
Result.map_error Json.Error.to_string (decode' ?layout ?locs ?file t reader)
911
+
912
+
let decode_string' ?layout ?locs ?file t s =
913
+
decode' ?layout ?locs ?file t (Bytes.Reader.of_string s)
914
+
915
+
let decode_string ?layout ?locs ?file t s =
916
+
decode ?layout ?locs ?file t (Bytes.Reader.of_string s)
917
+
918
+
(* Encoding *)
919
+
920
+
type encoder = {
921
+
writer : Bytes.Writer.t; (* Destination of bytes. *)
922
+
o : Bytes.t; (* Buffer for slices. *)
923
+
o_max : int; (* Max index in [o]. *)
924
+
mutable o_next : int; (* Next writable index in [o]. *)
925
+
format : Json.format;
926
+
number_format : string;
927
+
}
928
+
929
+
let make_encoder ?buf ?(format = Json.Minify)
930
+
?(number_format = Json.default_number_format) writer =
931
+
let o =
932
+
match buf with
933
+
| Some buf -> buf
934
+
| None -> Bytes.create (Bytes.Writer.slice_length writer)
935
+
in
936
+
let len = Bytes.length o in
937
+
let number_format = string_of_format number_format in
938
+
let o_max = len - 1 and o_next = 0 in
939
+
{ writer; o; o_max; o_next; format; number_format }
940
+
941
+
let[@inline] rem_len e = e.o_max - e.o_next + 1
942
+
943
+
let flush e =
944
+
Bytes.Writer.write e.writer (Bytes.Slice.make e.o ~first:0 ~length:e.o_next);
945
+
e.o_next <- 0
946
+
947
+
let write_eot ~eod e =
948
+
flush e;
949
+
if eod then Bytes.Writer.write_eod e.writer
950
+
951
+
let write_char e c =
952
+
if e.o_next > e.o_max then flush e;
953
+
Stdlib.Bytes.set e.o e.o_next c;
954
+
e.o_next <- e.o_next + 1
955
+
956
+
let rec write_substring e s first length =
957
+
if length = 0 then ()
958
+
else
959
+
let len = Int.min (rem_len e) length in
960
+
if len = 0 then (
961
+
flush e;
962
+
write_substring e s first length)
963
+
else begin
964
+
Bytes.blit_string s first e.o e.o_next len;
965
+
e.o_next <- e.o_next + len;
966
+
write_substring e s (first + len) (length - len)
967
+
end
968
+
969
+
let write_bytes e s = write_substring e s 0 (String.length s)
970
+
let write_sep e = write_char e ','
971
+
972
+
let write_indent e ~nest =
973
+
for i = 1 to nest do
974
+
write_char e ' ';
975
+
write_char e ' '
976
+
done
977
+
978
+
let write_ws_before e m = write_bytes e (Json.Meta.ws_before m)
979
+
let write_ws_after e m = write_bytes e (Json.Meta.ws_after m)
980
+
let write_json_null e = write_bytes e "null"
981
+
let write_json_bool e b = write_bytes e (if b then "true" else "false")
982
+
983
+
(* XXX we bypass the printf machinery as it costs quite quite a bit.
984
+
Would be even better if we could format directly to a bytes values
985
+
rather than allocating a string per number. *)
986
+
external format_float : string -> float -> string = "caml_format_float"
987
+
988
+
let write_json_number e f =
989
+
if Float.is_finite f then write_bytes e (format_float e.number_format f)
990
+
else write_json_null e
991
+
992
+
let write_json_string e s =
993
+
let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in
994
+
let len = String.length s in
995
+
let flush e start i max =
996
+
if start <= max then write_substring e s start (i - start)
997
+
in
998
+
let rec loop start i max =
999
+
if i > max then flush e start i max
1000
+
else
1001
+
let next = i + 1 in
1002
+
match String.get s i with
1003
+
| '\"' ->
1004
+
flush e start i max;
1005
+
write_bytes e "\\\"";
1006
+
loop next next max
1007
+
| '\\' ->
1008
+
flush e start i max;
1009
+
write_bytes e "\\\\";
1010
+
loop next next max
1011
+
| '\n' ->
1012
+
flush e start i max;
1013
+
write_bytes e "\\n";
1014
+
loop next next max
1015
+
| '\r' ->
1016
+
flush e start i max;
1017
+
write_bytes e "\\r";
1018
+
loop next next max
1019
+
| '\t' ->
1020
+
flush e start i max;
1021
+
write_bytes e "\\t";
1022
+
loop next next max
1023
+
| c when is_control c ->
1024
+
flush e start i max;
1025
+
write_bytes e "\\u";
1026
+
write_bytes e (Printf.sprintf "%04X" (Char.code c));
1027
+
loop next next max
1028
+
| c -> loop start next max
1029
+
in
1030
+
write_char e '"';
1031
+
loop 0 0 (len - 1);
1032
+
write_char e '"'
1033
+
1034
+
let encode_null (map : ('a, 'b) Json.Repr.base_map) e v =
1035
+
let () = map.enc v in
1036
+
match e.format with
1037
+
| Json.Minify | Json.Indent -> write_json_null e
1038
+
| Json.Layout ->
1039
+
let meta = map.enc_meta v in
1040
+
write_ws_before e meta;
1041
+
write_json_null e;
1042
+
write_ws_after e meta
1043
+
1044
+
let encode_bool (map : ('a, 'b) Json.Repr.base_map) e v =
1045
+
let b = map.enc v in
1046
+
match e.format with
1047
+
| Json.Minify | Json.Indent -> write_json_bool e b
1048
+
| Json.Layout ->
1049
+
let meta = map.enc_meta v in
1050
+
write_ws_before e meta;
1051
+
write_json_bool e b;
1052
+
write_ws_after e meta
1053
+
1054
+
let encode_number (map : ('a, 'b) Json.Repr.base_map) e v =
1055
+
let n = map.enc v in
1056
+
match e.format with
1057
+
| Json.Minify | Json.Indent -> write_json_number e n
1058
+
| Json.Layout ->
1059
+
let meta = map.enc_meta v in
1060
+
write_ws_before e meta;
1061
+
write_json_number e n;
1062
+
write_ws_after e meta
1063
+
1064
+
let encode_string (map : ('a, 'b) Json.Repr.base_map) e v =
1065
+
let s = map.enc v in
1066
+
match e.format with
1067
+
| Json.Minify | Json.Indent -> write_json_string e s
1068
+
| Json.Layout ->
1069
+
let meta = map.enc_meta v in
1070
+
write_ws_before e meta;
1071
+
write_json_string e s;
1072
+
write_ws_after e meta
1073
+
1074
+
let encode_mem_indent ~nest e =
1075
+
write_char e '\n';
1076
+
write_indent e ~nest
1077
+
1078
+
let encode_mem_name e meta n =
1079
+
match e.format with
1080
+
| Json.Minify ->
1081
+
write_json_string e n;
1082
+
write_char e ':'
1083
+
| Json.Indent ->
1084
+
write_json_string e n;
1085
+
write_bytes e ": "
1086
+
| Json.Layout ->
1087
+
write_ws_before e meta;
1088
+
write_json_string e n;
1089
+
write_ws_after e meta;
1090
+
write_char e ':'
1091
+
1092
+
let rec encode : type a. nest:int -> a Json.Repr.t -> encoder -> a -> unit =
1093
+
fun ~nest t e v ->
1094
+
match t with
1095
+
| Null map -> encode_null map e v
1096
+
| Bool map -> encode_bool map e v
1097
+
| Number map -> encode_number map e v
1098
+
| String map -> encode_string map e v
1099
+
| Array map -> encode_array ~nest map e v
1100
+
| Object map -> encode_object ~nest map e v
1101
+
| Any map -> encode ~nest (map.enc v) e v
1102
+
| Map map -> encode ~nest map.dom e (map.enc v)
1103
+
| Rec t -> encode ~nest (Lazy.force t) e v
1104
+
1105
+
and encode_array : type a elt b.
1106
+
nest:int -> (a, elt, b) Json.Repr.array_map -> encoder -> a -> unit =
1107
+
fun ~nest map e v ->
1108
+
let encode_element ~nest map e i v =
1109
+
if i <> 0 then write_sep e;
1110
+
try
1111
+
encode ~nest map.elt e v;
1112
+
e
1113
+
with Json.Error e ->
1114
+
Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e
1115
+
in
1116
+
match e.format with
1117
+
| Json.Minify ->
1118
+
write_char e '[';
1119
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1120
+
write_char e ']'
1121
+
| Json.Layout ->
1122
+
let meta = map.enc_meta v in
1123
+
write_ws_before e meta;
1124
+
write_char e '[';
1125
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1126
+
write_char e ']';
1127
+
write_ws_after e meta
1128
+
| Json.Indent ->
1129
+
let encode_element ~nest map e i v =
1130
+
if i <> 0 then write_sep e;
1131
+
write_char e '\n';
1132
+
write_indent e ~nest;
1133
+
try
1134
+
encode ~nest map.elt e v;
1135
+
e
1136
+
with Json.Error e ->
1137
+
Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e
1138
+
in
1139
+
let array_not_empty e =
1140
+
e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[')
1141
+
in
1142
+
write_char e '[';
1143
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
1144
+
if array_not_empty e then (
1145
+
write_char e '\n';
1146
+
write_indent e ~nest);
1147
+
write_char e ']'
1148
+
1149
+
and encode_object : type o enc.
1150
+
nest:int -> (o, o) Json.Repr.object_map -> encoder -> o -> unit =
1151
+
fun ~nest map e o ->
1152
+
match e.format with
1153
+
| Json.Minify ->
1154
+
write_char e '{';
1155
+
ignore
1156
+
@@ encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o;
1157
+
write_char e '}'
1158
+
| Json.Layout ->
1159
+
let meta = map.enc_meta o in
1160
+
write_ws_before e meta;
1161
+
write_char e '{';
1162
+
ignore
1163
+
@@ encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o;
1164
+
write_char e '}';
1165
+
write_ws_after e meta
1166
+
| Json.Indent ->
1167
+
write_char e '{';
1168
+
let start =
1169
+
encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o
1170
+
in
1171
+
if not start then (
1172
+
write_char e '\n';
1173
+
write_indent e ~nest);
1174
+
write_char e '}'
1175
+
1176
+
and encode_object_map : type o enc.
1177
+
nest:int ->
1178
+
(o, o) Json.Repr.object_map ->
1179
+
do_unknown:bool ->
1180
+
encoder ->
1181
+
start:bool ->
1182
+
o ->
1183
+
bool =
1184
+
fun ~nest map ~do_unknown e ~start o ->
1185
+
let encode_mem ~nest map e o start (Mem_enc mmap) =
1186
+
try
1187
+
let v = mmap.enc o in
1188
+
if mmap.enc_omit v then start
1189
+
else begin
1190
+
if not start then write_char e ',';
1191
+
if e.format = Json.Indent then encode_mem_indent ~nest e;
1192
+
let meta =
1193
+
(* if e.format = Json.Layout then mmap.enc_name_meta v else *)
1194
+
Json.Meta.none
1195
+
in
1196
+
encode_mem_name e meta mmap.name;
1197
+
encode ~nest mmap.type' e v;
1198
+
false
1199
+
end
1200
+
with Json.Error e ->
1201
+
Json.Repr.error_push_object Json.Meta.none map
1202
+
(mmap.name, Json.Meta.none)
1203
+
e
1204
+
in
1205
+
match map.shape with
1206
+
| Object_basic u ->
1207
+
let start =
1208
+
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
1209
+
in
1210
+
begin match u with
1211
+
| Unknown_keep (umap, enc) when do_unknown ->
1212
+
encode_unknown_mems ~nest map umap e ~start (enc o)
1213
+
| _ -> start
1214
+
end
1215
+
| Object_cases (umap, cases) -> (
1216
+
let (Case_value (case, c)) = cases.enc_case (cases.enc o) in
1217
+
let start =
1218
+
if cases.tag.enc_omit case.tag then start
1219
+
else encode_mem ~nest map e case.tag start (Mem_enc cases.tag)
1220
+
in
1221
+
let start =
1222
+
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
1223
+
in
1224
+
match umap with
1225
+
| Some (Unknown_keep (umap, enc)) ->
1226
+
let start =
1227
+
encode_object_map ~nest case.object_map ~do_unknown:false e ~start c
1228
+
in
1229
+
encode_unknown_mems ~nest map umap e ~start (enc o)
1230
+
| _ -> encode_object_map ~nest case.object_map ~do_unknown e ~start c)
1231
+
1232
+
and encode_unknown_mems : type o dec mems a builder.
1233
+
nest:int ->
1234
+
(o, o) object_map ->
1235
+
(mems, a, builder) mems_map ->
1236
+
encoder ->
1237
+
start:bool ->
1238
+
mems ->
1239
+
bool =
1240
+
fun ~nest map umap e ~start mems ->
1241
+
let encode_unknown_mem ~nest map umap e meta n v start =
1242
+
try
1243
+
if not start then write_char e ',';
1244
+
if e.format = Json.Indent then encode_mem_indent ~nest e;
1245
+
encode_mem_name e meta n;
1246
+
encode ~nest umap.mems_type e v;
1247
+
false
1248
+
with Json.Error e ->
1249
+
Json.Repr.error_push_object Json.Meta.none map (n, Json.Meta.none) e
1250
+
in
1251
+
umap.enc (encode_unknown_mem ~nest map umap e) mems start
1252
+
1253
+
let encode' ?buf ?format ?number_format t v ~eod w =
1254
+
let e = make_encoder ?buf ?format ?number_format w in
1255
+
let t = Json.Repr.of_t t in
1256
+
try
1257
+
Ok
1258
+
(encode ~nest:0 t e v;
1259
+
write_eot ~eod e)
1260
+
with Json.Error e -> Error e
1261
+
1262
+
let encode ?buf ?format ?number_format t v ~eod w =
1263
+
Result.map_error Json.Error.to_string
1264
+
@@ encode' ?buf ?format ?number_format ~eod t v w
1265
+
1266
+
let encode_string' ?buf ?format ?number_format t v =
1267
+
let b = Buffer.create 255 in
1268
+
let w = Bytes.Writer.of_buffer b in
1269
+
match encode' ?buf ?format ?number_format ~eod:true t v w with
1270
+
| Ok () -> Ok (Buffer.contents b)
1271
+
| Error _ as e -> e
1272
+
1273
+
let encode_string ?buf ?format ?number_format t v =
1274
+
Result.map_error Json.Error.to_string
1275
+
@@ encode_string' ?buf ?format ?number_format t v
1276
+
1277
+
(* Recode *)
1278
+
1279
+
let unsurprising_defaults layout format =
1280
+
match (layout, format) with
1281
+
| Some true, None -> (Some true, Some Json.Layout)
1282
+
| None, (Some Json.Layout as l) -> (Some true, l)
1283
+
| l, f -> (l, f)
1284
+
1285
+
let recode' ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1286
+
let layout, format = unsurprising_defaults layout format in
1287
+
match decode' ?layout ?locs ?file t r with
1288
+
| Error _ as e -> e
1289
+
| Ok v -> encode' ?buf ?format ?number_format t v ~eod w
1290
+
1291
+
let recode ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1292
+
Result.map_error Json.Error.to_string
1293
+
@@ recode' ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod
1294
+
1295
+
let recode_string' ?layout ?locs ?file ?buf ?format ?number_format t s =
1296
+
let layout, format = unsurprising_defaults layout format in
1297
+
match decode_string' ?layout ?locs ?file t s with
1298
+
| Error _ as e -> e
1299
+
| Ok v -> encode_string' ?buf ?format ?number_format t v
1300
+
1301
+
let recode_string ?layout ?locs ?file ?buf ?format ?number_format t s =
1302
+
Result.map_error Json.Error.to_string
1303
+
@@ recode_string' ?layout ?locs ?file ?buf ?format ?number_format t s
+188
lib/bytesrw/json_bytesrw.mli
+188
lib/bytesrw/json_bytesrw.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JSON codec.
7
+
8
+
According to {{:https://www.rfc-editor.org/rfc/rfc8259}RFC 8259}.
9
+
10
+
See notes about {{!layout}layout preservation} and behaviour on
11
+
{{!duplicate}duplicate members}.
12
+
13
+
{b Tip.} For maximal performance decode with [~layout:false] and
14
+
[~locs:false], this is the default. Howver using [~locs:true] improves some
15
+
error reports. *)
16
+
17
+
open Bytesrw
18
+
19
+
(** {1:decode Decode} *)
20
+
21
+
val decode :
22
+
?layout:bool ->
23
+
?locs:bool ->
24
+
?file:Json.Textloc.fpath ->
25
+
'a Json.t ->
26
+
Bytes.Reader.t ->
27
+
('a, string) result
28
+
(** [decode t r] decodes a value from [r] according to [t].
29
+
- If [layout] is [true] whitespace is preserved in {!Json.Meta.t} values.
30
+
Defaults to [false].
31
+
- If [locs] is [true] locations are preserved in {!Json.Meta.t} values and
32
+
error messages are precisely located. Defaults to [false].
33
+
- [file] is the file path from which [r] is assumed to read. Defaults to
34
+
{!Json.Textloc.file_none} *)
35
+
36
+
val decode' :
37
+
?layout:bool ->
38
+
?locs:bool ->
39
+
?file:Json.Textloc.fpath ->
40
+
'a Json.t ->
41
+
Bytes.Reader.t ->
42
+
('a, Json.Error.t) result
43
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
44
+
45
+
val decode_string :
46
+
?layout:bool ->
47
+
?locs:bool ->
48
+
?file:Json.Textloc.fpath ->
49
+
'a Json.t ->
50
+
string ->
51
+
('a, string) result
52
+
(** [decode_string] is like {!val-decode} but decodes directly from a string. *)
53
+
54
+
val decode_string' :
55
+
?layout:bool ->
56
+
?locs:bool ->
57
+
?file:Json.Textloc.fpath ->
58
+
'a Json.t ->
59
+
string ->
60
+
('a, Json.Error.t) result
61
+
(** [decode_string'] is like {!val-decode'} but decodes directly from a string.
62
+
*)
63
+
64
+
(** {1:encode Encode} *)
65
+
66
+
val encode :
67
+
?buf:Bytes.t ->
68
+
?format:Json.format ->
69
+
?number_format:Json.number_format ->
70
+
'a Json.t ->
71
+
'a ->
72
+
eod:bool ->
73
+
Bytes.Writer.t ->
74
+
(unit, string) result
75
+
(** [encode t v w] encodes value [v] according to [t] on [w].
76
+
- If [buf] is specified it is used as a buffer for the slices written on
77
+
[w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w].
78
+
- [format] specifies how the JSON should be formatted. Defaults to
79
+
{!Json.Minify}.
80
+
- [number_format] specifies the format string to format numbers. Defaults to
81
+
{!Json.default_number_format}.
82
+
- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be written on
83
+
[w]. *)
84
+
85
+
val encode' :
86
+
?buf:Bytes.t ->
87
+
?format:Json.format ->
88
+
?number_format:Json.number_format ->
89
+
'a Json.t ->
90
+
'a ->
91
+
eod:bool ->
92
+
Bytes.Writer.t ->
93
+
(unit, Json.Error.t) result
94
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
95
+
96
+
val encode_string :
97
+
?buf:Bytes.t ->
98
+
?format:Json.format ->
99
+
?number_format:Json.number_format ->
100
+
'a Json.t ->
101
+
'a ->
102
+
(string, string) result
103
+
(** [encode_string] is like {!val-encode} but writes to a string. *)
104
+
105
+
val encode_string' :
106
+
?buf:Bytes.t ->
107
+
?format:Json.format ->
108
+
?number_format:Json.number_format ->
109
+
'a Json.t ->
110
+
'a ->
111
+
(string, Json.Error.t) result
112
+
(** [encode_string'] is like {!val-encode'} but writes to a string. *)
113
+
114
+
(** {1:recode Recode}
115
+
116
+
The defaults in these functions are those of {!val-decode} and
117
+
{!val-encode}, except if [layout] is [true], [format] defaults to
118
+
[Json.Layout] and vice-versa. *)
119
+
120
+
val recode :
121
+
?layout:bool ->
122
+
?locs:bool ->
123
+
?file:Json.Textloc.fpath ->
124
+
?buf:Bytes.t ->
125
+
?format:Json.format ->
126
+
?number_format:Json.number_format ->
127
+
'a Json.t ->
128
+
Bytes.Reader.t ->
129
+
Bytes.Writer.t ->
130
+
eod:bool ->
131
+
(unit, string) result
132
+
(** [recode] is {!val-decode} followed by {!val-recode}. *)
133
+
134
+
val recode' :
135
+
?layout:bool ->
136
+
?locs:bool ->
137
+
?file:Json.Textloc.fpath ->
138
+
?buf:Bytes.t ->
139
+
?format:Json.format ->
140
+
?number_format:Json.number_format ->
141
+
'a Json.t ->
142
+
Bytes.Reader.t ->
143
+
Bytes.Writer.t ->
144
+
eod:bool ->
145
+
(unit, Json.Error.t) result
146
+
(** [recode'] is like {!val-recode} but preserves the error structure. *)
147
+
148
+
val recode_string :
149
+
?layout:bool ->
150
+
?locs:bool ->
151
+
?file:Json.Textloc.fpath ->
152
+
?buf:Bytes.t ->
153
+
?format:Json.format ->
154
+
?number_format:Json.number_format ->
155
+
'a Json.t ->
156
+
string ->
157
+
(string, string) result
158
+
(** [recode] is {!decode_string} followed by {!recode_string}. *)
159
+
160
+
val recode_string' :
161
+
?layout:bool ->
162
+
?locs:bool ->
163
+
?file:Json.Textloc.fpath ->
164
+
?buf:Bytes.t ->
165
+
?format:Json.format ->
166
+
?number_format:Json.number_format ->
167
+
'a Json.t ->
168
+
string ->
169
+
(string, Json.Error.t) result
170
+
(** [recode_string'] is like {!val-recode_string} but preserves the error
171
+
structure. *)
172
+
173
+
(** {1:layout Layout preservation}
174
+
175
+
In order to simplify the implementation not all layout is preserved. In
176
+
particular:
177
+
- White space in empty arrays and objects is dropped.
178
+
- Unicode escapes are replaced by their UTF-8 encoding.
179
+
- The format of numbers is not preserved. *)
180
+
181
+
(** {1:duplicate Duplicate object members}
182
+
183
+
Duplicate object members are undefined behaviour in JSON. We follow the
184
+
behaviour of
185
+
{{:https://262.ecma-international.org/6.0/#sec-internalizejsonproperty}
186
+
[JSON.parse]} and the last one takes over, however duplicate members all
187
+
have to parse with the specified type as we error as soon as possible. Also
188
+
{{!Json.Object.case_mem}case members} are not allowed to duplicate. *)
+2286
lib/json.ml
+2286
lib/json.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Fmt = Json_base.Fmt
7
+
8
+
type 'a fmt = 'a Fmt.t
9
+
10
+
let pp_kind = Fmt.code
11
+
let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind
12
+
let pp_name = Fmt.code
13
+
let pp_int ppf i = Fmt.code ppf (Int.to_string i)
14
+
15
+
module Textloc = Json_base.Textloc
16
+
module Meta = Json_base.Meta
17
+
18
+
type 'a node = 'a * Meta.t
19
+
20
+
module Path = Json_base.Path
21
+
module Sort = Json_base.Sort
22
+
23
+
type error_kind = string
24
+
type context_index = string node * Path.index
25
+
type context = context_index list
26
+
type error = context * Meta.t * error_kind
27
+
28
+
exception Error of error
29
+
30
+
module Error = struct
31
+
(* Kinds of errors *)
32
+
33
+
type kind = error_kind
34
+
35
+
let kind_to_string k = k
36
+
37
+
(* Errors *)
38
+
39
+
module Context = struct
40
+
type index = context_index
41
+
type t = context
42
+
43
+
let empty = []
44
+
let is_empty ctx = ctx = []
45
+
let push_array kinded_sort n ctx = (kinded_sort, Path.Nth n) :: ctx
46
+
let push_object kinded_sort n ctx = (kinded_sort, Path.Mem n) :: ctx
47
+
48
+
let pp ppf ctx =
49
+
let pp_meta ppf meta =
50
+
if Meta.is_none meta then ()
51
+
else Fmt.pf ppf "%a: " Textloc.pp (Meta.textloc meta)
52
+
in
53
+
let pp_el ppf (kind, index) =
54
+
match index with
55
+
| Path.Nth (n, meta) ->
56
+
Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]" pp_meta meta pp_int n
57
+
pp_meta (snd kind) pp_kind (fst kind)
58
+
| Path.Mem (name, meta) ->
59
+
Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]" pp_meta meta pp_name
60
+
name pp_meta (snd kind) pp_kind (fst kind)
61
+
in
62
+
if ctx = [] then ()
63
+
else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx)
64
+
end
65
+
66
+
type t = error
67
+
68
+
let make_msg ctx meta msg = (ctx, meta, msg)
69
+
let raise ctx meta msg = raise_notrace (Error (ctx, meta, msg))
70
+
let msg meta msg = raise_notrace (Error (Context.empty, meta, msg))
71
+
let msgf meta fmt = Format.kasprintf (fun m -> msg meta m) fmt
72
+
73
+
let push_array kinded_sort n (ctx, meta, e) =
74
+
raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e))
75
+
76
+
let push_object kinded_sort n (ctx, meta, e) =
77
+
raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e))
78
+
79
+
let adjust_context ~first_byte ~first_line (ctx, meta, e) =
80
+
match ctx with
81
+
| [] -> raise_notrace (Error (ctx, meta, e))
82
+
| ((sort, smeta), idx) :: is ->
83
+
let textloc = Meta.textloc smeta in
84
+
let textloc =
85
+
if Textloc.is_none textloc then textloc
86
+
else Textloc.set_first textloc ~first_byte ~first_line
87
+
in
88
+
let smeta = Meta.with_textloc smeta textloc in
89
+
let ctx = ((sort, smeta), idx) :: is in
90
+
raise_notrace (Error (ctx, meta, e))
91
+
92
+
let pp ppf (ctx, m, msg) =
93
+
let pp_meta ppf m =
94
+
if not (Meta.is_none m) then
95
+
Fmt.pf ppf "@,%a:" Textloc.pp (Meta.textloc m)
96
+
in
97
+
Fmt.pf ppf "@[<v>%a%a%a@]" Fmt.lines msg pp_meta m Context.pp ctx
98
+
99
+
let to_string e = Format.asprintf "%a" pp e
100
+
let puterr = Fmt.puterr
101
+
let disable_ansi_styler = Fmt.disable_ansi_styler
102
+
103
+
(* Predefined errors *)
104
+
105
+
let expected meta exp ~fnd =
106
+
msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd
107
+
108
+
let sort meta ~exp ~fnd =
109
+
msgf meta "Expected %a but found %a" Sort.pp exp Sort.pp fnd
110
+
111
+
let kinded_sort meta ~exp ~fnd =
112
+
msgf meta "Expected %a but found %a" Fmt.code exp Sort.pp fnd
113
+
114
+
let missing_mems meta ~kinded_sort ~exp ~fnd =
115
+
let pp_miss ppf m =
116
+
Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd)
117
+
in
118
+
match exp with
119
+
| [ n ] ->
120
+
msgf meta "@[<v>Missing member %a in %a%a@]" Fmt.code n Fmt.code
121
+
kinded_sort Fmt.similar_mems (n, fnd)
122
+
| exp ->
123
+
msgf meta "@[<v1>Missing members in %a:@,%a@]" Fmt.code kinded_sort
124
+
(Fmt.list pp_miss) exp
125
+
126
+
let unexpected_mems meta ~kinded_sort ~exp ~fnd =
127
+
let pp_unexp ppf m =
128
+
Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp)
129
+
in
130
+
match fnd with
131
+
| [ (u, _) ] ->
132
+
msgf meta "@[<v>Unexpected member %a for %a%a@]" Fmt.code u Fmt.code
133
+
kinded_sort Fmt.should_it_be_mem (u, exp)
134
+
| us ->
135
+
msgf meta "@[<v1>Unexpected members for %a:@,%a@]" Fmt.code kinded_sort
136
+
(Fmt.list pp_unexp) (List.map fst us)
137
+
138
+
let unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd =
139
+
let pp_kind ppf () =
140
+
Fmt.pf ppf "member %a value in %a" Fmt.code mem_name Fmt.code kinded_sort
141
+
in
142
+
msgf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp)
143
+
144
+
(* Numbers *)
145
+
146
+
let index_out_of_range meta ~n ~len =
147
+
msgf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1)
148
+
149
+
let number_range meta ~kind n =
150
+
msgf meta "Number %a not in %a range" Fmt.code
151
+
(Fmt.str "%a" Fmt.json_number n)
152
+
Fmt.code kind
153
+
154
+
let parse_string_number meta ~kind s =
155
+
msgf meta "String %a does not parse to %a value" Fmt.json_string s pp_kind
156
+
kind
157
+
158
+
let integer_range meta ~kind n =
159
+
msgf meta "Integer %a not in %a range" pp_int n pp_kind kind
160
+
161
+
(* Maps *)
162
+
163
+
let no_decoder meta ~kind = msgf meta "No decoder for %a" pp_kind kind
164
+
let no_encoder meta ~kind = msgf meta "No encoder for %a" pp_kind kind
165
+
let decode_todo meta ~kind_opt:k = msgf meta "TODO: decode%a" pp_kind_opt k
166
+
let encode_todo meta ~kind_opt:k = msgf meta "TODO: encode%a" pp_kind_opt k
167
+
let for' meta ~kind e = msgf meta "%a: %s" pp_kind kind e
168
+
end
169
+
170
+
(* Types *)
171
+
172
+
module Repr = struct
173
+
(* See the .mli for documentation *)
174
+
module String_map = Map.Make (String)
175
+
module Type = Json_base.Type
176
+
177
+
type ('ret, 'f) dec_fun =
178
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
179
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
180
+
181
+
type ('a, 'b) base_map = {
182
+
kind : string;
183
+
doc : string;
184
+
dec : Meta.t -> 'a -> 'b;
185
+
enc : 'b -> 'a;
186
+
enc_meta : 'b -> Meta.t;
187
+
}
188
+
189
+
type 'a t =
190
+
| Null : (unit, 'a) base_map -> 'a t
191
+
| Bool : (bool, 'a) base_map -> 'a t
192
+
| Number : (float, 'a) base_map -> 'a t
193
+
| String : (string, 'a) base_map -> 'a t
194
+
| Array : ('a, 'elt, 'builder) array_map -> 'a t
195
+
| Object : ('o, 'o) object_map -> 'o t
196
+
| Any : 'a any_map -> 'a t
197
+
| Map : ('a, 'b) map -> 'b t
198
+
| Rec : 'a t Lazy.t -> 'a t
199
+
200
+
and ('array, 'elt, 'builder) array_map = {
201
+
kind : string;
202
+
doc : string;
203
+
elt : 'elt t;
204
+
dec_empty : unit -> 'builder;
205
+
dec_skip : int -> 'builder -> bool;
206
+
dec_add : int -> 'elt -> 'builder -> 'builder;
207
+
dec_finish : Meta.t -> int -> 'builder -> 'array;
208
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
209
+
enc_meta : 'array -> Meta.t;
210
+
}
211
+
212
+
and ('o, 'dec) object_map = {
213
+
kind : string;
214
+
doc : string;
215
+
dec : ('o, 'dec) dec_fun;
216
+
mem_decs : mem_dec String_map.t;
217
+
mem_encs : 'o mem_enc list;
218
+
enc_meta : 'o -> Meta.t;
219
+
shape : 'o object_shape;
220
+
}
221
+
222
+
and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec
223
+
and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
224
+
225
+
and ('o, 'a) mem_map = {
226
+
name : string;
227
+
doc : string;
228
+
type' : 'a t;
229
+
id : 'a Type.Id.t;
230
+
dec_absent : 'a option;
231
+
enc : 'o -> 'a;
232
+
(* enc_name_meta : 'a -> Meta.t; See comment in .mli *)
233
+
enc_omit : 'a -> bool;
234
+
}
235
+
236
+
and 'o object_shape =
237
+
| Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape
238
+
| Object_cases :
239
+
('o, 'mems, 'builder) unknown_mems option
240
+
* ('o, 'cases, 'tag) object_cases
241
+
-> 'o object_shape
242
+
243
+
and ('o, 'mems, 'builder) unknown_mems =
244
+
| Unknown_skip : ('o, unit, unit) unknown_mems
245
+
| Unknown_error : ('o, unit, unit) unknown_mems
246
+
| Unknown_keep :
247
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems)
248
+
-> ('o, 'mems, 'builder) unknown_mems
249
+
250
+
and ('mems, 'a, 'builder) mems_map = {
251
+
kind : string;
252
+
doc : string;
253
+
mems_type : 'a t;
254
+
id : 'mems Type.Id.t;
255
+
dec_empty : unit -> 'builder;
256
+
dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder;
257
+
dec_finish : Meta.t -> 'builder -> 'mems;
258
+
enc :
259
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
260
+
}
261
+
262
+
and ('o, 'cases, 'tag) object_cases = {
263
+
tag : ('tag, 'tag) mem_map;
264
+
tag_compare : 'tag -> 'tag -> int;
265
+
tag_to_string : ('tag -> string) option;
266
+
id : 'cases Type.Id.t;
267
+
cases : ('cases, 'tag) case list;
268
+
enc : 'o -> 'cases;
269
+
enc_case : 'cases -> ('cases, 'tag) case_value;
270
+
}
271
+
272
+
and ('cases, 'case, 'tag) case_map = {
273
+
tag : 'tag;
274
+
object_map : ('case, 'case) object_map;
275
+
dec : 'case -> 'cases;
276
+
}
277
+
278
+
and ('cases, 'tag) case_value =
279
+
| Case_value :
280
+
('cases, 'case, 'tag) case_map * 'case
281
+
-> ('cases, 'tag) case_value
282
+
283
+
and ('cases, 'tag) case =
284
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
285
+
286
+
and 'a any_map = {
287
+
kind : string;
288
+
doc : string;
289
+
dec_null : 'a t option;
290
+
dec_bool : 'a t option;
291
+
dec_number : 'a t option;
292
+
dec_string : 'a t option;
293
+
dec_array : 'a t option;
294
+
dec_object : 'a t option;
295
+
enc : 'a -> 'a t;
296
+
}
297
+
298
+
and ('a, 'b) map = {
299
+
kind : string;
300
+
doc : string;
301
+
dom : 'a t;
302
+
dec : 'a -> 'b;
303
+
enc : 'b -> 'a;
304
+
}
305
+
306
+
(* Convert *)
307
+
308
+
let of_t = Fun.id
309
+
let unsafe_to_t = Fun.id
310
+
311
+
(* Kinds and doc *)
312
+
313
+
let base_map_with_doc ?kind ?doc (map : ('a, 'b) base_map) =
314
+
let kind = Option.value ~default:map.kind doc in
315
+
let doc = Option.value ~default:map.doc doc in
316
+
{ map with kind; doc }
317
+
318
+
let array_map_with_doc ?kind ?doc (map : ('a, 'b, 'c) array_map) =
319
+
let kind = Option.value ~default:map.kind doc in
320
+
let doc = Option.value ~default:map.doc doc in
321
+
{ map with kind; doc }
322
+
323
+
let object_map_with_doc ?kind ?doc (map : ('o, 'o) object_map) =
324
+
let kind = Option.value ~default:map.kind doc in
325
+
let doc = Option.value ~default:map.doc doc in
326
+
{ map with kind; doc }
327
+
328
+
let any_map_with_doc ?kind ?doc (map : 'a any_map) =
329
+
let kind = Option.value ~default:map.kind doc in
330
+
let doc = Option.value ~default:map.doc doc in
331
+
{ map with kind; doc }
332
+
333
+
let map_with_doc ?kind ?doc (map : ('a, 'b) map) =
334
+
let kind = Option.value ~default:map.kind doc in
335
+
let doc = Option.value ~default:map.doc doc in
336
+
{ map with kind; doc }
337
+
338
+
let rec with_doc ?kind ?doc = function
339
+
| Null map -> Null (base_map_with_doc ?kind ?doc map)
340
+
| Bool map -> Bool (base_map_with_doc ?kind ?doc map)
341
+
| Number map -> Number (base_map_with_doc ?kind ?doc map)
342
+
| String map -> String (base_map_with_doc ?kind ?doc map)
343
+
| Array map -> Array (array_map_with_doc ?kind ?doc map)
344
+
| Object map -> Object (object_map_with_doc ?kind ?doc map)
345
+
| Any map -> Any (any_map_with_doc ?kind ?doc map)
346
+
| Map map -> Map (map_with_doc ?kind ?doc map)
347
+
| Rec l -> with_doc ?kind ?doc (Lazy.force l)
348
+
349
+
let object_map_kinded_sort (map : ('o, 'dec) object_map) =
350
+
Sort.kinded ~kind:map.kind Object
351
+
352
+
let rec kinded_sort : type a. a t -> string = function
353
+
| Null map -> Sort.kinded ~kind:map.kind Null
354
+
| Bool map -> Sort.kinded ~kind:map.kind Bool
355
+
| Number map -> Sort.kinded ~kind:map.kind Number
356
+
| String map -> Sort.kinded ~kind:map.kind String
357
+
| Array map -> array_map_kinded_sort map
358
+
| Object map -> object_map_kinded_sort map
359
+
| Any map -> if map.kind = "" then any_map_kinded_sort map else map.kind
360
+
| Map map -> if map.kind = "" then kinded_sort map.dom else map.kind
361
+
| Rec l -> kinded_sort (Lazy.force l)
362
+
363
+
and array_map_kinded_sort : type a e b. (a, e, b) array_map -> string =
364
+
fun map ->
365
+
if map.kind <> "" then Sort.kinded ~kind:map.kind Array
366
+
else
367
+
let elt = kinded_sort map.elt in
368
+
String.concat "" [ "array<"; elt; ">" ]
369
+
370
+
and any_map_kinded_sort : type a. a any_map -> string =
371
+
fun map ->
372
+
let add_case ks sort = function
373
+
| None -> ks
374
+
| Some k ->
375
+
(if map.kind <> "" then kinded_sort k
376
+
else Sort.kinded ~kind:map.kind sort)
377
+
:: ks
378
+
in
379
+
let ks = add_case [] Object map.dec_object in
380
+
let ks = add_case ks Array map.dec_array in
381
+
let ks = add_case ks String map.dec_string in
382
+
let ks = add_case ks Number map.dec_number in
383
+
let ks = add_case ks Bool map.dec_bool in
384
+
let ks = add_case ks Null map.dec_null in
385
+
"one of " ^ String.concat ", " ks
386
+
387
+
let rec kind : type a. a t -> string = function
388
+
| Null map -> Sort.or_kind ~kind:map.kind Null
389
+
| Bool map -> Sort.or_kind ~kind:map.kind Bool
390
+
| Number map -> Sort.or_kind ~kind:map.kind Number
391
+
| String map -> Sort.or_kind ~kind:map.kind String
392
+
| Array map -> Sort.or_kind ~kind:map.kind Array
393
+
| Object map -> Sort.or_kind ~kind:map.kind Object
394
+
| Any map -> if map.kind <> "" then map.kind else "any"
395
+
| Map map -> if map.kind <> "" then map.kind else kind map.dom
396
+
| Rec l -> kind (Lazy.force l)
397
+
398
+
let rec doc : type a. a t -> string = function
399
+
| Null map -> map.doc
400
+
| Bool map -> map.doc
401
+
| Number map -> map.doc
402
+
| String map -> map.doc
403
+
| Array map -> map.doc
404
+
| Object map -> map.doc
405
+
| Any map -> map.doc
406
+
| Map map -> map.doc
407
+
| Rec l -> doc (Lazy.force l)
408
+
409
+
(* Errors *)
410
+
411
+
let pp_code = Fmt.code
412
+
let pp_kind = pp_kind
413
+
414
+
let error_push_object meta map name e =
415
+
Error.push_object (object_map_kinded_sort map, meta) name e
416
+
417
+
let error_push_array meta map i e =
418
+
Error.push_array (array_map_kinded_sort map, meta) i e
419
+
420
+
let type_error meta t ~fnd = Error.kinded_sort meta ~exp:(kinded_sort t) ~fnd
421
+
422
+
let missing_mems_error meta (object_map : ('o, 'o) object_map) ~exp ~fnd =
423
+
let kinded_sort = object_map_kinded_sort object_map in
424
+
let exp =
425
+
let add n (Mem_dec m) acc =
426
+
match m.dec_absent with None -> n :: acc | Some _ -> acc
427
+
in
428
+
List.rev (String_map.fold add exp [])
429
+
in
430
+
Error.missing_mems meta ~kinded_sort ~exp ~fnd
431
+
432
+
let unexpected_mems_error meta (object_map : ('o, 'o) object_map) ~fnd =
433
+
let kinded_sort = object_map_kinded_sort object_map in
434
+
let exp = List.map (fun (Mem_enc m) -> m.name) object_map.mem_encs in
435
+
Error.unexpected_mems meta ~kinded_sort ~exp ~fnd
436
+
437
+
let unexpected_case_tag_error meta object_map object_cases tag =
438
+
let kinded_sort = object_map_kinded_sort object_map in
439
+
let case_to_string (Case c) =
440
+
match object_cases.tag_to_string with
441
+
| None -> None
442
+
| Some str -> Some (str c.tag)
443
+
in
444
+
let exp = List.filter_map case_to_string object_cases.cases in
445
+
let fnd =
446
+
match object_cases.tag_to_string with
447
+
| None -> "<tag>" (* XXX not good *)
448
+
| Some str -> str tag
449
+
in
450
+
let mem_name = object_cases.tag.name in
451
+
Error.unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd
452
+
453
+
(* Processor toolbox *)
454
+
455
+
let object_meta_arg : Meta.t Type.Id.t = Type.Id.make ()
456
+
457
+
module Dict = struct
458
+
module M = Map.Make (Int)
459
+
460
+
type binding = B : 'a Type.Id.t * 'a -> binding
461
+
type t = binding M.t
462
+
463
+
let empty = M.empty
464
+
let mem k m = M.mem (Type.Id.uid k) m
465
+
let add k v m = M.add (Type.Id.uid k) (B (k, v)) m
466
+
let remove k m = M.remove (Type.Id.uid k) m
467
+
468
+
let find : type a. a Type.Id.t -> t -> a option =
469
+
fun k m ->
470
+
match M.find_opt (Type.Id.uid k) m with
471
+
| None -> None
472
+
| Some (B (k', v)) -> (
473
+
match Type.Id.provably_equal k k' with
474
+
| Some Type.Equal -> Some v
475
+
| None -> assert false)
476
+
end
477
+
478
+
let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f =
479
+
fun dec dict ->
480
+
match dec with
481
+
| Dec_fun f -> f
482
+
| Dec_app (f, arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict))
483
+
484
+
type unknown_mems_option =
485
+
| Unknown_mems :
486
+
('o, 'mems, 'builder) unknown_mems option
487
+
-> unknown_mems_option
488
+
489
+
let override_unknown_mems ~by umems dict =
490
+
match by with
491
+
| Unknown_mems None -> (umems, dict)
492
+
| Unknown_mems _ as by -> (
493
+
match umems with
494
+
| Unknown_mems (Some (Unknown_keep (umap, _))) ->
495
+
(* A decoding function still expect [umap.id] argument in
496
+
an Dec_app, we simply stub it with the empty map. *)
497
+
let empty = umap.dec_finish Meta.none (umap.dec_empty ()) in
498
+
let dict = Dict.add umap.id empty dict in
499
+
(by, dict)
500
+
| _ -> (by, dict))
501
+
502
+
let finish_object_decode : type o p m mems builder.
503
+
(o, o) object_map ->
504
+
Meta.t ->
505
+
(p, mems, builder) unknown_mems ->
506
+
builder ->
507
+
mem_dec String_map.t ->
508
+
Dict.t ->
509
+
Dict.t =
510
+
fun map meta umems umap mem_decs dict ->
511
+
let dict = Dict.add object_meta_arg meta dict in
512
+
let dict =
513
+
match umems with
514
+
| Unknown_skip | Unknown_error -> dict
515
+
| Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish meta umap) dict
516
+
in
517
+
let add_default _ (Mem_dec mem_map) dict =
518
+
match mem_map.dec_absent with
519
+
| Some v -> Dict.add mem_map.id v dict
520
+
| None -> raise Exit
521
+
in
522
+
try String_map.fold add_default mem_decs dict
523
+
with Exit ->
524
+
let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in
525
+
let exp = String_map.filter no_default mem_decs in
526
+
missing_mems_error meta map ~exp ~fnd:[]
527
+
end
528
+
529
+
(* Types *)
530
+
531
+
type 'a t = 'a Repr.t
532
+
533
+
let kinded_sort = Repr.kinded_sort
534
+
let kind = Repr.kind
535
+
let doc = Repr.doc
536
+
let with_doc = Repr.with_doc
537
+
538
+
(* Base types *)
539
+
540
+
let enc_meta_none _v = Meta.none
541
+
542
+
module Base = struct
543
+
type ('a, 'b) map = ('a, 'b) Repr.base_map
544
+
545
+
let base_map_sort = "base map"
546
+
547
+
let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () =
548
+
let dec =
549
+
match dec with
550
+
| Some dec -> dec
551
+
| None ->
552
+
let kind = Sort.kinded' ~kind base_map_sort in
553
+
fun meta _v -> Error.no_decoder meta ~kind
554
+
in
555
+
let enc =
556
+
match enc with
557
+
| Some enc -> enc
558
+
| None ->
559
+
let kind = Sort.kinded' ~kind base_map_sort in
560
+
fun _v -> Error.no_encoder Meta.none ~kind
561
+
in
562
+
{ Repr.kind; doc; dec; enc; enc_meta }
563
+
564
+
let id =
565
+
let dec _meta v = v and enc = Fun.id in
566
+
{ Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
567
+
568
+
let ignore =
569
+
let kind = "ignore" in
570
+
let dec _meta _v = () in
571
+
let enc _v =
572
+
let kind = Sort.kinded' ~kind base_map_sort in
573
+
Error.no_encoder Meta.none ~kind
574
+
in
575
+
{ Repr.kind; doc = ""; dec; enc; enc_meta = enc_meta_none }
576
+
577
+
let null map = Repr.Null map
578
+
let bool map = Repr.Bool map
579
+
let number map = Repr.Number map
580
+
let string map = Repr.String map
581
+
let dec dec = fun _meta v -> dec v
582
+
583
+
let dec_result ?(kind = "") dec =
584
+
let kind = Sort.kinded' ~kind base_map_sort in
585
+
fun meta v ->
586
+
match dec v with Ok v -> v | Error e -> Error.for' meta ~kind e
587
+
588
+
let dec_failure ?(kind = "") dec =
589
+
let kind = Sort.kinded' ~kind base_map_sort in
590
+
fun meta v -> try dec v with Failure e -> Error.for' meta ~kind e
591
+
592
+
let enc = Fun.id
593
+
594
+
let enc_result ?(kind = "") enc =
595
+
let kind = Sort.kinded' ~kind base_map_sort in
596
+
fun v ->
597
+
match enc v with Ok v -> v | Error e -> Error.for' Meta.none ~kind e
598
+
599
+
let enc_failure ?(kind = "") enc =
600
+
let kind = Sort.kinded' ~kind base_map_sort in
601
+
fun v -> try enc v with Failure e -> Error.for' Meta.none ~kind e
602
+
end
603
+
604
+
(* Any *)
605
+
606
+
let any ?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string
607
+
?dec_array ?dec_object ?enc () =
608
+
let enc =
609
+
match enc with
610
+
| Some enc -> enc
611
+
| None ->
612
+
let kind = Sort.kinded' ~kind "any" in
613
+
fun _v -> Error.no_encoder Meta.none ~kind
614
+
in
615
+
Repr.Any
616
+
{
617
+
kind;
618
+
doc;
619
+
dec_null;
620
+
dec_bool;
621
+
dec_number;
622
+
dec_string;
623
+
dec_array;
624
+
dec_object;
625
+
enc;
626
+
}
627
+
628
+
(* Maps and recursion *)
629
+
630
+
let map ?(kind = "") ?(doc = "") ?dec ?enc dom =
631
+
let map_sort = "map" in
632
+
let dec =
633
+
match dec with
634
+
| Some dec -> dec
635
+
| None ->
636
+
let kind = Sort.kinded' ~kind map_sort in
637
+
fun _v -> Error.no_decoder Meta.none ~kind
638
+
in
639
+
let enc =
640
+
match enc with
641
+
| Some enc -> enc
642
+
| None ->
643
+
let kind = Sort.kinded' ~kind map_sort in
644
+
fun _v -> Error.no_encoder Meta.none ~kind
645
+
in
646
+
Repr.Map { kind; doc; dom; dec; enc }
647
+
648
+
let iter ?(kind = "") ?(doc = "") ?dec ?enc dom =
649
+
let dec =
650
+
match dec with
651
+
| None -> Fun.id
652
+
| Some dec ->
653
+
fun v ->
654
+
dec v;
655
+
v
656
+
in
657
+
let enc =
658
+
match enc with
659
+
| None -> Fun.id
660
+
| Some enc ->
661
+
fun v ->
662
+
enc v;
663
+
v
664
+
in
665
+
Repr.Map { kind; doc; dom; dec; enc }
666
+
667
+
let rec' t = Repr.Rec t
668
+
669
+
(* Nulls and options *)
670
+
671
+
let null ?kind ?doc v =
672
+
let dec _meta () = v and enc _meta = () in
673
+
Repr.Null (Base.map ?doc ?kind ~dec ~enc ())
674
+
675
+
let none =
676
+
let none =
677
+
(* Can't use [Base.map] because of the value restriction. *)
678
+
let dec _meta _v = None and enc _ = () in
679
+
{ Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
680
+
in
681
+
Repr.Null none
682
+
683
+
let some t = map ~dec:Option.some ~enc:Option.get t
684
+
685
+
let option ?kind ?doc t =
686
+
let some = some t in
687
+
let enc = function None -> none | Some _ -> some in
688
+
match t with
689
+
| Null _ -> any ?doc ?kind ~dec_null:none ~enc ()
690
+
| Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc ()
691
+
| Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc ()
692
+
| String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc ()
693
+
| Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc ()
694
+
| Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc ()
695
+
| Any _ | Map _ | Rec _ ->
696
+
any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some
697
+
~dec_string:some ~dec_array:some ~dec_object:some ~enc ()
698
+
699
+
(* Booleans *)
700
+
701
+
let bool = Repr.Bool Base.id
702
+
703
+
(* Numbers *)
704
+
705
+
let[@inline] check_finite_number meta ~kind v =
706
+
if Float.is_finite v then ()
707
+
else Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null
708
+
709
+
let number = Repr.Number Base.id
710
+
711
+
let any_float =
712
+
let kind = "float" in
713
+
let finite = number in
714
+
let non_finite =
715
+
let dec m v =
716
+
match Float.of_string_opt v with
717
+
| Some v -> v
718
+
| None -> Error.parse_string_number m ~kind v
719
+
in
720
+
Base.string (Base.map ~kind ~dec ~enc:Float.to_string ())
721
+
in
722
+
let enc v = if Float.is_finite v then finite else non_finite in
723
+
any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc ()
724
+
725
+
let float_as_hex_string =
726
+
let kind = "float" in
727
+
let dec meta v =
728
+
match Float.of_string_opt v with
729
+
| Some v -> v
730
+
| None -> Error.parse_string_number meta ~kind v
731
+
in
732
+
let enc v = Printf.sprintf "%h" v in
733
+
Base.string (Base.map ~kind ~dec ~enc ())
734
+
735
+
let uint8 =
736
+
let kind = "uint8" in
737
+
let dec meta v =
738
+
check_finite_number meta ~kind v;
739
+
if Json_base.Number.in_exact_uint8_range v then Int.of_float v
740
+
else Error.number_range meta ~kind v
741
+
in
742
+
let enc v =
743
+
if Json_base.Number.int_is_uint8 v then Int.to_float v
744
+
else Error.integer_range Meta.none ~kind v
745
+
in
746
+
Base.number (Base.map ~kind ~dec ~enc ())
747
+
748
+
let uint16 =
749
+
let kind = "uint16" in
750
+
let dec meta v =
751
+
check_finite_number meta ~kind v;
752
+
if Json_base.Number.in_exact_uint16_range v then Int.of_float v
753
+
else Error.number_range meta ~kind v
754
+
in
755
+
let enc v =
756
+
if Json_base.Number.int_is_uint16 v then Int.to_float v
757
+
else Error.integer_range Meta.none ~kind v
758
+
in
759
+
Base.number (Base.map ~kind ~dec ~enc ())
760
+
761
+
let int8 =
762
+
let kind = "int8" in
763
+
let dec meta v =
764
+
check_finite_number meta ~kind v;
765
+
if Json_base.Number.in_exact_int8_range v then Int.of_float v
766
+
else Error.number_range meta ~kind v
767
+
in
768
+
let enc v =
769
+
if Json_base.Number.int_is_int8 v then Int.to_float v
770
+
else Error.integer_range Meta.none ~kind v
771
+
in
772
+
Base.number (Base.map ~kind ~dec ~enc ())
773
+
774
+
let int16 =
775
+
let kind = "int16" in
776
+
let dec meta v =
777
+
check_finite_number meta ~kind v;
778
+
if Json_base.Number.in_exact_int16_range v then Int.of_float v
779
+
else Error.number_range meta ~kind v
780
+
in
781
+
let enc v =
782
+
if Json_base.Number.int_is_int16 v then Int.to_float v
783
+
else Error.integer_range Meta.none ~kind v
784
+
in
785
+
Base.number (Base.map ~kind ~dec ~enc ())
786
+
787
+
let int32 =
788
+
let kind = "int32" in
789
+
let dec meta v =
790
+
check_finite_number meta ~kind v;
791
+
if Json_base.Number.in_exact_int32_range v then Int32.of_float v
792
+
else Error.number_range meta ~kind v
793
+
in
794
+
let enc =
795
+
Int32.to_float
796
+
(* Everything always fits *)
797
+
in
798
+
Base.number (Base.map ~kind ~dec ~enc ())
799
+
800
+
let int64_as_string =
801
+
let kind = "int64" in
802
+
let dec meta v =
803
+
match Int64.of_string_opt v with
804
+
| Some v -> v
805
+
| None -> Error.parse_string_number meta ~kind v
806
+
in
807
+
Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ())
808
+
809
+
let int64_number =
810
+
(* Usage by [int64] entails there's no need to test for nan or check
811
+
range on encoding. *)
812
+
let kind = "int64" in
813
+
let dec meta v =
814
+
if Json_base.Number.in_exact_int64_range v then Int64.of_float v
815
+
else Error.number_range meta ~kind v
816
+
in
817
+
Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ())
818
+
819
+
let int64 =
820
+
let dec_number = int64_number and dec_string = int64_as_string in
821
+
let enc v =
822
+
if Json_base.Number.can_store_exact_int64 v then int64_number
823
+
else int64_as_string
824
+
in
825
+
any ~kind:"int64" ~dec_number ~dec_string ~enc ()
826
+
827
+
let int_as_string =
828
+
let kind = "OCaml int" in
829
+
let dec meta v =
830
+
match int_of_string_opt v with
831
+
| Some v -> v
832
+
| None -> Error.parse_string_number meta ~kind v
833
+
in
834
+
Base.string (Base.map ~kind ~dec ~enc:Int.to_string ())
835
+
836
+
let int_number =
837
+
(* Usage by [int] entails there's no need to test for nan or check range on
838
+
encoding. *)
839
+
let kind = "OCaml int" in
840
+
let dec meta v =
841
+
if Json_base.Number.in_exact_int_range v then Int.of_float v
842
+
else Error.number_range meta ~kind v
843
+
in
844
+
Base.number (Base.map ~kind ~dec ~enc:Int.to_float ())
845
+
846
+
let int =
847
+
let enc v =
848
+
if Json_base.Number.can_store_exact_int v then int_number
849
+
else int_as_string
850
+
in
851
+
let dec_number = int_number and dec_string = int_as_string in
852
+
any ~kind:"OCaml int" ~dec_number ~dec_string ~enc ()
853
+
854
+
(* String and enums *)
855
+
856
+
let string = Repr.String Base.id
857
+
858
+
let of_of_string ?kind ?doc ?enc of_string =
859
+
let dec = Base.dec_result ?kind of_string in
860
+
let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in
861
+
Base.string (Base.map ?kind ?doc ?enc ~dec ())
862
+
863
+
let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc =
864
+
let kind = Sort.kinded' ~kind "enum" in
865
+
let dec_map =
866
+
let add m (k, v) = Repr.String_map.add k v m in
867
+
let m = List.fold_left add Repr.String_map.empty assoc in
868
+
fun k -> Repr.String_map.find_opt k m
869
+
in
870
+
let enc_map =
871
+
let module M = Map.Make (struct
872
+
type t = a
873
+
874
+
let compare = cmp
875
+
end) in
876
+
let add m (k, v) = M.add v k m in
877
+
let m = List.fold_left add M.empty assoc in
878
+
fun v -> M.find_opt v m
879
+
in
880
+
let dec meta s =
881
+
match dec_map s with
882
+
| Some v -> v
883
+
| None ->
884
+
let kind = Sort.kinded ~kind String in
885
+
let pp_kind ppf () = Fmt.pf ppf "%a value" Repr.pp_kind kind in
886
+
Error.msgf meta "%a" (Fmt.out_of_dom ~pp_kind ()) (s, List.map fst assoc)
887
+
in
888
+
let enc v =
889
+
match enc_map v with
890
+
| Some s -> s
891
+
| None ->
892
+
Error.msgf Meta.none "Encode %a: unknown enum value" Repr.pp_kind kind
893
+
in
894
+
Base.string (Base.map ~kind ?doc ~dec ~enc ())
895
+
896
+
let binary_string =
897
+
let kind = "hex" in
898
+
let kind' = Sort.kinded ~kind String in
899
+
let dec = Base.dec_result ~kind:kind' Json_base.binary_string_of_hex in
900
+
let enc = Base.enc Json_base.binary_string_to_hex in
901
+
Base.string (Base.map ~kind ~dec ~enc ())
902
+
903
+
(* Arrays and tuples *)
904
+
905
+
module Array = struct
906
+
type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) Repr.array_map
907
+
908
+
type ('array, 'elt) enc = {
909
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
910
+
}
911
+
912
+
let array_kind kind = Sort.kinded ~kind Sort.Array
913
+
let default_skip _i _builder = false
914
+
915
+
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish
916
+
?enc ?(enc_meta = enc_meta_none) elt =
917
+
let dec_empty =
918
+
match dec_empty with
919
+
| Some dec_empty -> dec_empty
920
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(array_kind kind)
921
+
in
922
+
let dec_skip = Option.value ~default:default_skip dec_skip in
923
+
let dec_add =
924
+
match dec_add with
925
+
| Some dec_add -> dec_add
926
+
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
927
+
in
928
+
let dec_finish =
929
+
match dec_finish with
930
+
| Some dec_finish -> dec_finish
931
+
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
932
+
in
933
+
let enc =
934
+
match enc with
935
+
| Some { enc } -> enc
936
+
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind)
937
+
in
938
+
{
939
+
Repr.kind;
940
+
doc;
941
+
elt;
942
+
dec_empty;
943
+
dec_add;
944
+
dec_skip;
945
+
dec_finish;
946
+
enc;
947
+
enc_meta;
948
+
}
949
+
950
+
let list_enc f acc l =
951
+
let rec loop f acc i = function
952
+
| [] -> acc
953
+
| v :: l -> loop f (f acc i v) (i + 1) l
954
+
in
955
+
loop f acc 0 l
956
+
957
+
let list_map ?kind ?doc ?dec_skip elt =
958
+
let dec_empty () = [] in
959
+
let dec_add _i v l = v :: l in
960
+
let dec_finish _meta _len l = List.rev l in
961
+
let enc = { enc = list_enc } in
962
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
963
+
964
+
type 'a array_builder = 'a Json_base.Rarray.t
965
+
966
+
let array_enc f acc a =
967
+
let acc = ref acc in
968
+
for i = 0 to Array.length a - 1 do
969
+
acc := f !acc i (Array.unsafe_get a i)
970
+
done;
971
+
!acc
972
+
973
+
let array_map ?kind ?doc ?dec_skip elt =
974
+
let dec_empty () = Json_base.Rarray.empty () in
975
+
let dec_add _i v a = Json_base.Rarray.add_last v a in
976
+
let dec_finish _meta _len a = Json_base.Rarray.to_array a in
977
+
let enc = { enc = array_enc } in
978
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
979
+
980
+
type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Json_base.Rbigarray1.t
981
+
982
+
let bigarray_map ?kind ?doc ?dec_skip k l elt =
983
+
let dec_empty _meta = Json_base.Rbigarray1.empty k l in
984
+
let dec_add _i v a = Json_base.Rbigarray1.add_last v a in
985
+
let dec_finish _meta _len a = Json_base.Rbigarray1.to_bigarray a in
986
+
let enc f acc a =
987
+
let acc = ref acc in
988
+
for i = 0 to Bigarray.Array1.dim a - 1 do
989
+
acc := f !acc i (Bigarray.Array1.unsafe_get a i)
990
+
done;
991
+
!acc
992
+
in
993
+
let enc = { enc } in
994
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
995
+
996
+
let array map = Repr.Array map
997
+
998
+
let stub_elt =
999
+
Repr.Map
1000
+
{
1001
+
kind = "";
1002
+
doc = "";
1003
+
dom = Base.(null id);
1004
+
enc = (fun _ -> assert false);
1005
+
dec = (fun _ -> assert false);
1006
+
}
1007
+
1008
+
let ignore =
1009
+
let kind = "ignore" in
1010
+
let kind' = Sort.kinded ~kind Array in
1011
+
let dec_empty () = () and dec_add _i _v () = () in
1012
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
1013
+
let enc =
1014
+
{ enc = (fun _ _ () -> Error.no_encoder Meta.none ~kind:kind') }
1015
+
in
1016
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
1017
+
1018
+
let zero =
1019
+
let dec_empty () = () and dec_add _i _v () = () in
1020
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
1021
+
let enc = { enc = (fun _ acc () -> acc) } in
1022
+
let kind = "zero" in
1023
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
1024
+
end
1025
+
1026
+
let list ?kind ?doc t = Repr.Array (Array.list_map ?kind ?doc t)
1027
+
let array ?kind ?doc t = Repr.Array (Array.array_map ?kind ?doc t)
1028
+
1029
+
let array_as_string_map ?kind ?doc ~key t =
1030
+
let dec_empty () = Repr.String_map.empty in
1031
+
let dec_add _i elt acc = Repr.String_map.add (key elt) elt acc in
1032
+
let dec_finish _meta _len acc = acc in
1033
+
let enc f acc m =
1034
+
let i = ref (-1) in
1035
+
Repr.String_map.fold
1036
+
(fun _ elt acc ->
1037
+
incr i;
1038
+
f acc !i elt)
1039
+
m acc
1040
+
in
1041
+
let enc = Array.{ enc } in
1042
+
let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in
1043
+
Repr.Array map
1044
+
1045
+
let bigarray ?kind ?doc k t =
1046
+
Repr.Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t)
1047
+
1048
+
let tuple_no_decoder ~kind meta =
1049
+
Error.no_decoder meta ~kind:(Sort.kinded' ~kind "tuple")
1050
+
1051
+
let tuple_no_encoder ~kind =
1052
+
Error.no_encoder Meta.none ~kind:(Sort.kinded' ~kind "tuple")
1053
+
1054
+
let error_tuple_size meta kind ~exp fnd =
1055
+
Error.msgf meta "Expected %a elements in %a but found %a" pp_int exp pp_kind
1056
+
(Sort.kinded' ~kind "tuple")
1057
+
pp_int fnd
1058
+
1059
+
let t2 ?(kind = "") ?doc ?dec ?enc t =
1060
+
let size = 2 in
1061
+
let dec =
1062
+
match dec with
1063
+
| None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta
1064
+
| Some dec -> fun _meta v0 v1 -> dec v0 v1
1065
+
in
1066
+
let dec_empty () = [] in
1067
+
let dec_add _i v acc = v :: acc in
1068
+
let dec_finish meta _len = function
1069
+
| [ v1; v0 ] -> dec meta v0 v1
1070
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
1071
+
in
1072
+
let enc =
1073
+
match enc with
1074
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
1075
+
| Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1)
1076
+
in
1077
+
let enc = { Array.enc } in
1078
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
1079
+
1080
+
let t3 ?(kind = "") ?doc ?dec ?enc t =
1081
+
let size = 3 in
1082
+
let dec =
1083
+
match dec with
1084
+
| None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta
1085
+
| Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2
1086
+
in
1087
+
let dec_empty () = [] in
1088
+
let dec_add _i v acc = v :: acc in
1089
+
let dec_finish meta _len = function
1090
+
| [ v2; v1; v0 ] -> dec meta v0 v1 v2
1091
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
1092
+
in
1093
+
let enc =
1094
+
match enc with
1095
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
1096
+
| Some enc ->
1097
+
fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)
1098
+
in
1099
+
let enc = { Array.enc } in
1100
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
1101
+
1102
+
let t4 ?(kind = "") ?doc ?dec ?enc t =
1103
+
let size = 4 in
1104
+
let dec =
1105
+
match dec with
1106
+
| None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta
1107
+
| Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3
1108
+
in
1109
+
let dec_empty () = [] in
1110
+
let dec_add _i v acc = v :: acc in
1111
+
let dec_finish meta _len = function
1112
+
| [ v3; v2; v1; v0 ] -> dec meta v0 v1 v2 v3
1113
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
1114
+
in
1115
+
let enc =
1116
+
match enc with
1117
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
1118
+
| Some enc ->
1119
+
fun f acc v ->
1120
+
f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3)
1121
+
in
1122
+
let enc = { Array.enc } in
1123
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
1124
+
1125
+
let tn ?(kind = "") ?doc ~n elt =
1126
+
let dec_empty () = Json_base.Rarray.empty () in
1127
+
let dec_add _i v a = Json_base.Rarray.add_last v a in
1128
+
let dec_finish meta _len a =
1129
+
let len = Json_base.Rarray.length a in
1130
+
if len <> n then error_tuple_size meta kind ~exp:n len
1131
+
else Json_base.Rarray.to_array a
1132
+
in
1133
+
let enc = { Array.enc = Array.array_enc } in
1134
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt)
1135
+
1136
+
(* Objects *)
1137
+
1138
+
module Object = struct
1139
+
open Repr
1140
+
1141
+
(* Maps *)
1142
+
1143
+
type ('o, 'dec) map = ('o, 'dec) object_map
1144
+
1145
+
let default_shape = Object_basic Unknown_skip
1146
+
1147
+
let _map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec =
1148
+
{
1149
+
kind;
1150
+
doc;
1151
+
dec;
1152
+
mem_decs = String_map.empty;
1153
+
mem_encs = [];
1154
+
enc_meta;
1155
+
shape = default_shape;
1156
+
}
1157
+
1158
+
let map ?kind ?doc dec = _map ?kind ?doc (Dec_fun dec)
1159
+
1160
+
let map' ?kind ?doc ?enc_meta dec =
1161
+
_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg))
1162
+
1163
+
let enc_only ?(kind = "") ?doc ?enc_meta () =
1164
+
let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in
1165
+
map' ~kind ?doc ?enc_meta dec
1166
+
1167
+
let check_name_unicity m =
1168
+
let add n kind = function
1169
+
| None -> Some kind
1170
+
| Some kind' ->
1171
+
let ks k = Sort.or_kind ~kind Object in
1172
+
let k0 = ks kind and k1 = ks kind' in
1173
+
invalid_arg
1174
+
@@
1175
+
if String.equal k0 k1 then
1176
+
Fmt.str "member %s defined twice in %s" n k0
1177
+
else Fmt.str "member %s defined both in %s and %s" n k0 k1
1178
+
in
1179
+
let rec loop : type o dec.
1180
+
string String_map.t -> (o, dec) object_map -> unit =
1181
+
fun names m ->
1182
+
let add_name names n = String_map.update n (add n m.kind) names in
1183
+
let add_mem_enc names (Mem_enc m) = add_name names m.name in
1184
+
let names = List.fold_left add_mem_enc names m.mem_encs in
1185
+
match m.shape with
1186
+
| Object_basic _ -> ()
1187
+
| Object_cases (u, cases) ->
1188
+
let names = add_name names cases.tag.name in
1189
+
let check_case (Case c) = loop names c.object_map in
1190
+
List.iter check_case cases.cases
1191
+
in
1192
+
loop String_map.empty m
1193
+
1194
+
let finish mems =
1195
+
let () = check_name_unicity mems in
1196
+
Object { mems with mem_encs = List.rev mems.mem_encs }
1197
+
1198
+
let get_object_map = function
1199
+
| Object map -> map
1200
+
| _ -> invalid_arg "Not an object"
1201
+
1202
+
(* Members *)
1203
+
1204
+
module Mem = struct
1205
+
type ('o, 'a) map = ('o, 'a) Repr.mem_map
1206
+
1207
+
let no_enc name =
1208
+
fun _v -> Error.msgf Meta.none "No encoder for member %a" pp_code name
1209
+
1210
+
let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' =
1211
+
let id = Type.Id.make () in
1212
+
let enc = match enc with None -> no_enc name | Some enc -> enc in
1213
+
let enc_omit =
1214
+
match enc_omit with None -> Fun.const false | Some omit -> omit
1215
+
in
1216
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
1217
+
1218
+
let app object_map mm =
1219
+
let mem_decs = String_map.add mm.name (Mem_dec mm) object_map.mem_decs in
1220
+
let mem_encs = Mem_enc mm :: object_map.mem_encs in
1221
+
let dec = Dec_app (object_map.dec, mm.id) in
1222
+
{ object_map with dec; mem_decs; mem_encs }
1223
+
end
1224
+
1225
+
let mem ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map =
1226
+
let mmap = Mem.map ~doc ?dec_absent ?enc ?enc_omit name type' in
1227
+
let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in
1228
+
let mem_encs = Mem_enc mmap :: map.mem_encs in
1229
+
let dec = Dec_app (map.dec, mmap.id) in
1230
+
{ map with dec; mem_decs; mem_encs }
1231
+
1232
+
let opt_mem ?doc ?enc:e name dom map =
1233
+
let dec = Option.some and enc = Option.get in
1234
+
let some = Map { kind = ""; doc = ""; dom; dec; enc } in
1235
+
mem ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map
1236
+
1237
+
(* Case objects *)
1238
+
1239
+
module Case = struct
1240
+
type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map
1241
+
type ('cases, 'tag) t = ('cases, 'tag) case
1242
+
type ('cases, 'tag) value = ('cases, 'tag) case_value
1243
+
1244
+
let no_dec _ = Error.msgf Meta.none "No decoder for case"
1245
+
1246
+
let map ?(dec = no_dec) tag obj =
1247
+
{ tag; object_map = get_object_map obj; dec }
1248
+
1249
+
let map_tag c = c.tag
1250
+
let make c = Case c
1251
+
let tag (Case c) = map_tag c
1252
+
let value c v = Case_value (c, v)
1253
+
end
1254
+
1255
+
let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string =
1256
+
match map.shape with
1257
+
| Object_cases _ -> invalid_arg "Multiple calls to Json.Object.case_mem"
1258
+
| _ -> (
1259
+
match dec_absent with
1260
+
| None -> ()
1261
+
| Some tag ->
1262
+
(* Check that we have a case definition for it *)
1263
+
let equal_t (Case case) = tag_compare case.tag tag = 0 in
1264
+
if not (List.exists equal_t cases) then
1265
+
let tag =
1266
+
match tag_to_string with
1267
+
| None -> ""
1268
+
| Some tag_to_string -> " " ^ tag_to_string tag
1269
+
in
1270
+
invalid_arg ("No case for dec_absent case member value" ^ tag))
1271
+
1272
+
let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit =
1273
+
let id = Type.Id.make () in
1274
+
let enc t =
1275
+
t
1276
+
(* N.B. this fact may be used by encoders. *)
1277
+
in
1278
+
let enc_omit =
1279
+
match enc_omit with None -> Fun.const false | Some omit -> omit
1280
+
in
1281
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
1282
+
1283
+
let case_mem ?doc ?(tag_compare = Stdlib.compare) ?tag_to_string ?dec_absent
1284
+
?enc ?enc_omit ?enc_case name type' cases map =
1285
+
let () = check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string in
1286
+
let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in
1287
+
let enc = match enc with None -> Mem.no_enc name | Some e -> e in
1288
+
let enc_case =
1289
+
match enc_case with
1290
+
| Some enc_case -> enc_case
1291
+
| None ->
1292
+
fun _case ->
1293
+
Error.msgf Meta.none "No case encoder for member %a" pp_code name
1294
+
in
1295
+
let id = Type.Id.make () in
1296
+
let cases = { tag; tag_compare; tag_to_string; id; cases; enc; enc_case } in
1297
+
let dec = Dec_app (map.dec, id) in
1298
+
{ map with dec; shape = Object_cases (None, cases) }
1299
+
1300
+
(* Unknown members *)
1301
+
1302
+
module Mems = struct
1303
+
type ('mems, 'a) enc = {
1304
+
enc :
1305
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
1306
+
}
1307
+
1308
+
type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map
1309
+
1310
+
let mems_kind kind = Sort.kinded' ~kind "members map"
1311
+
1312
+
let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish ?enc
1313
+
mems_type =
1314
+
let dec_empty =
1315
+
match dec_empty with
1316
+
| Some dec_empty -> dec_empty
1317
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1318
+
in
1319
+
let dec_add =
1320
+
match dec_add with
1321
+
| Some dec_add -> dec_add
1322
+
| None ->
1323
+
fun _ _ _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1324
+
in
1325
+
let dec_finish =
1326
+
match dec_finish with
1327
+
| Some dec_finish -> dec_finish
1328
+
| None -> fun _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1329
+
in
1330
+
let enc =
1331
+
match enc with
1332
+
| Some { enc } -> enc
1333
+
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(mems_kind kind)
1334
+
in
1335
+
let id = Type.Id.make () in
1336
+
{ kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc }
1337
+
1338
+
let string_map ?kind ?doc type' =
1339
+
let dec_empty () = String_map.empty in
1340
+
let dec_add _meta n v mems = String_map.add n v mems in
1341
+
let dec_finish _meta mems = mems in
1342
+
let enc f mems acc =
1343
+
String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc
1344
+
in
1345
+
map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{ enc }
1346
+
end
1347
+
1348
+
let set_shape_unknown_mems shape u =
1349
+
match shape with
1350
+
| Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _) ->
1351
+
invalid_arg "Json.Object.keep_unknown already called on object"
1352
+
| Object_basic _ -> Object_basic u
1353
+
| Object_cases (_, cases) -> Object_cases (Some u, cases)
1354
+
1355
+
let skip_unknown map =
1356
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_skip }
1357
+
1358
+
let error_unknown map =
1359
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_error }
1360
+
1361
+
let mems_noenc (mems : (_, _, _) mems_map) _o =
1362
+
let kind = Sort.kinded' ~kind:mems.kind "members" in
1363
+
Error.no_encoder Meta.none ~kind
1364
+
1365
+
let keep_unknown ?enc mems (map : ('o, 'dec) object_map) =
1366
+
let enc = match enc with None -> mems_noenc mems | Some enc -> enc in
1367
+
let dec = Dec_app (map.dec, mems.id) in
1368
+
let unknown = Unknown_keep (mems, enc) in
1369
+
{ map with dec; shape = set_shape_unknown_mems map.shape unknown }
1370
+
1371
+
let zero = finish (map ~kind:"zero" ())
1372
+
1373
+
let as_string_map ?kind ?doc t =
1374
+
map ?kind ?doc Fun.id
1375
+
|> keep_unknown (Mems.string_map t) ~enc:Fun.id
1376
+
|> finish
1377
+
end
1378
+
1379
+
(* Ignoring *)
1380
+
1381
+
let ignore =
1382
+
let kind = "ignore" in
1383
+
let dec_null = Repr.Null Base.ignore and dec_bool = Repr.Bool Base.ignore in
1384
+
let dec_number = Repr.Number Base.ignore in
1385
+
let dec_string = Repr.String Base.ignore in
1386
+
let dec_array = Array.ignore and dec_object = Object.zero in
1387
+
let enc _v = Error.no_encoder Meta.none ~kind in
1388
+
any ~kind ~dec_null ~dec_bool ~dec_number ~dec_string ~dec_array ~dec_object
1389
+
~enc ()
1390
+
1391
+
let zero =
1392
+
let kind = "zero" in
1393
+
let null = null () and dec_bool = Repr.Bool Base.ignore in
1394
+
let dec_number = Repr.Number Base.ignore in
1395
+
let dec_string = Repr.String Base.ignore in
1396
+
let dec_array = Array.ignore and dec_object = Object.zero in
1397
+
let enc () = null in
1398
+
any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array
1399
+
~dec_object ~enc ()
1400
+
1401
+
let todo ?(kind = "") ?doc ?dec_stub () =
1402
+
let dec =
1403
+
match dec_stub with
1404
+
| Some v -> Fun.const v
1405
+
| None -> fun _v -> Error.decode_todo Meta.none ~kind_opt:kind
1406
+
in
1407
+
let enc _v = Error.encode_todo Meta.none ~kind_opt:kind in
1408
+
map ~kind ?doc ~dec ~enc ignore
1409
+
1410
+
(* Generic JSON *)
1411
+
1412
+
type name = string node
1413
+
1414
+
type mem = name * json
1415
+
and object' = mem list
1416
+
1417
+
and json =
1418
+
| Null of unit node
1419
+
| Bool of bool node
1420
+
| Number of float node
1421
+
| String of string node
1422
+
| Array of json list node
1423
+
| Object of object' node
1424
+
1425
+
let pp_null = Fmt.json_null
1426
+
let pp_bool = Fmt.json_bool
1427
+
let pp_string = Fmt.json_string
1428
+
let pp_number = Fmt.json_number
1429
+
let pp_number' = Fmt.json_number'
1430
+
1431
+
let pp_json' ?(number_format = Fmt.json_default_number_format) () ppf j =
1432
+
let pp_indent = 2 in
1433
+
let pp_sep ppf () =
1434
+
Format.pp_print_char ppf ',';
1435
+
Format.pp_print_break ppf 1 pp_indent
1436
+
in
1437
+
let rec pp_array ppf a =
1438
+
Format.pp_open_hovbox ppf 0;
1439
+
Format.pp_print_char ppf '[';
1440
+
Format.pp_print_break ppf 0 pp_indent;
1441
+
(Format.pp_print_list ~pp_sep pp_value) ppf a;
1442
+
Format.pp_print_break ppf 0 0;
1443
+
Format.pp_print_char ppf ']';
1444
+
Format.pp_close_box ppf ()
1445
+
and pp_mem ppf ((m, _), v) =
1446
+
Format.pp_open_hvbox ppf 0;
1447
+
pp_string ppf m;
1448
+
Format.pp_print_string ppf ": ";
1449
+
pp_value ppf v;
1450
+
Format.pp_close_box ppf ()
1451
+
and pp_obj ppf o =
1452
+
Format.pp_open_hvbox ppf 0;
1453
+
Format.pp_print_char ppf '{';
1454
+
Format.pp_print_break ppf 0 pp_indent;
1455
+
(Format.pp_print_list ~pp_sep pp_mem) ppf o;
1456
+
Format.pp_print_break ppf 0 0;
1457
+
Format.pp_print_char ppf '}';
1458
+
Format.pp_close_box ppf ()
1459
+
and pp_value ppf = function
1460
+
| Null _ -> pp_null ppf ()
1461
+
| Bool (b, _) -> pp_bool ppf b
1462
+
| Number (f, _) -> pp_number' number_format ppf f
1463
+
| String (s, _) -> pp_string ppf s
1464
+
| Array (a, _) -> pp_array ppf a
1465
+
| Object (o, _) -> pp_obj ppf o
1466
+
in
1467
+
pp_value ppf j
1468
+
1469
+
let pp_json ppf j = pp_json' () ppf j
1470
+
1471
+
(* Generic JSON *)
1472
+
1473
+
module Json = struct
1474
+
type 'a cons = ?meta:Meta.t -> 'a -> json
1475
+
type t = json
1476
+
1477
+
let meta = function
1478
+
| Null (_, m) -> m
1479
+
| Bool (_, m) -> m
1480
+
| Number (_, m) -> m
1481
+
| String (_, m) -> m
1482
+
| Array (_, m) -> m
1483
+
| Object (_, m) -> m
1484
+
1485
+
let set_meta m = function
1486
+
| Null (v, _) -> Null (v, m)
1487
+
| Bool (v, _) -> Bool (v, m)
1488
+
| Number (v, _) -> Number (v, m)
1489
+
| String (v, _) -> String (v, m)
1490
+
| Array (v, _) -> Array (v, m)
1491
+
| Object (v, _) -> Object (v, m)
1492
+
1493
+
let get_meta = meta
1494
+
let copy_layout v ~dst = set_meta (Meta.copy_ws (meta v) ~dst:(meta dst)) dst
1495
+
1496
+
let sort = function
1497
+
| Null _ -> Sort.Null
1498
+
| Bool _ -> Sort.Bool
1499
+
| Number _ -> Sort.Number
1500
+
| String _ -> Sort.String
1501
+
| Array _ -> Sort.Array
1502
+
| Object _ -> Sort.Object
1503
+
1504
+
let rec compare (j0 : json) (j1 : json) =
1505
+
match (j0, j1) with
1506
+
| Null ((), _), Null ((), _) -> 0
1507
+
| Null _, _ -> -1
1508
+
| _, Null _ -> 1
1509
+
| Bool (b0, _), Bool (b1, _) -> Bool.compare b0 b1
1510
+
| Bool _, _ -> -1
1511
+
| _, Bool _ -> 1
1512
+
| Number (f0, _), Number (f1, _) -> Float.compare f0 f1
1513
+
| Number _, _ -> -1
1514
+
| _, Number _ -> 1
1515
+
| String (s0, _), String (s1, _) -> String.compare s0 s1
1516
+
| String _, _ -> -1
1517
+
| _, String _ -> 1
1518
+
| Array (a0, _), Array (a1, _) -> List.compare compare a0 a1
1519
+
| Array _, _ -> -1
1520
+
| _, Array _ -> 1
1521
+
| Object (o0, _), Object (o1, _) ->
1522
+
let order_mem ((n0, _), _) ((n1, _), _) = String.compare n0 n1 in
1523
+
let compare_mem ((n0, _), j0) ((n1, _), j1) =
1524
+
let c = String.compare n0 n1 in
1525
+
if c = 0 then compare j0 j1 else c
1526
+
in
1527
+
List.compare compare_mem (List.sort order_mem o0)
1528
+
(List.sort order_mem o1)
1529
+
1530
+
let equal j0 j1 = compare j0 j1 = 0
1531
+
let pp = pp_json
1532
+
1533
+
(* Nulls and options *)
1534
+
1535
+
let null' = Null ((), Meta.none)
1536
+
let null ?(meta = Meta.none) () = Null ((), meta)
1537
+
let option c ?meta = function None -> null ?meta () | Some v -> c ?meta v
1538
+
1539
+
(* Booleans *)
1540
+
1541
+
let bool ?(meta = Meta.none) b = Bool (b, meta)
1542
+
1543
+
(* Numbers *)
1544
+
1545
+
let number ?(meta = Meta.none) n = Number (n, meta)
1546
+
1547
+
let any_float ?(meta = Meta.none) v =
1548
+
if Float.is_finite v then Number (v, meta)
1549
+
else String (Float.to_string v, meta)
1550
+
1551
+
let int32 ?(meta = Meta.none) v = Number (Int32.to_float v, meta)
1552
+
let int64_as_string ?(meta = Meta.none) v = String (Int64.to_string v, meta)
1553
+
1554
+
let int64 ?(meta = Meta.none) v =
1555
+
if Json_base.Number.can_store_exact_int64 v then
1556
+
Number (Int64.to_float v, meta)
1557
+
else String (Int64.to_string v, meta)
1558
+
1559
+
let int_as_string ?(meta = Meta.none) i = String (Int.to_string i, meta)
1560
+
1561
+
let int ?(meta = Meta.none) v =
1562
+
if Json_base.Number.can_store_exact_int v then Number (Int.to_float v, meta)
1563
+
else String (Int.to_string v, meta)
1564
+
1565
+
(* Strings *)
1566
+
1567
+
let string ?(meta = Meta.none) s = String (s, meta)
1568
+
1569
+
(* Arrays *)
1570
+
1571
+
let list ?(meta = Meta.none) l = Array (l, meta)
1572
+
let array ?(meta = Meta.none) a = Array (Stdlib.Array.to_list a, meta)
1573
+
let empty_array = list []
1574
+
1575
+
(* Objects *)
1576
+
1577
+
let name ?(meta = Meta.none) n = (n, meta)
1578
+
let mem n v = (n, v)
1579
+
let object' ?(meta = Meta.none) mems = Object (mems, meta)
1580
+
let empty_object = object' []
1581
+
1582
+
let rec find_mem n = function
1583
+
| [] -> None
1584
+
| (((n', _), _) as m) :: ms ->
1585
+
if String.equal n n' then Some m else find_mem n ms
1586
+
1587
+
let find_mem' (n, _) ms = find_mem n ms
1588
+
let object_names mems = List.map (fun ((n, _), _) -> n) mems
1589
+
let object_names' mems = List.map fst mems
1590
+
1591
+
(* Zero *)
1592
+
1593
+
let zero ?meta j =
1594
+
match sort j with
1595
+
| Null -> null ?meta ()
1596
+
| Bool -> bool ?meta false
1597
+
| Number -> number ?meta 0.
1598
+
| String -> string ?meta ""
1599
+
| Array -> list ?meta []
1600
+
| Object -> object' ?meta []
1601
+
1602
+
(* Converting *)
1603
+
1604
+
open Repr
1605
+
1606
+
let error_sort ~exp j = Error.sort (meta j) ~exp ~fnd:(sort j)
1607
+
1608
+
let error_type t fnd =
1609
+
Error.kinded_sort (meta fnd) ~exp:(kinded_sort t) ~fnd:(sort fnd)
1610
+
1611
+
let find_all_unexpected ~mem_decs mems =
1612
+
let unexpected (((n, _) as nm), _v) =
1613
+
match Repr.String_map.find_opt n mem_decs with
1614
+
| None -> Some nm
1615
+
| Some _ -> None
1616
+
in
1617
+
List.filter_map unexpected mems
1618
+
1619
+
(* Decoding *)
1620
+
1621
+
let rec decode : type a. a Repr.t -> json -> a =
1622
+
fun t j ->
1623
+
match t with
1624
+
| Null map -> (
1625
+
match j with Null (n, meta) -> map.dec meta n | j -> error_type t j)
1626
+
| Bool map -> (
1627
+
match j with Bool (b, meta) -> map.dec meta b | j -> error_type t j)
1628
+
| Number map -> (
1629
+
match j with
1630
+
| Number (n, meta) -> map.dec meta n
1631
+
| Null (_, meta) -> map.dec meta Float.nan
1632
+
| j -> error_type t j)
1633
+
| String map -> (
1634
+
match j with String (s, meta) -> map.dec meta s | j -> error_type t j)
1635
+
| Array map -> (
1636
+
match j with
1637
+
| Array (vs, meta) -> decode_array map meta vs
1638
+
| j -> error_type t j)
1639
+
| Object map -> (
1640
+
match j with
1641
+
| Object (mems, meta) -> decode_object map meta mems
1642
+
| j -> error_type t j)
1643
+
| Map map -> map.dec (decode map.dom j)
1644
+
| Any map -> decode_any t map j
1645
+
| Rec t -> decode (Lazy.force t) j
1646
+
1647
+
and decode_array : type a elt b.
1648
+
(a, elt, b) array_map -> Meta.t -> json list -> a =
1649
+
fun map meta vs ->
1650
+
let rec next (map : (a, elt, b) array_map) meta b i = function
1651
+
| [] -> map.dec_finish meta i b
1652
+
| v :: vs ->
1653
+
let b =
1654
+
try
1655
+
if map.dec_skip i b then b else map.dec_add i (decode map.elt v) b
1656
+
with Error e -> Repr.error_push_array meta map (i, get_meta v) e
1657
+
in
1658
+
next map meta b (i + 1) vs
1659
+
in
1660
+
next map meta (map.dec_empty ()) 0 vs
1661
+
1662
+
and decode_object : type o. (o, o) Object.map -> Meta.t -> object' -> o =
1663
+
fun map meta mems ->
1664
+
let dict = Dict.empty in
1665
+
let umems = Unknown_mems None in
1666
+
apply_dict map.dec
1667
+
@@ decode_object_map map meta umems String_map.empty String_map.empty dict
1668
+
mems
1669
+
1670
+
and decode_object_map : type o.
1671
+
(o, o) Object.map ->
1672
+
Meta.t ->
1673
+
unknown_mems_option ->
1674
+
mem_dec String_map.t ->
1675
+
mem_dec String_map.t ->
1676
+
Dict.t ->
1677
+
object' ->
1678
+
Dict.t =
1679
+
fun map meta umems mem_miss mem_decs dict mems ->
1680
+
let u _ _ _ = assert false in
1681
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
1682
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
1683
+
match map.shape with
1684
+
| Object_cases (umems', cases) ->
1685
+
let umems' = Unknown_mems umems' in
1686
+
let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in
1687
+
decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems
1688
+
| Object_basic umems' -> (
1689
+
let umems' = Unknown_mems (Some umems') in
1690
+
let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in
1691
+
match umems with
1692
+
| Unknown_mems (Some Unknown_skip | None) ->
1693
+
let umems = Unknown_skip in
1694
+
decode_object_basic map meta umems () mem_miss mem_decs dict mems
1695
+
| Unknown_mems (Some (Unknown_error as umems)) ->
1696
+
decode_object_basic map meta umems () mem_miss mem_decs dict mems
1697
+
| Unknown_mems (Some (Unknown_keep (umap, _) as umems)) ->
1698
+
let umap = umap.dec_empty () in
1699
+
decode_object_basic map meta umems umap mem_miss mem_decs dict mems)
1700
+
1701
+
and decode_object_basic : type o p m b.
1702
+
(o, o) object_map ->
1703
+
Meta.t ->
1704
+
(p, m, b) unknown_mems ->
1705
+
b ->
1706
+
mem_dec String_map.t ->
1707
+
mem_dec String_map.t ->
1708
+
Dict.t ->
1709
+
object' ->
1710
+
Dict.t =
1711
+
fun map meta umems umap mem_miss mem_decs dict -> function
1712
+
| [] -> Repr.finish_object_decode map meta umems umap mem_miss dict
1713
+
| (((n, nmeta) as nm), v) :: mems -> (
1714
+
match String_map.find_opt n mem_decs with
1715
+
| Some (Mem_dec m) ->
1716
+
let dict =
1717
+
try Dict.add m.id (decode m.type' v) dict
1718
+
with Error e -> Repr.error_push_object meta map nm e
1719
+
in
1720
+
let mem_miss = String_map.remove n mem_miss in
1721
+
decode_object_basic map meta umems umap mem_miss mem_decs dict mems
1722
+
| None -> (
1723
+
match umems with
1724
+
| Unknown_skip ->
1725
+
decode_object_basic map meta umems umap mem_miss mem_decs dict
1726
+
mems
1727
+
| Unknown_error ->
1728
+
let fnd = nm :: find_all_unexpected ~mem_decs mems in
1729
+
Repr.unexpected_mems_error meta map ~fnd
1730
+
| Unknown_keep (umap', _) ->
1731
+
let umap =
1732
+
try umap'.dec_add nmeta n (decode umap'.mems_type v) umap
1733
+
with Error e -> Repr.error_push_object meta map nm e
1734
+
in
1735
+
decode_object_basic map meta umems umap mem_miss mem_decs dict
1736
+
mems))
1737
+
1738
+
and decode_object_cases : type o cs t.
1739
+
(o, o) object_map ->
1740
+
Meta.t ->
1741
+
unknown_mems_option ->
1742
+
(o, cs, t) object_cases ->
1743
+
mem_dec String_map.t ->
1744
+
mem_dec String_map.t ->
1745
+
Dict.t ->
1746
+
object' ->
1747
+
object' ->
1748
+
Dict.t =
1749
+
fun map meta umems cases mem_miss mem_decs dict delay mems ->
1750
+
let decode_case_tag map meta tag delay mems =
1751
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
1752
+
match List.find_opt eq_tag cases.cases with
1753
+
| None -> Repr.unexpected_case_tag_error meta map cases tag
1754
+
| Some (Case case) ->
1755
+
let mems = List.rev_append delay mems in
1756
+
let dict =
1757
+
decode_object_map case.object_map meta umems mem_miss mem_decs dict
1758
+
mems
1759
+
in
1760
+
Dict.add cases.id
1761
+
(case.dec (apply_dict case.object_map.dec dict))
1762
+
dict
1763
+
in
1764
+
match mems with
1765
+
| [] -> (
1766
+
match cases.tag.dec_absent with
1767
+
| Some tag -> decode_case_tag map meta tag delay []
1768
+
| None ->
1769
+
let kinded_sort = Repr.object_map_kinded_sort map in
1770
+
Error.missing_mems meta ~kinded_sort ~exp:[ cases.tag.name ]
1771
+
~fnd:(List.map (fun ((n, _), _) -> n) delay))
1772
+
| ((((n, meta) as nm), v) as mem) :: mems -> (
1773
+
if n = cases.tag.name then
1774
+
let tag =
1775
+
try decode cases.tag.type' v
1776
+
with Error e -> Repr.error_push_object meta map nm e
1777
+
in
1778
+
decode_case_tag map meta tag delay mems
1779
+
else
1780
+
match String_map.find_opt n mem_decs with
1781
+
| None ->
1782
+
let delay = mem :: delay in
1783
+
decode_object_cases map meta umems cases mem_miss mem_decs dict
1784
+
delay mems
1785
+
| Some (Mem_dec m) ->
1786
+
let dict =
1787
+
try Dict.add m.id (decode m.type' v) dict
1788
+
with Error e -> Repr.error_push_object meta map nm e
1789
+
in
1790
+
let mem_miss = String_map.remove n mem_miss in
1791
+
decode_object_cases map meta umems cases mem_miss mem_decs dict
1792
+
delay mems)
1793
+
1794
+
and decode_any : type a. a Repr.t -> a any_map -> json -> a =
1795
+
fun t map j ->
1796
+
let dec t map j =
1797
+
match map with Some t -> decode t j | None -> error_type t j
1798
+
in
1799
+
match j with
1800
+
| Null _ -> dec t map.dec_null j
1801
+
| Bool _ -> dec t map.dec_bool j
1802
+
| Number _ -> dec t map.dec_number j
1803
+
| String _ -> dec t map.dec_string j
1804
+
| Array _ -> dec t map.dec_array j
1805
+
| Object _ -> dec t map.dec_object j
1806
+
1807
+
let dec = decode
1808
+
let decode' t j = try Ok (decode t j) with Error e -> Result.Error e
1809
+
let decode t j = Result.map_error Error.to_string (decode' t j)
1810
+
1811
+
(* Encode *)
1812
+
1813
+
let rec encode : type a. a Repr.t -> a -> json =
1814
+
fun t v ->
1815
+
match t with
1816
+
| Null map -> null ~meta:(map.enc_meta v) (map.enc v)
1817
+
| Bool map -> bool ~meta:(map.enc_meta v) (map.enc v)
1818
+
| Number map -> number ~meta:(map.enc_meta v) (map.enc v)
1819
+
| String map -> string ~meta:(map.enc_meta v) (map.enc v)
1820
+
| Array map ->
1821
+
let enc map acc i elt =
1822
+
try encode map.elt elt :: acc
1823
+
with Error e -> Repr.error_push_array Meta.none map (i, Meta.none) e
1824
+
in
1825
+
list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v))
1826
+
| Object map ->
1827
+
let mems = encode_object map ~do_unknown:true v [] in
1828
+
Object (List.rev mems, map.enc_meta v)
1829
+
| Any map -> encode (map.enc v) v
1830
+
| Map map -> encode map.dom (map.enc v)
1831
+
| Rec t -> encode (Lazy.force t) v
1832
+
1833
+
and encode_object : type o dec.
1834
+
(o, o) object_map -> do_unknown:bool -> o -> object' -> object' =
1835
+
fun map ~do_unknown o obj ->
1836
+
let encode_mem map obj (Mem_enc mmap) =
1837
+
try
1838
+
let v = mmap.enc o in
1839
+
if mmap.enc_omit v then obj
1840
+
else ((mmap.name, Meta.none), encode mmap.type' v) :: obj
1841
+
with Error e ->
1842
+
Repr.error_push_object Meta.none map (mmap.name, Meta.none) e
1843
+
in
1844
+
let obj = List.fold_left (encode_mem map) obj map.mem_encs in
1845
+
match map.shape with
1846
+
| Object_basic (Unknown_keep (umap, enc)) when do_unknown ->
1847
+
encode_unknown_mems map umap (enc o) obj
1848
+
| Object_basic _ -> obj
1849
+
| Object_cases (u, cases) -> (
1850
+
let (Case_value (case, c)) = cases.enc_case (cases.enc o) in
1851
+
let obj =
1852
+
let n = (cases.tag.name, Meta.none) in
1853
+
try
1854
+
if cases.tag.enc_omit case.tag then obj
1855
+
else (n, encode cases.tag.type' case.tag) :: obj
1856
+
with Error e -> Repr.error_push_object Meta.none map n e
1857
+
in
1858
+
match u with
1859
+
| Some (Unknown_keep (umap, enc)) ->
1860
+
(* Less T.R. but feels nicer to encode unknowns at the end *)
1861
+
let obj = encode_object case.object_map ~do_unknown:false c obj in
1862
+
encode_unknown_mems map umap (enc o) obj
1863
+
| _ -> encode_object case.object_map ~do_unknown c obj)
1864
+
1865
+
and encode_unknown_mems : type o dec mems a builder.
1866
+
(o, o) object_map ->
1867
+
(mems, a, builder) mems_map ->
1868
+
mems ->
1869
+
object' ->
1870
+
object' =
1871
+
fun map umap mems obj ->
1872
+
let encode_mem map meta name v obj =
1873
+
let n = (name, meta) in
1874
+
let v =
1875
+
try encode umap.mems_type v
1876
+
with Error e -> Repr.error_push_object Meta.none map n e
1877
+
in
1878
+
(n, v) :: obj
1879
+
in
1880
+
umap.enc (encode_mem map) mems obj
1881
+
1882
+
let enc = encode
1883
+
let encode' t v = try Ok (encode t v) with Error e -> Result.Error e
1884
+
let encode t v = Result.map_error Error.to_string (encode' t v)
1885
+
1886
+
(* Recode *)
1887
+
1888
+
let update t v = enc t (dec t v)
1889
+
let recode' t v = try Ok (update t v) with Error e -> Result.Error e
1890
+
let recode t v = Result.map_error Error.to_string (recode' t v)
1891
+
end
1892
+
1893
+
let json_null =
1894
+
let dec meta () = Json.null ~meta () in
1895
+
let enc = function
1896
+
| Null ((), _) -> ()
1897
+
| j -> Json.error_sort ~exp:Sort.Null j
1898
+
in
1899
+
Repr.Null (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1900
+
1901
+
let json_bool =
1902
+
let dec meta b = Json.bool ~meta b in
1903
+
let enc = function
1904
+
| Bool (b, _) -> b
1905
+
| j -> Json.error_sort ~exp:Sort.Bool j
1906
+
in
1907
+
Repr.Bool (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1908
+
1909
+
let json_number =
1910
+
let dec meta n = Json.number ~meta n in
1911
+
let enc = function
1912
+
| Number (n, _) -> n
1913
+
| j -> Json.error_sort ~exp:Sort.Number j
1914
+
in
1915
+
Repr.Number (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1916
+
1917
+
let json_string =
1918
+
let dec meta s = Json.string ~meta s in
1919
+
let enc = function
1920
+
| String (s, _) -> s
1921
+
| j -> Json.error_sort ~exp:Sort.String j
1922
+
in
1923
+
Repr.String (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1924
+
1925
+
let json, json_array, mem_list, json_object =
1926
+
let rec elt = Repr.Rec any
1927
+
and array_map =
1928
+
lazy begin
1929
+
let dec_empty () = [] in
1930
+
let dec_add _i v a = v :: a in
1931
+
let dec_finish meta _len a = Json.list ~meta (List.rev a) in
1932
+
let enc f acc = function
1933
+
| Array (a, _) -> Array.list_enc f acc a
1934
+
| j -> Json.error_sort ~exp:Sort.Array j
1935
+
in
1936
+
let enc = { Array.enc } in
1937
+
Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Json.meta elt
1938
+
end
1939
+
and array = lazy (Array.array (Lazy.force array_map))
1940
+
and mems =
1941
+
lazy begin
1942
+
let dec_empty () = [] in
1943
+
let dec_add meta n v mems = ((n, meta), v) :: mems in
1944
+
let dec_finish _meta mems = List.rev mems in
1945
+
let enc f l a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
1946
+
let enc = { Object.Mems.enc } in
1947
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc elt
1948
+
end
1949
+
and object' =
1950
+
lazy begin
1951
+
let enc_meta = function
1952
+
| Object (_, meta) -> meta
1953
+
| j -> Json.error_sort ~exp:Sort.Object j
1954
+
in
1955
+
let enc = function
1956
+
| Object (mems, _) -> mems
1957
+
| j -> Json.error_sort ~exp:Sort.Object j
1958
+
in
1959
+
let dec meta mems = Object (mems, meta) in
1960
+
Object.map' dec ~enc_meta
1961
+
|> Object.keep_unknown (Lazy.force mems) ~enc
1962
+
|> Object.finish
1963
+
end
1964
+
and any =
1965
+
lazy begin
1966
+
let json_array = Lazy.force array in
1967
+
let json_object = Lazy.force object' in
1968
+
let enc = function
1969
+
| Null _ -> json_null
1970
+
| Bool _ -> json_bool
1971
+
| Number _ -> json_number
1972
+
| String _ -> json_string
1973
+
| Array _ -> json_array
1974
+
| Object _ -> json_object
1975
+
in
1976
+
Repr.Any
1977
+
{
1978
+
kind = "json";
1979
+
doc = "";
1980
+
dec_null = Some json_null;
1981
+
dec_bool = Some json_bool;
1982
+
dec_number = Some json_number;
1983
+
dec_string = Some json_string;
1984
+
dec_array = Some json_array;
1985
+
dec_object = Some json_object;
1986
+
enc;
1987
+
}
1988
+
end
1989
+
in
1990
+
(Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object')
1991
+
1992
+
let json_mems =
1993
+
let dec_empty () = [] in
1994
+
let dec_add meta name v mems = ((name, meta), v) :: mems in
1995
+
let dec_finish meta mems = Object (List.rev mems, meta) in
1996
+
let enc f j acc =
1997
+
match j with
1998
+
| Object (ms, _) ->
1999
+
List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms
2000
+
| j -> Json.error_sort ~exp:Sort.Object j
2001
+
in
2002
+
let enc = { Object.Mems.enc } in
2003
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
2004
+
2005
+
(* Queries and updates *)
2006
+
2007
+
(* val app : ('a -> 'b) t -> 'a t -> 'b t
2008
+
val product : 'a t -> 'b t -> ('a * 'b) t
2009
+
val bind : 'a t -> ('a -> 'b t) -> 'b t
2010
+
val map : ('a -> 'b) -> 'a t -> 'b t *)
2011
+
2012
+
let const t v =
2013
+
let const _ = v in
2014
+
let dec = map ~dec:const ignore in
2015
+
let enc = map ~enc:const t in
2016
+
let enc _v = enc in
2017
+
any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec ~dec_array:dec
2018
+
~dec_object:dec ~enc ()
2019
+
2020
+
let recode ~dec:dom f ~enc =
2021
+
let m = map ~dec:f dom in
2022
+
let enc _v = enc in
2023
+
any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m
2024
+
~dec_object:m ~enc ()
2025
+
2026
+
let update t =
2027
+
let dec v = Json.update t v in
2028
+
Repr.Map { kind = ""; doc = ""; dom = json; dec; enc = Fun.id }
2029
+
2030
+
(* Array queries *)
2031
+
2032
+
let rec list_repeat n v l = if n <= 0 then l else list_repeat (n - 1) v (v :: l)
2033
+
2034
+
let nth ?absent n t =
2035
+
let dec_empty () = None in
2036
+
let dec_skip i _v = i <> n in
2037
+
let dec_add _i v _acc = Some v in
2038
+
let dec_finish meta len v =
2039
+
match v with
2040
+
| Some v -> v
2041
+
| None -> (
2042
+
match absent with
2043
+
| Some v -> v
2044
+
| None -> Error.index_out_of_range meta ~n ~len)
2045
+
in
2046
+
let enc f acc v = f acc 0 v in
2047
+
let enc = { Array.enc } in
2048
+
Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t)
2049
+
2050
+
let update_nth ?stub ?absent n t =
2051
+
let update_elt n t v = Json.copy_layout v ~dst:(Json.update t v) in
2052
+
let rec update_array ~seen n t i acc = function
2053
+
| v :: vs when i = n ->
2054
+
let elt = update_elt (i, Json.meta v) t v in
2055
+
update_array ~seen:true n t (i + 1) (elt :: acc) vs
2056
+
| v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs
2057
+
| [] when seen -> Either.Right (List.rev acc)
2058
+
| [] -> Either.Left (acc, i)
2059
+
in
2060
+
let update ?stub ?absent n t j =
2061
+
match j with
2062
+
| Array (vs, meta) ->
2063
+
begin match update_array ~seen:false n t 0 [] vs with
2064
+
| Either.Right elts -> Array (elts, meta)
2065
+
| Either.Left (acc, len) -> (
2066
+
match absent with
2067
+
| None -> Error.index_out_of_range meta ~n ~len
2068
+
| Some absent ->
2069
+
let elt = Json.enc t absent in
2070
+
let stub =
2071
+
match stub with None -> Json.zero elt | Some j -> j
2072
+
in
2073
+
Array (List.rev (elt :: list_repeat (n - len) stub acc), meta))
2074
+
end
2075
+
| j -> Json.error_sort ~exp:Sort.Array j
2076
+
in
2077
+
let dec = update ?stub ?absent n t in
2078
+
let enc j = j in
2079
+
map ~dec ~enc json
2080
+
2081
+
let set_nth ?stub ?(allow_absent = false) t n v =
2082
+
let absent = if allow_absent then Some v else None in
2083
+
update_nth ?stub ?absent n (const t v)
2084
+
2085
+
let delete_nth ?(allow_absent = false) n =
2086
+
let dec_empty () = [] in
2087
+
let dec_add i v a = if i = n then a else v :: a in
2088
+
let dec_finish meta len a =
2089
+
if n < len || allow_absent then Json.list ~meta (List.rev a)
2090
+
else Error.index_out_of_range meta ~n ~len
2091
+
in
2092
+
let enc f acc = function
2093
+
| Array (a, _) -> Array.list_enc f acc a
2094
+
| j -> Json.error_sort ~exp:Sort.Array j
2095
+
in
2096
+
let enc_meta j = Json.meta j in
2097
+
let enc = { Array.enc } in
2098
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
2099
+
2100
+
let filter_map_array a b f =
2101
+
let dec_empty () = [] in
2102
+
let dec_add i v acc =
2103
+
match f i (Json.dec a v) with
2104
+
| None -> acc
2105
+
| Some v' -> Json.enc b v' :: acc
2106
+
in
2107
+
let dec_finish meta _len acc = Json.list ~meta (List.rev acc) in
2108
+
let enc f acc = function
2109
+
| Array (a, _) -> Array.list_enc f acc a
2110
+
| j -> Json.error_sort ~exp:Sort.Array j
2111
+
in
2112
+
let enc = { Array.enc } in
2113
+
let enc_meta j = Json.meta j in
2114
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
2115
+
2116
+
let fold_array t f acc =
2117
+
let dec_empty () = acc in
2118
+
let dec_add = f in
2119
+
let dec_finish _meta _len acc = acc in
2120
+
let enc _f acc _a = acc in
2121
+
let enc = { Array.enc } in
2122
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t)
2123
+
2124
+
(* Object queries *)
2125
+
2126
+
let mem ?absent name t =
2127
+
Object.map Fun.id
2128
+
|> Object.mem name t ~enc:Fun.id ?dec_absent:absent
2129
+
|> Object.finish
2130
+
2131
+
let update_mem ?absent name t =
2132
+
let update_mem n t v = (n, Json.copy_layout v ~dst:(Json.update t v)) in
2133
+
let rec update_object ~seen name t acc = function
2134
+
| (((name', _) as n), v) :: mems when String.equal name name' ->
2135
+
update_object ~seen:true name t (update_mem n t v :: acc) mems
2136
+
| mem :: mems -> update_object ~seen name t (mem :: acc) mems
2137
+
| [] when seen -> Either.Right (List.rev acc)
2138
+
| [] -> Either.Left acc
2139
+
in
2140
+
let update ?absent name t = function
2141
+
| Object (mems, meta) ->
2142
+
let mems =
2143
+
match update_object ~seen:false name t [] mems with
2144
+
| Either.Right mems -> mems
2145
+
| Either.Left acc -> (
2146
+
match absent with
2147
+
| None ->
2148
+
let fnd = Json.object_names mems in
2149
+
Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
2150
+
| Some absent ->
2151
+
let m = ((name, Meta.none), Json.enc t absent) in
2152
+
List.rev (m :: acc))
2153
+
in
2154
+
Object (mems, meta)
2155
+
| j -> Json.error_sort ~exp:Sort.Object j
2156
+
in
2157
+
let update = update ?absent name t in
2158
+
let enc j = j in
2159
+
map ~dec:update ~enc json
2160
+
2161
+
let set_mem ?(allow_absent = false) t name v =
2162
+
let absent = if allow_absent then Some v else None in
2163
+
update_mem ?absent name (const t v)
2164
+
2165
+
let update_json_object ~name ~dec_add ~dec_finish =
2166
+
let mems =
2167
+
let dec_empty () = (false, []) in
2168
+
let enc f (_, l) a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
2169
+
let enc = { Object.Mems.enc } in
2170
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
2171
+
in
2172
+
let enc_meta = function
2173
+
| Object (_, meta) -> meta
2174
+
| j -> Json.error_sort ~exp:Sort.Object j
2175
+
in
2176
+
let enc = function
2177
+
| Object (mems, _) -> (false, mems)
2178
+
| j -> Json.error_sort ~exp:Sort.Object j
2179
+
in
2180
+
let dec meta (ok, mems) =
2181
+
let fnd = Json.object_names mems in
2182
+
if not ok then Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd
2183
+
else Object (List.rev mems, meta)
2184
+
in
2185
+
Object.map' dec ~enc_meta |> Object.keep_unknown mems ~enc |> Object.finish
2186
+
2187
+
let delete_mem ?(allow_absent = false) name =
2188
+
let dec_add meta n v (ok, mems) =
2189
+
if n = name then (true, mems) else (ok, ((n, meta), v) :: mems)
2190
+
in
2191
+
let dec_finish _meta ((ok, ms) as a) =
2192
+
if allow_absent then (true, ms) else a
2193
+
in
2194
+
update_json_object ~name ~dec_add ~dec_finish
2195
+
2196
+
let fold_object t f acc =
2197
+
let mems =
2198
+
let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in
2199
+
let enc f _ acc = acc in
2200
+
Object.Mems.map t ~dec_empty ~dec_add ~dec_finish ~enc:{ Object.Mems.enc }
2201
+
in
2202
+
Object.map Fun.id |> Object.keep_unknown mems ~enc:Fun.id |> Object.finish
2203
+
2204
+
let filter_map_object a b f =
2205
+
let dec_add meta n v (_, mems) =
2206
+
match f meta n (Json.dec a v) with
2207
+
| None -> (true, mems)
2208
+
| Some (n', v') -> (true, (n', Json.enc b v') :: mems)
2209
+
in
2210
+
let dec_finish _meta acc = acc in
2211
+
update_json_object ~name:"" (* irrelevant *) ~dec_add ~dec_finish
2212
+
2213
+
(* Index queries *)
2214
+
2215
+
let index ?absent i t =
2216
+
match i with
2217
+
| Path.Nth (n, _) -> nth ?absent n t
2218
+
| Path.Mem (n, _) -> mem ?absent n t
2219
+
2220
+
let set_index ?allow_absent t i v =
2221
+
match i with
2222
+
| Path.Nth (n, _) -> set_nth ?allow_absent t n v
2223
+
| Path.Mem (n, _) -> set_mem ?allow_absent t n v
2224
+
2225
+
let update_index ?stub ?absent i t =
2226
+
match i with
2227
+
| Path.Nth (n, _) -> update_nth ?stub ?absent n t
2228
+
| Path.Mem (n, _) -> update_mem ?absent n t
2229
+
2230
+
let delete_index ?allow_absent = function
2231
+
| Path.Nth (n, _) -> delete_nth ?allow_absent n
2232
+
| Path.Mem (n, _) -> delete_mem ?allow_absent n
2233
+
2234
+
(* Path queries *)
2235
+
2236
+
let path ?absent p q =
2237
+
List.fold_left (fun q i -> index ?absent i q) q (Path.rev_indices p)
2238
+
2239
+
let update_path ?stub ?absent p t =
2240
+
match Path.rev_indices p with
2241
+
| [] -> update t
2242
+
| i :: is -> (
2243
+
match absent with
2244
+
| None ->
2245
+
let update t i = update_index i t in
2246
+
List.fold_left update (update_index i t) is
2247
+
| Some absent -> (
2248
+
let rec loop absent t = function
2249
+
| Path.Nth (n, _) :: is ->
2250
+
loop Json.empty_array (update_nth ~absent n t) is
2251
+
| Path.Mem (n, _) :: is ->
2252
+
loop Json.empty_object (update_mem ~absent n t) is
2253
+
| [] -> t
2254
+
in
2255
+
match i with
2256
+
| Path.Nth (n, _) ->
2257
+
loop Json.empty_array (update_nth ?stub ~absent n t) is
2258
+
| Path.Mem (n, _) ->
2259
+
loop Json.empty_object (update_mem ~absent n t) is))
2260
+
2261
+
let delete_path ?allow_absent p =
2262
+
match Path.rev_indices p with
2263
+
| [] -> recode ~dec:ignore (fun () -> Json.null') ~enc:json
2264
+
| i :: is ->
2265
+
let upd del i = update_index i del in
2266
+
List.fold_left upd (delete_index ?allow_absent i) is
2267
+
2268
+
let set_path ?stub ?(allow_absent = false) t p v =
2269
+
match Path.rev_indices p with
2270
+
| [] -> recode ~dec:ignore (fun () -> Json.enc t v) ~enc:json
2271
+
| i :: is ->
2272
+
let absent = if allow_absent then Some v else None in
2273
+
update_path ?stub ?absent p (const t v)
2274
+
2275
+
(* Formatting *)
2276
+
2277
+
type format = Minify | Indent | Layout
2278
+
type number_format = Fmt.json_number_format
2279
+
2280
+
let default_number_format = Fmt.json_default_number_format
2281
+
2282
+
let pp_value ?number_format t () =
2283
+
fun ppf v ->
2284
+
match Json.encode t v with
2285
+
| Ok j -> pp_json' ?number_format () ppf j
2286
+
| Error e -> pp_string ppf e
+2077
lib/json.mli
+2077
lib/json.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Types for JSON values.
7
+
8
+
This module provides a type for describing subsets of JSON values as
9
+
bidirectional maps with arbitrary OCaml values. We call these values
10
+
{e JSON types}.
11
+
12
+
In these maps the {e decoding} direction maps from JSON values to OCaml
13
+
values and the {e encoding} direction maps from OCaml values to JSON values.
14
+
Depending on your needs, one direction or the other can be left unspecified.
15
+
Some of the decoding maps may be lossy or creative which leads to JSON
16
+
queries and transforms.
17
+
18
+
Read the {{!page-index.quick_start}quick start} and the
19
+
{{!page-cookbook}cookbook}. *)
20
+
21
+
(** {1:preliminaries Preliminaries} *)
22
+
23
+
type 'a fmt = Format.formatter -> 'a -> unit
24
+
(** The type for formatters of values of type ['a]. *)
25
+
26
+
(** Text locations.
27
+
28
+
A text location identifies a text span in a given UTF-8 encoded file by an
29
+
inclusive range of absolute {{!Textloc.type-byte_pos}byte} positions and the
30
+
{{!Textloc.type-line_pos}line positions} on which those occur. *)
31
+
module Textloc : sig
32
+
(** {1:fpath File paths} *)
33
+
34
+
type fpath = string
35
+
(** The type for file paths. *)
36
+
37
+
val file_none : fpath
38
+
(** [file_none] is ["-"]. A file path to use when there is none. *)
39
+
40
+
(** {1:pos Positions} *)
41
+
42
+
(** {2:byte_pos Byte positions} *)
43
+
44
+
type byte_pos = int
45
+
(** The type for zero-based, absolute, byte positions in text. If the text has
46
+
[n] bytes, [0] is the first position and [n-1] is the last position. *)
47
+
48
+
val byte_pos_none : byte_pos
49
+
(** [byte_pos_none] is [-1]. A position to use when there is none. *)
50
+
51
+
(** {2:lines Lines} *)
52
+
53
+
type line_num = int
54
+
(** The type for one-based, line numbers in the text. Lines increment after a
55
+
{e newline} which is either a line feed ['\n'] (U+000A), a carriage return
56
+
['\r'] (U+000D) or a carriage return and a line feed ["\r\n"]
57
+
(<U+000D,U+000A>). *)
58
+
59
+
val line_num_none : line_num
60
+
(** [line_num_none] is [-1]. A line number to use when there is none. *)
61
+
62
+
(** {2:line_pos Line positions} *)
63
+
64
+
type line_pos = line_num * byte_pos
65
+
(** The type for line positions. This identifies a line by its line number and
66
+
the absolute byte position following its newline (or the start of text for
67
+
the first line). That byte position:
68
+
- Indexes the first byte of text of the line if the line is non-empty.
69
+
- Indexes the first byte of the next {e newline} sequence if the line is
70
+
empty.
71
+
- Is out of bounds and equal to the text's length for a last empty line.
72
+
This is also the case on empty text. *)
73
+
74
+
val line_pos_first : line_pos
75
+
(** [line_pos_first] is [1, 0]. Note that this is the only line position of
76
+
the empty text. *)
77
+
78
+
val line_pos_none : line_pos
79
+
(** [line_pos_none] is [(line_pos_none, pos_pos_none)]. *)
80
+
81
+
(** {1:tloc Text locations} *)
82
+
83
+
type t
84
+
(** The type for text locations. A text location identifies a text span in an
85
+
UTF-8 encoded file by an inclusive range of absolute
86
+
{{!type-byte_pos}byte positions} and the {{!type-line_pos}line positions}
87
+
on which they occur.
88
+
89
+
If the first byte equals the last byte the range contains exactly that
90
+
byte. If the first byte is greater than the last byte this represents an
91
+
insertion point before the first byte. In this case information about the
92
+
last position should be ignored: it can contain anything. *)
93
+
94
+
val none : t
95
+
(** [none] is a position to use when there is none. *)
96
+
97
+
val make :
98
+
file:fpath ->
99
+
first_byte:byte_pos ->
100
+
last_byte:byte_pos ->
101
+
first_line:line_pos ->
102
+
last_line:line_pos ->
103
+
t
104
+
(** [v ~file ~first_byte ~last_byte ~first_line ~last_line] is a text location
105
+
with the given arguments, see corresponding accessors for the semantics.
106
+
If you don't have a file use {!file_none}. *)
107
+
108
+
val file : t -> fpath
109
+
(** [file l] is [l]'s file. *)
110
+
111
+
val set_file : t -> fpath -> t
112
+
(** [set_file l file] is [l] with {!file} set to [file]. *)
113
+
114
+
val first_byte : t -> byte_pos
115
+
(** [first_byte l] is [l]'s first byte. Irrelevant if {!is_none} is [true]. *)
116
+
117
+
val last_byte : t -> byte_pos
118
+
(** [last_byte l] is [l]'s last byte. Irrelevant if {!is_none} or {!is_empty}
119
+
is [true]. *)
120
+
121
+
val first_line : t -> line_pos
122
+
(** [first_line l] is the line position on which [first_byte l] lies.
123
+
Irrelevant if {!is_none} is [true].*)
124
+
125
+
val last_line : t -> line_pos
126
+
(** [last_line l] is the line position on which [last_byte l] lies. Irrelevant
127
+
if {!is_none} or {!is_empty} is [true].*)
128
+
129
+
(** {2:preds Predicates and comparisons} *)
130
+
131
+
val is_none : t -> bool
132
+
(** [is_none t] is [true] iff [first_byte < 0]. *)
133
+
134
+
val is_empty : t -> bool
135
+
(** [is_empty t] is [true] iff [first_byte t > last_byte t]. *)
136
+
137
+
val equal : t -> t -> bool
138
+
(** [equal t0 t1] is [true] iff [t0] and [t1] are equal. This checks that
139
+
{!file}, {!first_byte} and {!last_byte} are equal. Line information is
140
+
ignored. *)
141
+
142
+
val compare : t -> t -> int
143
+
(** [compare t0 t1] orders [t0] and [t1]. The order is compatible with
144
+
{!equal}. Comparison starts with {!file}, follows with {!first_byte} and
145
+
ends, if needed, with {!last_byte}. Line information is ignored. *)
146
+
147
+
(** {2:shrink_and_stretch Shrink and stretch} *)
148
+
149
+
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
150
+
(** [set_first l ~first_byte ~first_line] sets the the first position of [l]
151
+
to given values. *)
152
+
153
+
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
154
+
(** [set_last l ~last_byte ~last_line] sets the last position of [l] to given
155
+
values. *)
156
+
157
+
val to_first : t -> t
158
+
(** [to_first l] has both first and last positions set to [l]'s first
159
+
position. The range spans {!first_byte}. See also {!before}. *)
160
+
161
+
val to_last : t -> t
162
+
(** [to_last l] has both first and last positions set to [l]'s last position.
163
+
The range spans {!last_byte}. See also {!after}. *)
164
+
165
+
val before : t -> t
166
+
(** [before t] is the {{!is_empty}empty} text location starting at
167
+
{!first_byte}. *)
168
+
169
+
val after : t -> t
170
+
(** [after t] is the empty {{!is_empty}empty} location starting at
171
+
[last_byte t + 1]; note that at the end of input this may be an invalid
172
+
byte {e index}. The {!first_line} and {!last_line} of the result is
173
+
[last_line t]. *)
174
+
175
+
val span : t -> t -> t
176
+
(** [span l0 l1] is the span from the smallest byte position of [l0] and [l1]
177
+
to the largest byte position of [l0] and [l1]. The file path is taken from
178
+
the greatest byte position. *)
179
+
180
+
val reloc : first:t -> last:t -> t
181
+
(** [reloc ~first ~last] uses the first position of [first], the last position
182
+
of [last] and the file of [last]. *)
183
+
184
+
(** {2:fmt Formatting} *)
185
+
186
+
val pp_ocaml : Format.formatter -> t -> unit
187
+
(** [pp_ocaml] formats text locations like the OCaml compiler. *)
188
+
189
+
val pp_gnu : Format.formatter -> t -> unit
190
+
(** [pp_gnu] formats text locations according to the
191
+
{{:https://www.gnu.org/prep/standards/standards.html#Errors}GNU
192
+
convention}. *)
193
+
194
+
val pp : Format.formatter -> t -> unit
195
+
(** [pp] is {!pp_ocaml}. *)
196
+
197
+
val pp_dump : Format.formatter -> t -> unit
198
+
(** [pp_dump] formats raw data for debugging. *)
199
+
end
200
+
201
+
(** Abstract syntax tree node metadata.
202
+
203
+
This type keeps information about source text locations and whitespace. *)
204
+
module Meta : sig
205
+
type t
206
+
(** The type for node metadata. *)
207
+
208
+
val make : ?ws_before:string -> ?ws_after:string -> Textloc.t -> t
209
+
(** [make textloc ~ws_before ~ws_after] is metadata with text location
210
+
[textloc] whitespace [ws_before] before the node and [ws_after] after the
211
+
node. Both default to [""]. *)
212
+
213
+
val none : t
214
+
(** [none] is metadata for when there is none. Its {!textloc} is
215
+
{!Textloc.none} and its whitespace is empty. *)
216
+
217
+
val is_none : t -> bool
218
+
(** [is_none m] is [true] iff [m] is {!none}. *)
219
+
220
+
val textloc : t -> Textloc.t
221
+
(** [textloc m] is the text location of [m]. *)
222
+
223
+
val ws_before : t -> string
224
+
(** [ws_before m] is source whitespace before the node. *)
225
+
226
+
val ws_after : t -> string
227
+
(** [ws_after m] is source whitespace after the node. *)
228
+
229
+
val with_textloc : t -> Textloc.t -> t
230
+
(** [with_textloc m l] is [m] with text location [l] *)
231
+
232
+
val clear_ws : t -> t
233
+
(** [clear_ws m] is [m] with {!ws_before} and {!ws_after} set to [""]. *)
234
+
235
+
val clear_textloc : t -> t
236
+
(** [clear_textloc m] is [m] with {!textloc} set to {!Textloc.none}. *)
237
+
238
+
val copy_ws : t -> dst:t -> t
239
+
(** [copy_ws src ~dst] copies {!ws_before} and {!ws_after} of [src] to [dst].
240
+
*)
241
+
end
242
+
243
+
type 'a node = 'a * Meta.t
244
+
(** The type for abstract syntax tree nodes. The node data of type ['a] and its
245
+
metadata. *)
246
+
247
+
(** JSON paths.
248
+
249
+
Paths are used for keeping track of erroring {{!Error.Context.t}contexts}
250
+
and for specifying {{!Json.queries} query and update} locations. *)
251
+
module Path : sig
252
+
(** {1:indices Indices} *)
253
+
254
+
(** The type for indexing operations on JSON values. *)
255
+
type index =
256
+
| Mem of string node
257
+
(** Indexes the value of the member [n] of an object. *)
258
+
| Nth of int node
259
+
(** Indexes the value of the [n]th element of an array. *)
260
+
261
+
val pp_index : index fmt
262
+
(** [pp_index] formats indexes. *)
263
+
264
+
val pp_index_trace : index fmt
265
+
(** [pp_index] formats indexes and their location. *)
266
+
267
+
(** {1:path Paths} *)
268
+
269
+
type t
270
+
(** The type for paths, a sequence of indexing operations. *)
271
+
272
+
val root : t
273
+
(** [root] is the root path. *)
274
+
275
+
val is_root : t -> bool
276
+
(** [is_root p] is [true] iff [p] is the root path. *)
277
+
278
+
val nth : ?meta:Meta.t -> int -> t -> t
279
+
(** [nth n p] indexes the array indexed by [p] at index [n]. *)
280
+
281
+
val mem : ?meta:Meta.t -> string -> t -> t
282
+
(** [mem n p] indexes the object indexed by [p] at member [n]. *)
283
+
284
+
val rev_indices : t -> index list
285
+
(** [rev_indices p] are the indices of [p] in reverse order, the last indexing
286
+
operation appears first. *)
287
+
288
+
val of_string : string -> (t, string) result
289
+
(** [of_string s] parses a path according to the
290
+
{{!Path.path_syntax}path syntax}. *)
291
+
292
+
val pp : t fmt
293
+
(** [pp] formats paths. *)
294
+
295
+
val pp_trace : t fmt
296
+
(** [pp_trace] formats paths as a stack trace, if not empty. *)
297
+
298
+
(** {1:path_syntax Path syntax}
299
+
300
+
Path provide a way for end users to address JSON and edit locations.
301
+
302
+
A {e path} is a sequence of member and list indexing operations. Applying
303
+
the path to a JSON value leads to either a JSON value, or nothing if one
304
+
of the indices does not exist, or an error if ones tries to index a
305
+
non-indexable value.
306
+
307
+
Here are a few examples of paths.
308
+
309
+
{@json[
310
+
{
311
+
"ocaml": {
312
+
"libs": ["jsont", "brr", "cmdliner"]
313
+
}
314
+
}
315
+
]}
316
+
317
+
{@shell[
318
+
ocaml.libs # value of member "libs" of member "ocaml"
319
+
ocaml.libs.[0] # first element of member "libs" of member "ocaml"
320
+
]}
321
+
322
+
More formally a {e path} is a [.] seperated list of indices. An {e index}
323
+
is written [[i]]. [i] can a zero-based list index. Or [i] can be an object
324
+
member name [n]. If there is no ambiguity, the surrounding brackets can be
325
+
dropped.
326
+
327
+
{b Notes.}
328
+
- The syntax has no form of quoting at the moment this means key names
329
+
can't contain, [\[], [\]], or start with a number.
330
+
- It would be nice to be able to drop the dots in order to be compatible
331
+
with {{:https://www.rfc-editor.org/rfc/rfc9535} JSONPath} syntax.
332
+
- Reintroduce and implement negative indices (they are parsed). *)
333
+
end
334
+
335
+
(** Sorts of JSON values. *)
336
+
module Sort : sig
337
+
(** The type for sorts of JSON values. *)
338
+
type t =
339
+
| Null (** Nulls *)
340
+
| Bool (** Booleans *)
341
+
| Number (** Numbers *)
342
+
| String (** Strings *)
343
+
| Array (** Arrays *)
344
+
| Object (** Objects *)
345
+
346
+
val to_string : t -> string
347
+
(** [to_string sort] is a string for sort [sort]. *)
348
+
349
+
val pp : Format.formatter -> t -> unit
350
+
(** [pp] formats sorts. *)
351
+
352
+
(** {1:kinds Kinds}
353
+
354
+
For formatting error messages. *)
355
+
356
+
val or_kind : kind:string -> t -> string
357
+
(** [or_kind ~kind sort] is [to_string sort] if [kind] is [""] and [kind]
358
+
otherwise. *)
359
+
360
+
val kinded : kind:string -> t -> string
361
+
(** [kinded ~kind sort] is [to_string sort] if [kind] is [""] and
362
+
[String.concat " " [kind; to_string sort]] otherwise. *)
363
+
364
+
val kinded' : kind:string -> string -> string
365
+
(** [kinded' ~kind sort] is [sort] if [kind] is [""] and
366
+
[String.concat " " [kind; sort]] otherwise. *)
367
+
end
368
+
369
+
(** Encoding, decoding and query errors. *)
370
+
module Error : sig
371
+
(** {1:kinds Kinds of errors} *)
372
+
373
+
type kind
374
+
(** The type for kind of errors. *)
375
+
376
+
val kind_to_string : kind -> string
377
+
(** [kind_to_string kind] is [kind] as a string. *)
378
+
379
+
(** {1:errors Errors} *)
380
+
381
+
(** JSON error contexts. *)
382
+
module Context : sig
383
+
type index = string node * Path.index
384
+
(** The type for context indices. The {{!Json.kinded_sort}kinded sort} of
385
+
an array or object and its index. *)
386
+
387
+
type t = index list
388
+
(** The type for erroring contexts. The first element indexes the root JSON
389
+
value. *)
390
+
391
+
val empty : t
392
+
(** [empty] is the empty context. *)
393
+
394
+
val is_empty : t -> bool
395
+
(** [is_empty ctx] is [true] iff [ctx] is {!empty}. *)
396
+
397
+
val push_array : string node -> int node -> t -> t
398
+
(** [push_array kinded_sort n ctx] wraps [ctx] as the [n]th element of an
399
+
array of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
400
+
401
+
val push_object : string node -> string node -> t -> t
402
+
(** [push_object kinded_sort n ctx] wraps [ctx] as the member named [n] of
403
+
an object of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
404
+
end
405
+
406
+
type t = Context.t * Meta.t * kind
407
+
(** The type for errors. The context, the error localisation and the kind of
408
+
error. *)
409
+
410
+
val raise : Context.t -> Meta.t -> kind -> 'a
411
+
(** [raise ctx meta k] raises an error with given paramters. *)
412
+
413
+
val make_msg : Context.t -> Meta.t -> string -> t
414
+
(** [make_msg ctx meta msg] is an error with message [msg] for meta [meta] in
415
+
context [ctx]. *)
416
+
417
+
val msg : Meta.t -> string -> 'a
418
+
(** [msg meta msg] raises an error with message [msg] for meta [meta] in an
419
+
empty context. *)
420
+
421
+
val msgf : Meta.t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a
422
+
(** [msgf meta fmt …] is like {!val-msg} but formats an error message. *)
423
+
424
+
val expected : Meta.t -> string -> fnd:string -> 'a
425
+
(** [expected meta fmt exp ~fnd] is [msgf "Expected %s but found %s" exp fnd].
426
+
*)
427
+
428
+
val push_array : string node -> int node -> t -> 'a
429
+
(** [push_array kinded_sort n e] contextualises [e] as an error in the [n]th
430
+
element of an array of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
431
+
432
+
val push_object : string node -> string node -> t -> 'a
433
+
(** [push_object kinded_sort n e] contextualises [e] as an error in the member
434
+
[n] of an object of {{!Json.kinded_sort}kinded sort} [kinded_sort]. *)
435
+
436
+
val adjust_context :
437
+
first_byte:Textloc.byte_pos -> first_line:Textloc.line_pos -> t -> 'a
438
+
(** [adjust_context ~first_byte ~first_line] adjusts the error's context's
439
+
meta to encompass the given positions. *)
440
+
441
+
(** {1:fmt Formatting} *)
442
+
443
+
val to_string : t -> string
444
+
(** [error_to_string e] formats [e] using {!val-pp} to a string. *)
445
+
446
+
val pp : t fmt
447
+
(** [pp_error] formats errors. *)
448
+
449
+
val puterr : unit fmt
450
+
(** [puterr] formats [Error:] in red. *)
451
+
452
+
(**/**)
453
+
454
+
val disable_ansi_styler : unit -> unit
455
+
456
+
(**/**)
457
+
end
458
+
459
+
exception Error of Error.t
460
+
(** The exception raised on map errors. In general codec and query functions
461
+
turn that for you into a {!result} value. *)
462
+
463
+
(** {1:types Types} *)
464
+
465
+
type 'a t
466
+
(** The type for JSON types.
467
+
468
+
A value of this type represents a subset of JSON values mapped to a subset
469
+
of values of type ['a] and vice versa. *)
470
+
471
+
val kinded_sort : 'a t -> string
472
+
(** [kinded_sort t] is a human readable string describing the JSON values typed
473
+
by [t]. This combines the kind of the map with the {{!Sort}sort}(s) of JSON
474
+
value mapped by [t]. For example if [t] is an object map and the kind
475
+
specified for the {{!Object.val-map}map} is ["T"] then this is ["T object"],
476
+
if the kind is empty this is simply ["object"]. See also {!Sort.kinded}. *)
477
+
478
+
val kind : 'a t -> string
479
+
(** [kind t] is the [kind] of the underlying map. If the kind is an empty string
480
+
this falls back to mention the {{!Sort}sort}. For example if [t] is an
481
+
object map and the kind specified for the {{!Object.val-map}map} is ["T"]
482
+
then this is ["T"], if the kind is empty then this is ["object"]. See also
483
+
{!Sort.or_kind}. *)
484
+
485
+
val doc : 'a t -> string
486
+
(** [doc t] is a documentation string for the JSON values typed by [t]. *)
487
+
488
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
489
+
(** [with_doc ?kind ?doc t] is [t] with its {!doc} or {!kind} updated to the
490
+
corresponding values if specified. *)
491
+
492
+
(** {1:base Base types}
493
+
494
+
Read the {{!page-cookbook.base_types}cookbook} on base types. *)
495
+
496
+
(** Mapping JSON base types. *)
497
+
module Base : sig
498
+
(** {1:maps Maps} *)
499
+
500
+
type ('a, 'b) map
501
+
(** The type for mapping JSON values of type ['a] to values of type ['b]. *)
502
+
503
+
val map :
504
+
?kind:string ->
505
+
?doc:string ->
506
+
?dec:(Meta.t -> 'a -> 'b) ->
507
+
?enc:('b -> 'a) ->
508
+
?enc_meta:('b -> Meta.t) ->
509
+
unit ->
510
+
('a, 'b) map
511
+
(** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types represented
512
+
by value of type ['a] to values of type ['b] with:
513
+
- [kind] names the entities represented by the map and [doc] documents
514
+
them. Both default to [""].
515
+
- [dec] is used to decode values of type ['a] to values of type ['b]. Can
516
+
be omitted if the map is only used for encoding, the default
517
+
unconditionally errors.
518
+
- [enc] is used to encode values of type ['b] to values of type ['a]. Can
519
+
be omitted if the map is only used for decoding, the default
520
+
unconditionally errors.
521
+
- [enc_meta] is used to recover JSON metadata (source text layout
522
+
information) from a value to encode. The default unconditionnaly returns
523
+
{!Json.Meta.none}.
524
+
525
+
{{!decenc}These functions} can be used to quickly devise [dec] and [enc]
526
+
functions from standard OCaml conversion interfaces. *)
527
+
528
+
val id : ('a, 'a) map
529
+
(** [id] is the identity map. *)
530
+
531
+
val ignore : ('a, unit) map
532
+
(** [ignore] is the ignoring map. It ignores decodes and errors on encodes. *)
533
+
534
+
(** {2:types JSON types} *)
535
+
536
+
val null : (unit, 'a) map -> 'a t
537
+
(** [null map] maps with [map] JSON nulls represented by [()] to values of
538
+
type ['a]. See also {!Json.null}. *)
539
+
540
+
val bool : (bool, 'a) map -> 'a t
541
+
(** [bool map] maps with [map] JSON booleans represented by [bool] values to
542
+
values of type ['a]. See also {!Json.bool}. *)
543
+
544
+
val number : (float, 'a) map -> 'a t
545
+
(** [number map] maps with [map] JSON nulls or numbers represented by [float]
546
+
values to values of type ['a]. The [float] representation decodes JSON
547
+
nulls to {!Float.nan} and lossily encodes any
548
+
{{!Float.is_finite}non-finite} to JSON null
549
+
({{!page-cookbook.non_finite_numbers}explanation}). See also
550
+
{!Json.number}. *)
551
+
552
+
val string : (string, 'a) map -> 'a t
553
+
(** [string map] maps with [map] {e unescaped} JSON strings represented by
554
+
UTF-8 encoded [string] values to values of type ['a]. See also
555
+
{!Json.string}. *)
556
+
557
+
(** {1:decenc Decoding and encoding functions}
558
+
559
+
These function create suitable [dec] and [enc] functions to give to
560
+
{!val-map} from standard OCaml conversion interfaces. See also
561
+
{!Json.of_of_string}. *)
562
+
563
+
val dec : ('a -> 'b) -> Meta.t -> 'a -> 'b
564
+
(** [dec f] is a decoding function from [f]. This assumes [f] never fails. *)
565
+
566
+
val dec_result :
567
+
?kind:string -> ('a -> ('b, string) result) -> Meta.t -> 'a -> 'b
568
+
(** [dec f] is a decoding function from [f]. [Error _] values are given to
569
+
{!Error.msg}, prefixed by [kind:] (if specified). *)
570
+
571
+
val dec_failure : ?kind:string -> ('a -> 'b) -> Meta.t -> 'a -> 'b
572
+
(** [dec f] is a decoding function from [f]. [Failure _] exceptions are
573
+
catched and given to {!Error.msg}, prefixed by [kind:] (if specified). *)
574
+
575
+
val enc : ('b -> 'a) -> 'b -> 'a
576
+
(** [enc f] is an encoding function from [f]. This assumes [f] never fails. *)
577
+
578
+
val enc_result : ?kind:string -> ('b -> ('a, string) result) -> 'b -> 'a
579
+
(** [enc_result f] is an encoding function from [f]. [Error _] values are
580
+
given to {!Error.msg}, prefixed by [kind:] (if specified). *)
581
+
582
+
val enc_failure : ?kind:string -> ('b -> 'a) -> 'b -> 'a
583
+
(** [enc_failure f] is an encoding function from [f]. [Failure _] exceptions
584
+
are catched and given to {!Error.msg}, prefixed by [kind:] (if specified).
585
+
*)
586
+
end
587
+
588
+
(** {2:option Nulls and options}
589
+
590
+
Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *)
591
+
592
+
val null : ?kind:string -> ?doc:string -> 'a -> 'a t
593
+
(** [null v] maps JSON nulls to [v]. On encodes any value of type ['a] is
594
+
encoded by null. [doc] and [kind] are given to the underlying
595
+
{!Base.type-map}. See also {!Base.null}. *)
596
+
597
+
val none : 'a option t
598
+
(** [none] maps JSON nulls to [None]. *)
599
+
600
+
val some : 'a t -> 'a option t
601
+
(** [some t] maps JSON like [t] does but wraps results in [Some]. Encoding fails
602
+
if the value is [None]. *)
603
+
604
+
val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t
605
+
(** [option t] maps JSON nulls to [None] and other values by [t]. [doc] and
606
+
[kind] are given to the underlying {!val-any} map. *)
607
+
608
+
(** {2:booleans Booleans} *)
609
+
610
+
val bool : bool t
611
+
(** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *)
612
+
613
+
(** {2:numbers Numbers}
614
+
615
+
Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON numbers and
616
+
their many pitfalls. *)
617
+
618
+
val number : float t
619
+
(** [number] maps JSON nulls or numbers to [float] values. On decodes JSON null
620
+
is mapped to {!Float.nan}. On encodes any {{!Float.is_finite}non-finite}
621
+
float is lossily mapped to JSON null
622
+
({{!page-cookbook.non_finite_numbers}explanation}). See also {!Base.number},
623
+
{!any_float} and the integer combinators below. *)
624
+
625
+
val any_float : float t
626
+
(** [any_float] is a lossless representation for IEEE 754 doubles. It maps
627
+
{{!Float.is_finite}non-finite} floats by the JSON strings defined by
628
+
{!Float.to_string}. This contrasts with {!val-number} which maps them to
629
+
JSON null values ({{!page-cookbook.non_finite_numbers}explanation}). Note
630
+
that on decodes this still maps JSON nulls to {!Float.nan} and any
631
+
successful string decode of {!Float.of_string_opt} (so numbers can also be
632
+
written as strings). See also {!val-number}.
633
+
634
+
{b Warning.} [any_float] should only be used between parties that have
635
+
agreed on such an encoding. To maximize interoperability you should use the
636
+
lossy {!val-number} map. *)
637
+
638
+
val float_as_hex_string : float t
639
+
(** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex
640
+
notation to float values. On encodes strings this uses the ["%h"] format
641
+
string. On decodes it accepts anything sucessfully decoded by
642
+
{!Float.of_string_opt}. *)
643
+
644
+
val uint8 : int t
645
+
(** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers are
646
+
sucessfully decoded if after truncation they can be represented on the
647
+
\[0;255\] range. Encoding errors if the integer is out of range.*)
648
+
649
+
val uint16 : int t
650
+
(** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers are
651
+
sucessfully decoded if after truncation they can be represented on the
652
+
\[0;65535\] range. Encoding errors if the integer is out of range.*)
653
+
654
+
val int8 : int t
655
+
(** [int8] maps JSON numbers to 8-bit integers. JSON numbers are sucessfully
656
+
decoded if after truncation they can be represented on the \[-128;127\]
657
+
range. Encoding errors if the integer is out of range.*)
658
+
659
+
val int16 : int t
660
+
(** [int16] maps JSON numbers to 16-bit integers. JSON numbers are sucessfully
661
+
decoded if after truncation they can be represented on the \[-32768;32767\]
662
+
range. Encoding errors if the integer is out of range. *)
663
+
664
+
val int32 : int32 t
665
+
(** [int32] maps JSON numbers to 32-bit integers. JSON numbers are sucessfully
666
+
decoded if after truncation they can be represented on the [int32] range,
667
+
otherwise the decoder errors. *)
668
+
669
+
val int64 : int64 t
670
+
(** [int] maps truncated JSON numbers or JSON strings to 64-bit integers.
671
+
- JSON numbers are sucessfully decoded if after truncation they can be
672
+
represented on the [int64] range, otherwise the decoder errors. [int64]
673
+
values are encoded as JSON numbers if the integer is in the
674
+
\[-2{^ 53};2{^ 53}\] range.
675
+
- JSON strings are decoded using {!int_of_string_opt}, this allows binary,
676
+
octal, decimal and hex syntaxes and errors on overflow and syntax errors.
677
+
[int] values are encoded as JSON strings with {!Int.to_string} when the
678
+
integer is outside the \[-2{^ 53};2{^ 53}\] range *)
679
+
680
+
val int64_as_string : int64 t
681
+
(** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this uses
682
+
{!Int64.of_string_opt} which allows binary, octal, decimal and hex syntaxes
683
+
and errors on overflow and syntax errors. On encodes uses
684
+
{!Int64.to_string}. *)
685
+
686
+
val int : int t
687
+
(** [int] maps truncated JSON numbers or JSON strings to [int] values.
688
+
- JSON numbers are sucessfully decoded if after truncation they can be
689
+
represented on the [int] range, otherwise the decoder errors. [int] values
690
+
are encoded as JSON numbers if the integer is in the \[-2{^ 53};2{^ 53}\]
691
+
range.
692
+
- JSON strings are decoded using {!int_of_string_opt}, this allows binary,
693
+
octal, decimal and hex syntaxes and errors on overflow and syntax errors.
694
+
[int] values are encoded as JSON strings with {!Int.to_string} when the
695
+
integer is outside the \[-2{^ 53};2{^ 53}\] range
696
+
697
+
{b Warning.} The behaviour of this function is platform dependent, it
698
+
depends on the value of {!Sys.int_size}. *)
699
+
700
+
val int_as_string : int t
701
+
(** [int_as_string] maps JSON strings to [int] values. On decodes this uses
702
+
{!int_of_string_opt} which allows binary, octal, decimal and hex syntaxes
703
+
and errors on overflow and syntax errors. On encodes uses {!Int.to_string}.
704
+
705
+
{b Warning.} The behaviour of this function is platform dependent, it
706
+
depends on the value of {!Sys.int_size}. *)
707
+
708
+
(** {2:enums Strings and enums}
709
+
710
+
Read the {{!page-cookbook.transform_strings}cookbook} on transforming
711
+
strings. *)
712
+
713
+
val string : string t
714
+
(** [string] maps unescaped JSON strings to UTF-8 encoded [string] values. See
715
+
also {!Base.string}.
716
+
717
+
{b Warning.} Encoders assume OCaml [string]s have been checked for UTF-8
718
+
validity. *)
719
+
720
+
val of_of_string :
721
+
?kind:string ->
722
+
?doc:string ->
723
+
?enc:('a -> string) ->
724
+
(string -> ('a, string) result) ->
725
+
'a t
726
+
(** [of_of_string of_string] maps JSON string with a {{!Base.type-map}base map}
727
+
using [of_string] for decoding and [enc] for encoding. See the
728
+
{{!page-cookbook.transform_strings}cookbook}. *)
729
+
730
+
val enum :
731
+
?cmp:('a -> 'a -> int) ->
732
+
?kind:string ->
733
+
?doc:string ->
734
+
(string * 'a) list ->
735
+
'a t
736
+
(** [enum assoc] maps JSON strings member of the [assoc] list to the
737
+
corresponding OCaml value and vice versa in log(n). [cmp] is used to compare
738
+
the OCaml values, it defaults to {!Stdlib.compare}. Decoding and encoding
739
+
errors on strings or values not part of [assoc] *)
740
+
741
+
val binary_string : string t
742
+
(** [binary_string] maps JSON strings made of an even number of hexdecimal
743
+
US-ASCII upper or lower case digits to the corresponding byte sequence. On
744
+
encoding uses only lower case hexadecimal digits to encode the byte
745
+
sequence. *)
746
+
747
+
(** {1:arrays Arrays and tuples}
748
+
749
+
Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays and see
750
+
also {{!array_queries}array queries and updates}. *)
751
+
752
+
(** Mapping JSON arrays. *)
753
+
module Array : sig
754
+
(** {1:maps Maps} *)
755
+
756
+
type ('array, 'elt) enc = {
757
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
758
+
}
759
+
(** The type for specifying array encoding functions. A function to fold over
760
+
the elements of type ['elt] of the array of type ['array]. *)
761
+
762
+
type ('array, 'elt, 'builder) map
763
+
(** The type for mapping JSON arrays with elements of type ['elt] to arrays of
764
+
type ['array] using values of type ['builder] to build them. *)
765
+
766
+
val map :
767
+
?kind:string ->
768
+
?doc:string ->
769
+
?dec_empty:(unit -> 'builder) ->
770
+
?dec_skip:(int -> 'builder -> bool) ->
771
+
?dec_add:(int -> 'elt -> 'builder -> 'builder) ->
772
+
?dec_finish:(Meta.t -> int -> 'builder -> 'array) ->
773
+
?enc:('array, 'elt) enc ->
774
+
?enc_meta:('array -> Meta.t) ->
775
+
'elt t ->
776
+
('array, 'elt, 'builder) map
777
+
(** [map elt] maps JSON arrays of type ['elt] to arrays of type ['array] built
778
+
with type ['builder].
779
+
- [kind] names the entities represented by the map and [doc] documents
780
+
them. Both default to [""].
781
+
- [dec_empty ()] is used to create a builder for the empty array. Can be
782
+
omitted if the map is only used for encoding, the default
783
+
unconditionally errors.
784
+
- [dec_skip i b] is used to skip the [i]th index of the JSON array. If
785
+
[true], the element is not decoded with [elt] and not added with
786
+
[dec_add] but skipped. The default always returns [false].
787
+
- [dec_add i v] is used to add the [i]th JSON element [v] $ decoded by
788
+
[elt] to the builder [b]. Can be omitted if the map is only used for
789
+
encoding, the default unconditionally errors.
790
+
- [dec_finish b] converts the builder to the final array. Can be omitted
791
+
if the map is only used for encoding, the default unconditionally
792
+
errors.
793
+
- [enc.enc f acc a] folds over the elements of array [a] in increasing
794
+
order with [f] and starting with [acc]. This function is used to encode
795
+
[a] to a JSON array. Can be omitted if the map is only used for
796
+
decoding, the default unconditionally errors.
797
+
- [enc_meta a] is the metadata to use for encoding [v] to a JSON array.
798
+
Default returns {!Meta.none}. *)
799
+
800
+
val list_map :
801
+
?kind:string ->
802
+
?doc:string ->
803
+
?dec_skip:(int -> 'a list -> bool) ->
804
+
'a t ->
805
+
('a list, 'a, 'a list) map
806
+
(** [list_map elt] maps JSON arrays with elements of type [elt] to [list]
807
+
values. See also {!Json.list}. *)
808
+
809
+
type 'a array_builder
810
+
(** The type for array builders. *)
811
+
812
+
val array_map :
813
+
?kind:string ->
814
+
?doc:string ->
815
+
?dec_skip:(int -> 'a array_builder -> bool) ->
816
+
'a t ->
817
+
('a array, 'a, 'a array_builder) map
818
+
(** [array_map elt] maps JSON arrays with elements of type [elt] to [array]
819
+
values. See also {!Json.array}. *)
820
+
821
+
type ('a, 'b, 'c) bigarray_builder
822
+
(** The type for bigarray_builders. *)
823
+
824
+
val bigarray_map :
825
+
?kind:string ->
826
+
?doc:string ->
827
+
?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) ->
828
+
('a, 'b) Bigarray.kind ->
829
+
'c Bigarray.layout ->
830
+
'a t ->
831
+
(('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map
832
+
(** [bigarray k l elt] maps JSON arrays with elements of type [elt] to
833
+
bigarray values of kind [k] and layout [l]. See also {!Json.bigarray}. *)
834
+
835
+
(** {1:types JSON types} *)
836
+
837
+
val array : ('a, _, _) map -> 'a t
838
+
(** [array map] maps with [map] JSON arrays to values of type ['a]. See the
839
+
the {{!section-arrays}array combinators}. *)
840
+
841
+
val ignore : unit t
842
+
(** [ignore] ignores JSON arrays on decoding and errors on encoding. *)
843
+
844
+
val zero : unit t
845
+
(** [zero] ignores JSON arrays on decoding and encodes an empty array. *)
846
+
end
847
+
848
+
val list : ?kind:string -> ?doc:string -> 'a t -> 'a list t
849
+
(** [list t] maps JSON arrays of type [t] to [list] values. See also
850
+
{!Array.list_map}. *)
851
+
852
+
val array : ?kind:string -> ?doc:string -> 'a t -> 'a array t
853
+
(** [array t] maps JSON arrays of type [t] to [array] values. See also
854
+
{!Array.array_map}. *)
855
+
856
+
val array_as_string_map :
857
+
?kind:string ->
858
+
?doc:string ->
859
+
key:('a -> string) ->
860
+
'a t ->
861
+
'a Map.Make(String).t t
862
+
(** [array_as_string_map ~key t] maps JSON array elements of type [t] to string
863
+
maps by indexing them with [key]. If two elements have the same [key] the
864
+
element with the greatest index takes over. Elements of the map are encoded
865
+
to a JSON array in (binary) key order. *)
866
+
867
+
val bigarray :
868
+
?kind:string ->
869
+
?doc:string ->
870
+
('a, 'b) Bigarray.kind ->
871
+
'a t ->
872
+
('a, 'b, Bigarray.c_layout) Bigarray.Array1.t t
873
+
(** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t] values.
874
+
See also {!Array.bigarray_map}. *)
875
+
876
+
val t2 :
877
+
?kind:string ->
878
+
?doc:string ->
879
+
?dec:('a -> 'a -> 't2) ->
880
+
?enc:('t2 -> int -> 'a) ->
881
+
'a t ->
882
+
't2 t
883
+
(** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type [t] to
884
+
value of type ['t2]. Decodes error if there are more elements. [enc v i]
885
+
must return the zero-based [i]th element. *)
886
+
887
+
val t3 :
888
+
?kind:string ->
889
+
?doc:string ->
890
+
?dec:('a -> 'a -> 'a -> 't3) ->
891
+
?enc:('t3 -> int -> 'a) ->
892
+
'a t ->
893
+
't3 t
894
+
(** [t3] is like {!t2} but for 3 elements. *)
895
+
896
+
val t4 :
897
+
?kind:string ->
898
+
?doc:string ->
899
+
?dec:('a -> 'a -> 'a -> 'a -> 't4) ->
900
+
?enc:('t4 -> int -> 'a) ->
901
+
'a t ->
902
+
't4 t
903
+
(** [t4] is like {!t2} but for 4 elements. *)
904
+
905
+
val tn : ?kind:string -> ?doc:string -> n:int -> 'a t -> 'a array t
906
+
(** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to [array]
907
+
values. This is {!val-array} limited by [n]. *)
908
+
909
+
(** {1:objects Objects}
910
+
911
+
Read the {{!page-cookbook.dealing_with_objects}cookbook} on objects. See a
912
+
{{!page-cookbook.objects_as_records}simple example}. See also
913
+
{{!object_queries}object queries and updates}. *)
914
+
915
+
(** Mapping JSON objects. *)
916
+
module Object : sig
917
+
(** {1:maps Maps} *)
918
+
919
+
type ('o, 'dec) map
920
+
(** The type for mapping JSON objects to values of type ['o]. The ['dec] type
921
+
is used to construct ['o] from members see {!val-mem}. *)
922
+
923
+
val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
924
+
(** [map dec] is an empty JSON object decoded by function [dec].
925
+
- [kind] names the entities represented by the map and [doc] documents
926
+
them. Both default to [""].
927
+
- [dec] is a constructor eventually returning a value of type ['o] to be
928
+
saturated with calls to {!val-mem}, {!val-case_mem} or
929
+
{!val-keep_unknown}. This is needed for decoding. Use {!enc_only} if the
930
+
result is only used for encoding. *)
931
+
932
+
val map' :
933
+
?kind:string ->
934
+
?doc:string ->
935
+
?enc_meta:('o -> Meta.t) ->
936
+
(Meta.t -> 'dec) ->
937
+
('o, 'dec) map
938
+
(** [map' dec] is like {!val-map} except you get the object's decoding metdata
939
+
in [dec] and [enc_meta] is used to recover it on encoding. *)
940
+
941
+
val enc_only :
942
+
?kind:string ->
943
+
?doc:string ->
944
+
?enc_meta:('o -> Meta.t) ->
945
+
unit ->
946
+
('o, 'a) map
947
+
(** [enc_only ()] is like {!val-map'} but can only be used for encoding. *)
948
+
949
+
val finish : ('o, 'o) map -> 'o t
950
+
(** [finish map] is a JSON type for objects mapped by [map]. Raises
951
+
[Invalid_argument] if [map] describes a member name more than once. *)
952
+
953
+
(** {1:mems Members} *)
954
+
955
+
(** Member maps.
956
+
957
+
Usually it's better to use {!Json.Object.mem} or {!Json.Object.opt_mem}
958
+
directly. But this may be useful in certain abstraction contexts. *)
959
+
module Mem : sig
960
+
type ('o, 'dec) object_map := ('o, 'dec) map
961
+
962
+
type ('o, 'a) map
963
+
(** The type for mapping a member object to a value ['a] stored in an OCaml
964
+
value of type ['o]. *)
965
+
966
+
val map :
967
+
?doc:string ->
968
+
?dec_absent:'a ->
969
+
?enc:('o -> 'a) ->
970
+
?enc_omit:('a -> bool) ->
971
+
string ->
972
+
'a t ->
973
+
('o, 'a) map
974
+
(** See {!Json.Object.mem}. *)
975
+
976
+
val app : ('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map
977
+
(** [app map mmap] applies the member map [mmap] to the contructor of the
978
+
object map [map]. In turn this adds the [mmap] member definition to the
979
+
object described by [map]. *)
980
+
end
981
+
982
+
val mem :
983
+
?doc:string ->
984
+
?dec_absent:'a ->
985
+
?enc:('o -> 'a) ->
986
+
?enc_omit:('a -> bool) ->
987
+
string ->
988
+
'a t ->
989
+
('o, 'a -> 'b) map ->
990
+
('o, 'b) map
991
+
(** [mem name t map] is a member named [name] of type [t] for an object of
992
+
type ['o] being constructed by [map].
993
+
- [doc] is a documentation string for the member. Defaults to [""].
994
+
- [dec_absent], if specified, is the value used for the decoding direction
995
+
when the member named [name] is missing. If unspecified decoding errors
996
+
when the member is absent. See also {!opt_mem} and
997
+
{{!page-cookbook.optional_members}this example}.
998
+
- [enc] is used to project the member's value from the object
999
+
representation ['o] for encoding to JSON with [t]. It can be omitted if
1000
+
the result is only used for decoding.
1001
+
- [enc_omit] is for the encoding direction. If the member value returned
1002
+
by [enc] returns [true] on [enc_omit], the member is omited in the
1003
+
encoded JSON object. Defaults to [Fun.const false]. See also {!opt_mem}
1004
+
and {{!page-cookbook.optional_members}this example}. *)
1005
+
1006
+
val opt_mem :
1007
+
?doc:string ->
1008
+
?enc:('o -> 'a option) ->
1009
+
string ->
1010
+
'a t ->
1011
+
('o, 'a option -> 'b) map ->
1012
+
('o, 'b) map
1013
+
(** [opt_mem name t map] is:
1014
+
{[
1015
+
let dec_absent = None and enc_omit = Option.is_none in
1016
+
Json.Object.mem name (Json.some t) map ~dec_absent ~enc_omit
1017
+
]}
1018
+
A shortcut to represent optional members of type ['a] with ['a option]
1019
+
values. *)
1020
+
1021
+
(** {1:cases Case objects}
1022
+
1023
+
Read the {{!page-cookbook.cases}cookbook} on case objects. *)
1024
+
1025
+
(** Case objects.
1026
+
1027
+
Case objects are used to describe objects whose members depend on the tag
1028
+
value of a distinguished case member. See an
1029
+
{{!page-cookbook.cases}example}. *)
1030
+
module Case : sig
1031
+
(** {1:maps Maps} *)
1032
+
1033
+
type 'a codec := 'a t
1034
+
1035
+
type ('cases, 'case, 'tag) map
1036
+
(** The type for mapping a case object represented by ['case] belonging to a
1037
+
common type represented by ['cases] depending on the value of a case
1038
+
member of type ['tag]. *)
1039
+
1040
+
val map :
1041
+
?dec:('case -> 'cases) -> 'tag -> 'case codec -> ('cases, 'case, 'tag) map
1042
+
(** [map ~dec v obj] defines the object map [obj] as being the case for the
1043
+
tag value [v] of the case member. [dec] indicates how to inject the
1044
+
object case into the type common to all cases.
1045
+
1046
+
Raises [Invalid_argument] if [obj] is not a direct result of {!finish},
1047
+
that is if [obj] does not describe an object. *)
1048
+
1049
+
val map_tag : ('cases, 'case, 'tag) map -> 'tag
1050
+
(** [map_tag m] is [m]'s tag. *)
1051
+
1052
+
(** {1:cases Cases} *)
1053
+
1054
+
type ('cases, 'tag) t
1055
+
(** The type for a case of the type ['cases]. This is {!type-map} with its
1056
+
['case] representation hidden. *)
1057
+
1058
+
val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t
1059
+
(** [make map] is [map] as a case. *)
1060
+
1061
+
val tag : ('cases, 'tag) t -> 'tag
1062
+
(** [tag c] is the tag of [c]. *)
1063
+
1064
+
(** {1:case Case values} *)
1065
+
1066
+
type ('cases, 'tag) value
1067
+
(** The type for case values. This holds a case value and its case map
1068
+
{!type-map}. Use {!val-value} to construct them. *)
1069
+
1070
+
val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value
1071
+
(** [value map v] is a case value [v] described by [map]. *)
1072
+
end
1073
+
1074
+
val case_mem :
1075
+
?doc:string ->
1076
+
?tag_compare:('tag -> 'tag -> int) ->
1077
+
?tag_to_string:('tag -> string) ->
1078
+
?dec_absent:'tag ->
1079
+
?enc:('o -> 'cases) ->
1080
+
?enc_omit:('tag -> bool) ->
1081
+
?enc_case:('cases -> ('cases, 'tag) Case.value) ->
1082
+
string ->
1083
+
'tag t ->
1084
+
('cases, 'tag) Case.t list ->
1085
+
('o, 'cases -> 'a) map ->
1086
+
('o, 'a) map
1087
+
(** [case_mem name t cases map] is mostly like {!val-mem} except the member
1088
+
[name] selects an object representation according to the member value of
1089
+
type [t]:
1090
+
- [doc] is a documentation string for the member. Defaults to [""].
1091
+
- [tag_compare] is used to compare tags. Defaults to {!Stdlib.compare}
1092
+
- [tag_to_string] is used to stringify tags for improving error reporting.
1093
+
- [dec_absent], if specified, is the case value used for the decoding
1094
+
direction when the case member named [name] is missing. If unspecified
1095
+
decoding errors when the member is absent.
1096
+
- [enc] is used to project the value in which cases are stored from the
1097
+
object representation ['o] for encoding to JSON. It can be omitted if
1098
+
the result is only used for decoding.
1099
+
- [enc_case] determines the actual case value from the value returned by
1100
+
[enc].
1101
+
- [enc_omit] is used on the tag of the case returned by [enc_case] to
1102
+
determine if the case member can be ommited in the encoded JSON object
1103
+
- [cases] enumerates all the cases, it is needed for decoding.
1104
+
1105
+
The names of the members of each case must be disjoint from [name] or
1106
+
those of [map] otherwise [Invalid_argument] is raised on {!finish}. Raises
1107
+
[Invalid_argument] if [case_mem] was already called on map. *)
1108
+
1109
+
(** {1:unknown_members Unknown members}
1110
+
1111
+
Read the {{!page-cookbook.unknown_members}cookbook} on unknown object
1112
+
members.
1113
+
1114
+
On {{!cases}case objects} each individual case has its own behaviour
1115
+
unless the combinators are used on the case object map in which case it
1116
+
overrides the behaviour of cases. For those cases that use {!keep_unknown}
1117
+
they will get the result of an empty builder in their decoding function
1118
+
and the encoder is ignored on encode. *)
1119
+
1120
+
(** Uniform members. *)
1121
+
module Mems : sig
1122
+
(** {1:maps Maps} *)
1123
+
1124
+
type 'a codec := 'a t
1125
+
1126
+
type ('mems, 'a) enc = {
1127
+
enc :
1128
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
1129
+
}
1130
+
(** The type for specifying unknown members encoding function. A function to
1131
+
fold over unknown members of uniform type ['a] stored in a value of type
1132
+
['mems]. *)
1133
+
1134
+
type ('mems, 'a, 'builder) map
1135
+
(** The type for mapping members of uniform type ['a] to values of type
1136
+
['mems] using a builder of type ['builder]. *)
1137
+
1138
+
val map :
1139
+
?kind:string ->
1140
+
?doc:string ->
1141
+
?dec_empty:(unit -> 'builder) ->
1142
+
?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) ->
1143
+
?dec_finish:(Meta.t -> 'builder -> 'mems) ->
1144
+
?enc:('mems, 'a) enc ->
1145
+
'a codec ->
1146
+
('mems, 'a, 'builder) map
1147
+
(** [map type'] maps unknown members of uniform type ['a] to values of type
1148
+
['mems] built with type ['builder].
1149
+
- [kind] names the entities represented by the map and [doc] documents
1150
+
them. Both default to [""].
1151
+
- [dec_empty] is used to create a builder for the members. Can be
1152
+
omitted if the map is only used for encoding, the default
1153
+
unconditionally errors.
1154
+
- [dec_add meta name v b] is used to add a member named [name] with meta
1155
+
[meta] with member value [v] to builder [b]. Can be omitted if the map
1156
+
is only used for encoding, the default unconditionally errors.
1157
+
- [dec_finish meta b] converts the builder to the final members value.
1158
+
[meta] is the metadata of the object in which they were found. Can be
1159
+
omitted if the map is only used for encoding, the default
1160
+
unconditionally errors.
1161
+
- [enc f mems acc] folds over the elements of [mems] starting with
1162
+
[acc]. This function is used to encode the members. Can be omitted if
1163
+
the map is only used for decoding, the default unconditionally errors.
1164
+
1165
+
See {!keep_unknown}. *)
1166
+
1167
+
val string_map :
1168
+
?kind:string ->
1169
+
?doc:string ->
1170
+
'a codec ->
1171
+
('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map
1172
+
(** [string_map t] collects unknown member by name and types their values
1173
+
with [t]. See {!keep_unknown} and {!as_string_map}. *)
1174
+
end
1175
+
1176
+
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
1177
+
(** [skip_unknown map] makes [map] skip unknown members. This is the default,
1178
+
no need to specify it. Raises [Invalid_argument] if {!keep_unknown} was
1179
+
already specified on [map]. *)
1180
+
1181
+
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
1182
+
(** [error_unknown map] makes [map] error on unknown members. Raises
1183
+
[Invalid_argument] if {!keep_unknown} was already specified on [map]. See
1184
+
{{!page-cookbook.erroring}this example}. *)
1185
+
1186
+
val keep_unknown :
1187
+
?enc:('o -> 'mems) ->
1188
+
('mems, _, _) Mems.map ->
1189
+
('o, 'mems -> 'a) map ->
1190
+
('o, 'a) map
1191
+
(** [keep_unknown mems map] makes [map] keep unknown member with [mems].
1192
+
Raises [Invalid_argument] if {!keep_unknown} was already specified on
1193
+
[map]. See this {{!page-cookbook.keeping}this example}, {!Mems.string_map}
1194
+
and {!Json.json_mems}. *)
1195
+
1196
+
(** {1:types JSON types} *)
1197
+
1198
+
val as_string_map :
1199
+
?kind:string -> ?doc:string -> 'a t -> 'a Stdlib.Map.Make(String).t t
1200
+
(** [as_string_map t] maps object to key-value maps of type [t]. See also
1201
+
{!Mems.string_map} and {!Json.json_mems}. *)
1202
+
1203
+
val zero : unit t
1204
+
(** [zero] ignores JSON objects on decoding and encodes an empty object. *)
1205
+
end
1206
+
1207
+
(** {1:any Any} *)
1208
+
1209
+
val any :
1210
+
?kind:string ->
1211
+
?doc:string ->
1212
+
?dec_null:'a t ->
1213
+
?dec_bool:'a t ->
1214
+
?dec_number:'a t ->
1215
+
?dec_string:'a t ->
1216
+
?dec_array:'a t ->
1217
+
?dec_object:'a t ->
1218
+
?enc:('a -> 'a t) ->
1219
+
unit ->
1220
+
'a t
1221
+
(** [any ()] maps subsets of JSON value of different sorts to values of type
1222
+
['a]. The unspecified cases are not part of the subset and error on
1223
+
decoding. [enc] selects the type to use on encoding and errors if omitted.
1224
+
[kind] names the entities represented by the type and [doc] documents them,
1225
+
both defaults to [""]. *)
1226
+
1227
+
(** {1:maps Maps & recursion} *)
1228
+
1229
+
val map :
1230
+
?kind:string ->
1231
+
?doc:string ->
1232
+
?dec:('a -> 'b) ->
1233
+
?enc:('b -> 'a) ->
1234
+
'a t ->
1235
+
'b t
1236
+
(** [map t] changes the type of [t] from ['a] to ['b].
1237
+
- [kind] names the entities represented by the type and [doc] documents
1238
+
them, both default to [""].
1239
+
- [dec] decodes values of type ['a] to values of type ['b]. Can be omitted
1240
+
if the result is only used for encoding. The default errors.
1241
+
- [enc] encodes values of type ['b] to values of type ['a]. Can be omitted
1242
+
if the result is only used for decoding. The default errors.
1243
+
1244
+
For mapping base types use {!Json.Base.map}. *)
1245
+
1246
+
val iter :
1247
+
?kind:string ->
1248
+
?doc:string ->
1249
+
?dec:('a -> unit) ->
1250
+
?enc:('a -> unit) ->
1251
+
'a t ->
1252
+
'a t
1253
+
(** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding but
1254
+
otherwise behaves like [t] does. Typically [dec] can be used to further
1255
+
assert the shape of the decoded value and {!Error.msgf} if it hasn't the
1256
+
right shape. [iter] can also be used as a tracing facility for debugging. *)
1257
+
1258
+
val rec' : 'a t Lazy.t -> 'a t
1259
+
(** [rec'] maps recursive JSON values. See the
1260
+
{{!page-cookbook.recursion} cookbook}. *)
1261
+
1262
+
(** {1:ignoring Ignoring} *)
1263
+
1264
+
val ignore : unit t
1265
+
(** [ignore] lossily maps all JSON values to [()] on decoding and errors on
1266
+
encoding. See also {!const}. *)
1267
+
1268
+
val zero : unit t
1269
+
(** [zero] lossily maps all JSON values to [()] on decoding and encodes JSON
1270
+
nulls. *)
1271
+
1272
+
val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a t
1273
+
(** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if specified (errors
1274
+
otherwise) and errors on encoding. *)
1275
+
1276
+
(** {1:generic_json Generic JSON} *)
1277
+
1278
+
type name = string node
1279
+
(** The type for JSON member names. *)
1280
+
1281
+
type mem = name * json
1282
+
(** The type for generic JSON object members. *)
1283
+
1284
+
and object' = mem list
1285
+
(** The type for generic JSON objects. *)
1286
+
1287
+
(** The type for generic JSON values. *)
1288
+
and json =
1289
+
| Null of unit node
1290
+
| Bool of bool node
1291
+
| Number of float node
1292
+
(** Encoders must use [Null] if float is {{!Float.is_finite}not finite}.
1293
+
*)
1294
+
| String of string node
1295
+
| Array of json list node
1296
+
| Object of object' node (** *)
1297
+
1298
+
(** Generic JSON values. *)
1299
+
module Json : sig
1300
+
(** {1:json JSON values} *)
1301
+
1302
+
type 'a codec := 'a t
1303
+
1304
+
type 'a cons = ?meta:Meta.t -> 'a -> json
1305
+
(** The type for constructing JSON values from an OCaml value of type ['a].
1306
+
[meta] defaults to {!Meta.none}. *)
1307
+
1308
+
type t = json
1309
+
(** See {!Json.val-json}. *)
1310
+
1311
+
val meta : json -> Meta.t
1312
+
(** [meta v] is the metadata of value [v]. *)
1313
+
1314
+
val set_meta : Meta.t -> json -> json
1315
+
(** [set_meta m v] replaces [v]'s meta with [m]. *)
1316
+
1317
+
val copy_layout : json -> dst:json -> json
1318
+
(** [copy_layout src ~dst] copies the layout of [src] and sets it on [dst]
1319
+
using {!Meta.copy_ws}. *)
1320
+
1321
+
val sort : json -> Sort.t
1322
+
(** [sort v] is the sort of value [v]. *)
1323
+
1324
+
val zero : json cons
1325
+
(** [zero j] is a stub value of the sort value of [j]. The stub value is the
1326
+
“natural” zero: null, false, 0, empty string, empty array, empty object.
1327
+
*)
1328
+
1329
+
val equal : json -> json -> bool
1330
+
(** [equal j0 j1] is {!compare}[ j0 j1 = 0]. *)
1331
+
1332
+
val compare : json -> json -> int
1333
+
(** [compare j0 j1] is a total order on JSON values:
1334
+
- Floating point values are compared with {!Float.compare}, this means NaN
1335
+
values are equal.
1336
+
- Strings are compared byte wise.
1337
+
- Objects members are sorted before being compared.
1338
+
- {!Meta.t} values are ignored. *)
1339
+
1340
+
val pp : t fmt
1341
+
(** See {!Json.pp_json}. *)
1342
+
1343
+
(** {2:null Nulls and options} *)
1344
+
1345
+
val null : unit cons
1346
+
(** [null] is [Null (unit, meta)]. *)
1347
+
1348
+
val option : 'a cons -> 'a option cons
1349
+
(** [option c] constructs [Some v] values with [c v] and [None] ones with
1350
+
{!val-null}. *)
1351
+
1352
+
(** {2:bool Booleans} *)
1353
+
1354
+
val bool : bool cons
1355
+
(** [bool b] is [Bool (b, meta)]. *)
1356
+
1357
+
(** {2:numbers Numbers} *)
1358
+
1359
+
val number : float cons
1360
+
(** [number n] is [Number (n, meta)]. *)
1361
+
1362
+
val any_float : float cons
1363
+
(** [any_float v] is [number v] if {!Float.is_finite}[ v] is [true] and
1364
+
[string (Float.to_string v)] otherwise. See {!Json.any_float}. *)
1365
+
1366
+
val int32 : int32 cons
1367
+
(** [int32] is [i] as a JSON number. *)
1368
+
1369
+
val int64 : int64 cons
1370
+
(** [int64 i] is [i] as a JSON number or a JSON string if not in the range
1371
+
\[-2{^ 53};2{^ 53}\]. See also {!int64_as_string}. *)
1372
+
1373
+
val int64_as_string : int64 cons
1374
+
(** [int64_as_string i] is [i] as a JSON string. See also {!int64}. *)
1375
+
1376
+
val int : int cons
1377
+
(** [int] is [i] as a JSON number or a JSON string if not in the range
1378
+
\[-2{^ 53};2{^ 53}\]. See also {!int_as_string}. *)
1379
+
1380
+
val int_as_string : int cons
1381
+
(** [int_as_string i] is [i] as a JSON string. See also {!int}. *)
1382
+
1383
+
(** {2:strings Strings} *)
1384
+
1385
+
val string : string cons
1386
+
(** [string s] is [String (s, meta)]. *)
1387
+
1388
+
(** {2:arrays Arrays} *)
1389
+
1390
+
val list : json list cons
1391
+
(** [list l] is [Array (l, meta)]. *)
1392
+
1393
+
val array : json array cons
1394
+
(** [array l] is [Array (Array.to_list a, meta)]. See also {!list}. *)
1395
+
1396
+
(** {2:objects Objects} *)
1397
+
1398
+
val name : ?meta:Meta.t -> string -> name
1399
+
(** [name ?meta n] is [(n, meta)]. [meta] defaults to {!Meta.none}. *)
1400
+
1401
+
val mem : name -> json -> mem
1402
+
(** [mem n v] is [(n, v)]. [meta] defaults to {!Meta.none}. *)
1403
+
1404
+
val object' : object' cons
1405
+
(** [object o] is [Object (o, meta)]. *)
1406
+
1407
+
val find_mem : string -> object' -> mem option
1408
+
(** [find_mem n ms] find the first member whose name matches [n] in [ms]. *)
1409
+
1410
+
val find_mem' : name -> object' -> mem option
1411
+
(** [find_mem n ms] is [find_mem (fst n) ms]. *)
1412
+
1413
+
val object_names : object' -> string list
1414
+
(** [object_names ms] are the names of [ms]. *)
1415
+
1416
+
val object_names' : object' -> name list
1417
+
(** [object_names ms] are the names of [ms]. *)
1418
+
1419
+
(** {1:decode Decode} *)
1420
+
1421
+
val decode : 'a codec -> json -> ('a, string) result
1422
+
(** [decode t j] decodes a value from the generic JSON [j] according to type
1423
+
[t]. *)
1424
+
1425
+
val decode' : 'a codec -> json -> ('a, Error.t) result
1426
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
1427
+
1428
+
(** {1:encode Encode} *)
1429
+
1430
+
val encode : 'a codec -> 'a -> (json, string) result
1431
+
(** [encode t v] encodes a generic JSON value for [v] according to type [t].
1432
+
*)
1433
+
1434
+
val encode' : 'a codec -> 'a -> (json, Error.t) result
1435
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
1436
+
1437
+
(** {1:recode Recode} *)
1438
+
1439
+
val recode : 'a codec -> json -> (json, string) result
1440
+
(** [recode t v] decodes [v] with [t] and encodes it with [t]. *)
1441
+
1442
+
val recode' : 'a codec -> json -> (json, Error.t) result
1443
+
(** [recode'] is like {!val-recode} but preserves the error structure. *)
1444
+
1445
+
val update : 'a codec -> json -> json
1446
+
(** [update] is like {!val-recode} but raises {!Json.exception-Error}. *)
1447
+
1448
+
(** {1:errors Errors} *)
1449
+
1450
+
val error_sort : exp:Sort.t -> json -> 'a
1451
+
(** [error_sort ~exp fnd] errors when sort [exp] was expected but generic JSON
1452
+
[fnd] was found. *)
1453
+
1454
+
val error_type : 'a codec -> json -> 'a
1455
+
(** [error_type t fnd] errors when the type expected by [t] does not match
1456
+
[fnd]. *)
1457
+
end
1458
+
1459
+
val json : json t
1460
+
(** [json] maps any JSON value to its generic representation. *)
1461
+
1462
+
val json_null : json t
1463
+
(** [json_null] maps JSON nulls to their generic representation. *)
1464
+
1465
+
val json_bool : json t
1466
+
(** [json_bool] maps JSON booleans to their generic representation. *)
1467
+
1468
+
val json_number : json t
1469
+
(** [json_number] maps JSON nulls or numbers
1470
+
({{!page-cookbook.non_finite_numbers}explanation}) to their generic
1471
+
representation. *)
1472
+
1473
+
val json_string : json t
1474
+
(** [json_string] represents JSON strings by their generic representation. *)
1475
+
1476
+
val json_array : json t
1477
+
(** [json_array] represents JSON arrays by their generic representation. *)
1478
+
1479
+
val json_object : json t
1480
+
(** [json_object] represents JSON objects by their generic representation. *)
1481
+
1482
+
val json_mems : (json, json, mem list) Object.Mems.map
1483
+
(** [json_mems] is a members map collecting unknown members into a generic JSON
1484
+
object. See {{!page-cookbook.keeping}this example}. *)
1485
+
1486
+
(** {1:queries Queries and updates}
1487
+
1488
+
Queries are lossy or aggregating decodes. Updates decode to {!type-json}
1489
+
values but transform the data along the way. They allow to process JSON data
1490
+
without having to fully model it (see the update example in the
1491
+
{{!page-index.quick_start}quick start}). *)
1492
+
1493
+
val const : 'a t -> 'a -> 'a t
1494
+
(** [const t v] maps any JSON value to [v] on decodes and unconditionally
1495
+
encodes [v] with [t]. *)
1496
+
1497
+
val recode : dec:'a t -> ('a -> 'b) -> enc:'b t -> 'b t
1498
+
(** [recode ~dec f ~enc] maps on decodes like [dec] does followed by [f] and on
1499
+
encodes uses [enc]. This can be used to change the JSON sort of value. For
1500
+
example:
1501
+
{[
1502
+
recode ~dec:int (fun _ i -> string_of_int s) ~enc:string
1503
+
]}
1504
+
decodes an integer but encodes the integer as a string. *)
1505
+
1506
+
val update : 'a t -> json t
1507
+
(** [update t] decodes any JSON with [t] and directly encodes it back with [t]
1508
+
to yield the decode result. Encodes any JSON like {!val-json} does. *)
1509
+
1510
+
(** {2:array_queries Arrays} *)
1511
+
1512
+
val nth : ?absent:'a -> int -> 'a t -> 'a t
1513
+
(** [nth n t] decodes the [n]th index of a JSON array with [t]. Other indices
1514
+
are skipped. The decode errors if there is no such index unless [absent] is
1515
+
specified in which case this value is returned. Encodes a singleton array.
1516
+
*)
1517
+
1518
+
val set_nth : ?stub:json -> ?allow_absent:bool -> 'a t -> int -> 'a -> json t
1519
+
(** [set_nth t n v] on decodes sets the [n]th value of a JSON array to [v]
1520
+
encoded by [t]. Other indices are left untouched. Errors if there is no such
1521
+
index unless [~allow_absent:true] is specified in which case the index is
1522
+
created preceeded by as many [stub] indices as needed. [stub] defaults to
1523
+
{!Json.zero} applied to the value [v] encoded by [t] (i.e. the "natural
1524
+
zero" of [v]'s encoding sort). Encodes like {!json_array} does. *)
1525
+
1526
+
val update_nth : ?stub:json -> ?absent:'a -> int -> 'a t -> json t
1527
+
(** [update_nth n t] on decode recodes the [n]th value of a JSON array with [t].
1528
+
Errors if there is no such index unless [absent] is specified in which case
1529
+
the index is created with [absent], encoded with [t] and preceeded by as
1530
+
many [stub] values as needed. [stub] defaults to {!Json.zero} applied to the
1531
+
recode. Encodes like {!json_array} does. *)
1532
+
1533
+
val delete_nth : ?allow_absent:bool -> int -> json t
1534
+
(** [delete_nth n] drops the [n]th index of a JSON array on both decode and
1535
+
encodes. Other indices are left untouched. Errors if there is no such index
1536
+
unless [~allow_absent:true] is specified in which case the data is left
1537
+
untouched. *)
1538
+
1539
+
val filter_map_array : 'a t -> 'b t -> (int -> 'a -> 'b option) -> json t
1540
+
(** [filter_map_array a b f] maps the [a] elements of a JSON array with [f] to
1541
+
[b] elements or deletes them on [None]. Encodes generic JSON arrays like
1542
+
{!json_array} does. *)
1543
+
1544
+
val fold_array : 'a t -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b t
1545
+
(** [fold_array t f acc] fold [f] over the [t] elements of a JSON array starting
1546
+
with [acc]. Encodes an empty JSON array. *)
1547
+
1548
+
(** {2:object_queries Objects} *)
1549
+
1550
+
val mem : ?absent:'a -> string -> 'a t -> 'a t
1551
+
(** [mem name t] decodes the member named [name] of a JSON object with [t].
1552
+
Other members are skipped. The decode errors if there is no such member
1553
+
unless [absent] is specified in which case this value is returned. Encodes
1554
+
an object with a single [name] member. *)
1555
+
1556
+
val set_mem : ?allow_absent:bool -> 'a t -> string -> 'a -> json t
1557
+
(** [set_mem t name v] sets the member value of [name] of a [JSON] object to an
1558
+
encoding of [v] with [t]. This happens both on decodes and encodes. Errors
1559
+
if there is no such member unless [allow_absent:true] is specified in which
1560
+
case a member is added to the object. *)
1561
+
1562
+
val update_mem : ?absent:'a -> string -> 'a t -> json t
1563
+
(** [update_mem name t] recodes the member value of [name] of a JSON object with
1564
+
[t]. This happens both on decodes and encodes. Errors if there is no such
1565
+
member unless [absent] is specified in which case a member with this value
1566
+
encoded with [t] is added to the object. *)
1567
+
1568
+
val delete_mem : ?allow_absent:bool -> string -> json t
1569
+
(** [delete_mem name] deletes the member named [name] of a JSON object on
1570
+
decode. Other members are left untouched. The decode errors if there is no
1571
+
such member unless [~allow_absent:true] is specified in which case the data
1572
+
is left untouched. Encodes generic JSON objects like {!json_object} does. *)
1573
+
1574
+
val filter_map_object :
1575
+
'a t -> 'b t -> (Meta.t -> string -> 'a -> (name * 'b) option) -> json t
1576
+
(** [filter_map_object a b f] maps the [a] members of a JSON object with [f] to
1577
+
[(n, b)] members or deletes them on [None]. The meta given to [f] is the
1578
+
meta of the member name. Encodes generic JSON arrays like {!json_object}
1579
+
does. *)
1580
+
1581
+
val fold_object : 'a t -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b t
1582
+
(** [fold_object t f acc] folds [f] over the [t] members of a JSON object
1583
+
starting with [acc]. Encodes an empty JSON object. *)
1584
+
1585
+
(** {2:index_queries Indices} *)
1586
+
1587
+
val index : ?absent:'a -> Path.index -> 'a t -> 'a t
1588
+
(** [index] uses {!val-nth} or {!val-mem} on the given index. *)
1589
+
1590
+
val set_index : ?allow_absent:bool -> 'a t -> Path.index -> 'a -> json t
1591
+
(** [set_index] uses {!set_nth} or {!set_mem} on the given index. *)
1592
+
1593
+
val update_index : ?stub:json -> ?absent:'a -> Path.index -> 'a t -> json t
1594
+
(** [update_index] uses {!update_nth} or {!update_mem} on the given index. *)
1595
+
1596
+
val delete_index : ?allow_absent:bool -> Path.index -> json t
1597
+
(** [delete_index] uses {!delete_nth} or {!delete_mem} on the given index. *)
1598
+
1599
+
(** {2:path_queries Paths} *)
1600
+
1601
+
val path : ?absent:'a -> Path.t -> 'a t -> 'a t
1602
+
(** [path p t] {{!index}decodes} with [t] on the last index of [p]. If [p] is
1603
+
{!Path.root} this is [t]. *)
1604
+
1605
+
val set_path :
1606
+
?stub:json -> ?allow_absent:bool -> 'a t -> Path.t -> 'a -> json t
1607
+
(** [set_path t p v] {{!set_index}sets} the last index of [p]. If [p] is
1608
+
{!Path.root} this encodes [v] with [t]. *)
1609
+
1610
+
val update_path : ?stub:json -> ?absent:'a -> Path.t -> 'a t -> json t
1611
+
(** [update_path p t] {{!update_index}updates} the last index of [p] with [t].
1612
+
On the root path this is [t]. *)
1613
+
1614
+
val delete_path : ?allow_absent:bool -> Path.t -> json t
1615
+
(** [delete_path p] {{!delete_index}deletes} the last index of [p]. If [p] is
1616
+
{!Path.root} this is {!Json.val-null}. *)
1617
+
1618
+
(** {1:fmt Formatting} *)
1619
+
1620
+
(** The type for specifying JSON encoding formatting. See for example
1621
+
{!Json_bytesrw.val-encode}. *)
1622
+
type format =
1623
+
| Minify (** Compact. No whitespace, no newlines. *)
1624
+
| Indent (** Indented output (not necessarily pretty). *)
1625
+
| Layout (** Follow {!Meta} layout information. *)
1626
+
1627
+
type number_format = (float -> unit, Format.formatter, unit) Stdlib.format
1628
+
(** The type for JSON number formatters. *)
1629
+
1630
+
val default_number_format : number_format
1631
+
(** [default_number_format] is ["%.17g"]. This number formats ensures that
1632
+
finite floating point values can be interchanged without loss of precision.
1633
+
*)
1634
+
1635
+
val pp_null : unit fmt
1636
+
(** [pp_null] formats a JSON null. *)
1637
+
1638
+
val pp_bool : bool fmt
1639
+
(** [pp_bool] formats a JSON bool. *)
1640
+
1641
+
val pp_number : float fmt
1642
+
(** [pp_number] formats a JSON number of a JSON null if the float is not finite.
1643
+
Uses the {!default_number_format}. *)
1644
+
1645
+
val pp_number' : number_format -> float fmt
1646
+
(** [pp_number fmt] is like {!pp_number} but uses [fmt] to format the number. *)
1647
+
1648
+
val pp_string : string fmt
1649
+
(** [pp_string] formats a JSON string (quoted and escaped). Assumes the string
1650
+
is valid UTF-8. *)
1651
+
1652
+
val pp_json : json fmt
1653
+
(** [pp_json] formats JSON, see {!pp_json'}. *)
1654
+
1655
+
val pp_json' : ?number_format:number_format -> unit -> json fmt
1656
+
(** [pp' ~format ~number_format () ppf j] formats [j] on [ppf]. The output is
1657
+
indented but may be more compact than an [Indent] JSON encoder may do. For
1658
+
example arrays may be output on one line if they fit etc.
1659
+
- [number_format] is used to format JSON numbers. Defaults to
1660
+
{!default_number_format}
1661
+
- Non-finite numbers are output as JSON nulls
1662
+
({{!page-cookbook.non_finite_numbers}explanation}).
1663
+
- Strings are assumed to be valid UTF-8. *)
1664
+
1665
+
val pp_value : ?number_format:number_format -> 'a t -> unit -> 'a fmt
1666
+
(** [pp_value t ()] formats the JSON representation of values as described by
1667
+
[t] by encoding it with {!Json.val-encode} and formatting it with
1668
+
{!pp_json'}. If the encoding of the value errors a JSON string with the
1669
+
error message is formatted. This means that {!pp_value} should always format
1670
+
valid JSON text. *)
1671
+
1672
+
(** {1:low Low-level representation} *)
1673
+
1674
+
(** Low level representation (unstable).
1675
+
1676
+
This representation may change even between minor versions of the library.
1677
+
It can be used to devise new processors on JSON types.
1678
+
1679
+
Processors should be ready to catch the {!Json.exception-Error} exception
1680
+
when they invoke functional members of the representation.
1681
+
1682
+
Processors should make sure they interpret mappings correctly. In
1683
+
particular:
1684
+
- The [Number] case represents the sets of JSON numbers and nulls.
1685
+
1686
+
See the source of {!Json.decode'} and {!Json.encode'} for a simple example
1687
+
on how to process this representation. The
1688
+
{{:https://erratique.ch/repos/jsont/tree/paper}paper} in the Json source
1689
+
repository may also help to understand this menagerie of types. *)
1690
+
module Repr : sig
1691
+
type 'a t' := 'a t
1692
+
1693
+
module String_map : Map.S with type key = string
1694
+
(** A [Map.Make(String)] instance. *)
1695
+
1696
+
(** Type identifiers. Can be removed once we require OCaml 5.1 *)
1697
+
module Type : sig
1698
+
type (_, _) eq = Equal : ('a, 'a) eq
1699
+
1700
+
module Id : sig
1701
+
type 'a t
1702
+
1703
+
val make : unit -> 'a t
1704
+
val uid : 'a t -> int
1705
+
val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option
1706
+
end
1707
+
end
1708
+
1709
+
(** The type for decoding functions. *)
1710
+
type ('ret, 'f) dec_fun =
1711
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
1712
+
(** The function and its return type. *)
1713
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
1714
+
(** Application of an argument to a function witnessed by a type
1715
+
identifier. The type identifier can be used to lookup a value of the
1716
+
right type in an heterogenous dictionary. *)
1717
+
1718
+
(** {1:base Base value maps} *)
1719
+
1720
+
type ('a, 'b) base_map = {
1721
+
kind : string;
1722
+
(** The kind of JSON value that are mapped (documentation) *)
1723
+
doc : string; (** A doc string for the kind of JSON value. *)
1724
+
dec : Meta.t -> 'a -> 'b;
1725
+
(** [dec] decodes a base value represented by its metadata and ['a] to
1726
+
['b]. *)
1727
+
enc : 'b -> 'a;
1728
+
(** [enc] encodes a value of type ['b] to a base JSON value represented
1729
+
by ['a]. *)
1730
+
enc_meta : 'b -> Meta.t;
1731
+
(** [enc_meta] recovers the base JSON value metadata from ['b] (if any).
1732
+
*)
1733
+
}
1734
+
(** The type for mapping JSON base values represented in OCaml by ['a] (these
1735
+
values are fixed by the cases in {!t}) to a value of type ['b]. *)
1736
+
1737
+
(** {1:types JSON types} *)
1738
+
1739
+
(** The type for JSON types. *)
1740
+
type 'a t =
1741
+
| Null : (unit, 'a) base_map -> 'a t (** Null maps. *)
1742
+
| Bool : (bool, 'a) base_map -> 'a t (** Boolean maps. *)
1743
+
| Number : (float, 'a) base_map -> 'a t (** Number maps. *)
1744
+
| String : (string, 'a) base_map -> 'a t (** String maps. *)
1745
+
| Array : ('a, 'elt, 'builder) array_map -> 'a t (** Array maps. *)
1746
+
| Object : ('o, 'o) object_map -> 'o t (** Object maps. *)
1747
+
| Any : 'a any_map -> 'a t (** Map for different sorts of JSON values. *)
1748
+
| Map : ('b, 'a) map -> 'a t
1749
+
(** Map from JSON type ['b] to JSON type ['a]. *)
1750
+
| Rec : 'a t Lazy.t -> 'a t (** Recursive definition. *)
1751
+
1752
+
(** {1:array Array maps} *)
1753
+
1754
+
and ('array, 'elt, 'builder) array_map = {
1755
+
kind : string; (** The kind of JSON array mapped (documentation). *)
1756
+
doc : string; (** Documentation string for the JSON array. *)
1757
+
elt : 'elt t; (** The type for the array elements. *)
1758
+
dec_empty : unit -> 'builder;
1759
+
(** [dec_empty ()] creates a new empty array builder. *)
1760
+
dec_skip : int -> 'builder -> bool;
1761
+
(** [dec_skip i b] determines if the [i]th index of the JSON array can
1762
+
be skipped. *)
1763
+
dec_add : int -> 'elt -> 'builder -> 'builder;
1764
+
(** [dec_add] adds the [i]th index value of the JSON array as decoded by
1765
+
[elt] to the builder. *)
1766
+
dec_finish : Meta.t -> int -> 'builder -> 'array;
1767
+
(** [dec_finish] turns the builder into an array given its metadata and
1768
+
length. *)
1769
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
1770
+
(** [enc] folds over the elements of the array for encoding. *)
1771
+
enc_meta : 'array -> Meta.t;
1772
+
(** [enc_meta] recovers the metadata of an array (if any). *)
1773
+
}
1774
+
(** The type for mapping JSON arrays to values of type ['array] with array
1775
+
elements mapped to type ['elt] and using a ['builder] value to construct
1776
+
the array. *)
1777
+
1778
+
(** {1:object_map Object maps} *)
1779
+
1780
+
and ('o, 'dec) object_map = {
1781
+
kind : string; (** The kind of JSON object (documentation). *)
1782
+
doc : string; (** A doc string for the JSON member. *)
1783
+
dec : ('o, 'dec) dec_fun;
1784
+
(** The object decoding function to construct an ['o] value. *)
1785
+
mem_decs : mem_dec String_map.t;
1786
+
(** [mem_decs] are the member decoders sorted by member name. *)
1787
+
mem_encs : 'o mem_enc list;
1788
+
(** [mem_encs] is the list of member encoders. *)
1789
+
enc_meta : 'o -> Meta.t;
1790
+
(** [enc_meta] recovers the metadata of an object (if any). *)
1791
+
shape : 'o object_shape;
1792
+
(** [shape] is the {{!object_shape}shape} of the object. *)
1793
+
}
1794
+
(** The type for mapping a JSON object to values of type ['o] using a decoding
1795
+
function of type ['dec]. [mem_decs] and [mem_encs] have the same
1796
+
{!mem_map} values they are just sorted differently for decoding and
1797
+
encoding purposes. *)
1798
+
1799
+
and mem_dec =
1800
+
| Mem_dec : ('o, 'a) mem_map -> mem_dec
1801
+
(** The type for member maps in decoding position. *)
1802
+
1803
+
and 'o mem_enc =
1804
+
| Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
1805
+
(** The type for member maps in encoding position. *)
1806
+
1807
+
and ('o, 'a) mem_map = {
1808
+
name : string; (** The JSON member name. *)
1809
+
doc : string; (** Documentation for the JSON member. *)
1810
+
type' : 'a t; (** The type for the member value. *)
1811
+
id : 'a Type.Id.t;
1812
+
(** A type identifier for the member. This allows to store the decode in
1813
+
a {!Dict.t} on decode and give it in time to the object decoding
1814
+
function of the object map. *)
1815
+
dec_absent : 'a option; (** The value to use if absent (if any). *)
1816
+
enc : 'o -> 'a; (** [enc] recovers the value to encode from ['o]. *)
1817
+
(* enc_name_meta : 'a -> Meta.t;
1818
+
XXX This should have been the meta found for the name, but
1819
+
that does not fit so well in the member combinators, it's
1820
+
not impossible to fit it in but likely increases the cost
1821
+
for decoding objects. The layout preserving updates occur
1822
+
via generic JSON which uses [mems_map] in which the meta
1823
+
is available in [dec_add]. Let's leave it that way for now. *)
1824
+
enc_omit : 'a -> bool;
1825
+
(** [enc_omit] is [true] if the result of [enc] should not be encoded.
1826
+
*)
1827
+
}
1828
+
(** The type for mapping a JSON member to a value of type ['a] in an object
1829
+
represented by a value of type ['o]. *)
1830
+
1831
+
(** The type for object shapes. *)
1832
+
and 'o object_shape =
1833
+
| Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape
1834
+
(** A basic object, possibly indicating how to handle unknown members *)
1835
+
| Object_cases :
1836
+
('o, 'mems, 'builder) unknown_mems option
1837
+
* ('o, 'cases, 'tag) object_cases
1838
+
-> 'o object_shape
1839
+
(** An object with a case member each case further describing an object
1840
+
map. *)
1841
+
1842
+
(** {2:unknown_mems Unknown members} *)
1843
+
1844
+
(** The type for specifying decoding behaviour on unknown JSON object members.
1845
+
*)
1846
+
and ('o, 'mems, 'builder) unknown_mems =
1847
+
| Unknown_skip : ('o, unit, unit) unknown_mems (** Skip unknown members. *)
1848
+
| Unknown_error : ('o, unit, unit) unknown_mems
1849
+
(** Error on unknown members. *)
1850
+
| Unknown_keep :
1851
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems)
1852
+
-> ('o, 'mems, 'builder) unknown_mems
1853
+
(** Gather unknown members in a member map. *)
1854
+
1855
+
and ('mems, 'a, 'builder) mems_map = {
1856
+
kind : string; (** The kind for unknown members (documentation). *)
1857
+
doc : string; (** Documentation string for the unknown members. *)
1858
+
mems_type : 'a t;
1859
+
(** The uniform type according which unknown members are typed. *)
1860
+
id : 'mems Type.Id.t; (** A type identifier for the unknown member map. *)
1861
+
dec_empty : unit -> 'builder;
1862
+
(** [dec_empty] create a new empty member map builder. *)
1863
+
dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder;
1864
+
(** [dec_add] adds a member named [n] with metadata [meta] and value
1865
+
parsed by [mems_type] to the builder. *)
1866
+
dec_finish : Meta.t -> 'builder -> 'mems;
1867
+
(** [dec_finish] turns the builder into an unknown member map. The
1868
+
[meta] is the meta data of the object in which they were found. *)
1869
+
enc :
1870
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
1871
+
(** [enc] folds over the member map for encoding. *)
1872
+
}
1873
+
(** The type for gathering unknown JSON members uniformly typed according to
1874
+
['a] in a map ['mems] constructed with ['builder]. *)
1875
+
1876
+
(** {2:case_objects Case objects} *)
1877
+
1878
+
and ('o, 'cases, 'tag) object_cases = {
1879
+
tag : ('tag, 'tag) mem_map;
1880
+
(** The JSON member used to decide cases. The [enc] field of this
1881
+
[mem_map] should be the identity, this allows encoders to reuse
1882
+
generic encoding code for members. We don't have
1883
+
[('o, 'tag) mem_map] here because the tag is not stored we recover
1884
+
the case via [enc] and [enc_case] below. *)
1885
+
tag_compare : 'tag -> 'tag -> int; (** The function to compare tags. *)
1886
+
tag_to_string : ('tag -> string) option;
1887
+
(** The function to stringify tags for error reporting. *)
1888
+
id : 'cases Type.Id.t; (** A type identifier for the tag. *)
1889
+
cases : ('cases, 'tag) case list; (** The list of possible cases. *)
1890
+
enc : 'o -> 'cases;
1891
+
(** [enc] is the function to recover case values from the value ['o] the
1892
+
object is mapped to. *)
1893
+
enc_case : 'cases -> ('cases, 'tag) case_value;
1894
+
(** [enc_case] retrieves the concrete case from the common [cases]
1895
+
values. You can see it as preforming a match. *)
1896
+
}
1897
+
(** The type for object cases mapped to a common type ['cases] stored in a
1898
+
vlue of type ['o] and identified by tag values of type ['tag]. *)
1899
+
1900
+
and ('cases, 'case, 'tag) case_map = {
1901
+
tag : 'tag; (** The tag value for the case. *)
1902
+
object_map : ('case, 'case) object_map; (** The object map for the case. *)
1903
+
dec : 'case -> 'cases;
1904
+
(** [dec] is the function used on decoding to inject the case into the
1905
+
common ['cases] type. *)
1906
+
}
1907
+
(** The type for an object case with common type ['cases] specific type
1908
+
['case] and tag type ['tag]. *)
1909
+
1910
+
and ('cases, 'tag) case_value =
1911
+
| Case_value :
1912
+
('cases, 'case, 'tag) case_map * 'case
1913
+
-> ('cases, 'tag) case_value
1914
+
(** The type for case values. This packs a case value and its
1915
+
description. *)
1916
+
1917
+
and ('cases, 'tag) case =
1918
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
1919
+
(** The type for hiding the the concrete type of a case . *)
1920
+
1921
+
(** {1:any Any maps} *)
1922
+
1923
+
and 'a any_map = {
1924
+
kind : string; (** The kind of JSON values mapped (documentation). *)
1925
+
doc : string; (** Documentation string for the kind of values. *)
1926
+
dec_null : 'a t option;
1927
+
(** [dec_null], if any, is used for decoding JSON nulls. *)
1928
+
dec_bool : 'a t option;
1929
+
(** [dec_bool], if any, is used for decoding JSON bools. *)
1930
+
dec_number : 'a t option;
1931
+
(** [dec_number], if any, is used for decoding JSON numbers. *)
1932
+
dec_string : 'a t option;
1933
+
(** [dec_string], if any, is used for decoding JSON strings. *)
1934
+
dec_array : 'a t option;
1935
+
(** [dec_array], if any, is used for decoding JSON arrays. *)
1936
+
dec_object : 'a t option;
1937
+
(** [dec_object], if any, is used for decoding JSON objects. *)
1938
+
enc : 'a -> 'a t;
1939
+
(** [enc] specifies the encoder to use on a given value. *)
1940
+
}
1941
+
(** The type for mapping JSON values with multiple sorts to a value of type
1942
+
['a]. If a decoding case is [None], the decoding errors on these JSON
1943
+
values. *)
1944
+
1945
+
(** {1:type_map Type maps} *)
1946
+
1947
+
and ('a, 'b) map = {
1948
+
kind : string; (** The kind of JSON values mapped (documentation). *)
1949
+
doc : string; (** Documentation string for the kind of values. *)
1950
+
dom : 'a t; (** The domain of the map. *)
1951
+
dec : 'a -> 'b; (** [dec] decodes ['a] to ['b]. *)
1952
+
enc : 'b -> 'a; (** [enc] encodes ['b] to ['a]. *)
1953
+
}
1954
+
(** The type for mapping JSON types of type ['a] to a JSON type of type ['b].
1955
+
*)
1956
+
1957
+
(** {1:conv Convert} *)
1958
+
1959
+
val of_t : 'a t' -> 'a t
1960
+
(** [of_t] is {!Stdlib.Fun.id}. *)
1961
+
1962
+
val unsafe_to_t : 'a t -> 'a t'
1963
+
(** [unsafe_to_t r] converts the representation to a type [r]. It is unsafe
1964
+
because constructors of the {!Json} module do maintain some invariants.
1965
+
*)
1966
+
1967
+
(** {1:kinds Kinds and doc} *)
1968
+
1969
+
val kinded_sort : 'a t -> string
1970
+
(** [kinded_sort t] is kinded sort of [t], see {!Json.kinded_sort}. *)
1971
+
1972
+
val array_map_kinded_sort : ('a, 'elt, 'builder) array_map -> string
1973
+
(** [array_map_kinded_sort map] is like {!kinded_sort} but acts directly on
1974
+
the array [map]. *)
1975
+
1976
+
val object_map_kinded_sort : ('o, 'dec) object_map -> string
1977
+
(** [object_map_kind map] is like {!kinded_sort} but acts directly on the
1978
+
object [map]. *)
1979
+
1980
+
val pp_kind : string fmt
1981
+
(** [pp_kind] formats kinds. *)
1982
+
1983
+
val doc : 'a t -> string
1984
+
(** See {!Json.doc}. *)
1985
+
1986
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
1987
+
(** See {!Json.with_doc}. *)
1988
+
1989
+
(** {1:errors Errors} *)
1990
+
1991
+
val error_push_array :
1992
+
Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a
1993
+
(** [error_push_array] is like {!Error.push_array} but uses the given array
1994
+
[meta] and array map to caracterize the context. *)
1995
+
1996
+
val error_push_object :
1997
+
Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a
1998
+
(** [error_push_object] is like {!Error.push_object} but uses the given object
1999
+
[meta] and object map to caracterize the context. *)
2000
+
2001
+
val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b
2002
+
(** [type_error meta ~exp ~fnd] errors when kind [exp] was expected but sort
2003
+
[fnd] was found. *)
2004
+
2005
+
val missing_mems_error :
2006
+
Meta.t ->
2007
+
('o, 'o) object_map ->
2008
+
exp:mem_dec String_map.t ->
2009
+
fnd:string list ->
2010
+
'a
2011
+
(** [missing_mems_error m map exp fnd] errors when [exp] cannot be found,
2012
+
[fnd] can list a few members that were found. *)
2013
+
2014
+
val unexpected_mems_error :
2015
+
Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a
2016
+
(** [unexpected_mems_error meta map ~fnd] errors when [fnd] are unexpected
2017
+
members for object [map]. *)
2018
+
2019
+
val unexpected_case_tag_error :
2020
+
Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases -> 'tag -> 'a
2021
+
(** [unexpected_case_tag_error meta map cases tag] is when a [tag] of a case
2022
+
member has no corresponding case. *)
2023
+
2024
+
(** {1:toolbox Processor toolbox} *)
2025
+
2026
+
val object_meta_arg : Meta.t Type.Id.t
2027
+
(** [object_meta_arg] holds the {!Json.Object.mem} to *)
2028
+
2029
+
(** Heterogeneous dictionaries. *)
2030
+
module Dict : sig
2031
+
type binding = B : 'a Type.Id.t * 'a -> binding
2032
+
type t
2033
+
2034
+
val empty : t
2035
+
val mem : 'a Type.Id.t -> t -> bool
2036
+
val add : 'a Type.Id.t -> 'a -> t -> t
2037
+
val remove : 'a Type.Id.t -> t -> t
2038
+
val find : 'a Type.Id.t -> t -> 'a option
2039
+
end
2040
+
2041
+
val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f
2042
+
(** [apply_dict dec dict] applies [dict] to [f] in order to get the value
2043
+
['f]. Raises [Invalid_argument] if [dict] has not all the type identifiers
2044
+
that [dec] needs. *)
2045
+
2046
+
type unknown_mems_option =
2047
+
| Unknown_mems :
2048
+
('o, 'mems, 'builder) unknown_mems option
2049
+
-> unknown_mems_option
2050
+
(** A type for hiding an optional {!type-unknown_mems} values. *)
2051
+
2052
+
val override_unknown_mems :
2053
+
by:unknown_mems_option ->
2054
+
unknown_mems_option ->
2055
+
Dict.t ->
2056
+
unknown_mems_option * Dict.t
2057
+
(** [override_unknown_mems ~by current dict] preforms the unknown member
2058
+
overriding logic for {!Json.Object.Case} objects. In particular if
2059
+
[current] is a {!Json.Object.Mems.val-map} it adds an empty one in [dict]
2060
+
so that the associated decoding function does not fail. *)
2061
+
2062
+
val finish_object_decode :
2063
+
('o, 'o) object_map ->
2064
+
Meta.t ->
2065
+
('p, 'mems, 'builder) unknown_mems ->
2066
+
'builder ->
2067
+
mem_dec String_map.t ->
2068
+
Dict.t ->
2069
+
Dict.t
2070
+
(** [finish_object_decode map meta unknown_mems umap rem_mems dict] finishes
2071
+
an object map [map] decode. It adds the [umap] (if needed) to [dict], it
2072
+
adds [meta] to [dict] under {!object_meta_arg} and tries to find andd
2073
+
default values to [dict] for [rem_mems] (and errors if it can't). *)
2074
+
2075
+
val pp_code : string fmt
2076
+
(** [pp_code] formats strings like code (in bold). *)
2077
+
end
+748
lib/json_base.ml
+748
lib/json_base.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* These three things should really belong to String. *)
7
+
8
+
let string_subrange ?(first = 0) ?last s =
9
+
let max = String.length s - 1 in
10
+
let last =
11
+
match last with None -> max | Some l when l > max -> max | Some l -> l
12
+
in
13
+
let first = if first < 0 then 0 else first in
14
+
if first > last then "" else String.sub s first (last - first + 1)
15
+
16
+
let edit_distance s0 s1 =
17
+
let min_by f a b = if f a <= f b then a else b in
18
+
let max_by f a b = if f a <= f b then b else a in
19
+
let minimum a b c = min a (min b c) in
20
+
let s0 = min_by String.length s0 s1 (* row *)
21
+
and s1 = max_by String.length s0 s1 in
22
+
(* column *)
23
+
let m = String.length s0 and n = String.length s1 in
24
+
let rec rows row0 row i =
25
+
if i > n then row0.(m)
26
+
else begin
27
+
row.(0) <- i;
28
+
for j = 1 to m do
29
+
if s0.[j - 1] = s1.[i - 1] then row.(j) <- row0.(j - 1)
30
+
else
31
+
row.(j) <- minimum (row0.(j - 1) + 1) (row0.(j) + 1) (row.(j - 1) + 1)
32
+
done;
33
+
rows row row0 (i + 1)
34
+
end
35
+
in
36
+
rows (Array.init (m + 1) (fun x -> x)) (Array.make (m + 1) 0) 1
37
+
38
+
let suggest ?(dist = 2) candidates s =
39
+
let add (min, acc) name =
40
+
let d = edit_distance s name in
41
+
if d = min then (min, name :: acc)
42
+
else if d < min then (d, [ name ])
43
+
else (min, acc)
44
+
in
45
+
let d, suggs = List.fold_left add (max_int, []) candidates in
46
+
if d <= dist (* suggest only if not too far *) then List.rev suggs else []
47
+
48
+
(* Hex converters *)
49
+
50
+
let lower_hex_digit n =
51
+
let n = n land 0xF in
52
+
Char.unsafe_chr (if n < 10 then 0x30 + n else 0x57 + n)
53
+
54
+
let binary_string_to_hex s =
55
+
let rec loop max s i h k =
56
+
if i > max then Bytes.unsafe_to_string h
57
+
else
58
+
let byte = Char.code s.[i] in
59
+
Bytes.set h k (lower_hex_digit (byte lsr 4));
60
+
Bytes.set h (k + 1) (lower_hex_digit byte);
61
+
loop max s (i + 1) h (k + 2)
62
+
in
63
+
let len = String.length s in
64
+
let h = Bytes.create (2 * len) in
65
+
loop (len - 1) s 0 h 0
66
+
67
+
exception Illegal_hex of int
68
+
69
+
let binary_string_of_hex h =
70
+
let hex_value s i =
71
+
match s.[i] with
72
+
| '0' .. '9' as c -> Char.code c - 0x30
73
+
| 'A' .. 'F' as c -> 10 + (Char.code c - 0x41)
74
+
| 'a' .. 'f' as c -> 10 + (Char.code c - 0x61)
75
+
| _ -> raise_notrace (Illegal_hex i)
76
+
in
77
+
try
78
+
match String.length h with
79
+
| len when len mod 2 <> 0 -> raise (Illegal_hex len)
80
+
| len ->
81
+
let rec loop max s i h k =
82
+
if i > max then Ok (Bytes.unsafe_to_string s)
83
+
else
84
+
let hi = hex_value h k and lo = hex_value h (k + 1) in
85
+
Bytes.set s i (Char.chr @@ ((hi lsl 4) lor lo));
86
+
loop max s (i + 1) h (k + 2)
87
+
in
88
+
let s_len = len / 2 in
89
+
let s = Bytes.create s_len in
90
+
loop (s_len - 1) s 0 h 0
91
+
with Illegal_hex i ->
92
+
if i = String.length h then Error "Missing final hexadecimal digit"
93
+
else
94
+
let c = String.get_uint8 h i in
95
+
Error (Printf.sprintf "%d: byte x%x not an ASCII hexadecimal digit" i c)
96
+
97
+
(* Type identifiers. *)
98
+
99
+
module Type = struct
100
+
(* Can be removed once we require OCaml 5.1 *)
101
+
type (_, _) eq = Equal : ('a, 'a) eq
102
+
103
+
module Id = struct
104
+
type _ id = ..
105
+
106
+
module type ID = sig
107
+
type t
108
+
type _ id += Id : t id
109
+
end
110
+
111
+
type 'a t = (module ID with type t = 'a)
112
+
113
+
let make (type a) () : a t =
114
+
(module struct
115
+
type t = a
116
+
type _ id += Id : t id
117
+
end)
118
+
119
+
let provably_equal (type a b) ((module A) : a t) ((module B) : b t) :
120
+
(a, b) eq option =
121
+
match A.Id with B.Id -> Some Equal | _ -> None
122
+
123
+
let uid (type a) ((module A) : a t) =
124
+
Obj.Extension_constructor.id (Obj.Extension_constructor.of_val A.Id)
125
+
end
126
+
end
127
+
128
+
(* Resizable arrays *)
129
+
130
+
module Rarray = struct
131
+
type 'a t = {
132
+
mutable els : 'a array;
133
+
mutable max : int; (* index of last element of [els]. *)
134
+
}
135
+
136
+
let get a i = a.els.(i)
137
+
let empty () = { els = [||]; max = -1 }
138
+
139
+
let grow a v =
140
+
let len = a.max + 1 in
141
+
let els' = Array.make (2 * if len = 0 then 1 else len) v in
142
+
Array.blit a.els 0 els' 0 len;
143
+
a.els <- els'
144
+
145
+
let length a = a.max + 1
146
+
147
+
let add_last v a =
148
+
let max = a.max + 1 in
149
+
if max = Array.length a.els then grow a v;
150
+
a.max <- max;
151
+
a.els.(max) <- v;
152
+
a
153
+
154
+
let to_array a =
155
+
if a.max + 1 = Array.length a.els then a.els
156
+
else
157
+
let v = Array.make (a.max + 1) a.els.(0) in
158
+
Array.blit a.els 0 v 0 (a.max + 1);
159
+
v
160
+
end
161
+
162
+
(* Resizable bigarrays *)
163
+
164
+
module Rbigarray1 = struct
165
+
type ('a, 'b, 'c) t = {
166
+
mutable els : ('a, 'b, 'c) Bigarray.Array1.t;
167
+
mutable max : int; (* index of the last element of [els]. *)
168
+
}
169
+
170
+
let get a i = Bigarray.Array1.get a.els i
171
+
172
+
let empty kind layout =
173
+
{ els = Bigarray.Array1.create kind layout 0; max = -1 }
174
+
175
+
let grow a v =
176
+
let len = a.max + 1 in
177
+
let len = if len = 0 then 1 else len in
178
+
let init i = Bigarray.Array1.(if i <= a.max then get a.els i else v) in
179
+
let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
180
+
let els' = Bigarray.Array1.init k l (2 * len) init in
181
+
a.els <- els'
182
+
183
+
let length a = a.max + 1
184
+
185
+
let add_last v a =
186
+
let max = a.max + 1 in
187
+
if max = Bigarray.Array1.dim a.els then grow a v;
188
+
a.max <- max;
189
+
Bigarray.Array1.set a.els max v;
190
+
a
191
+
192
+
let to_bigarray a =
193
+
if a.max + 1 = Bigarray.Array1.dim a.els then a.els
194
+
else
195
+
let init i = Bigarray.Array1.get a.els i in
196
+
let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
197
+
Bigarray.Array1.init k l (a.max + 1) init
198
+
end
199
+
200
+
(* Mini fmt *)
201
+
202
+
module Fmt = struct
203
+
type 'a t = Format.formatter -> 'a -> unit
204
+
205
+
let pf = Format.fprintf
206
+
let str = Format.asprintf
207
+
let nop _ () = ()
208
+
let sp = Format.pp_print_space
209
+
210
+
let comma ppf () =
211
+
Format.pp_print_char ppf ',';
212
+
sp ppf ()
213
+
214
+
let list = Format.pp_print_list
215
+
let char = Format.pp_print_char
216
+
let string = Format.pp_print_string
217
+
218
+
let substring first len ppf s =
219
+
if first = 0 && len = String.length s then string ppf s
220
+
else
221
+
(* One day use https://github.com/ocaml/ocaml/pull/12133 *)
222
+
for i = first to first + len - 1 do
223
+
char ppf s.[i]
224
+
done
225
+
226
+
let lines ppf s =
227
+
Format.pp_print_list string ppf (String.split_on_char '\n' s)
228
+
229
+
(* ANSI styling
230
+
231
+
Note this is the scheme we have in More.Fmt but obviously
232
+
we can't depend on it. For now we decided not to surface it
233
+
at the library level. Ideally something should be provided
234
+
upstream. *)
235
+
236
+
type styler = Ansi | Plain
237
+
238
+
let styler' =
239
+
Atomic.make
240
+
@@
241
+
match Sys.getenv_opt "NO_COLOR" with
242
+
| Some s when s <> "" -> Plain
243
+
| _ -> (
244
+
match Sys.getenv_opt "TERM" with
245
+
| Some "dumb" -> Plain
246
+
| None when Sys.backend_type <> Other "js_of_ocaml" -> Plain
247
+
| _ -> Ansi)
248
+
249
+
let set_styler styler = Atomic.set styler' styler
250
+
let styler () = Atomic.get styler'
251
+
let ansi_reset = "\x1B[0m"
252
+
253
+
let bold ppf s =
254
+
if Atomic.get styler' = Plain then string ppf s
255
+
else pf ppf "@<0>%s%s@<0>%s" "\x1B[1m" s ansi_reset
256
+
257
+
let bold_red ppf s =
258
+
if Atomic.get styler' = Plain then string ppf s
259
+
else pf ppf "@<0>%s%s@<0>%s" "\x1B[31;1m" s ansi_reset
260
+
261
+
let code = bold
262
+
263
+
let puterr ppf () =
264
+
bold_red ppf "Error";
265
+
char ppf ':'
266
+
267
+
let disable_ansi_styler () = set_styler Plain
268
+
269
+
(* HCI fragments *)
270
+
271
+
let op_enum op ?(empty = nop) pp_v ppf = function
272
+
| [] -> empty ppf ()
273
+
| [ v ] -> pp_v ppf v
274
+
| _ as vs ->
275
+
let rec loop ppf = function
276
+
| [ v0; v1 ] -> pf ppf "%a@ %s@ %a" pp_v v0 op pp_v v1
277
+
| v :: vs ->
278
+
pf ppf "%a,@ " pp_v v;
279
+
loop ppf vs
280
+
| [] -> assert false
281
+
in
282
+
loop ppf vs
283
+
284
+
let or_enum ?empty pp_v ppf vs = op_enum "or" ?empty pp_v ppf vs
285
+
286
+
let should_it_be pp_v ppf = function
287
+
| [] -> ()
288
+
| vs -> pf ppf "Should it be %a ?" (or_enum pp_v) vs
289
+
290
+
let must_be pp_v ppf = function
291
+
| [] -> ()
292
+
| vs -> pf ppf "Must be %a." (or_enum pp_v) vs
293
+
294
+
let unexpected ~kind pp_v ppf v = pf ppf "Unexpected %a: %a." kind () pp_v v
295
+
296
+
let unexpected' ~kind pp_v ~hint ppf (v, hints) =
297
+
match hints with
298
+
| [] -> unexpected ~kind pp_v ppf v
299
+
| hints ->
300
+
unexpected ~kind pp_v ppf v;
301
+
sp ppf ();
302
+
(hint pp_v) ppf hints
303
+
304
+
let out_of_dom ?pp_kind () ppf (s, ss) =
305
+
let kind =
306
+
match pp_kind with
307
+
| None -> fun ppf () -> string ppf "value"
308
+
| Some pp_kind -> pp_kind
309
+
in
310
+
let hint, ss =
311
+
match suggest ss s with [] -> (must_be, ss) | ss -> (should_it_be, ss)
312
+
in
313
+
pf ppf "@[%a@]" (unexpected' ~kind code ~hint) (s, ss)
314
+
315
+
let similar_mems ppf (exp, fnd) =
316
+
match suggest fnd exp with
317
+
| [] -> ()
318
+
| ms ->
319
+
pf ppf "@;@[Similar members in object: %a@]" (list ~pp_sep:comma code)
320
+
ms
321
+
322
+
let should_it_be_mem ppf (exp, fnd) =
323
+
match suggest fnd exp with
324
+
| [] -> ()
325
+
| ms -> pf ppf "@;@[%a@]" (should_it_be code) ms
326
+
327
+
(* JSON formatting *)
328
+
329
+
type json_number_format = (float -> unit, Format.formatter, unit) format
330
+
331
+
let json_default_number_format : json_number_format = format_of_string "%.17g"
332
+
let json_null ppf () = string ppf "null"
333
+
let json_bool ppf b = string ppf (if b then "true" else "false")
334
+
335
+
let json_number' fmt ppf f =
336
+
(* cf. ECMAScript's JSON.stringify *)
337
+
if Float.is_finite f then pf ppf fmt f else json_null ppf ()
338
+
339
+
let json_number ppf v = json_number' json_default_number_format ppf v
340
+
341
+
let json_string ppf s =
342
+
let is_control = function
343
+
| '\x00' .. '\x1F' | '\x7F' -> true
344
+
| _ -> false
345
+
in
346
+
let len = String.length s in
347
+
let max_idx = len - 1 in
348
+
let flush ppf start i =
349
+
if start < len then substring start (i - start) ppf s
350
+
in
351
+
let rec loop start i =
352
+
if i > max_idx then flush ppf start i
353
+
else
354
+
let next = i + 1 in
355
+
match String.get s i with
356
+
| '"' ->
357
+
flush ppf start i;
358
+
string ppf "\\\"";
359
+
loop next next
360
+
| '\\' ->
361
+
flush ppf start i;
362
+
string ppf "\\\\";
363
+
loop next next
364
+
| '\n' ->
365
+
flush ppf start i;
366
+
string ppf "\\n";
367
+
loop next next
368
+
| '\r' ->
369
+
flush ppf start i;
370
+
string ppf "\\r";
371
+
loop next next
372
+
| '\t' ->
373
+
flush ppf start i;
374
+
string ppf "\\t";
375
+
loop next next
376
+
| c when is_control c ->
377
+
flush ppf start i;
378
+
string ppf (Printf.sprintf "\\u%04X" (Char.code c));
379
+
loop next next
380
+
| _c -> loop start next
381
+
in
382
+
char ppf '"';
383
+
loop 0 0;
384
+
char ppf '"'
385
+
end
386
+
387
+
(* Text locations *)
388
+
389
+
module Textloc = struct
390
+
(* File paths *)
391
+
392
+
type fpath = string
393
+
394
+
let file_none = "-"
395
+
let pp_path = Format.pp_print_string
396
+
397
+
(* Byte positions *)
398
+
399
+
type byte_pos = int (* zero-based *)
400
+
401
+
let byte_pos_none = -1
402
+
403
+
(* Lines *)
404
+
405
+
type line_num = int (* one-based *)
406
+
407
+
let line_num_none = -1
408
+
409
+
(* Line positions
410
+
411
+
We keep the byte position of the first element on the line. This
412
+
first element may not exist and be equal to the text length if
413
+
the input ends with a newline. Editors expect tools to compute
414
+
visual columns (not a very good idea). By keeping these byte
415
+
positions we can approximate columns by subtracting the line byte
416
+
position data byte location. This will only be correct on
417
+
US-ASCII data. *)
418
+
419
+
type line_pos = line_num * byte_pos
420
+
421
+
let line_pos_first = (1, 0)
422
+
let line_pos_none = (line_num_none, byte_pos_none)
423
+
424
+
(* Text locations *)
425
+
426
+
type t = {
427
+
file : fpath;
428
+
first_byte : byte_pos;
429
+
last_byte : byte_pos;
430
+
first_line : line_pos;
431
+
last_line : line_pos;
432
+
}
433
+
434
+
let make ~file ~first_byte ~last_byte ~first_line ~last_line =
435
+
{ file; first_byte; last_byte; first_line; last_line }
436
+
437
+
let file l = l.file
438
+
let set_file l file = { l with file }
439
+
let first_byte l = l.first_byte
440
+
let last_byte l = l.last_byte
441
+
let first_line l = l.first_line
442
+
let last_line l = l.last_line
443
+
444
+
let none =
445
+
let first_byte = byte_pos_none and last_byte = byte_pos_none in
446
+
let first_line = line_pos_none and last_line = line_pos_none in
447
+
make ~file:file_none ~first_byte ~last_byte ~first_line ~last_line
448
+
449
+
(* Predicates and comparisons *)
450
+
451
+
let is_none l = l.first_byte < 0
452
+
let is_empty l = l.first_byte > l.last_byte
453
+
454
+
let equal l0 l1 =
455
+
String.equal l0.file l1.file
456
+
&& Int.equal l0.first_byte l1.first_byte
457
+
&& Int.equal l0.last_byte l1.last_byte
458
+
459
+
let compare l0 l1 =
460
+
let c = String.compare l0.file l1.file in
461
+
if c <> 0 then c
462
+
else
463
+
let c = Int.compare l0.first_byte l1.first_byte in
464
+
if c <> 0 then c else Int.compare l0.last_byte l1.last_byte
465
+
466
+
(* Shrink and stretch *)
467
+
468
+
let set_first l ~first_byte ~first_line = { l with first_byte; first_line }
469
+
let set_last l ~last_byte ~last_line = { l with last_byte; last_line }
470
+
471
+
[@@@warning "-6"]
472
+
473
+
let to_first l =
474
+
make l.file l.first_byte l.first_byte l.first_line l.first_line
475
+
476
+
let to_last l = make l.file l.last_byte l.last_byte l.last_line l.last_line
477
+
478
+
let before l =
479
+
make l.file l.first_byte byte_pos_none l.first_line line_pos_none
480
+
481
+
let after l =
482
+
make l.file (l.first_byte + 1) byte_pos_none l.last_line line_pos_none
483
+
484
+
[@@@warning "+6"]
485
+
486
+
let span l0 l1 =
487
+
let first_byte, first_line =
488
+
if l0.first_byte < l1.first_byte then (l0.first_byte, l0.first_line)
489
+
else (l1.first_byte, l1.first_line)
490
+
in
491
+
let last_byte, last_line, file =
492
+
if l0.last_byte < l1.last_byte then (l1.last_byte, l1.last_line, l1.file)
493
+
else (l0.last_byte, l0.last_line, l0.file)
494
+
in
495
+
make ~file ~first_byte ~first_line ~last_byte ~last_line
496
+
497
+
[@@@warning "-6"]
498
+
499
+
let reloc ~first ~last =
500
+
make last.file first.first_byte last.last_byte first.first_line
501
+
last.last_line
502
+
503
+
[@@@warning "+6"]
504
+
505
+
(* Formatters *)
506
+
507
+
let pf = Format.fprintf
508
+
509
+
let pp_ocaml ppf l =
510
+
match is_none l with
511
+
| true -> pf ppf "File \"%a\"" pp_path l.file
512
+
| false ->
513
+
let pp_lines ppf l =
514
+
match fst l.first_line = fst l.last_line with
515
+
| true -> pf ppf "line %d" (fst l.first_line)
516
+
| false -> pf ppf "lines %d-%d" (fst l.first_line) (fst l.last_line)
517
+
in
518
+
(* "characters" represent positions (insertion points) not columns *)
519
+
let pos_s = l.first_byte - snd l.first_line in
520
+
let pos_e = l.last_byte - snd l.last_line + 1 in
521
+
if pos_s = 0 && pos_e = 0 then
522
+
pf ppf "File \"%a\", %a" pp_path l.file pp_lines l
523
+
else
524
+
pf ppf "File \"%a\", %a, characters %d-%d" pp_path l.file pp_lines l
525
+
pos_s pos_e
526
+
527
+
let pp_gnu ppf l =
528
+
match is_none l with
529
+
| true -> pf ppf "%a:" pp_path l.file
530
+
| false ->
531
+
let pp_lines ppf l =
532
+
let col_s = l.first_byte - snd l.first_line + 1 in
533
+
let col_e = l.last_byte - snd l.last_line + 1 in
534
+
match fst l.first_line = fst l.last_line with
535
+
| true -> pf ppf "%d.%d-%d" (fst l.first_line) col_s col_e
536
+
| false ->
537
+
pf ppf "%d.%d-%d.%d" (fst l.first_line) col_s (fst l.last_line)
538
+
col_e
539
+
in
540
+
pf ppf "%a:%a" pp_path l.file pp_lines l
541
+
542
+
let pp = pp_ocaml
543
+
544
+
let pp_dump ppf l =
545
+
pf ppf "file:%s bytes:%d-%d lines:(%d,%d)-(%d,%d)" l.file l.first_byte
546
+
l.last_byte (fst l.first_line) (snd l.first_line) (fst l.last_line)
547
+
(snd l.last_line)
548
+
end
549
+
550
+
type 'a fmt = Stdlib.Format.formatter -> 'a -> unit
551
+
552
+
(* Node meta data *)
553
+
554
+
module Meta = struct
555
+
type t = { textloc : Textloc.t; ws_before : string; ws_after : string }
556
+
557
+
let make ?(ws_before = "") ?(ws_after = "") textloc =
558
+
{ textloc; ws_before; ws_after }
559
+
560
+
let none = { textloc = Textloc.none; ws_before = ""; ws_after = "" }
561
+
let is_none m = none == m
562
+
let textloc m = m.textloc
563
+
let ws_before m = m.ws_before
564
+
let ws_after m = m.ws_after
565
+
let with_textloc m textloc = { m with textloc }
566
+
let clear_ws m = { m with ws_before = ""; ws_after = "" }
567
+
let clear_textloc m = { m with textloc = Textloc.none }
568
+
569
+
let copy_ws src ~dst =
570
+
{ dst with ws_before = src.ws_before; ws_after = src.ws_after }
571
+
end
572
+
573
+
type 'a node = 'a * Meta.t
574
+
575
+
(* JSON numbers *)
576
+
577
+
module Number = struct
578
+
let number_contains_int = Sys.int_size <= 53
579
+
let min_exact_int = if number_contains_int then Int.min_int else -(1 lsl 53)
580
+
let max_exact_int = if number_contains_int then Int.max_int else 1 lsl 53
581
+
let min_exact_uint8 = 0
582
+
let max_exact_uint8 = 255
583
+
let min_exact_uint16 = 0
584
+
let max_exact_uint16 = 65535
585
+
let min_exact_int8 = -128
586
+
let max_exact_int8 = 127
587
+
let min_exact_int16 = -32768
588
+
let max_exact_int16 = 32767
589
+
let min_exact_int32 = Int32.min_int
590
+
let max_exact_int32 = Int32.max_int
591
+
let max_exact_int64 = Int64.shift_left 1L 53
592
+
let min_exact_int64 = Int64.neg max_exact_int64
593
+
let[@inline] int_is_uint8 v = v land lnot 0xFF = 0
594
+
let[@inline] int_is_uint16 v = v land lnot 0xFFFF = 0
595
+
let[@inline] int_is_int8 v = min_exact_int8 <= v && v <= max_exact_int8
596
+
let[@inline] int_is_int16 v = min_exact_int16 <= v && v <= max_exact_int16
597
+
let[@inline] can_store_exact_int v = min_exact_int <= v && v <= max_exact_int
598
+
599
+
let[@inline] can_store_exact_int64 v =
600
+
Int64.(compare min_exact_int64 v <= 0 && compare v max_exact_int64 <= 0)
601
+
602
+
let max_exact_int_float = Int.to_float max_exact_int
603
+
let min_exact_int_float = Int.to_float min_exact_int
604
+
let max_exact_uint8_float = Int.to_float max_exact_uint8
605
+
let min_exact_uint8_float = Int.to_float min_exact_uint8
606
+
let max_exact_uint16_float = Int.to_float max_exact_uint16
607
+
let min_exact_uint16_float = Int.to_float min_exact_uint16
608
+
let max_exact_int8_float = Int.to_float max_exact_int8
609
+
let min_exact_int8_float = Int.to_float min_exact_int8
610
+
let min_exact_int16_float = Int.to_float min_exact_int16
611
+
let max_exact_int16_float = Int.to_float max_exact_int16
612
+
let max_exact_int32_float = Int32.to_float max_exact_int32
613
+
let min_exact_int32_float = Int32.to_float min_exact_int32
614
+
let max_exact_int64_float = Int64.to_float max_exact_int64
615
+
let min_exact_int64_float = Int64.to_float min_exact_int64
616
+
617
+
let[@inline] in_exact_int_range v =
618
+
min_exact_int_float <= v && v <= max_exact_int_float
619
+
620
+
let[@inline] in_exact_uint8_range v =
621
+
min_exact_uint8_float <= v && v <= max_exact_uint8_float
622
+
623
+
let[@inline] in_exact_uint16_range v =
624
+
min_exact_uint16_float <= v && v <= max_exact_uint16_float
625
+
626
+
let[@inline] in_exact_int8_range v =
627
+
min_exact_int8_float <= v && v <= max_exact_int8_float
628
+
629
+
let[@inline] in_exact_int16_range v =
630
+
min_exact_int16_float <= v && v <= max_exact_int16_float
631
+
632
+
let[@inline] in_exact_int32_range v =
633
+
min_exact_int32_float <= v && v <= max_exact_int32_float
634
+
635
+
let[@inline] in_exact_int64_range v =
636
+
min_exact_int64_float <= v && v <= max_exact_int64_float
637
+
end
638
+
639
+
(* JSON Paths *)
640
+
641
+
module Path = struct
642
+
(* Indices *)
643
+
644
+
type index = Mem of string node | Nth of int node
645
+
646
+
let pp_name ppf n = Fmt.code ppf n
647
+
let pp_index_num ppf n = Fmt.code ppf (Int.to_string n)
648
+
649
+
let pp_index ppf = function
650
+
| Mem (n, _) -> pp_name ppf n
651
+
| Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n
652
+
653
+
let pp_index_trace ppf = function
654
+
| Mem (n, meta) ->
655
+
Fmt.pf ppf "%a: in member %a" Textloc.pp (Meta.textloc meta) pp_name n
656
+
| Nth (n, meta) ->
657
+
Fmt.pf ppf "%a: at index %a" Textloc.pp (Meta.textloc meta) pp_index_num
658
+
n
659
+
660
+
let pp_bracketed_index ppf = function
661
+
| Mem (n, _) -> Fmt.pf ppf "[%a]" pp_name n
662
+
| Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n
663
+
664
+
(* Paths *)
665
+
666
+
type t = index list
667
+
668
+
let root = []
669
+
let is_root = function [] -> true | _ -> false
670
+
let nth ?(meta = Meta.none) n p = Nth (n, meta) :: p
671
+
let mem ?(meta = Meta.none) n p = Mem (n, meta) :: p
672
+
let rev_indices p = p
673
+
674
+
let pp ppf is =
675
+
let pp_sep ppf () = Fmt.char ppf '.' in
676
+
Fmt.list ~pp_sep pp_index ppf (List.rev is)
677
+
678
+
let pp_trace ppf is =
679
+
if is <> [] then Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_index_trace) is
680
+
681
+
let none = []
682
+
let err i fmt = Format.kasprintf failwith ("%d: " ^^ fmt) i
683
+
let err_unexp_eoi i = err i "Unexpected end of input"
684
+
let err_unexp_char i s = err i "Unexpected character: %C" s.[i]
685
+
let err_illegal_char i s = err i "Illegal character here: %C" s.[i]
686
+
let err_unexp i s = err i "Unexpected input: %S" (string_subrange ~first:i s)
687
+
688
+
(* Parsing *)
689
+
690
+
let parse_eoi s i max = if i > max then () else err_unexp i s
691
+
692
+
let parse_index p s i max =
693
+
let first, stop = match s.[i] with '[' -> (i + 1, ']') | _ -> (i, '.') in
694
+
let last, next =
695
+
let rec loop stop s i max =
696
+
match i > max with
697
+
| true -> if stop = ']' then err_unexp_eoi i else (i - 1, i)
698
+
| false ->
699
+
let illegal = s.[i] = '[' || (s.[i] = ']' && stop = '.') in
700
+
if illegal then err_illegal_char i s
701
+
else if s.[i] <> stop then loop stop s (i + 1) max
702
+
else (i - 1, if stop = ']' then i + 1 else i)
703
+
in
704
+
loop stop s first max
705
+
in
706
+
let idx = string_subrange ~first ~last s in
707
+
if idx = "" then err first "illegal empty index"
708
+
else
709
+
match int_of_string idx with
710
+
| exception Failure _ -> (next, Mem (idx, Meta.none) :: p)
711
+
| idx -> (next, Nth (idx, Meta.none) :: p)
712
+
713
+
let of_string s =
714
+
let rec loop p s i max =
715
+
if i > max then p
716
+
else
717
+
let next, p = parse_index p s i max in
718
+
if next > max then p
719
+
else if s.[next] <> '.' then err_unexp_char next s
720
+
else if next + 1 <= max then loop p s (next + 1) max
721
+
else err_unexp_eoi next
722
+
in
723
+
try
724
+
if s = "" then Ok []
725
+
else
726
+
let start = if s.[0] = '.' then 1 else 0 in
727
+
Ok (loop [] s start (String.length s - 1))
728
+
with Failure e -> Error e
729
+
end
730
+
731
+
(* JSON sorts *)
732
+
733
+
module Sort = struct
734
+
type t = Null | Bool | Number | String | Array | Object
735
+
736
+
let to_string = function
737
+
| Null -> "null"
738
+
| Bool -> "bool"
739
+
| Number -> "number"
740
+
| String -> "string"
741
+
| Array -> "array"
742
+
| Object -> "object"
743
+
744
+
let kinded' ~kind:k s = if k = "" then s else String.concat " " [ k; s ]
745
+
let kinded ~kind sort = kinded' ~kind (to_string sort)
746
+
let or_kind ~kind sort = if kind <> "" then kind else to_string sort
747
+
let pp ppf s = Fmt.code ppf (to_string s)
748
+
end
+202
lib/json_base.mli
+202
lib/json_base.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Low-level internal tools for {!Json}. *)
7
+
8
+
val string_subrange : ?first:int -> ?last:int -> string -> string
9
+
val binary_string_of_hex : string -> (string, string) result
10
+
val binary_string_to_hex : string -> string
11
+
12
+
(** Type identifiers. Can be removed once we require OCaml 5.1 *)
13
+
module Type : sig
14
+
type (_, _) eq = Equal : ('a, 'a) eq
15
+
16
+
module Id : sig
17
+
type 'a t
18
+
19
+
val make : unit -> 'a t
20
+
val uid : 'a t -> int
21
+
val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option
22
+
end
23
+
end
24
+
25
+
(** Resizable arrays. *)
26
+
module Rarray : sig
27
+
type 'a t
28
+
29
+
val get : 'a t -> int -> 'a
30
+
val empty : unit -> 'a t
31
+
val grow : 'a t -> 'a -> unit
32
+
val length : 'a t -> int
33
+
val add_last : 'a -> 'a t -> 'a t
34
+
val to_array : 'a t -> 'a array
35
+
end
36
+
37
+
(** Resizable bigarrays. *)
38
+
module Rbigarray1 : sig
39
+
type ('a, 'b, 'c) t
40
+
41
+
val get : ('a, 'b, 'c) t -> int -> 'a
42
+
val empty : ('a, 'b) Bigarray.kind -> 'c Bigarray.layout -> ('a, 'b, 'c) t
43
+
val grow : ('a, 'b, 'c) t -> 'a -> unit
44
+
val length : ('a, 'b, 'c) t -> int
45
+
val add_last : 'a -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
46
+
val to_bigarray : ('a, 'b, 'c) t -> ('a, 'b, 'c) Bigarray.Array1.t
47
+
end
48
+
49
+
(** Mini fmt *)
50
+
module Fmt : sig
51
+
type 'a t = Format.formatter -> 'a -> unit
52
+
53
+
val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
54
+
val str : ('a, Format.formatter, unit, string) format4 -> 'a
55
+
val disable_ansi_styler : unit -> unit
56
+
val nop : unit t
57
+
val sp : unit t
58
+
val list : ?pp_sep:unit t -> 'a t -> 'a list t
59
+
val char : char t
60
+
val string : string t
61
+
val substring : int -> int -> string t
62
+
val lines : string t
63
+
val bold : string t
64
+
val bold_red : string t
65
+
val code : string t
66
+
val puterr : unit t
67
+
val out_of_dom : ?pp_kind:unit t -> unit -> (string * string list) t
68
+
val should_it_be_mem : (string * string list) t
69
+
val similar_mems : (string * string list) t
70
+
71
+
type json_number_format = (float -> unit, Format.formatter, unit) format
72
+
73
+
val json_null : unit t
74
+
val json_bool : bool t
75
+
val json_default_number_format : json_number_format
76
+
val json_number' : json_number_format -> float t
77
+
val json_number : float t
78
+
val json_string : string t
79
+
end
80
+
81
+
(** See {!Json.Textloc} *)
82
+
module Textloc : sig
83
+
type fpath = string
84
+
85
+
val file_none : fpath
86
+
87
+
type byte_pos = int
88
+
89
+
val byte_pos_none : byte_pos
90
+
91
+
type line_num = int
92
+
93
+
val line_num_none : line_num
94
+
95
+
type line_pos = line_num * byte_pos
96
+
97
+
val line_pos_first : line_pos
98
+
val line_pos_none : line_pos
99
+
100
+
type t
101
+
102
+
val none : t
103
+
104
+
val make :
105
+
file:fpath ->
106
+
first_byte:byte_pos ->
107
+
last_byte:byte_pos ->
108
+
first_line:line_pos ->
109
+
last_line:line_pos ->
110
+
t
111
+
112
+
val file : t -> fpath
113
+
val set_file : t -> fpath -> t
114
+
val first_byte : t -> byte_pos
115
+
val last_byte : t -> byte_pos
116
+
val first_line : t -> line_pos
117
+
val last_line : t -> line_pos
118
+
val is_none : t -> bool
119
+
val is_empty : t -> bool
120
+
val equal : t -> t -> bool
121
+
val compare : t -> t -> int
122
+
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
123
+
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
124
+
val to_first : t -> t
125
+
val to_last : t -> t
126
+
val before : t -> t
127
+
val after : t -> t
128
+
val span : t -> t -> t
129
+
val reloc : first:t -> last:t -> t
130
+
val pp_ocaml : Format.formatter -> t -> unit
131
+
val pp_gnu : Format.formatter -> t -> unit
132
+
val pp : Format.formatter -> t -> unit
133
+
val pp_dump : Format.formatter -> t -> unit
134
+
end
135
+
136
+
type 'a fmt = Stdlib.Format.formatter -> 'a -> unit
137
+
138
+
(** See {!Json.Meta} *)
139
+
module Meta : sig
140
+
type t
141
+
142
+
val make : ?ws_before:string -> ?ws_after:string -> Textloc.t -> t
143
+
val none : t
144
+
val is_none : t -> bool
145
+
val textloc : t -> Textloc.t
146
+
val ws_before : t -> string
147
+
val ws_after : t -> string
148
+
val with_textloc : t -> Textloc.t -> t
149
+
val clear_ws : t -> t
150
+
val clear_textloc : t -> t
151
+
val copy_ws : t -> dst:t -> t
152
+
end
153
+
154
+
type 'a node = 'a * Meta.t
155
+
156
+
(** JSON number tools. *)
157
+
module Number : sig
158
+
val number_contains_int : bool
159
+
val int_is_uint8 : int -> bool
160
+
val int_is_uint16 : int -> bool
161
+
val int_is_int8 : int -> bool
162
+
val int_is_int16 : int -> bool
163
+
val can_store_exact_int : int -> bool
164
+
val can_store_exact_int64 : Int64.t -> bool
165
+
val in_exact_int_range : float -> bool
166
+
val in_exact_uint8_range : float -> bool
167
+
val in_exact_uint16_range : float -> bool
168
+
val in_exact_int8_range : float -> bool
169
+
val in_exact_int16_range : float -> bool
170
+
val in_exact_int32_range : float -> bool
171
+
val in_exact_int64_range : float -> bool
172
+
end
173
+
174
+
(** See {!Json.Path} *)
175
+
module Path : sig
176
+
type index = Mem of string node | Nth of int node
177
+
178
+
val pp_index : index fmt
179
+
val pp_index_trace : index fmt
180
+
181
+
type t
182
+
183
+
val root : t
184
+
val is_root : t -> bool
185
+
val nth : ?meta:Meta.t -> int -> t -> t
186
+
val mem : ?meta:Meta.t -> string -> t -> t
187
+
val rev_indices : t -> index list
188
+
val of_string : string -> (t, string) result
189
+
val pp : t fmt
190
+
val pp_trace : t fmt
191
+
end
192
+
193
+
(** See {!Json.Sort} *)
194
+
module Sort : sig
195
+
type t = Null | Bool | Number | String | Array | Object
196
+
197
+
val to_string : t -> string
198
+
val kinded' : kind:string -> string -> string
199
+
val kinded : kind:string -> t -> string
200
+
val or_kind : kind:string -> t -> string
201
+
val pp : Format.formatter -> t -> unit
202
+
end
+281
test/cookbook.ml
+281
test/cookbook.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: CC0-1.0
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Dealing with null values. *)
7
+
8
+
let string_null_is_empty =
9
+
let null = Jsont.null "" in
10
+
let enc = function "" -> null | _ -> Jsont.string in
11
+
Jsont.any ~dec_null:null ~dec_string:Jsont.string ~enc ()
12
+
13
+
(* Base maps *)
14
+
15
+
module M = struct
16
+
type t = unit
17
+
18
+
let result_of_string s : (t, string) result = invalid_arg "unimplemented"
19
+
let of_string_or_failure s : t = invalid_arg "unimplemented"
20
+
let to_string v : string = invalid_arg "unimplemented"
21
+
end
22
+
23
+
let m_jsont =
24
+
let dec = Jsont.Base.dec_result M.result_of_string in
25
+
let enc = Jsont.Base.enc M.to_string in
26
+
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
27
+
28
+
let m_jsont' =
29
+
let dec = Jsont.Base.dec_failure M.of_string_or_failure in
30
+
let enc = Jsont.Base.enc M.to_string in
31
+
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
32
+
33
+
let m_jsont'' =
34
+
Jsont.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string
35
+
36
+
(* Objects as records *)
37
+
38
+
module Person = struct
39
+
type t = { name : string; age : int }
40
+
41
+
let make name age = { name; age }
42
+
let name p = p.name
43
+
let age p = p.age
44
+
45
+
let jsont =
46
+
Jsont.Object.map ~kind:"Person" make
47
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
48
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
49
+
|> Jsont.Object.finish
50
+
end
51
+
52
+
(* Objects as key-value maps *)
53
+
54
+
module String_map = Map.Make (String)
55
+
56
+
let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t =
57
+
fun ?kind t ->
58
+
Jsont.Object.map ?kind Fun.id
59
+
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id
60
+
|> Jsont.Object.finish
61
+
62
+
(* Optional members *)
63
+
64
+
module Person_opt_age = struct
65
+
type t = { name : string; age : int option }
66
+
67
+
let make name age = { name; age }
68
+
let name p = p.name
69
+
let age p = p.age
70
+
71
+
let jsont =
72
+
Jsont.Object.map ~kind:"Person" make
73
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
74
+
|> Jsont.Object.mem "age"
75
+
Jsont.(some int)
76
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:age
77
+
|> Jsont.Object.finish
78
+
end
79
+
80
+
(* Unknown object members *)
81
+
82
+
module Person_strict = struct
83
+
type t = { name : string; age : int }
84
+
85
+
let make name age = { name; age }
86
+
let name p = p.name
87
+
let age p = p.age
88
+
89
+
let jsont =
90
+
Jsont.Object.map ~kind:"Person" make
91
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
92
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
93
+
|> Jsont.Object.error_unknown |> Jsont.Object.finish
94
+
end
95
+
96
+
module Person_keep = struct
97
+
type t = { name : string; age : int; unknown : Jsont.json }
98
+
99
+
let make name age unknown = { name; age; unknown }
100
+
let name p = p.name
101
+
let age p = p.age
102
+
let unknown v = v.unknown
103
+
104
+
let jsont =
105
+
Jsont.Object.map ~kind:"Person" make
106
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
107
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
108
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
109
+
|> Jsont.Object.finish
110
+
end
111
+
112
+
(* Dealing with recursive JSON *)
113
+
114
+
module Tree = struct
115
+
type 'a t = Node of 'a * 'a t list
116
+
117
+
let make v children = Node (v, children)
118
+
let value (Node (v, _)) = v
119
+
let children (Node (_, children)) = children
120
+
121
+
let jsont value_type =
122
+
let rec t =
123
+
lazy
124
+
(Jsont.Object.map ~kind:"Tree" make
125
+
|> Jsont.Object.mem "value" value_type ~enc:value
126
+
|> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children
127
+
|> Jsont.Object.finish)
128
+
in
129
+
Lazy.force t
130
+
end
131
+
132
+
(* Dealing with object types or classes *)
133
+
134
+
module Geometry_variant = struct
135
+
module Circle = struct
136
+
type t = { name : string; radius : float }
137
+
138
+
let make name radius = { name; radius }
139
+
let name c = c.name
140
+
let radius c = c.radius
141
+
142
+
let jsont =
143
+
Jsont.Object.map ~kind:"Circle" make
144
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
145
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
146
+
|> Jsont.Object.finish
147
+
end
148
+
149
+
module Rect = struct
150
+
type t = { name : string; width : float; height : float }
151
+
152
+
let make name width height = { name; width; height }
153
+
let name r = r.name
154
+
let width r = r.width
155
+
let height r = r.height
156
+
157
+
let jsont =
158
+
Jsont.Object.map ~kind:"Rect" make
159
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
160
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
161
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
162
+
|> Jsont.Object.finish
163
+
end
164
+
165
+
type t = Circle of Circle.t | Rect of Rect.t
166
+
167
+
let circle c = Circle c
168
+
let rect r = Rect r
169
+
170
+
let jsont =
171
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
172
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
173
+
let enc_case = function
174
+
| Circle c -> Jsont.Object.Case.value circle c
175
+
| Rect r -> Jsont.Object.Case.value rect r
176
+
in
177
+
let cases = Jsont.Object.Case.[ make circle; make rect ] in
178
+
Jsont.Object.map ~kind:"Geometry" Fun.id
179
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
180
+
|> Jsont.Object.finish
181
+
end
182
+
183
+
module Geometry_record = struct
184
+
module Circle = struct
185
+
type t = { radius : float }
186
+
187
+
let make radius = { radius }
188
+
let radius c = c.radius
189
+
190
+
let jsont =
191
+
Jsont.Object.map ~kind:"Circle" make
192
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
193
+
|> Jsont.Object.finish
194
+
end
195
+
196
+
module Rect = struct
197
+
type t = { width : float; height : float }
198
+
199
+
let make width height = { width; height }
200
+
let width r = r.width
201
+
let height r = r.height
202
+
203
+
let jsont =
204
+
Jsont.Object.map ~kind:"Rect" make
205
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
206
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
207
+
|> Jsont.Object.finish
208
+
end
209
+
210
+
type type' = Circle of Circle.t | Rect of Rect.t
211
+
212
+
let circle c = Circle c
213
+
let rect r = Rect r
214
+
215
+
type t = { name : string; type' : type' }
216
+
217
+
let make name type' = { name; type' }
218
+
let name g = g.name
219
+
let type' g = g.type'
220
+
221
+
let jsont =
222
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
223
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
224
+
let enc_case = function
225
+
| Circle c -> Jsont.Object.Case.value circle c
226
+
| Rect r -> Jsont.Object.Case.value rect r
227
+
in
228
+
let cases = Jsont.Object.Case.[ make circle; make rect ] in
229
+
Jsont.Object.map ~kind:"Geometry" make
230
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
231
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
232
+
|> Jsont.Object.finish
233
+
end
234
+
235
+
(* Untagged object types *)
236
+
237
+
module Response = struct
238
+
type t = { id : int; value : (Jsont.json, string) result }
239
+
240
+
let make id result error =
241
+
let pp_mem = Jsont.Repr.pp_code in
242
+
match (result, error) with
243
+
| Some result, None -> { id; value = Ok result }
244
+
| None, Some error -> { id; value = Error error }
245
+
| Some _, Some _ ->
246
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
247
+
pp_mem "result" pp_mem "error"
248
+
| None, None ->
249
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" pp_mem
250
+
"result" pp_mem "error"
251
+
252
+
let result r = match r.value with Ok v -> Some v | Error _ -> None
253
+
let error r = match r.value with Ok _ -> None | Error e -> Some e
254
+
255
+
let jsont =
256
+
Jsont.Object.map make
257
+
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id)
258
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:result
259
+
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:error
260
+
|> Jsont.Object.finish
261
+
end
262
+
263
+
(* Flattening objects on queries *)
264
+
265
+
module Group = struct
266
+
type t = { id : int; name : string; persons : Person.t list }
267
+
268
+
let make id name persons = { id; name; persons }
269
+
270
+
let info_jsont =
271
+
Jsont.Object.map make
272
+
|> Jsont.Object.mem "id" Jsont.int
273
+
|> Jsont.Object.mem "name" Jsont.string
274
+
|> Jsont.Object.finish
275
+
276
+
let jsont =
277
+
Jsont.Object.map (fun k persons -> k persons)
278
+
|> Jsont.Object.mem "info" info_jsont
279
+
|> Jsont.Object.mem "persons" (Jsont.list Person.jsont)
280
+
|> Jsont.Object.finish
281
+
end
+374
test/geojson.ml
+374
test/geojson.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* GeoJSON codec https://datatracker.ietf.org/doc/html/rfc7946
7
+
8
+
Note: a few length constraints on arrays should be checked,
9
+
a combinators should be added for that.
10
+
11
+
In contrast to Topojson the structure is a bit more annoying to
12
+
model because there is subtyping on the "type" field: GeoJSON
13
+
objects can be Feature, FeatureCollection or any Geometry object
14
+
and Geometry objects are recursive on themselves (but not on
15
+
Feature or Feature collection) and FeatureCollection only have
16
+
Feature objects. We handle this by redoing the cases to handle only
17
+
the subsets. *)
18
+
19
+
type float_array = float array
20
+
21
+
let float_array_jsont ~kind = Jsont.array ~kind Jsont.number
22
+
23
+
type 'a garray = 'a array
24
+
25
+
let garray = Jsont.array
26
+
27
+
module Bbox = struct
28
+
type t = float_array
29
+
30
+
let jsont = float_array_jsont ~kind:"Bbox"
31
+
end
32
+
33
+
module Position = struct
34
+
type t = float_array
35
+
36
+
let jsont = float_array_jsont ~kind:"Position"
37
+
end
38
+
39
+
module Geojson_object = struct
40
+
type 'a t = { type' : 'a; bbox : Bbox.t option; unknown : Jsont.json }
41
+
42
+
let make type' bbox unknown = { type'; bbox; unknown }
43
+
let type' o = o.type'
44
+
let bbox o = o.bbox
45
+
let unknown o = o.unknown
46
+
47
+
let finish_jsont map =
48
+
map
49
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
50
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
51
+
|> Jsont.Object.finish
52
+
53
+
let geometry ~kind coordinates =
54
+
Jsont.Object.map ~kind make
55
+
|> Jsont.Object.mem "coordinates" coordinates ~enc:type'
56
+
|> finish_jsont
57
+
end
58
+
59
+
module Point = struct
60
+
type t = Position.t
61
+
62
+
let jsont = Geojson_object.geometry ~kind:"Point" Position.jsont
63
+
end
64
+
65
+
module Multi_point = struct
66
+
type t = Position.t garray
67
+
68
+
let jsont = Geojson_object.geometry ~kind:"MultiPoint" (garray Position.jsont)
69
+
end
70
+
71
+
module Line_string = struct
72
+
type t = Position.t garray
73
+
74
+
let jsont = Geojson_object.geometry ~kind:"LineString" (garray Position.jsont)
75
+
end
76
+
77
+
module Multi_line_string = struct
78
+
type t = Line_string.t garray
79
+
80
+
let jsont =
81
+
Geojson_object.geometry ~kind:"LineString" (garray (garray Position.jsont))
82
+
end
83
+
84
+
module Polygon = struct
85
+
type t = Line_string.t garray
86
+
87
+
let jsont =
88
+
Geojson_object.geometry ~kind:"Polygon" (garray (garray Position.jsont))
89
+
end
90
+
91
+
module Multi_polygon = struct
92
+
type t = Polygon.t garray
93
+
94
+
let jsont =
95
+
Geojson_object.geometry ~kind:"MultiPolygon"
96
+
(garray (garray (garray Position.jsont)))
97
+
end
98
+
99
+
module Geojson = struct
100
+
type 'a object' = 'a Geojson_object.t
101
+
102
+
type geometry =
103
+
[ `Point of Point.t object'
104
+
| `Multi_point of Multi_point.t object'
105
+
| `Line_string of Line_string.t object'
106
+
| `Multi_line_string of Multi_line_string.t object'
107
+
| `Polygon of Polygon.t object'
108
+
| `Multi_polygon of Multi_polygon.t object'
109
+
| `Geometry_collection of geometry_collection object' ]
110
+
111
+
and geometry_collection = geometry list
112
+
113
+
module Feature = struct
114
+
type id = [ `Number of float | `String of string ]
115
+
116
+
type t = {
117
+
id : id option;
118
+
geometry : geometry option;
119
+
properties : Jsont.json option;
120
+
}
121
+
122
+
let make id geometry properties = { id; geometry; properties }
123
+
124
+
let make_geojson_object id geometry properties =
125
+
Geojson_object.make (make id geometry properties)
126
+
127
+
let id f = f.id
128
+
let geometry f = f.geometry
129
+
let properties f = f.properties
130
+
131
+
type collection = t object' list
132
+
end
133
+
134
+
type t =
135
+
[ `Feature of Feature.t object'
136
+
| `Feature_collection of Feature.collection object'
137
+
| geometry ]
138
+
139
+
let point v = `Point v
140
+
let multi_point v = `Multi_point v
141
+
let line_string v = `Line_string v
142
+
let multi_line_string v = `Multi_line_string v
143
+
let polygon v = `Polygon v
144
+
let multi_polygon v = `Multi_polygon v
145
+
let geometry_collection vs = `Geometry_collection vs
146
+
let feature v = `Feature v
147
+
let feature_collection vs = `Feature_collection vs
148
+
149
+
let feature_id_jsont =
150
+
let number =
151
+
let dec = Jsont.Base.dec (fun n -> `Number n) in
152
+
let enc =
153
+
Jsont.Base.enc (function `Number n -> n | _ -> assert false)
154
+
in
155
+
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
156
+
in
157
+
let string =
158
+
let dec = Jsont.Base.dec (fun n -> `String n) in
159
+
let enc =
160
+
Jsont.Base.enc (function `String n -> n | _ -> assert false)
161
+
in
162
+
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
163
+
in
164
+
let enc = function `Number _ -> number | `String _ -> string in
165
+
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
166
+
167
+
(* The first two Json types below handle subtyping by redoing
168
+
cases for subsets of types. *)
169
+
170
+
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec
171
+
172
+
let rec geometry_jsont =
173
+
lazy begin
174
+
let case_point = case_map Point.jsont point in
175
+
let case_multi_point = case_map Multi_point.jsont multi_point in
176
+
let case_line_string = case_map Line_string.jsont line_string in
177
+
let case_multi_line_string =
178
+
case_map Multi_line_string.jsont multi_line_string
179
+
in
180
+
let case_polygon = case_map Polygon.jsont polygon in
181
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
182
+
let case_geometry_collection =
183
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
184
+
in
185
+
let enc_case = function
186
+
| `Point v -> Jsont.Object.Case.value case_point v
187
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
188
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
189
+
| `Multi_line_string v ->
190
+
Jsont.Object.Case.value case_multi_line_string v
191
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
192
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
193
+
| `Geometry_collection v ->
194
+
Jsont.Object.Case.value case_geometry_collection v
195
+
in
196
+
let cases =
197
+
Jsont.Object.Case.
198
+
[
199
+
make case_point;
200
+
make case_multi_point;
201
+
make case_line_string;
202
+
make case_multi_line_string;
203
+
make case_polygon;
204
+
make case_multi_polygon;
205
+
make case_geometry_collection;
206
+
]
207
+
in
208
+
Jsont.Object.map ~kind:"Geometry object" Fun.id
209
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
210
+
~tag_to_string:Fun.id ~tag_compare:String.compare
211
+
|> Jsont.Object.finish
212
+
end
213
+
214
+
and feature_jsont : Feature.t object' Jsont.t Lazy.t =
215
+
lazy begin
216
+
let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in
217
+
let enc_case v = Jsont.Object.Case.value case_feature v in
218
+
let cases = Jsont.Object.Case.[ make case_feature ] in
219
+
Jsont.Object.map ~kind:"Feature" Fun.id
220
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
221
+
~tag_to_string:Fun.id ~tag_compare:String.compare
222
+
|> Jsont.Object.finish
223
+
end
224
+
225
+
and case_feature_jsont : Feature.t object' Jsont.t Lazy.t =
226
+
lazy begin
227
+
Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object
228
+
|> Jsont.Object.opt_mem "id" feature_id_jsont ~enc:(fun o ->
229
+
Feature.id (Geojson_object.type' o))
230
+
|> Jsont.Object.mem "geometry"
231
+
(Jsont.option (Jsont.rec' geometry_jsont))
232
+
~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
233
+
|> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object)
234
+
~enc:(fun o -> Feature.properties (Geojson_object.type' o))
235
+
|> Geojson_object.finish_jsont
236
+
end
237
+
238
+
and geometry_collection_jsont =
239
+
lazy begin
240
+
Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make
241
+
|> Jsont.Object.mem "geometries"
242
+
(Jsont.list (Jsont.rec' geometry_jsont))
243
+
~enc:Geojson_object.type'
244
+
|> Geojson_object.finish_jsont
245
+
end
246
+
247
+
and feature_collection_json =
248
+
lazy begin
249
+
Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make
250
+
|> Jsont.Object.mem "features"
251
+
Jsont.(list (Jsont.rec' feature_jsont))
252
+
~enc:Geojson_object.type'
253
+
|> Geojson_object.finish_jsont
254
+
end
255
+
256
+
and jsont : t Jsont.t Lazy.t =
257
+
lazy begin
258
+
let case_point = case_map Point.jsont point in
259
+
let case_multi_point = case_map Multi_point.jsont multi_point in
260
+
let case_line_string = case_map Line_string.jsont line_string in
261
+
let case_multi_line_string =
262
+
case_map Multi_line_string.jsont multi_line_string
263
+
in
264
+
let case_polygon = case_map Polygon.jsont polygon in
265
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
266
+
let case_geometry_collection =
267
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
268
+
in
269
+
let case_feature = case_map (Lazy.force case_feature_jsont) feature in
270
+
let case_feature_collection =
271
+
case_map (Lazy.force feature_collection_json) feature_collection
272
+
in
273
+
let enc_case = function
274
+
| `Point v -> Jsont.Object.Case.value case_point v
275
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
276
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
277
+
| `Multi_line_string v ->
278
+
Jsont.Object.Case.value case_multi_line_string v
279
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
280
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
281
+
| `Geometry_collection v ->
282
+
Jsont.Object.Case.value case_geometry_collection v
283
+
| `Feature v -> Jsont.Object.Case.value case_feature v
284
+
| `Feature_collection v ->
285
+
Jsont.Object.Case.value case_feature_collection v
286
+
in
287
+
let cases =
288
+
Jsont.Object.Case.
289
+
[
290
+
make case_point;
291
+
make case_multi_point;
292
+
make case_line_string;
293
+
make case_multi_line_string;
294
+
make case_polygon;
295
+
make case_multi_polygon;
296
+
make case_geometry_collection;
297
+
make case_feature;
298
+
make case_feature_collection;
299
+
]
300
+
in
301
+
Jsont.Object.map ~kind:"GeoJSON" Fun.id
302
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
303
+
~tag_to_string:Fun.id ~tag_compare:String.compare
304
+
|> Jsont.Object.finish
305
+
end
306
+
307
+
let jsont = Lazy.force jsont
308
+
end
309
+
310
+
(* Command line interface *)
311
+
312
+
let ( let* ) = Result.bind
313
+
let strf = Printf.sprintf
314
+
315
+
let log_if_error ~use = function
316
+
| Ok v -> v
317
+
| Error e ->
318
+
let lines = String.split_on_char '\n' e in
319
+
Format.eprintf "@[%a @[<v>%a@]@]" Jsont.Error.puterr ()
320
+
(Format.pp_print_list Format.pp_print_string)
321
+
lines;
322
+
use
323
+
324
+
let with_infile file f =
325
+
(* XXX add something to bytesrw. *)
326
+
let process file ic =
327
+
try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic))
328
+
with Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
329
+
in
330
+
try
331
+
match file with
332
+
| "-" -> process file In_channel.stdin
333
+
| file -> In_channel.with_open_bin file (process file)
334
+
with Sys_error e -> Error e
335
+
336
+
let trip ~file ~format ~locs ~dec_only =
337
+
log_if_error ~use:1 @@ with_infile file
338
+
@@ fun r ->
339
+
log_if_error ~use:1
340
+
@@
341
+
let* t = Jsont_bytesrw.decode ~file ~locs Geojson.jsont r in
342
+
if dec_only then Ok 0
343
+
else
344
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
345
+
let* () = Jsont_bytesrw.encode ~format ~eod:true Geojson.jsont t w in
346
+
Ok 0
347
+
348
+
open Cmdliner
349
+
open Cmdliner.Term.Syntax
350
+
351
+
let geojson =
352
+
Cmd.v (Cmd.info "geojson" ~doc:"round trip GeoJSON")
353
+
@@
354
+
let+ file =
355
+
let doc = "$(docv) is the GeoJSON file. Use $(b,-) for stdin." in
356
+
Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
357
+
and+ locs =
358
+
let doc = "Preserve locations (better errors)." in
359
+
Arg.(value & flag & info [ "l"; "locs" ] ~doc)
360
+
and+ format =
361
+
let fmt = [ ("indent", Jsont.Indent); ("minify", Jsont.Minify) ] in
362
+
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt) in
363
+
Arg.(
364
+
value
365
+
& opt (enum fmt) Jsont.Minify
366
+
& info [ "f"; "format" ] ~doc ~docv:"FMT")
367
+
and+ dec_only =
368
+
let doc = "Decode only." in
369
+
Arg.(value & flag & info [ "d" ] ~doc)
370
+
in
371
+
trip ~file ~format ~locs ~dec_only
372
+
373
+
let main () = Cmd.eval' geojson
374
+
let () = if !Sys.interactive then () else exit (main ())
+114
test/json_rpc.ml
+114
test/json_rpc.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: CC0-1.0
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JSON-RPC codec https://www.jsonrpc.org/ *)
7
+
8
+
(* JSON-RPC version *)
9
+
10
+
type jsonrpc = [ `V2 ]
11
+
12
+
let jsonrpc_jsont = Jsont.enum [ ("2.0", `V2) ]
13
+
14
+
(* JSON-RPC identifiers *)
15
+
16
+
type id = [ `String of string | `Number of float | `Null ]
17
+
18
+
let id_jsont : id Jsont.t =
19
+
let null = Jsont.null `Null in
20
+
let string =
21
+
let dec s = `String s in
22
+
let enc = function `String s -> s | _ -> assert false in
23
+
Jsont.map ~dec ~enc Jsont.string
24
+
in
25
+
let number =
26
+
let dec n = `Number n in
27
+
let enc = function `Number n -> n | _ -> assert false in
28
+
Jsont.map ~dec ~enc Jsont.number
29
+
in
30
+
let enc = function
31
+
| `Null -> null
32
+
| `String _ -> string
33
+
| `Number _ -> number
34
+
in
35
+
Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
36
+
37
+
(* JSON-RPC request object *)
38
+
39
+
type params = Jsont.json (* An array or object *)
40
+
41
+
let params_jsont =
42
+
let enc = function
43
+
| Jsont.Object _ | Jsont.Array _ -> Jsont.json
44
+
| j ->
45
+
let meta = Jsont.Meta.none in
46
+
let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in
47
+
Jsont.Error.expected meta "object or array" ~fnd
48
+
in
49
+
let kind = "JSON-RPC params" in
50
+
Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc ()
51
+
52
+
type request = {
53
+
jsonrpc : jsonrpc;
54
+
method' : string;
55
+
params : params option;
56
+
id : id option;
57
+
}
58
+
59
+
let request jsonrpc method' params id = { jsonrpc; method'; params; id }
60
+
61
+
let request_jsont : request Jsont.t =
62
+
Jsont.Object.map request
63
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
64
+
|> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method')
65
+
|> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
66
+
|> Jsont.Object.opt_mem "id" id_jsont ~enc:(fun r -> r.id)
67
+
|> Jsont.Object.finish
68
+
69
+
(* JSON-RPC error objects *)
70
+
71
+
type error = { code : int; message : string; data : Jsont.json option }
72
+
73
+
let error code message data = { code; message; data }
74
+
75
+
let error_jsont =
76
+
Jsont.Object.map error
77
+
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
78
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
79
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
80
+
|> Jsont.Object.finish
81
+
82
+
(* JSON-RPC response object *)
83
+
84
+
type response = {
85
+
jsonrpc : jsonrpc;
86
+
value : (Jsont.json, error) result;
87
+
id : id;
88
+
}
89
+
90
+
let response jsonrpc result error id : response =
91
+
let err_both () =
92
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
93
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
94
+
in
95
+
let err_none () =
96
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
97
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
98
+
in
99
+
match (result, error) with
100
+
| Some result, None -> { jsonrpc; value = Ok result; id }
101
+
| None, Some error -> { jsonrpc; value = Error error; id }
102
+
| Some _, Some _ -> err_both ()
103
+
| None, None -> err_none ()
104
+
105
+
let response_result r = match r.value with Ok v -> Some v | Error _ -> None
106
+
let response_error r = match r.value with Ok _ -> None | Error e -> Some e
107
+
108
+
let response_jsont : response Jsont.t =
109
+
Jsont.Object.map response
110
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
111
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result
112
+
|> Jsont.Object.opt_mem "error" error_jsont ~enc:response_error
113
+
|> Jsont.Object.mem "id" id_jsont ~enc:(fun r -> r.id)
114
+
|> Jsont.Object.finish
+489
test/jsont_tool.ml
+489
test/jsont_tool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let ( let* ) = Result.bind
7
+
let strf = Format.asprintf
8
+
9
+
let log_if_error ~use = function
10
+
| Ok v -> v
11
+
| Error e ->
12
+
let exec = Filename.basename Sys.executable_name in
13
+
let lines = String.split_on_char '\n' e in
14
+
Format.eprintf "%s: %a @[<v>%a@]@." exec Jsont.Error.puterr ()
15
+
Format.(pp_print_list pp_print_string)
16
+
lines;
17
+
use
18
+
19
+
let exit_err_file = 1
20
+
let exit_err_json = 2
21
+
let exit_err_diff = 3
22
+
23
+
module Os = struct
24
+
(* Emulate B0_std.Os functionality to eschew the dep.
25
+
Note: this is only used for the [diff] function. *)
26
+
27
+
let read_file file =
28
+
try
29
+
let ic = if file = "-" then stdin else open_in_bin file in
30
+
let finally () = if file = "-" then () else close_in_noerr ic in
31
+
Fun.protect ~finally @@ fun () -> Ok (In_channel.input_all ic)
32
+
with Sys_error err -> Error err
33
+
34
+
let write_file file s =
35
+
try
36
+
let oc = if file = "-" then stdout else open_out_bin file in
37
+
let finally () = if file = "-" then () else close_out_noerr oc in
38
+
Fun.protect ~finally @@ fun () -> Ok (Out_channel.output_string oc s)
39
+
with Sys_error err -> Error err
40
+
41
+
let with_tmp_dir f =
42
+
try
43
+
let tmpdir =
44
+
let file = Filename.temp_file "cmarkit" "dir" in
45
+
Sys.remove file;
46
+
Sys.mkdir file 0o700;
47
+
file
48
+
in
49
+
let finally () = try Sys.rmdir tmpdir with Sys_error _ -> () in
50
+
Fun.protect ~finally @@ fun () -> Ok (f tmpdir)
51
+
with Sys_error err -> Error ("Making temporary dir: " ^ err)
52
+
53
+
let with_cwd cwd f =
54
+
try
55
+
let curr = Sys.getcwd () in
56
+
let () = Sys.chdir cwd in
57
+
let finally () = try Sys.chdir curr with Sys_error _ -> () in
58
+
Fun.protect ~finally @@ fun () -> Ok (f ())
59
+
with Sys_error err -> Error ("With cwd: " ^ err)
60
+
end
61
+
62
+
let diff src fmted =
63
+
let env = [ "GIT_CONFIG_SYSTEM=/dev/null"; "GIT_CONFIG_GLOBAL=/dev/null" ] in
64
+
let set_env =
65
+
match Sys.win32 with
66
+
| true -> String.concat "" (List.map (fun e -> "set " ^ e ^ " && ") env)
67
+
| false -> String.concat " " env
68
+
in
69
+
let diff = "git diff --ws-error-highlight=all --no-index --patience " in
70
+
let src_file = "src" and fmted_file = "fmt" in
71
+
let cmd = String.concat " " [ set_env; diff; src_file; fmted_file ] in
72
+
Result.join @@ Result.join @@ Os.with_tmp_dir
73
+
@@ fun dir ->
74
+
Os.with_cwd dir @@ fun () ->
75
+
let* () = Os.write_file src_file src in
76
+
let* () = Os.write_file fmted_file fmted in
77
+
Ok (Sys.command cmd)
78
+
79
+
let with_infile file f =
80
+
(* XXX add something to bytesrw. *)
81
+
let process file ic =
82
+
try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic))
83
+
with Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
84
+
in
85
+
try
86
+
match file with
87
+
| "-" -> process file In_channel.stdin
88
+
| file -> In_channel.with_open_bin file (process file)
89
+
with Sys_error e -> Error e
90
+
91
+
let output ~format ~number_format j =
92
+
match format with
93
+
| `Pretty ->
94
+
Ok (Format.printf "@[%a@]@." (Jsont.pp_json' ~number_format ()) j)
95
+
| `Format format ->
96
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
97
+
Jsont_bytesrw.encode ~format ~number_format ~eod:true Jsont.json j w
98
+
99
+
let output_string ~format ~number_format j =
100
+
match format with
101
+
| `Pretty ->
102
+
Ok (Format.asprintf "@[%a@]" (Jsont.pp_json' ~number_format ()) j)
103
+
| `Format format ->
104
+
Jsont_bytesrw.encode_string ~format ~number_format Jsont.json j
105
+
106
+
let trip_type ?(dec_only = false) ~file ~format ~number_format ~diff:do_diff
107
+
~locs t =
108
+
log_if_error ~use:exit_err_file
109
+
@@ with_infile file
110
+
@@ fun r ->
111
+
log_if_error ~use:exit_err_json
112
+
@@
113
+
let layout = format = `Format Jsont.Layout in
114
+
match do_diff with
115
+
| false ->
116
+
let* j = Jsont_bytesrw.decode ~file ~layout ~locs t r in
117
+
if dec_only then Ok 0
118
+
else
119
+
let* () = output ~format ~number_format j in
120
+
Ok 0
121
+
| true -> (
122
+
let src = Bytesrw.Bytes.Reader.to_string r in
123
+
let* j = Jsont_bytesrw.decode_string ~file ~layout ~locs t src in
124
+
let* fmted = output_string ~format ~number_format j in
125
+
match diff src fmted with
126
+
| Ok exit -> if exit = 0 then Ok 0 else Ok exit_err_diff
127
+
| Error e ->
128
+
Format.eprintf "%s" e;
129
+
Ok Cmdliner.Cmd.Exit.some_error)
130
+
131
+
let delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs =
132
+
let del = Jsont.delete_path ~allow_absent path in
133
+
trip_type ~file ~format ~number_format ~diff ~locs del
134
+
135
+
let fmt ~file ~format ~number_format ~diff ~locs ~dec_only =
136
+
trip_type ~file ~format ~number_format ~diff ~locs ~dec_only Jsont.json
137
+
138
+
let get ~file ~path ~format ~number_format ~diff ~absent ~locs =
139
+
let get = Jsont.path ?absent path Jsont.json in
140
+
trip_type ~file ~format ~number_format ~diff ~locs get
141
+
142
+
let locs' ~file =
143
+
let pf = Format.fprintf in
144
+
let pp_code = Jsont.Repr.pp_code in
145
+
let pp_locs_outline ppf v =
146
+
let indent = 2 in
147
+
let loc label ppf m =
148
+
pf ppf "@[<v>%s:@,%a@]@," label Jsont.Textloc.pp_ocaml
149
+
(Jsont.Meta.textloc m)
150
+
in
151
+
let rec value ppf = function
152
+
| Jsont.Null ((), m) ->
153
+
loc (strf "%a" pp_code (strf "%a" Jsont.pp_null ())) ppf m
154
+
| Jsont.Bool (b, m) ->
155
+
loc (strf "Bool %a" pp_code (strf "%a" Jsont.pp_bool b)) ppf m
156
+
| Jsont.Number (n, m) ->
157
+
loc (strf "Number %a" pp_code (strf "%a" Jsont.pp_number n)) ppf m
158
+
| Jsont.String (s, m) ->
159
+
loc (strf "String %a" pp_code (strf "%a" Jsont.pp_string s)) ppf m
160
+
| Jsont.Array (l, m) ->
161
+
Format.pp_open_vbox ppf indent;
162
+
loc "Array" ppf m;
163
+
(Format.pp_print_list value) ppf l;
164
+
Format.pp_close_box ppf ()
165
+
| Jsont.Object (o, m) ->
166
+
let mem ppf ((name, m), v) =
167
+
let l = strf "Member %a" pp_code (strf "%a" Jsont.pp_string name) in
168
+
loc l ppf m;
169
+
value ppf v
170
+
in
171
+
Format.pp_open_vbox ppf indent;
172
+
loc "Object" ppf m;
173
+
(Format.pp_print_list mem) ppf o;
174
+
Format.pp_close_box ppf ()
175
+
in
176
+
value ppf v
177
+
in
178
+
log_if_error ~use:exit_err_file
179
+
@@ with_infile file
180
+
@@ fun reader ->
181
+
log_if_error ~use:exit_err_json
182
+
@@
183
+
let* j = Jsont_bytesrw.decode ~file ~locs:true Jsont.json reader in
184
+
pp_locs_outline Format.std_formatter j;
185
+
Ok 0
186
+
187
+
let set ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json:j
188
+
~locs =
189
+
let set = Jsont.set_path ?stub ~allow_absent Jsont.json path j in
190
+
trip_type ~file ~format ~number_format ~diff ~locs set
191
+
192
+
(* Command line interface *)
193
+
194
+
open Cmdliner
195
+
open Cmdliner.Term.Syntax
196
+
197
+
let exits =
198
+
Cmd.Exit.info exit_err_file ~doc:"on file read errors."
199
+
:: Cmd.Exit.info exit_err_json ~doc:"on JSON parse or path errors."
200
+
:: Cmd.Exit.info exit_err_diff ~doc:"on JSON output differences."
201
+
:: Cmd.Exit.defaults
202
+
203
+
let path_arg = Arg.conv' ~docv:"JSON_PATH" Jsont.Path.(of_string, pp)
204
+
205
+
let json_arg =
206
+
let of_string s =
207
+
Jsont_bytesrw.decode_string ~locs:true ~layout:true Jsont.json s
208
+
in
209
+
let pp = Jsont.pp_json in
210
+
Arg.conv' ~docv:"JSON" (of_string, pp)
211
+
212
+
let format_opt ~default =
213
+
let fmt =
214
+
[
215
+
("indent", `Format Jsont.Indent);
216
+
("minify", `Format Jsont.Minify);
217
+
("preserve", `Format Jsont.Layout);
218
+
("pretty", `Pretty);
219
+
]
220
+
in
221
+
let doc =
222
+
strf
223
+
"Output style. Must be %s. $(b,minify) guarantess there is no CR \
224
+
(U+000D) or LF (U+000A) in the output. $(b,pretty) is similar to \
225
+
$(b,indent) but may yield more compact outputs."
226
+
(Arg.doc_alts_enum fmt)
227
+
in
228
+
Arg.(value & opt (enum fmt) default & info [ "f"; "format" ] ~doc ~docv:"FMT")
229
+
230
+
let format_opt_default_pretty = format_opt ~default:`Pretty
231
+
let format_opt_default_preserve = format_opt ~default:(`Format Jsont.Layout)
232
+
233
+
let allow_absent_opt =
234
+
let doc = "Do not error if $(i,JSON_PATH) does not exist." in
235
+
Arg.(value & flag & info [ "a"; "allow-absent" ] ~doc)
236
+
237
+
let locs_default_false =
238
+
let doc = "Keep track of source locations (improves error messages)." in
239
+
Arg.(value & flag & info [ "locs" ] ~doc)
240
+
241
+
let locs_default_true =
242
+
let doc = "Do not keep track of source locations." in
243
+
Term.(const not $ Arg.(value & flag & info [ "no-locs" ] ~doc))
244
+
245
+
let number_format_opt =
246
+
let doc = "Use C float format string $(docv) to format JSON numbers." in
247
+
let number_format : Jsont.number_format Arg.conv =
248
+
let parse s =
249
+
try Ok (Scanf.format_from_string s Jsont.default_number_format)
250
+
with Scanf.Scan_failure _ ->
251
+
Error (strf "Cannot format a float with %S" s)
252
+
in
253
+
let pp ppf fmt = Format.pp_print_string ppf (string_of_format fmt) in
254
+
Arg.conv' (parse, pp)
255
+
in
256
+
Arg.(
257
+
value
258
+
& opt number_format Jsont.default_number_format
259
+
& info [ "n"; "number-format" ] ~doc ~docv:"FMT")
260
+
261
+
let diff_flag =
262
+
let doc =
263
+
"Output diff between input and output (needs $(b,git) in your $(b,PATH)). \
264
+
Exits with 0 only there are no differences."
265
+
in
266
+
Arg.(value & flag & info [ "diff" ] ~doc)
267
+
268
+
let dec_only =
269
+
let doc = "Decode only, no output." in
270
+
Arg.(value & flag & info [ "d"; "decode-only" ] ~doc)
271
+
272
+
let file_pos ~pos:p =
273
+
let doc = "$(docv) is the JSON file. Use $(b,-) for stdin." in
274
+
Arg.(value & pos p string "-" & info [] ~doc ~docv:"FILE")
275
+
276
+
let file_pos0 = file_pos ~pos:0
277
+
let file_pos1 = file_pos ~pos:1
278
+
let file_pos2 = file_pos ~pos:2
279
+
280
+
let common_man =
281
+
[
282
+
`S Manpage.s_bugs;
283
+
`P
284
+
"This program is distributed with the jsont OCaml library. See \
285
+
$(i,https://erratique.ch/software/jsont) for contact information.";
286
+
]
287
+
288
+
let delete_cmd =
289
+
let doc = "Delete the value indexed by a JSON path" in
290
+
let sdocs = Manpage.s_common_options in
291
+
let man =
292
+
[
293
+
`S Manpage.s_description;
294
+
`P
295
+
"$(iname) deletes the value indexed by a JSON path. Outputs $(b,null) \
296
+
on the root path $(b,'.'). Examples:";
297
+
`Pre "$(iname) $(b,keywords.[0] package.json)";
298
+
`Noblank;
299
+
`Pre "$(iname) $(b,-a keywords.[0] package.json)";
300
+
`Blocks common_man;
301
+
]
302
+
in
303
+
let path_opt =
304
+
let doc = "Delete JSON path $(docv)." and docv = "JSON_PATH" in
305
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv)
306
+
in
307
+
Cmd.v (Cmd.info "delete" ~doc ~sdocs ~exits ~man)
308
+
@@
309
+
let+ file = file_pos1
310
+
and+ path = path_opt
311
+
and+ format = format_opt_default_preserve
312
+
and+ number_format = number_format_opt
313
+
and+ diff = diff_flag
314
+
and+ allow_absent = allow_absent_opt
315
+
and+ locs = locs_default_true in
316
+
delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs
317
+
318
+
let fmt_cmd =
319
+
let doc = "Format JSON" in
320
+
let sdocs = Manpage.s_common_options in
321
+
let man =
322
+
[
323
+
`S Manpage.s_description;
324
+
`P "$(iname) formats JSON. Examples:";
325
+
`Pre "$(iname) $(b,package.json)";
326
+
`Noblank;
327
+
`Pre "$(iname) $(b,-f minify package.json)";
328
+
`Blocks common_man;
329
+
]
330
+
in
331
+
Cmd.v (Cmd.info "fmt" ~doc ~sdocs ~exits ~man)
332
+
@@
333
+
let+ file = file_pos0
334
+
and+ format = format_opt_default_pretty
335
+
and+ number_format = number_format_opt
336
+
and+ diff = diff_flag
337
+
and+ locs = locs_default_false
338
+
and+ dec_only = dec_only in
339
+
fmt ~file ~format ~number_format ~diff ~locs ~dec_only
340
+
341
+
let get_cmd =
342
+
let doc = "Extract the value indexed by a JSON path" in
343
+
let sdocs = Manpage.s_common_options in
344
+
let man =
345
+
[
346
+
`S Manpage.s_description;
347
+
`P "$(iname) outputs the value indexed by a JSON path. Examples:";
348
+
`Pre "$(iname) $(b,'keywords.[0]' package.json)";
349
+
`Noblank;
350
+
`Pre "$(iname) $(b,-a 'null' 'keywords.[0]' package.json)";
351
+
`Noblank;
352
+
`Pre "$(iname) $(b,-a '[]' 'keywords' package.json)";
353
+
`Noblank;
354
+
`Pre "$(iname) $(b,'.' package.json)";
355
+
`Blocks common_man;
356
+
]
357
+
in
358
+
let path_pos =
359
+
let doc = "Extract the value indexed by JSON path $(docv)." in
360
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH")
361
+
in
362
+
let absent_opt =
363
+
let doc =
364
+
"Do not error if $(i,JSON_PATH) does not exist, output $(docv) instead."
365
+
in
366
+
Arg.(
367
+
value
368
+
& opt (some json_arg) None
369
+
& info [ "a"; "absent" ] ~doc ~docv:"JSON")
370
+
in
371
+
Cmd.v (Cmd.info "get" ~doc ~sdocs ~exits ~man)
372
+
@@
373
+
let+ file = file_pos1
374
+
and+ path = path_pos
375
+
and+ format = format_opt_default_pretty
376
+
and+ number_format = number_format_opt
377
+
and+ diff = diff_flag
378
+
and+ absent = absent_opt
379
+
and+ locs = locs_default_true in
380
+
get ~file ~path ~format ~number_format ~diff ~absent ~locs
381
+
382
+
let set_cmd =
383
+
let doc = "Set the value indexed by a JSON path" in
384
+
let sdocs = Manpage.s_common_options in
385
+
let man =
386
+
[
387
+
`S Manpage.s_description;
388
+
`P "$(iname) sets the value indexed by a JSON path. Examples:";
389
+
`Pre "$(iname) $(b,keywords '[\"codec\"]' package.json)";
390
+
`Noblank;
391
+
`Pre "$(iname) $(b,keywords.[0] '\"codec\"' package.json)";
392
+
`Noblank;
393
+
`Pre "$(iname) $(b,-a keywords.[4] '\"codec\"' package.json)";
394
+
`Noblank;
395
+
`Pre "$(iname) $(b,-s null -a keywords.[4] '\"codec\"' package.json)";
396
+
`Blocks common_man;
397
+
]
398
+
in
399
+
let path_pos =
400
+
let doc = "Set the value indexed by JSON path $(docv)." in
401
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH")
402
+
in
403
+
let json_pos =
404
+
let doc = "Set value to $(docv)." in
405
+
Arg.(required & pos 1 (some json_arg) None & info [] ~doc ~docv:"JSON")
406
+
in
407
+
let stub =
408
+
let doc =
409
+
"Use $(b,docv) as a stub value to use if an array needs to be extended \
410
+
when $(b,-a) is used. By default uses the natural zero of the set data: \
411
+
null for null, false for booleans, 0 for numbers, empty\n\
412
+
\ string for strings, empty array for array, empty object for \
413
+
object."
414
+
in
415
+
Arg.(
416
+
value & opt (some json_arg) None & info [ "s"; "stub" ] ~doc ~docv:"JSON")
417
+
in
418
+
Cmd.v (Cmd.info "set" ~doc ~sdocs ~exits ~man)
419
+
@@
420
+
let+ file = file_pos2
421
+
and+ path = path_pos
422
+
and+ json = json_pos
423
+
and+ stub = stub
424
+
and+ format = format_opt_default_preserve
425
+
and+ number_format = number_format_opt
426
+
and+ diff = diff_flag
427
+
and+ allow_absent = allow_absent_opt
428
+
and+ locs = locs_default_true in
429
+
set ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json ~locs
430
+
431
+
let locs_cmd =
432
+
let doc = "Show JSON parse locations" in
433
+
let sdocs = Manpage.s_common_options in
434
+
let man =
435
+
[
436
+
`S Manpage.s_description;
437
+
`P "$(tname) outputs JSON parse locations. Example:";
438
+
`Pre "$(iname) $(b,package.json)";
439
+
`Blocks common_man;
440
+
]
441
+
in
442
+
Cmd.v (Cmd.info "locs" ~doc ~sdocs ~exits ~man)
443
+
@@
444
+
let+ file = file_pos0 in
445
+
locs' ~file
446
+
447
+
let jsont =
448
+
let doc = "Process JSON data" in
449
+
let sdocs = Manpage.s_common_options in
450
+
let man =
451
+
[
452
+
`S Manpage.s_description;
453
+
`P "$(mname) processes JSON data in various ways.";
454
+
`Pre "$(b,curl -L URL) | $(mname) $(b,fmt)";
455
+
`Noblank;
456
+
`Pre "$(mname) $(b,fmt package.json)";
457
+
`Noblank;
458
+
`Pre "$(mname) $(b,get 'keywords.[0]' package.json)";
459
+
`Noblank;
460
+
`Pre "$(mname) $(b,set 'keywords.[0]' '\"codec\"' package.json)";
461
+
`Noblank;
462
+
`Pre "$(mname) $(b,delete 'keywords.[0]' package.json)";
463
+
`P
464
+
"More information about $(b,jsont)'s JSON paths is in the section JSON \
465
+
PATHS below.";
466
+
`S Manpage.s_commands;
467
+
`S Manpage.s_common_options;
468
+
`S "JSON PATHS";
469
+
`P
470
+
"For $(mname) a JSON path is a dot separated sequence of indexing \
471
+
operations. For example $(b,books.[1].authors.[0]) indexes an object \
472
+
on the $(b,books) member, then on the second element of an array, \
473
+
then the $(b,authors) member of an object and finally the first \
474
+
element of that array. The root path is $(b,.), it can\n\
475
+
\ be omitted if there are indexing operations.";
476
+
`P
477
+
"In general because of your shell's special characters it's better to \
478
+
single quote your JSON paths.";
479
+
`P
480
+
"Note that $(mname)'s JSON PATH are unrelated to the JSONPath query \
481
+
language (RFC 9535).";
482
+
`Blocks common_man;
483
+
]
484
+
in
485
+
Cmd.group (Cmd.info "jsont" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man)
486
+
@@ [ get_cmd; delete_cmd; fmt_cmd; locs_cmd; set_cmd ]
487
+
488
+
let main () = Cmd.eval' jsont
489
+
let () = if !Sys.interactive then () else exit (main ())
+46
test/quickstart.ml
+46
test/quickstart.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: CC0-1.0
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Examples from the docs *)
7
+
8
+
let data =
9
+
{|{ "task": "Make new release",
10
+
"status": "todo",
11
+
"tags": ["work", "softwre"] }|}
12
+
13
+
let () =
14
+
let p = Jsont.Path.(root |> mem "tags" |> nth 1) in
15
+
let update = Jsont.(set_path string p "software") in
16
+
let correct = Jsont_bytesrw.recode_string ~layout:true update data in
17
+
print_endline (Result.get_ok correct)
18
+
19
+
module Status = struct
20
+
type t = Todo | Done | Cancelled
21
+
22
+
let assoc = [ ("todo", Todo); ("done", Done); ("cancelled", Cancelled) ]
23
+
let jsont = Jsont.enum ~kind:"Status" assoc
24
+
end
25
+
26
+
module Item = struct
27
+
type t = { task : string; status : Status.t; tags : string list }
28
+
29
+
let make task status tags = { task; status; tags }
30
+
let task i = i.task
31
+
let status i = i.status
32
+
let tags i = i.tags
33
+
34
+
let jsont =
35
+
Jsont.Object.map ~kind:"Item" make
36
+
|> Jsont.Object.mem "task" Jsont.string ~enc:task
37
+
|> Jsont.Object.mem "status" Status.jsont ~enc:status
38
+
|> Jsont.Object.mem "tags"
39
+
Jsont.(list string)
40
+
~enc:tags ~dec_absent:[] ~enc_omit:(( = ) [])
41
+
|> Jsont.Object.finish
42
+
end
43
+
44
+
let items = Jsont.list Item.jsont
45
+
let items_of_json s = Jsont_bytesrw.decode_string items s
46
+
let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is
+39
test/test_brr.ml
+39
test/test_brr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open B0_testing
8
+
9
+
(* Tests the common test suite with the Jsont_brr codec. *)
10
+
11
+
let error_to_string e = Jstr.to_string (Jv.Error.message e)
12
+
13
+
let decode ?layout t json =
14
+
Result.map_error error_to_string @@ Jsont_brr.decode t (Jstr.v json)
15
+
16
+
let encode ?format t v =
17
+
match Jsont_brr.encode ?format t v with
18
+
| Ok v -> Ok (Jstr.to_string v)
19
+
| Error e -> Error (error_to_string e)
20
+
21
+
let test_funs = { Test_common.supports_layout = false; decode; encode }
22
+
23
+
let main () =
24
+
let exit =
25
+
Test.main @@ fun () ->
26
+
Test_common.test_funs := test_funs;
27
+
Test_common.tests ()
28
+
in
29
+
let result = if exit = 0 then "All tests passed!" else "Some tests FAILED!" in
30
+
let children =
31
+
[
32
+
El.h1 [ El.txt' "Jsont_brr tests" ];
33
+
El.p [ El.txt' result ];
34
+
El.p [ El.txt' "Open the browser console for details." ];
35
+
]
36
+
in
37
+
El.set_children (Document.body G.document) children
38
+
39
+
let () = if !Sys.interactive then () else main ()
+37
test/test_bytesrw.ml
+37
test/test_bytesrw.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open B0_std
7
+
open B0_testing
8
+
open Bytesrw
9
+
10
+
(* Tests the common test suite with the Jsont_bytesrw codec. *)
11
+
12
+
let decode ?layout t json =
13
+
Jsont_bytesrw.decode_string ?layout ~locs:true t json
14
+
15
+
let encode ?format t v = Jsont_bytesrw.encode_string ?format t v
16
+
let test_funs = { Test_common.supports_layout = true; decode; encode }
17
+
18
+
(* Other tests *)
19
+
20
+
let test_eod =
21
+
Test.test "Jsont_bytesrw.encode ~eod" @@ fun () ->
22
+
let b = Buffer.create 255 in
23
+
let w = Bytes.Writer.of_buffer b in
24
+
let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:false w) in
25
+
let () = Result.get_ok (Jsont_bytesrw.encode' Jsont.bool true ~eod:true w) in
26
+
Test.string (Buffer.contents b) "truetrue";
27
+
Snap.raise (fun () -> Jsont_bytesrw.encode' Jsont.bool true ~eod:true w)
28
+
@> __POS_OF__ (Invalid_argument "slice written after eod");
29
+
()
30
+
31
+
let main () =
32
+
Test.main @@ fun () ->
33
+
Test_common.test_funs := test_funs;
34
+
Test.autorun ();
35
+
()
36
+
37
+
let () = if !Sys.interactive then () else exit (main ())
+686
test/test_common.ml
+686
test/test_common.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open B0_std
7
+
open B0_testing
8
+
open Test_common_samples
9
+
10
+
let ( let* ) = Result.bind
11
+
12
+
(* This abstracts over codecs Jsont_brr, Jsont_bytesrw and Jsont.Json *)
13
+
14
+
type test_funs = {
15
+
supports_layout : bool;
16
+
decode : 'a. ?layout:bool -> 'a Jsont.t -> string -> ('a, string) result;
17
+
encode :
18
+
'a. ?format:Jsont.format -> 'a Jsont.t -> 'a -> (string, string) result;
19
+
}
20
+
21
+
let test_funs : test_funs ref =
22
+
ref
23
+
{
24
+
supports_layout = false;
25
+
decode = (fun ?layout _ _ -> assert false);
26
+
encode = (fun ?format _ _ -> assert false);
27
+
}
28
+
29
+
let supports_layout () = !test_funs.supports_layout
30
+
let decode ?layout t json = !test_funs.decode ?layout t json
31
+
let encode ?format t v = !test_funs.encode ?format t v
32
+
33
+
(* Test combinators
34
+
35
+
Note that the part of the test combinators rely on the library to
36
+
be correct. If something really feels fishy you may have to
37
+
investigate here too. *)
38
+
39
+
let decode_ok ?__POS__:pos ?value ?(eq = Test.T.any) t json =
40
+
Test.block ?__POS__:pos @@ fun () ->
41
+
match decode t json with
42
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
43
+
| Ok v' -> (
44
+
match value with None -> () | Some value -> Test.eq eq v' value ~__POS__)
45
+
46
+
let encode_ok ?__POS__:pos ?format t ~value json =
47
+
Test.block ?__POS__:pos @@ fun () ->
48
+
match encode ?format t value with
49
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
50
+
| Ok json' -> Test.string json' json ~__POS__
51
+
52
+
let decode_error ?__POS__:pos ?layout ?msg t json =
53
+
Test.block ?__POS__:pos @@ fun () ->
54
+
match decode ?layout t json with
55
+
| Ok _ -> Test.fail "Decode did not error" ~__POS__
56
+
| Error e -> (
57
+
match msg with
58
+
| None -> ()
59
+
| Some msg -> Test.styled_string msg e ~__POS__)
60
+
61
+
let encode_error ?__POS__:pos ?msg t v =
62
+
Test.block ?__POS__:pos @@ fun () ->
63
+
match encode t v with
64
+
| Ok _ -> Test.fail "Encode did not error" ~__POS__
65
+
| Error e -> (
66
+
match msg with
67
+
| None -> ()
68
+
| Some msg -> Test.styled_string msg e ~__POS__)
69
+
70
+
let update ?__POS__:pos ?(format = Jsont.Minify) q j j' =
71
+
let layout = format = Jsont.Layout in
72
+
Test.block ?__POS__:pos @@ fun () ->
73
+
match decode ~layout q j with
74
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
75
+
| Ok v when supports_layout () || not (format = Jsont.Layout) ->
76
+
encode_ok ~format Jsont.json ~value:v j' ~__POS__
77
+
| Ok v ->
78
+
let j' =
79
+
encode ~format:Jsont.Indent Jsont.json
80
+
(decode Jsont.json j' |> Result.get_ok)
81
+
|> Result.get_ok
82
+
in
83
+
encode_ok ~format:Jsont.Indent Jsont.json ~value:v j' ~__POS__
84
+
85
+
(* [trip t src] is the über testing combinator.
86
+
87
+
It rounds trips a decode of [src] according to [t] and verifies
88
+
that the generated JSON [trip] has the same data unless [lossy] is
89
+
specified. If [value] is provided both decodes of [src] and [trip]
90
+
are tested against [value]. If [format] is specified with
91
+
[Jsont.Indent] or [Jsont.Layout] it assumes that [src] and [trip]
92
+
must be equal *)
93
+
94
+
let trip ?(format = Jsont.Minify) ?(lossy = false) ?value ?(eq = Test.T.any)
95
+
?__POS__:pos t src =
96
+
Test.block ?__POS__:pos @@ fun () ->
97
+
let layout = format = Jsont.Layout in
98
+
let v =
99
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode ~layout t src)
100
+
in
101
+
let trip =
102
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (encode ~format t v)
103
+
in
104
+
let v' = Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode t trip) in
105
+
begin match value with
106
+
| None -> Test.eq eq v v' ~__POS__
107
+
| Some value ->
108
+
Test.eq eq v value ~__POS__;
109
+
Test.eq eq v' value ~__POS__
110
+
end;
111
+
if not lossy then begin
112
+
let json =
113
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Jsont.json src)
114
+
in
115
+
let trip =
116
+
Test.noraise ~__POS__ @@ fun () -> Result.get_ok' (decode Jsont.json trip)
117
+
in
118
+
Test.eq (module Jsont.Json) json trip ~__POS__
119
+
end;
120
+
if format <> Jsont.Minify then
121
+
begin if format = Jsont.Layout && not (supports_layout ()) then ()
122
+
else
123
+
(* Test that src is a representation of the requested encoding format *)
124
+
Test.string src trip ~__POS__
125
+
end
126
+
127
+
let eq : (module Test.T with type t = 'a) = (module Jsont.Json)
128
+
129
+
(* Tests *)
130
+
131
+
let test_basic_invalid =
132
+
Test.test "basic invalid JSON" @@ fun () ->
133
+
decode_error Jsont.json "" ~__POS__;
134
+
decode_error (Jsont.null ()) "" ~__POS__;
135
+
decode_error Jsont.bool "" ~__POS__;
136
+
decode_error Jsont.json "ha" ~__POS__;
137
+
decode_error (Jsont.null ()) "ha" ~__POS__;
138
+
decode_error Jsont.bool "ha" ~__POS__;
139
+
decode_error Jsont.json " ha" ~__POS__;
140
+
decode_error Jsont.json " r6 " ~__POS__;
141
+
decode_error Jsont.json " { " ~__POS__;
142
+
decode_error Jsont.json " [ " ~__POS__;
143
+
decode_error Jsont.json " ][ " ~__POS__;
144
+
()
145
+
146
+
let test_indent = Test.test "Encode with indentation" @@ fun () -> ()
147
+
148
+
let test_null =
149
+
Test.test "Jsont.null" @@ fun () ->
150
+
trip ~eq ~format:Layout Jsont.json " null \r\n" ~__POS__;
151
+
trip ~eq ~format:Layout Jsont.json "\n null " ~__POS__;
152
+
trip ~eq ~format:Layout Jsont.json "null" ~__POS__;
153
+
trip ~eq ~format:Indent Jsont.json "null" ~__POS__;
154
+
decode_error Jsont.json " nu " ~__POS__;
155
+
decode_error Jsont.json " nul " ~__POS__;
156
+
decode_error Jsont.json " n " ~__POS__;
157
+
trip (Jsont.null ()) " \n null \n " ~value:() ~__POS__;
158
+
trip (Jsont.null ()) " null " ~value:() ~__POS__;
159
+
decode_error (Jsont.null ()) " true " ~__POS__;
160
+
()
161
+
162
+
let test_bool =
163
+
Test.test "Jsont.bool" @@ fun () ->
164
+
trip ~eq ~format:Layout Jsont.json " true \r\n" ~__POS__;
165
+
trip ~eq ~format:Layout Jsont.json "\n false " ~__POS__;
166
+
trip ~eq ~format:Layout Jsont.json "false" ~__POS__;
167
+
trip ~eq ~format:Indent Jsont.json "true" ~__POS__;
168
+
trip ~eq ~format:Indent Jsont.json "false" ~__POS__;
169
+
decode_error Jsont.json " fals " ~__POS__;
170
+
decode_error Jsont.json " falsee " ~__POS__;
171
+
decode_error Jsont.json " f " ~__POS__;
172
+
trip ~eq:Test.T.bool Jsont.bool " true \n " ~value:true ~__POS__;
173
+
trip ~eq:Test.T.bool Jsont.bool " false " ~value:false ~__POS__;
174
+
decode_error Jsont.bool " fals " ~__POS__;
175
+
()
176
+
177
+
let test_numbers =
178
+
Test.test "Jsont.number" @@ fun () ->
179
+
trip ~eq ~format:Layout Jsont.json " 1 " ~__POS__;
180
+
trip ~eq ~format:Layout Jsont.json " 0 \n " ~__POS__;
181
+
trip ~eq ~format:Layout Jsont.json "\n 2.5 " ~__POS__;
182
+
trip ~eq ~format:Indent Jsont.json "0";
183
+
trip ~eq ~format:Indent Jsont.json "0.5";
184
+
decode_error Jsont.json " 01 " ~__POS__;
185
+
decode_error Jsont.json " -a " ~__POS__;
186
+
decode_error Jsont.json " 1. " ~__POS__;
187
+
decode_error Jsont.json " 1.0e+ " ~__POS__;
188
+
decode_error Jsont.json " inf " ~__POS__;
189
+
decode_error Jsont.json " infinity " ~__POS__;
190
+
decode_error Jsont.json " nan " ~__POS__;
191
+
let eq = Test.T.float in
192
+
trip ~eq Jsont.number " -0 " ~value:(-0.) ~__POS__;
193
+
trip ~eq Jsont.number " 0 " ~value:0. ~__POS__;
194
+
trip ~eq Jsont.number " 0E1 " ~value:0. ~__POS__;
195
+
trip ~eq Jsont.number " 0e+1 " ~value:0. ~__POS__;
196
+
trip ~eq Jsont.number " null " ~value:Float.nan ~__POS__;
197
+
encode_ok Jsont.number "null" ~value:Float.infinity ~__POS__;
198
+
encode_ok Jsont.number "null" ~value:Float.neg_infinity ~__POS__;
199
+
trip ~eq Jsont.number " 1e300 " ~value:1.e300 ~__POS__;
200
+
decode_error Jsont.number " fals " ~__POS__;
201
+
decode_error Jsont.number " 1. " ~__POS__;
202
+
decode_error Jsont.number " 1.0e+ " ~__POS__;
203
+
decode_error Jsont.number " 0E " ~__POS__;
204
+
decode_error Jsont.number " 1eE2 " ~__POS__;
205
+
()
206
+
207
+
let test_strings =
208
+
Test.test "Jsont.string" @@ fun () ->
209
+
trip ~eq ~format:Layout Jsont.json {| "" |} ~__POS__;
210
+
trip ~eq ~format:Layout Jsont.json " \"\\\"\" " ~__POS__;
211
+
trip ~eq ~format:Layout Jsont.json " \"\\\\\" " ~__POS__;
212
+
trip ~eq ~format:Layout Jsont.json " \"hihi\" \n " ~__POS__;
213
+
trip ~eq ~format:Layout Jsont.json " \"hi\\nhi\" \n " ~__POS__;
214
+
if Sys.backend_type <> Sys.Other "js_of_ocaml" then begin
215
+
decode_error Jsont.json "\"\\uDC01\"" ~__POS__;
216
+
decode_error Jsont.json "\"\\uDBFF\"" ~__POS__;
217
+
decode_error Jsont.json "\"\\uDBFF\\uDBFF\"" ~__POS__
218
+
end;
219
+
trip ~format:Indent Jsont.json {|""|};
220
+
trip ~format:Indent Jsont.json {|"blablabla"|};
221
+
decode_error Jsont.json "\"hi\nhi\"" ~__POS__;
222
+
decode_error Jsont.json "\n \"abla\" hi " ~__POS__;
223
+
decode_error Jsont.json "\n \"unclosed hi " ~__POS__;
224
+
trip ~eq:Test.T.string Jsont.string "\"\\ud83D\\uDc2B\"" ~value:"🐫" ~__POS__;
225
+
trip ~eq:Test.T.string Jsont.string "\"🐫 a\"" ~value:"🐫 a" ~__POS__;
226
+
decode_error Jsont.string " false " ~__POS__;
227
+
decode_error Jsont.string "1.0" ~__POS__;
228
+
()
229
+
230
+
let test_option =
231
+
Test.test "Jsont.{none,some,option}" @@ fun () ->
232
+
(* none *)
233
+
decode_error Jsont.none "2" ~__POS__;
234
+
decode_error Jsont.none "true" ~__POS__;
235
+
trip Jsont.none "null" ~value:None ~__POS__;
236
+
(* some *)
237
+
decode_error Jsont.(some bool) "null" ~__POS__;
238
+
decode_error Jsont.(some bool) "1.0" ~__POS__;
239
+
trip Jsont.(some bool) "true" ~value:(Some true) ~__POS__;
240
+
(* option *)
241
+
decode_error Jsont.(option bool) "1.0" ~__POS__;
242
+
decode_error Jsont.(option bool) "{}" ~__POS__;
243
+
trip Jsont.(option bool) "true" ~value:(Some true) ~__POS__;
244
+
trip Jsont.(option bool) "false" ~value:(Some false) ~__POS__;
245
+
trip Jsont.(option bool) "null" ~value:None ~__POS__;
246
+
()
247
+
248
+
let test_ints =
249
+
Test.test "Jsont.{int…,uint…}" @@ fun () ->
250
+
(* uint8 *)
251
+
decode_error Jsont.uint8 "null" ~__POS__;
252
+
decode_error Jsont.uint8 "true" ~__POS__;
253
+
decode_error Jsont.uint8 "-1" ~__POS__;
254
+
decode_error Jsont.uint8 "256" ~__POS__;
255
+
trip Jsont.uint8 "0" ~value:0 ~__POS__;
256
+
trip Jsont.uint8 "255" ~value:255 ~__POS__;
257
+
(* uint16 *)
258
+
decode_error Jsont.uint16 "null" ~__POS__;
259
+
decode_error Jsont.uint16 "true" ~__POS__;
260
+
decode_error Jsont.uint16 "-1" ~__POS__;
261
+
decode_error Jsont.uint16 "65536" ~__POS__;
262
+
trip Jsont.uint16 "0" ~value:0 ~__POS__;
263
+
trip Jsont.uint16 "65535" ~value:65535 ~__POS__;
264
+
(* int8 *)
265
+
decode_error Jsont.int8 "null" ~__POS__;
266
+
decode_error Jsont.int8 "true" ~__POS__;
267
+
decode_error Jsont.int8 "-129" ~__POS__;
268
+
decode_error Jsont.int8 "128" ~__POS__;
269
+
trip Jsont.int8 "-128" ~value:(-128) ~__POS__;
270
+
trip Jsont.int8 "127" ~value:127 ~__POS__;
271
+
(* int32 *)
272
+
decode_error Jsont.int32 "null" ~__POS__;
273
+
decode_error Jsont.int32 "true" ~__POS__;
274
+
decode_error Jsont.int32 "-2147483649" ~__POS__;
275
+
decode_error Jsont.int32 "2147483648" ~__POS__;
276
+
trip Jsont.int32 "-2147483648" ~value:Int32.min_int ~__POS__;
277
+
trip Jsont.int32 "2147483647" ~value:Int32.max_int ~__POS__;
278
+
(* int64 *)
279
+
let max_exact = Int64.shift_left 1L 53 in
280
+
let max_exact_next = Int64.(add max_exact 1L) in
281
+
let min_exact = Int64.shift_left 1L 53 in
282
+
let min_exact_prev = Int64.(add max_exact 1L) in
283
+
decode_error Jsont.int64 "null" ~__POS__;
284
+
decode_error Jsont.int64 "true" ~__POS__;
285
+
trip Jsont.int64 (Fmt.str "%Ld" max_exact) ~value:max_exact ~__POS__;
286
+
trip Jsont.int64 (Fmt.str "%Ld" min_exact) ~value:min_exact ~__POS__;
287
+
trip Jsont.int64
288
+
(Fmt.str {|"%Ld"|} max_exact_next)
289
+
~value:max_exact_next ~__POS__;
290
+
trip Jsont.int64
291
+
(Fmt.str {|"%Ld"|} min_exact_prev)
292
+
~value:min_exact_prev ~__POS__;
293
+
(* int_as_string *)
294
+
trip Jsont.int_as_string {|"2"|} ~value:2 ~__POS__;
295
+
trip Jsont.int_as_string
296
+
(Fmt.str {|"%d"|} Int.max_int)
297
+
~value:Int.max_int ~__POS__;
298
+
trip Jsont.int_as_string
299
+
(Fmt.str {|"%d"|} Int.min_int)
300
+
~value:Int.min_int ~__POS__;
301
+
(* int64_as_string *)
302
+
trip Jsont.int64_as_string
303
+
(Fmt.str {|"%Ld"|} Int64.max_int)
304
+
~value:Int64.max_int ~__POS__;
305
+
trip Jsont.int64_as_string
306
+
(Fmt.str {|"%Ld"|} Int64.min_int)
307
+
~value:Int64.min_int ~__POS__;
308
+
()
309
+
310
+
let test_floats =
311
+
Test.test "Jsont.{any_float,float_as_hex_string}" @@ fun () ->
312
+
(* any_float *)
313
+
let jsonstr f = Fmt.str {|"%s"|} (Float.to_string f) in
314
+
let eq = Test.T.float in
315
+
decode_ok ~eq Jsont.any_float "null" ~value:Float.nan ~__POS__;
316
+
trip ~eq Jsont.any_float " -0 " ~value:(-0.) ~__POS__;
317
+
trip ~eq Jsont.any_float " 0 " ~value:0. ~__POS__;
318
+
trip ~eq Jsont.any_float " 0.5 " ~value:0.5 ~__POS__;
319
+
decode_ok ~eq Jsont.any_float (jsonstr 0.5) ~value:0.5 ~__POS__;
320
+
trip ~eq Jsont.any_float (jsonstr Float.nan) ~value:Float.nan ~__POS__;
321
+
trip ~eq Jsont.any_float (jsonstr Float.infinity) ~value:Float.infinity
322
+
~__POS__;
323
+
trip ~eq Jsont.any_float
324
+
(jsonstr Float.neg_infinity)
325
+
~value:Float.neg_infinity ~__POS__;
326
+
327
+
(* float_as_hex_string *)
328
+
let jsonstr f = Fmt.str {|"%h"|} f in
329
+
let t = Jsont.float_as_hex_string in
330
+
decode_error t "null" ~__POS__;
331
+
decode_error t "1.0" ~__POS__;
332
+
trip ~eq t (jsonstr 0.5) ~value:0.5 ~__POS__;
333
+
trip ~eq t (jsonstr Float.nan) ~value:Float.nan ~__POS__;
334
+
trip ~eq t (jsonstr Float.infinity) ~value:Float.infinity ~__POS__;
335
+
trip ~eq t (jsonstr Float.neg_infinity) ~value:Float.neg_infinity ~__POS__;
336
+
()
337
+
338
+
let test_enum_and_binary_string =
339
+
Test.test "Jsont.{of_of_string,enum,binary_string}" @@ fun () ->
340
+
(* of_string *)
341
+
let int_of_string s =
342
+
match int_of_string_opt s with
343
+
| None -> Error "Not an integer"
344
+
| Some i -> Ok i
345
+
in
346
+
let t = Jsont.of_of_string ~kind:"int" int_of_string ~enc:Int.to_string in
347
+
trip ~eq:Test.T.int t {|"1"|} ~value:1 ~__POS__;
348
+
decode_error t {|"bla"|} ~__POS__;
349
+
(* enum *)
350
+
let enum = Jsont.enum ~kind:"heyho" [ ("hey", `Hey); ("ho", `Ho) ] in
351
+
decode_error enum {|null|} ~__POS__;
352
+
decode_error enum {|"ha"|} ~__POS__;
353
+
decode_error enum {|"farfarfar"|} ~__POS__;
354
+
trip enum {|"hey"|} ~value:`Hey ~__POS__;
355
+
trip enum {|"ho"|} ~value:`Ho ~__POS__;
356
+
(* binary_string *)
357
+
decode_error Jsont.binary_string {|null|};
358
+
decode_error Jsont.binary_string {|"00gabb"|} ~__POS__;
359
+
decode_error Jsont.binary_string {|"00aab"|} ~__POS__;
360
+
trip Jsont.binary_string {|"00a1bb"|} ~__POS__;
361
+
trip Jsont.binary_string {|"00a1ff"|} ~value:"\x00\xa1\xff" ~__POS__;
362
+
()
363
+
364
+
let test_arrays =
365
+
Test.test "Jsont.{list,array,bigarray,t2,t3,t4,tn}" @@ fun () ->
366
+
let barr arr = Bigarray.Array1.of_array Int C_layout arr in
367
+
trip ~eq ~format:Layout Jsont.json " [] \n" ~__POS__;
368
+
trip ~eq ~format:Layout Jsont.json " [1, 3] \n\n" ~__POS__;
369
+
trip ~eq ~format:Layout Jsont.json " [1\n,3] \n\n" ~__POS__;
370
+
trip ~eq ~format:Layout Jsont.json " [1\n, \"a\",\n3 ] \n\n" ~__POS__;
371
+
trip ~eq ~format:Indent Jsont.json "[]" ~__POS__;
372
+
trip ~eq ~format:Indent Jsont.json "[\n 1\n]" ~__POS__;
373
+
trip ~eq ~format:Indent Jsont.json "[\n 1,\n \"bla\",\n 2\n]" ~__POS__;
374
+
decode_error Jsont.json "[1 ~__POS__;3]" ~__POS__;
375
+
decode_error Jsont.json " [1,3 " ~__POS__;
376
+
decode_error Jsont.(list number) "[1,true,3]" ~__POS__;
377
+
trip Jsont.(list int) " [ ] \n" ~value:[] ~__POS__;
378
+
trip Jsont.(list int) "[1,2,3]" ~value:[ 1; 2; 3 ] ~__POS__;
379
+
trip Jsont.(array int) " [ ] \n" ~value:[||] ~__POS__;
380
+
trip Jsont.(array int) "[1,2,3]" ~value:[| 1; 2; 3 |] ~__POS__;
381
+
trip Jsont.(bigarray Int int) " [ ] \n" ~value:(barr [||]) ~__POS__;
382
+
trip
383
+
Jsont.(bigarray Int int)
384
+
" [1,2,3] \n"
385
+
~value:(barr [| 1; 2; 3 |])
386
+
~__POS__;
387
+
let enc = Array.get in
388
+
let t2_int = Jsont.t2 ~dec:(fun x y -> [| x; y |]) ~enc Jsont.int in
389
+
decode_error t2_int "[]" ~__POS__;
390
+
decode_error t2_int "[1]" ~__POS__;
391
+
trip t2_int "[1,2]" ~value:[| 1; 2 |] ~__POS__;
392
+
decode_error t2_int "[1,2,3]" ~__POS__;
393
+
let t3_int = Jsont.t3 ~dec:(fun x y z -> [| x; y; z |]) ~enc Jsont.int in
394
+
decode_error t3_int "[]" ~__POS__;
395
+
decode_error t3_int "[1]" ~__POS__;
396
+
decode_error t3_int "[1,2]" ~__POS__;
397
+
trip t3_int "[1,2,3]" ~value:[| 1; 2; 3 |] ~__POS__;
398
+
decode_error t3_int "[1,2,3,4]" ~__POS__;
399
+
let t4_int = Jsont.t4 ~dec:(fun x y z w -> [| x; y; z; w |]) ~enc Jsont.int in
400
+
decode_error t4_int "[]" ~__POS__;
401
+
decode_error t4_int "[1]" ~__POS__;
402
+
decode_error t4_int "[1,2]" ~__POS__;
403
+
decode_error t4_int "[1,2,3]" ~__POS__;
404
+
trip t4_int "[1,2,3,4]" ~value:[| 1; 2; 3; 4 |] ~__POS__;
405
+
decode_error t4_int "[1,2,3,4,5]" ~__POS__;
406
+
let t0_int = Jsont.(tn ~n:0 int) in
407
+
let t2_int = Jsont.(tn ~n:2 int) in
408
+
trip t0_int "[]" ~value:[||] ~__POS__;
409
+
decode_error t0_int "[1]" ~__POS__;
410
+
decode_error t0_int "[1;2]" ~__POS__;
411
+
decode_error t2_int "[]" ~__POS__;
412
+
decode_error t2_int "[1]" ~__POS__;
413
+
trip t2_int "[1,2]" ~value:[| 1; 2 |] ~__POS__;
414
+
decode_error t2_int "[1,2,3]" ~__POS__;
415
+
()
416
+
417
+
let test_objects =
418
+
Test.test "Jsont.Object.map" @@ fun () ->
419
+
trip ~eq ~format:Layout Jsont.json " {} \n" ~__POS__;
420
+
trip ~eq ~format:Layout Jsont.json {| {"a": 1} |} ~__POS__;
421
+
trip ~eq ~format:Layout Jsont.json {| {"a": 1, "b":2} |} ~__POS__;
422
+
trip ~eq ~format:Indent Jsont.json "{}" ~__POS__;
423
+
trip ~eq ~format:Indent Jsont.json "{\n \"bla\": 1\n}";
424
+
trip ~format:Indent Item.jsont Item_data.i0_json ~value:Item_data.i0 ~__POS__;
425
+
trip ~format:Indent Item.jsont Item_data.i1_json ~value:Item_data.i1 ~__POS__;
426
+
()
427
+
428
+
let test_unknown_mems =
429
+
Test.test "Jsont.Object.*_unknown" @@ fun () ->
430
+
(* Skip unknowns *)
431
+
trip Unknown.skip_jsont Unknown_data.u0 ~__POS__;
432
+
trip ~lossy:true Unknown.skip_jsont Unknown_data.u1 ~__POS__;
433
+
trip ~lossy:true Unknown.skip_jsont Unknown_data.u2 ~__POS__;
434
+
(* Error on unknown *)
435
+
trip Unknown.error_jsont Unknown_data.u0 ~__POS__;
436
+
decode_error Unknown.error_jsont Unknown_data.u1 ~__POS__;
437
+
decode_error Unknown.error_jsont Unknown_data.u2 ~__POS__;
438
+
(* Keep unknowns *)
439
+
trip Unknown.keep_jsont Unknown_data.u0 ~__POS__;
440
+
trip Unknown.keep_jsont Unknown_data.u1 ~__POS__;
441
+
trip Unknown.keep_jsont Unknown_data.u2 ~__POS__;
442
+
()
443
+
444
+
let test_cases =
445
+
Test.test "Jsont.Object.Case" @@ fun () ->
446
+
decode_error Cases.Person_top.jsont Cases_data.invalid_miss ~__POS__;
447
+
decode_error Cases.Person_top.jsont Cases_data.invalid_case ~__POS__;
448
+
decode_error Cases.Person_field.jsont Cases_data.invalid_miss ~__POS__;
449
+
decode_error Cases.Person_field.jsont Cases_data.invalid_case ~__POS__;
450
+
trip Cases.Person_top.jsont Cases_data.author0 ~value:Cases_data.author0_top
451
+
~__POS__;
452
+
trip Cases.Person_top.jsont Cases_data.author0' ~value:Cases_data.author0_top
453
+
~__POS__;
454
+
trip Cases.Person_top.jsont Cases_data.editor0 ~value:Cases_data.editor0_top
455
+
~__POS__;
456
+
trip Cases.Person_top.jsont Cases_data.editor0' ~value:Cases_data.editor0_top
457
+
~__POS__;
458
+
trip Cases.Person_field.jsont Cases_data.author0
459
+
~value:Cases_data.author0_field ~__POS__;
460
+
trip Cases.Person_field.jsont Cases_data.author0'
461
+
~value:Cases_data.author0_field ~__POS__;
462
+
trip Cases.Person_field.jsont Cases_data.editor0
463
+
~value:Cases_data.editor0_field ~__POS__;
464
+
trip Cases.Person_field.jsont Cases_data.editor0'
465
+
~value:Cases_data.editor0_field ~__POS__;
466
+
(* Unknown value override *)
467
+
trip Cases.Keep_unknown.jsont
468
+
~eq:(module Cases.Keep_unknown)
469
+
Cases_data.unknown_a ~value:Cases_data.unknown_a_value ~__POS__;
470
+
trip Cases.Keep_unknown.jsont
471
+
~eq:(module Cases.Keep_unknown)
472
+
Cases_data.unknown_b ~value:Cases_data.unknown_b_value ~__POS__;
473
+
let module M = struct
474
+
type t = string String_map.t
475
+
476
+
let equal = String_map.equal String.equal
477
+
let pp ppf v = Fmt.string ppf "<value>"
478
+
end in
479
+
trip Cases.Keep_unknown.a_jsont
480
+
~eq:(module M)
481
+
Cases_data.unknown_a ~value:Cases_data.unknown_a_a_value ~__POS__;
482
+
encode_ok Cases.Keep_unknown.jsont ~format:Indent
483
+
~value:Cases_data.unknown_a_no_a_unknown_value
484
+
Cases_data.unknown_a_no_a_unknown;
485
+
()
486
+
487
+
let test_rec =
488
+
Test.test "Jsont.rec" @@ fun () ->
489
+
let tree_null = Tree.jsont_with_null Jsont.int in
490
+
trip tree_null Tree_data.empty_null ~value:Tree_data.empty ~__POS__;
491
+
trip tree_null Tree_data.tree0_null ~value:Tree_data.tree0 ~__POS__;
492
+
let tree_cases = Tree.jsont_with_cases Jsont.int in
493
+
trip tree_cases Tree_data.empty_cases ~value:Tree_data.empty ~__POS__;
494
+
trip tree_cases Tree_data.tree0_cases ~value:Tree_data.tree0 ~__POS__;
495
+
()
496
+
497
+
let test_zero =
498
+
Test.test "Jsont.zero" @@ fun () ->
499
+
let decode_ok = decode_ok ~eq:Test.T.unit in
500
+
decode_ok Jsont.zero "null" ~value:() ~__POS__;
501
+
decode_ok Jsont.zero "2" ~value:() ~__POS__;
502
+
decode_ok Jsont.zero {|"a"|} ~value:() ~__POS__;
503
+
decode_ok Jsont.zero {|[1]|} ~value:() ~__POS__;
504
+
decode_ok Jsont.zero {|{"bli":"bla"}|} ~value:() ~__POS__;
505
+
encode_ok Jsont.zero ~value:() "null" ~__POS__;
506
+
()
507
+
508
+
let test_const =
509
+
Test.test "Jsont.const" @@ fun () ->
510
+
trip ~lossy:true Jsont.(const int 4) " {} " ~value:4 ~__POS__;
511
+
trip ~lossy:true Jsont.(const bool true) ~value:true "false" ~__POS__;
512
+
()
513
+
514
+
let recode_int_to_string = Jsont.(recode ~dec:int string_of_int ~enc:string)
515
+
516
+
let test_array_queries =
517
+
let a = "[1,[ 1, 2], 3] " in
518
+
Test.test "Jsont.{nth,*_nth,filter_map_array,fold_array}" @@ fun () ->
519
+
(* Jsont.nth *)
520
+
decode_ok Jsont.(nth 0 @@ int) a ~value:1 ~__POS__;
521
+
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
522
+
decode_ok Jsont.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
523
+
decode_error Jsont.(nth 3 @@ int) a ~__POS__;
524
+
decode_ok Jsont.(nth ~absent:3 3 @@ int) ~value:3 a ~__POS__;
525
+
decode_ok Jsont.(nth 0 @@ int) ~value:1 a ~__POS__;
526
+
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
527
+
decode_ok Jsont.(nth 1 @@ list int) a ~value:[ 1; 2 ] ~__POS__;
528
+
(* Jsont.{set,update}_nth} *)
529
+
update ~format:Jsont.Layout
530
+
Jsont.(update_nth 1 @@ update_nth 1 Jsont.(const int 4))
531
+
a "[1,[ 1, 4], 3] " ~__POS__;
532
+
update ~format:Jsont.Layout
533
+
Jsont.(update_nth 1 @@ set_nth int 0 2)
534
+
a "[1,[ 2, 2], 3] " ~__POS__;
535
+
decode_error Jsont.(update_nth 1 @@ set_nth int 2 3) a;
536
+
decode_error Jsont.(update_nth 3 int) a;
537
+
update ~format:Jsont.Layout
538
+
Jsont.(update_nth 3 ~absent:5 int)
539
+
a "[1,[ 1, 2], 3,5] ";
540
+
update ~format:Jsont.Layout
541
+
Jsont.(update_nth 1 @@ set_nth ~allow_absent:true int 3 3)
542
+
a "[1,[ 1, 2,0,3], 3] " ~__POS__;
543
+
update ~format:Jsont.Layout
544
+
Jsont.(
545
+
update_nth 1
546
+
@@ set_nth ~stub:(Jsont.Json.null ()) ~allow_absent:true int 3 3)
547
+
a "[1,[ 1, 2,null,3], 3] " ~__POS__;
548
+
update ~format:Jsont.Layout
549
+
Jsont.(update_nth 1 @@ update_nth 1 recode_int_to_string)
550
+
a "[1,[ 1, \"2\"], 3] " ~__POS__;
551
+
update Jsont.(update_nth 1 @@ delete_nth 0) a "[1,[2],3]" ~__POS__;
552
+
decode_ok
553
+
Jsont.(nth 1 @@ fold_array int (fun i v acc -> (i, v) :: acc) [])
554
+
a
555
+
~value:[ (1, 2); (0, 1) ]
556
+
~__POS__;
557
+
update
558
+
Jsont.(
559
+
update_nth 1
560
+
@@ filter_map_array int int (fun _ v ->
561
+
if v mod 2 = 0 then None else Some (v - 1)))
562
+
a "[1,[0],3]" ~__POS__;
563
+
(* Jsont.delete_nth *)
564
+
update ~format:Jsont.Layout Jsont.(delete_nth 1) a "[1, 3] " ~__POS__;
565
+
decode_error Jsont.(delete_nth 3) a ~__POS__;
566
+
update ~format:Jsont.Layout
567
+
Jsont.(delete_nth ~allow_absent:true 3)
568
+
a a ~__POS__;
569
+
(* Jsont.filter_map_array *)
570
+
update ~format:Jsont.Layout
571
+
Jsont.(
572
+
filter_map_array Jsont.json Jsont.json (fun i v ->
573
+
if i = 1 then None else Some v))
574
+
a "[1, 3] " ~__POS__;
575
+
(* Jsont.fold_array *)
576
+
decode_ok
577
+
Jsont.(nth 1 @@ fold_array int (fun i v acc -> i + v + acc) 0)
578
+
a ~value:4 ~__POS__;
579
+
()
580
+
581
+
let test_object_queries =
582
+
Test.test "Jsont.{mem,*_mem,fold_object,filter_map_object}" @@ fun () ->
583
+
let o = {| { "a" : { "b" : 1 }, "c": 2 } |} in
584
+
(* Jsont.mem *)
585
+
decode_ok Jsont.(mem "a" @@ mem "b" int) o ~value:1 ~__POS__;
586
+
decode_error Jsont.(mem "a" @@ mem "c" int) o ~__POS__;
587
+
decode_ok Jsont.(mem "a" @@ mem ~absent:3 "c" int) o ~value:3 ~__POS__;
588
+
(* Jsont.{update,set}_mem *)
589
+
update ~format:Jsont.Layout
590
+
Jsont.(update_mem "a" @@ update_mem "b" (const int 3))
591
+
o {| { "a" : { "b" : 3 }, "c": 2 } |} ~__POS__;
592
+
update ~format:Jsont.Layout
593
+
Jsont.(update_mem "a" @@ update_mem "b" recode_int_to_string)
594
+
o {| { "a" : { "b" : "1" }, "c": 2 } |} ~__POS__;
595
+
decode_error Jsont.(update_mem "a" @@ update_mem "c" (const int 4)) o ~__POS__;
596
+
update ~format:Jsont.Layout
597
+
Jsont.(update_mem "a" @@ update_mem "c" ~absent:4 (const int 5))
598
+
o {| { "a" : { "b" : 1 ,"c":5}, "c": 2 } |} ~__POS__;
599
+
update ~format:Jsont.Layout
600
+
Jsont.(set_mem int "a" 2)
601
+
o {| { "a" : 2, "c": 2 } |} ~__POS__;
602
+
decode_error Jsont.(set_mem int "d" 2) o ~__POS__;
603
+
update ~format:Jsont.Layout
604
+
Jsont.(set_mem ~allow_absent:true int "d" 3)
605
+
o {| { "a" : { "b" : 1 }, "c": 2 ,"d":3} |} ~__POS__;
606
+
(* Jsont.delete_mem *)
607
+
decode_error Jsont.(update_mem "a" @@ delete_mem "c") o ~__POS__;
608
+
update ~format:Jsont.Layout
609
+
Jsont.(update_mem "a" @@ delete_mem ~allow_absent:true "c")
610
+
o o ~__POS__;
611
+
update ~format:Jsont.Layout
612
+
Jsont.(update_mem "a" @@ delete_mem "b")
613
+
o {| { "a" : {}, "c": 2 } |} ~__POS__;
614
+
update ~format:Jsont.Layout Jsont.(delete_mem "a") o {| { "c": 2 } |} ~__POS__;
615
+
(* Jsont.filter_map_object *)
616
+
update ~format:Jsont.Layout
617
+
Jsont.(
618
+
filter_map_object Jsont.json Jsont.json (fun m n v ->
619
+
if n = "a" then None else Some ((n, m), v)))
620
+
o {| { "c": 2 } |} ~__POS__;
621
+
(* Jsont.fold *)
622
+
decode_ok
623
+
Jsont.(mem "a" @@ fold_object int (fun _ n i acc -> i + acc) 2)
624
+
o ~value:3 ~__POS__;
625
+
()
626
+
627
+
let test_path_queries =
628
+
Test.test "Jsont.{path,*_path}" @@ fun () ->
629
+
let v = {| [ 0, { "a": 1}, 2 ] |} in
630
+
(* Jsont.path *)
631
+
decode_error Jsont.(path Path.root int) v ~__POS__;
632
+
update ~format:Jsont.Layout Jsont.(path Path.root Jsont.json) v v ~__POS__;
633
+
decode_ok Jsont.(path Path.(root |> nth 1 |> mem "a") int) v ~value:1;
634
+
decode_ok
635
+
Jsont.(path Path.(root |> nth 1 |> mem "b") ~absent:2 int)
636
+
v ~value:2 ~__POS__;
637
+
(* Jsont.{set,update}_path} *)
638
+
update ~format:Jsont.Layout Jsont.(set_path int Path.root 2) v {|2|} ~__POS__;
639
+
update ~format:Jsont.Layout
640
+
Jsont.(set_path string Path.(root |> nth 1 |> mem "a") "hey")
641
+
v {| [ 0, { "a": "hey"}, 2 ] |} ~__POS__;
642
+
update ~format:Jsont.Layout
643
+
Jsont.(
644
+
set_path ~allow_absent:true string Path.(root |> nth 1 |> mem "b") "hey")
645
+
v {| [ 0, { "a": 1,"b":"hey"}, 2 ] |} ~__POS__;
646
+
update ~format:Jsont.Layout
647
+
Jsont.(
648
+
update_path
649
+
Path.(root |> nth 1 |> mem "a")
650
+
(map int ~dec:succ ~enc:Fun.id))
651
+
v {| [ 0, { "a": 2}, 2 ] |} ~__POS__;
652
+
(* Jsont.delete_path *)
653
+
update ~format:Jsont.Layout
654
+
Jsont.(delete_path Path.(root |> nth 1 |> mem "a"))
655
+
v {| [ 0, {}, 2 ] |} ~__POS__;
656
+
update ~format:Jsont.Layout
657
+
Jsont.(delete_path Path.(root |> nth 1))
658
+
v {| [ 0, 2 ] |} ~__POS__;
659
+
update ~format:Jsont.Layout Jsont.(delete_path Path.root) v {|null|} ~__POS__;
660
+
decode_error Jsont.(delete_path Path.(root |> nth 1 |> mem "b")) v ~__POS__;
661
+
update ~format:Jsont.Layout
662
+
Jsont.(delete_path ~allow_absent:true Path.(root |> nth 1 |> mem "b"))
663
+
v v ~__POS__;
664
+
()
665
+
666
+
let tests () =
667
+
test_basic_invalid ();
668
+
test_null ();
669
+
test_bool ();
670
+
test_numbers ();
671
+
test_strings ();
672
+
test_option ();
673
+
test_ints ();
674
+
test_floats ();
675
+
test_enum_and_binary_string ();
676
+
test_arrays ();
677
+
test_objects ();
678
+
test_unknown_mems ();
679
+
test_cases ();
680
+
test_rec ();
681
+
test_zero ();
682
+
test_const ();
683
+
test_array_queries ();
684
+
test_object_queries ();
685
+
test_path_queries ();
686
+
()
+431
test/test_common_samples.ml
+431
test/test_common_samples.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module String_map = Map.Make (String)
7
+
8
+
(* Items to do. *)
9
+
10
+
module Status = struct
11
+
type t = Todo | Done | Cancelled
12
+
13
+
let assoc = [ ("todo", Todo); ("done", Done); ("cancelled", Cancelled) ]
14
+
let jsont = Jsont.enum ~kind:"Status" assoc
15
+
end
16
+
17
+
module Item = struct
18
+
type t = { task : string; status : Status.t; tags : string list }
19
+
20
+
let make task status tags = { task; status; tags }
21
+
let task i = i.task
22
+
let status i = i.status
23
+
let tags i = i.tags
24
+
25
+
let jsont =
26
+
Jsont.Object.map ~kind:"Item" make
27
+
|> Jsont.Object.mem "task" Jsont.string ~enc:task
28
+
|> Jsont.Object.mem "status" Status.jsont ~enc:status
29
+
|> Jsont.Object.mem "tags"
30
+
Jsont.(list string)
31
+
~dec_absent:[] ~enc:tags ~enc_omit:(( = ) [])
32
+
|> Jsont.Object.finish
33
+
end
34
+
35
+
module Item_data = struct
36
+
let i0 = Item.{ task = "Hey"; status = Todo; tags = [ "huhu"; "haha" ] }
37
+
38
+
let i0_json =
39
+
(* in Jsont.Indent format *)
40
+
"{\n\
41
+
\ \"task\": \"Hey\",\n\
42
+
\ \"status\": \"todo\",\n\
43
+
\ \"tags\": [\n\
44
+
\ \"huhu\",\n\
45
+
\ \"haha\"\n\
46
+
\ ]\n\
47
+
}"
48
+
49
+
let i1 = Item.{ task = "Ho"; status = Done; tags = [] }
50
+
51
+
let i1_json =
52
+
(* in Jsont.Indent format *)
53
+
"{\n \"task\": \"Ho\",\n \"status\": \"done\"\n}"
54
+
end
55
+
56
+
(* JSON types to excerice the different unknown member behaviours. *)
57
+
58
+
module Unknown = struct
59
+
type t = { m : bool }
60
+
61
+
let make m = { m }
62
+
let m v = v.m
63
+
64
+
let skip_jsont =
65
+
Jsont.Object.map ~kind:"unknown-skip" make
66
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
67
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
68
+
69
+
let error_jsont =
70
+
Jsont.Object.map ~kind:"unknown-skip" make
71
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
72
+
|> Jsont.Object.error_unknown |> Jsont.Object.finish
73
+
74
+
let keep_jsont : (t * int String_map.t) Jsont.t =
75
+
let unknown = Jsont.Object.Mems.string_map Jsont.int in
76
+
Jsont.Object.map ~kind:"unknown-keep" (fun m imap -> (make m, imap))
77
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:(fun (v, _) -> m v)
78
+
|> Jsont.Object.keep_unknown unknown ~enc:snd
79
+
|> Jsont.Object.finish
80
+
end
81
+
82
+
module Unknown_data = struct
83
+
let u0 = {| { "m": true } |}
84
+
let u1 = {| { "m": true, "u0": 0, "u1": 1 } |}
85
+
let u2 = {| { "u": 0, "m": true } |}
86
+
end
87
+
88
+
(* Object cases *)
89
+
90
+
module Cases = struct
91
+
(* There are two ways to encode object cases in OCaml, either as a toplevel
92
+
variant or as a record with a field that is a variant. With the design
93
+
we have the encoding is mostly the same. This is the JSON we deal with:
94
+
95
+
{ "type": "author",
96
+
"name": "…",
97
+
"pseudo": "…",
98
+
"book_count": 1 }
99
+
100
+
{ "type": "editor",
101
+
"name": "…",
102
+
"publisher": "…" } *)
103
+
104
+
module Person_top = struct
105
+
(* Toplevel variant *)
106
+
module Author = struct
107
+
type t = { name : string; pseudo : string; book_count : int }
108
+
109
+
let make name book_count pseudo = { name; pseudo; book_count }
110
+
let name a = a.name
111
+
let book_count a = a.book_count
112
+
let pseudo a = a.pseudo
113
+
114
+
let jsont =
115
+
Jsont.Object.map ~kind:"Author" make
116
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
117
+
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
118
+
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
119
+
|> Jsont.Object.finish
120
+
end
121
+
122
+
module Editor = struct
123
+
type t = { name : string; publisher : string }
124
+
125
+
let make name publisher = { name; publisher }
126
+
let name e = e.name
127
+
let publisher e = e.publisher
128
+
129
+
let jsont =
130
+
Jsont.Object.map ~kind:"Editor" make
131
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
132
+
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
133
+
|> Jsont.Object.finish
134
+
end
135
+
136
+
type t = Author of Author.t | Editor of Editor.t
137
+
138
+
let author a = Author a
139
+
let editor e = Editor e
140
+
141
+
let jsont =
142
+
let case_a = Jsont.Object.Case.map "author" Author.jsont ~dec:author in
143
+
let case_e = Jsont.Object.Case.map "editor" Editor.jsont ~dec:editor in
144
+
let cases = Jsont.Object.Case.[ make case_a; make case_e ] in
145
+
let enc_case = function
146
+
| Author a -> Jsont.Object.Case.value case_a a
147
+
| Editor e -> Jsont.Object.Case.value case_e e
148
+
in
149
+
Jsont.Object.map ~kind:"Person" Fun.id
150
+
|> Jsont.Object.case_mem "type" Jsont.string ~tag_to_string:Fun.id
151
+
~enc:Fun.id ~enc_case cases
152
+
|> Jsont.Object.finish
153
+
end
154
+
155
+
module Person_field = struct
156
+
(* Variant in a field *)
157
+
type author = { pseudo : string; book_count : int }
158
+
159
+
let make_author pseudo book_count = { pseudo; book_count }
160
+
let pseudo a = a.pseudo
161
+
let book_count a = a.book_count
162
+
163
+
let author_jsont =
164
+
Jsont.Object.map ~kind:"Author" make_author
165
+
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
166
+
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
167
+
|> Jsont.Object.finish
168
+
169
+
type editor = { publisher : string }
170
+
171
+
let make_editor publisher = { publisher }
172
+
let publisher e = e.publisher
173
+
174
+
let editor_jsont =
175
+
Jsont.Object.map ~kind:"Editor" make_editor
176
+
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
177
+
|> Jsont.Object.finish
178
+
179
+
type type' = Author of author | Editor of editor
180
+
181
+
let author a = Author a
182
+
let editor e = Editor e
183
+
184
+
type t = { type' : type'; name : string }
185
+
186
+
let make type' name = { type'; name }
187
+
let type' v = v.type'
188
+
let name v = v.name
189
+
190
+
let jsont =
191
+
let case_a = Jsont.Object.Case.map "author" author_jsont ~dec:author in
192
+
let case_e = Jsont.Object.Case.map "editor" editor_jsont ~dec:editor in
193
+
let cases = Jsont.Object.Case.[ make case_a; make case_e ] in
194
+
let enc_case = function
195
+
| Author a -> Jsont.Object.Case.value case_a a
196
+
| Editor e -> Jsont.Object.Case.value case_e e
197
+
in
198
+
Jsont.Object.map ~kind:"Person" make
199
+
|> Jsont.Object.case_mem "type" ~tag_to_string:Fun.id Jsont.string
200
+
~enc:type' ~enc_case cases
201
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
202
+
|> Jsont.Object.finish
203
+
end
204
+
205
+
module Keep_unknown = struct
206
+
type a = string String_map.t
207
+
208
+
let a_jsont =
209
+
let unknown = Jsont.Object.Mems.string_map Jsont.string in
210
+
Jsont.Object.map ~kind:"A" Fun.id
211
+
|> Jsont.Object.keep_unknown unknown ~enc:Fun.id
212
+
|> Jsont.Object.finish
213
+
214
+
type b = { name : string }
215
+
216
+
let name b = b.name
217
+
218
+
let b_jsont =
219
+
Jsont.Object.map ~kind:"B" (fun name -> { name })
220
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
221
+
|> Jsont.Object.error_unknown |> Jsont.Object.finish
222
+
223
+
type type' = A of a | B of b
224
+
225
+
let a a = A a
226
+
let b b = B b
227
+
228
+
type t = { type' : type'; unknown : Jsont.json }
229
+
230
+
let make type' unknown = { type'; unknown }
231
+
let type' v = v.type'
232
+
let unknown v = v.unknown
233
+
234
+
let equal v0 v1 =
235
+
match (v0.type', v1.type') with
236
+
| A a0, A a1 ->
237
+
String_map.equal String.equal a0 a1
238
+
&& Jsont.Json.equal v0.unknown v1.unknown
239
+
| B b0, B b1 ->
240
+
String.equal b0.name b1.name && Jsont.Json.equal v0.unknown v1.unknown
241
+
| _, _ -> false
242
+
243
+
let pp ppf v = B0_std.Fmt.string ppf "<value>"
244
+
245
+
let jsont =
246
+
let case_a = Jsont.Object.Case.map "A" a_jsont ~dec:a in
247
+
let case_b = Jsont.Object.Case.map "B" b_jsont ~dec:b in
248
+
let cases = Jsont.Object.Case.[ make case_a; make case_b ] in
249
+
let enc_case = function
250
+
| A a -> Jsont.Object.Case.value case_a a
251
+
| B b -> Jsont.Object.Case.value case_b b
252
+
in
253
+
Jsont.Object.map ~kind:"Keep_unknown" make
254
+
|> Jsont.Object.case_mem "type" ~tag_to_string:Fun.id Jsont.string
255
+
~enc:type' ~enc_case cases
256
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
257
+
|> Jsont.Object.finish
258
+
end
259
+
end
260
+
261
+
module Cases_data = struct
262
+
let author0_top, author0_field =
263
+
let name = "Jane" and book_count = 2 and pseudo = "Jude" in
264
+
( Cases.Person_top.Author { name; book_count; pseudo },
265
+
{ Cases.Person_field.type' = Author { book_count; pseudo }; name } )
266
+
267
+
let invalid_miss =
268
+
(* Missing type field. *)
269
+
{| { "name": "Jane", "tope": "ha", "tape": "ha",
270
+
"book_count": 2, "pseudo": "Jude" }|}
271
+
272
+
let invalid_case = {| { "type": "reader", "name": "Jane" }|}
273
+
274
+
let author0 =
275
+
{| { "type": "author", "name": "Jane", "book_count": 2, "pseudo": "Jude" }|}
276
+
277
+
let author0' =
278
+
(* out of order case field in the middle *)
279
+
{| { "name": "Jane", "book_count": 2, "type": "author", "pseudo": "Jude" }|}
280
+
281
+
let editor0_top, editor0_field =
282
+
let name = "Joe" and publisher = "Red books" in
283
+
( Cases.Person_top.Editor { name; publisher },
284
+
{ Cases.Person_field.type' = Editor { publisher }; name } )
285
+
286
+
let editor0 =
287
+
{| { "type": "editor", "name": "Joe", "publisher": "Red books" } |}
288
+
289
+
let editor0' =
290
+
(* out of order case field at the end *)
291
+
{| { "name": "Joe", "publisher": "Red books", "type": "editor" } |}
292
+
293
+
let unknown_a = {| { "m1": "n", "type": "A", "m0": "o" } |}
294
+
let unknown_b = {| { "type": "B", "m1": "v1", "name": "ha", "m2": 0 } |}
295
+
296
+
let unknown_a_value =
297
+
let unknown =
298
+
Jsont.Json.(
299
+
object' [ mem (name "m0") (string "o"); mem (name "m1") (string "n") ])
300
+
in
301
+
Cases.Keep_unknown.make (A String_map.empty) unknown
302
+
303
+
let unknown_a_a_value =
304
+
String_map.empty |> String_map.add "m0" "o" |> String_map.add "m1" "n"
305
+
|> String_map.add "type" "A"
306
+
307
+
let unknown_a_no_a_unknown = "{\n \"type\": \"A\"\n}"
308
+
309
+
let unknown_a_no_a_unknown_value =
310
+
(* Since the map should be ignored since the case object overides it *)
311
+
let unknown = Jsont.Json.object' [] in
312
+
Cases.Keep_unknown.make (A String_map.(empty |> add "bli" "bla")) unknown
313
+
314
+
let unknown_b_value =
315
+
let unknown =
316
+
Jsont.Json.(
317
+
object' [ mem (name "m1") (string "v1"); mem (name "m2") (number 0.0) ])
318
+
in
319
+
Cases.Keep_unknown.make (B { name = "ha" }) unknown
320
+
end
321
+
322
+
(* Type recursion *)
323
+
324
+
module Tree = struct
325
+
type 'a tree = Empty | Node of 'a tree * 'a * 'a tree
326
+
327
+
let rec pp pp_v ppf = function
328
+
| Empty -> Format.fprintf ppf "Empty"
329
+
| Node (l, v, r) ->
330
+
Format.fprintf ppf "@[Node @[<1>(%a,@ %a,@ %a)@]@]" (pp pp_v) l pp_v v
331
+
(pp pp_v) r
332
+
333
+
(* Encoded with null for Empty and nodes with:
334
+
335
+
{ "left": …,
336
+
"value": …,
337
+
"right": … }
338
+
339
+
and null is used for empty. *)
340
+
let jsont_with_null t =
341
+
let rec tree =
342
+
lazy begin
343
+
let empty = Jsont.null Empty in
344
+
let node =
345
+
let not_a_node () = failwith "not a node" in
346
+
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
347
+
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
348
+
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
349
+
Jsont.Object.map ~kind:"node" (fun l v r -> Node (l, v, r))
350
+
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
351
+
|> Jsont.Object.mem ~enc:value "value" t
352
+
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
353
+
|> Jsont.Object.finish
354
+
in
355
+
let enc = function Empty -> empty | Node _ -> node in
356
+
Jsont.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc ()
357
+
end
358
+
in
359
+
Lazy.force tree
360
+
361
+
(* Encoded as two cases :
362
+
363
+
{ "type": "empty" }
364
+
365
+
{ "type": "node",
366
+
"left": …,
367
+
"value": …,
368
+
"right": … } *)
369
+
370
+
let jsont_with_cases t =
371
+
let rec tree =
372
+
lazy begin
373
+
let leaf_jsont = Jsont.Object.map Empty |> Jsont.Object.finish in
374
+
let node_jsont =
375
+
let not_a_node () = failwith "not a node" in
376
+
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
377
+
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
378
+
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
379
+
Jsont.Object.map (fun l v r -> Node (l, v, r))
380
+
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
381
+
|> Jsont.Object.mem ~enc:value "value" t
382
+
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
383
+
|> Jsont.Object.finish
384
+
in
385
+
let case_leaf = Jsont.Object.Case.map "empty" leaf_jsont ~dec:Fun.id in
386
+
let case_node = Jsont.Object.Case.map "node" node_jsont ~dec:Fun.id in
387
+
let enc_case = function
388
+
| Empty as v -> Jsont.Object.Case.value case_leaf v
389
+
| Node _ as v -> Jsont.Object.Case.value case_node v
390
+
in
391
+
let cases = Jsont.Object.Case.[ make case_leaf; make case_node ] in
392
+
Jsont.Object.map ~kind:"tree" Fun.id
393
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
394
+
|> Jsont.Object.finish
395
+
end
396
+
in
397
+
Lazy.force tree
398
+
end
399
+
400
+
module Tree_data = struct
401
+
let empty = Tree.Empty
402
+
let empty_null = {| null |}
403
+
let empty_cases = {| { "type": "empty" } |}
404
+
405
+
let tree0 =
406
+
Tree.Node
407
+
(Node (Node (Empty, 1, Empty), 2, Empty), 3, Node (Empty, 4, Empty))
408
+
409
+
let tree0_null =
410
+
{| { "left": { "left": { "left": null, "value": 1, "right": null },
411
+
"value": 2,
412
+
"right": null },
413
+
"value": 3,
414
+
"right": { "left": null, "value": 4, "right": null } } |}
415
+
416
+
let tree0_cases =
417
+
(* Case member not in order to check decode delays. *)
418
+
{| { "left": { "type": "node",
419
+
"left": { "type": "node",
420
+
"left": { "type": "empty" },
421
+
"right": { "type": "empty" },
422
+
"value": 1 },
423
+
"value": 2,
424
+
"right": { "type" : "empty" }},
425
+
"value": 3,
426
+
"type": "node",
427
+
"right": { "type": "node",
428
+
"left": { "type" : "empty" },
429
+
"value": 4,
430
+
"right": { "type" : "empty" }}} |}
431
+
end
+34
test/test_json.ml
+34
test/test_json.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open B0_std
7
+
open B0_testing
8
+
9
+
(* Tests the common test suite with the Jsont.Json codec. *)
10
+
11
+
(* Since the Jsont.Json codec works only on Jsont.json values we use
12
+
Jsont_bytesrw to codec JSON to Jsont.json values and then apply the
13
+
Jsont.Json codec. So the tests rely on a working Jsont_bytesrw
14
+
codec *)
15
+
16
+
let decode ?layout t json =
17
+
match Jsont_bytesrw.decode_string ?layout ~locs:true Jsont.json json with
18
+
| Error _ as e -> e
19
+
| Ok json -> Jsont.Json.decode t json
20
+
21
+
let encode ?format t v =
22
+
match Jsont.Json.encode t v with
23
+
| Error _ as e -> e
24
+
| Ok json -> Jsont_bytesrw.encode_string ?format Jsont.json json
25
+
26
+
let test_funs = { Test_common.supports_layout = true; decode; encode }
27
+
28
+
let main () =
29
+
Test.main @@ fun () ->
30
+
Test_common.test_funs := test_funs;
31
+
Test_common.tests ();
32
+
()
33
+
34
+
let () = if !Sys.interactive then () else exit (main ())
+82
test/test_jsont_tool.ml
+82
test/test_jsont_tool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open B0_std
7
+
open Result.Syntax
8
+
open B0_testing
9
+
10
+
let args = Test.Arg.make ()
11
+
let src_in ~cwd src = Fpath.drop_strict_prefix ~prefix:cwd src |> Option.get
12
+
13
+
let snap_stdout ~cwd cmd ~ext src =
14
+
let cmd = Cmd.(cmd %% path (src_in ~cwd src)) in
15
+
Snap.stdout ~cwd ~trim:false cmd !@Fpath.(src -+ ext) ~__POS__
16
+
17
+
let test_textlocs =
18
+
Test.test' args "locs" @@ fun (finit, cwd, (_i, valid_srcs)) ->
19
+
let cmd = Cmd.(finit % "locs") and ext = ".locs" in
20
+
List.iter (snap_stdout ~cwd cmd ~ext) valid_srcs;
21
+
()
22
+
23
+
let test_pretty =
24
+
Test.test' args "fmt -fpretty" @@ fun (finit, cwd, (_i, valid_srcs)) ->
25
+
let cmd = Cmd.(finit % "fmt" % "-fpretty") and ext = ".pretty.json" in
26
+
List.iter (snap_stdout ~cwd cmd ~ext) valid_srcs;
27
+
()
28
+
29
+
let test_indent =
30
+
Test.test' args "fmt -findent" @@ fun (finit, cwd, (_i, valid_srcs)) ->
31
+
let cmd = Cmd.(finit % "fmt" % "-findent") and ext = ".indent.json" in
32
+
List.iter (snap_stdout ~cwd cmd ~ext) valid_srcs;
33
+
()
34
+
35
+
let test_minify =
36
+
Test.test' args "fmt -fminify" @@ fun (finit, cwd, (_i, valid_srcs)) ->
37
+
let cmd = Cmd.(finit % "fmt" % "-fminify") and ext = ".minify.json" in
38
+
List.iter (snap_stdout ~cwd cmd ~ext) valid_srcs;
39
+
()
40
+
41
+
let test_preserve =
42
+
Test.test' args "fmt -fpreserve" @@ fun (finit, cwd, (_i, valid_srcs)) ->
43
+
let cmd = Cmd.(finit % "fmt" % "-fpreserve") and ext = ".layout.json" in
44
+
List.iter (snap_stdout ~cwd cmd ~ext) valid_srcs;
45
+
()
46
+
47
+
let test_invalid =
48
+
Test.test' args "fmt invalid JSON" @@ fun (finit, cwd, (invalid_srcs, _v)) ->
49
+
let snap src =
50
+
let cmd = Cmd.(finit % "fmt" %% path (src_in ~cwd src)) in
51
+
Snap.run ~cwd cmd !@Fpath.(src -+ ".run") ~__POS__
52
+
in
53
+
List.iter snap invalid_srcs
54
+
55
+
(* Try to streamline that in B0_testing *)
56
+
57
+
let get_jsont_cmd () =
58
+
let var = "B0_TESTING_JSONT" in
59
+
match Os.Env.var ~empty_is_none:true var with
60
+
| None -> Fmt.error "%s unspecified, needs to point to jsont executable" var
61
+
| Some cmd -> Ok (Cmd.tool cmd)
62
+
63
+
let get_srcs dir =
64
+
let* files =
65
+
let dotfiles = false and follow_symlinks = true and recurse = true in
66
+
Os.Dir.contents ~kind:`Files ~dotfiles ~follow_symlinks ~recurse dir
67
+
in
68
+
let is_json f = Fpath.take_ext ~multi:true f = ".json" in
69
+
let is_invalid f = String.starts_with ~prefix:"invalid" (Fpath.basename f) in
70
+
Ok (List.partition is_invalid (List.filter is_json files))
71
+
72
+
let main () =
73
+
Test.main @@ fun () ->
74
+
Test.error_to_failstop
75
+
@@
76
+
let* cmd = get_jsont_cmd () in
77
+
let snapshot_dir = Fpath.(Test.dir () / "snapshots") in
78
+
let* srcs = get_srcs snapshot_dir in
79
+
let args = Test.Arg.[ value args (cmd, snapshot_dir, srcs) ] in
80
+
Ok (Test.autorun ~args ())
81
+
82
+
let () = if !Sys.interactive then () else exit (main ())
+70
test/test_seriot_suite.ml
+70
test/test_seriot_suite.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Runs the codec on https://github.com/nst/JSONTestSuite *)
7
+
8
+
open B0_std
9
+
open B0_testing
10
+
open Result.Syntax
11
+
12
+
let status_of_filename name =
13
+
if String.starts_with ~prefix:"y_" name then `Accept
14
+
else if String.starts_with ~prefix:"n_" name then `Reject
15
+
else if String.starts_with ~prefix:"i_" name then `Indeterminate
16
+
else Test.failstop "Unknown kind of test: %s" name
17
+
18
+
let args = Test.Arg.make ()
19
+
20
+
let test_file ~show_errors file =
21
+
Test.error_to_fail
22
+
@@
23
+
let* json = Os.File.read file in
24
+
let name = Fpath.basename file in
25
+
let status = status_of_filename name in
26
+
let file = Fpath.to_string file in
27
+
match Jsont_bytesrw.decode_string ~file ~locs:true Jsont.json json with
28
+
| Ok _ ->
29
+
if status = `Accept || status = `Indeterminate then Ok (Test.pass ())
30
+
else Fmt.error "@[<v>Test %s@,Should have been rejected:@,%s@]" name json
31
+
| Error e ->
32
+
if show_errors then Test.Log.msg "@[<v>Test %s@,%s@]" name e;
33
+
if status = `Reject || status = `Indeterminate then Ok (Test.pass ())
34
+
else Fmt.error "@[<v>Test %s@,Should have been accepted:@,%s@]" name json
35
+
36
+
let test =
37
+
Test.test' args "test_parsing tests" @@ fun (show_errors, test_files) ->
38
+
Test.block ~kind:"test file" @@ fun () ->
39
+
List.iter (test_file ~show_errors) test_files
40
+
41
+
let get_test_files dir =
42
+
let* exists = Os.Dir.exists dir in
43
+
if not exists then
44
+
Fmt.error "@[%a @[<v>JSONTestSuite not found@,Use %a to download it@]@]"
45
+
Test.Fmt.skip () Fmt.code "b0 -- download-seriot-suite"
46
+
else
47
+
let dir = Fpath.(dir / "test_parsing") in
48
+
let dotfiles = false and follow_symlinks = true and recurse = false in
49
+
Os.Dir.contents ~kind:`Files ~dotfiles ~follow_symlinks ~recurse dir
50
+
51
+
open Cmdliner
52
+
open Cmdliner.Term.Syntax
53
+
54
+
let main () =
55
+
Test.main'
56
+
@@
57
+
let+ show_errors =
58
+
let doc = "Show errors" in
59
+
Arg.(value & flag & info [ "e"; "show-errors" ] ~doc)
60
+
and+ dir =
61
+
let doc = "Repository directory of the test suite." in
62
+
let default = Fpath.v "../tmp/JSONTestSuite" in
63
+
Arg.(value & opt B0_std_cli.dirpath default & info [ "repo-dir" ] ~doc)
64
+
in
65
+
fun () ->
66
+
let dir = Fpath.(Test.dir () // dir) in
67
+
let files = get_test_files dir |> Test.error_to_failstop in
68
+
Test.autorun ~args:Test.Arg.[ value args (show_errors, files) ] ()
69
+
70
+
let () = if !Sys.interactive then () else exit (main ())
+327
test/topojson.ml
+327
test/topojson.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Topojson codec https://github.com/topojson/topojson-specification *)
7
+
8
+
module String_map = Map.Make (String)
9
+
10
+
module Position = struct
11
+
type t = float array
12
+
13
+
let jsont = Jsont.(array ~kind:"Position" number)
14
+
end
15
+
16
+
module Bbox = struct
17
+
type t = float array
18
+
19
+
let jsont = Jsont.(array ~kind:"Bbox" number)
20
+
end
21
+
22
+
module Arcs = struct
23
+
type t = Position.t array array
24
+
25
+
let jsont = Jsont.(array ~kind:"Arcs" (array Position.jsont))
26
+
end
27
+
28
+
module Transform = struct
29
+
type v2 = float * float
30
+
type t = { scale : v2; translate : v2 }
31
+
32
+
let make scale translate = { scale; translate }
33
+
let scale t = t.scale
34
+
let translate t = t.translate
35
+
36
+
let v2_jsont =
37
+
let dec x y = (x, y) in
38
+
let enc (x, y) i = if i = 0 then x else y in
39
+
Jsont.t2 ~dec ~enc Jsont.number
40
+
41
+
let jsont =
42
+
Jsont.Object.map ~kind:"Transform" make
43
+
|> Jsont.Object.mem "scale" v2_jsont ~enc:scale
44
+
|> Jsont.Object.mem "translate" v2_jsont ~enc:translate
45
+
|> Jsont.Object.finish
46
+
end
47
+
48
+
module Point = struct
49
+
type t = { coordinates : Position.t }
50
+
51
+
let make coordinates = { coordinates }
52
+
let coordinates v = v.coordinates
53
+
54
+
let jsont =
55
+
Jsont.Object.map ~kind:"Point" make
56
+
|> Jsont.Object.mem "coordinates" Position.jsont ~enc:coordinates
57
+
|> Jsont.Object.finish
58
+
end
59
+
60
+
module Multi_point = struct
61
+
type t = { coordinates : Position.t list }
62
+
63
+
let make coordinates = { coordinates }
64
+
let coordinates v = v.coordinates
65
+
66
+
let jsont =
67
+
Jsont.Object.map ~kind:"MultiPoint" make
68
+
|> Jsont.Object.mem "coordinates"
69
+
(Jsont.list Position.jsont)
70
+
~enc:coordinates
71
+
|> Jsont.Object.finish
72
+
end
73
+
74
+
module Line_string = struct
75
+
type t = { arcs : int32 list }
76
+
77
+
let make arcs = { arcs }
78
+
let arcs v = v.arcs
79
+
80
+
let jsont =
81
+
Jsont.Object.map ~kind:"LineString" make
82
+
|> Jsont.Object.mem "arcs" Jsont.(list int32) ~enc:arcs
83
+
|> Jsont.Object.finish
84
+
end
85
+
86
+
module Multi_line_string = struct
87
+
type t = { arcs : int32 list list }
88
+
89
+
let make arcs = { arcs }
90
+
let arcs v = v.arcs
91
+
92
+
let jsont =
93
+
Jsont.Object.map ~kind:"MultiLineString" make
94
+
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
95
+
|> Jsont.Object.finish
96
+
end
97
+
98
+
module Polygon = struct
99
+
type t = { arcs : int32 list list }
100
+
101
+
let make arcs = { arcs }
102
+
let arcs v = v.arcs
103
+
104
+
let jsont =
105
+
Jsont.Object.map ~kind:"Polygon" make
106
+
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
107
+
|> Jsont.Object.finish
108
+
end
109
+
110
+
module Multi_polygon = struct
111
+
type t = { arcs : int32 list list list }
112
+
113
+
let make arcs = { arcs }
114
+
let arcs v = v.arcs
115
+
116
+
let jsont =
117
+
Jsont.Object.map ~kind:"MultiPolygon" make
118
+
|> Jsont.Object.mem "arcs" Jsont.(list (list (list int32))) ~enc:arcs
119
+
|> Jsont.Object.finish
120
+
end
121
+
122
+
module Geometry = struct
123
+
type id = [ `Number of float | `String of string ]
124
+
125
+
let id_jsont =
126
+
let number =
127
+
let dec = Jsont.Base.dec (fun n -> `Number n) in
128
+
let enc =
129
+
Jsont.Base.enc (function `Number n -> n | _ -> assert false)
130
+
in
131
+
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
132
+
in
133
+
let string =
134
+
let dec = Jsont.Base.dec (fun n -> `String n) in
135
+
let enc =
136
+
Jsont.Base.enc (function `String n -> n | _ -> assert false)
137
+
in
138
+
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
139
+
in
140
+
let enc = function `Number _ -> number | `String _ -> string in
141
+
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
142
+
143
+
type t = {
144
+
type' : type';
145
+
id : id option;
146
+
properties : Jsont.json String_map.t option;
147
+
bbox : Bbox.t option;
148
+
unknown : Jsont.json;
149
+
}
150
+
151
+
and type' =
152
+
| Point of Point.t
153
+
| Multi_point of Multi_point.t
154
+
| Line_string of Line_string.t
155
+
| Multi_line_string of Multi_line_string.t
156
+
| Polygon of Polygon.t
157
+
| Multi_polygon of Multi_polygon.t
158
+
| Geometry_collection of t list
159
+
160
+
let make type' id properties bbox unknown =
161
+
{ type'; id; properties; bbox; unknown }
162
+
163
+
let type' g = g.type'
164
+
let id g = g.id
165
+
let properties g = g.properties
166
+
let bbox g = g.bbox
167
+
let unknown g = g.unknown
168
+
let point v = Point v
169
+
let multi_point v = Multi_point v
170
+
let line_string v = Line_string v
171
+
let multi_linestr v = Multi_line_string v
172
+
let polygon v = Polygon v
173
+
let multi_polygon v = Multi_polygon v
174
+
let collection vs = Geometry_collection vs
175
+
let properties_type = Jsont.Object.as_string_map ~kind:"properties" Jsont.json
176
+
177
+
let rec collection_jsont =
178
+
lazy begin
179
+
Jsont.Object.map ~kind:"GeometryCollection" Fun.id
180
+
|> Jsont.Object.mem "geometries"
181
+
(Jsont.list (Jsont.rec' jsont))
182
+
~enc:Fun.id
183
+
|> Jsont.Object.finish
184
+
end
185
+
186
+
and jsont =
187
+
lazy begin
188
+
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec in
189
+
let case_point = case_map Point.jsont point in
190
+
let case_multi_point = case_map Multi_point.jsont multi_point in
191
+
let case_line_string = case_map Line_string.jsont line_string in
192
+
let case_multi_linestr = case_map Multi_line_string.jsont multi_linestr in
193
+
let case_polygon = case_map Polygon.jsont polygon in
194
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
195
+
let case_coll = case_map (Lazy.force collection_jsont) collection in
196
+
let enc_case = function
197
+
| Point p -> Jsont.Object.Case.value case_point p
198
+
| Multi_point m -> Jsont.Object.Case.value case_multi_point m
199
+
| Line_string l -> Jsont.Object.Case.value case_line_string l
200
+
| Multi_line_string m -> Jsont.Object.Case.value case_multi_linestr m
201
+
| Polygon p -> Jsont.Object.Case.value case_polygon p
202
+
| Multi_polygon m -> Jsont.Object.Case.value case_multi_polygon m
203
+
| Geometry_collection gs -> Jsont.Object.Case.value case_coll gs
204
+
and cases =
205
+
Jsont.Object.Case.
206
+
[
207
+
make case_point;
208
+
make case_multi_point;
209
+
make case_line_string;
210
+
make case_multi_linestr;
211
+
make case_polygon;
212
+
make case_multi_polygon;
213
+
make case_coll;
214
+
]
215
+
in
216
+
Jsont.Object.map ~kind:"Geometry" make
217
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
218
+
~tag_to_string:Fun.id ~tag_compare:String.compare
219
+
|> Jsont.Object.opt_mem "id" id_jsont ~enc:id
220
+
|> Jsont.Object.opt_mem "properties" properties_type ~enc:properties
221
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
222
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
223
+
|> Jsont.Object.finish
224
+
end
225
+
226
+
let jsont = Lazy.force jsont
227
+
228
+
type objects = t String_map.t
229
+
230
+
let objects_jsont = Jsont.Object.as_string_map ~kind:"objects map" jsont
231
+
end
232
+
233
+
module Topology = struct
234
+
type t = {
235
+
objects : Geometry.objects;
236
+
arcs : Arcs.t;
237
+
transform : Transform.t option;
238
+
bbox : Bbox.t option;
239
+
unknown : Jsont.json;
240
+
}
241
+
242
+
let make objects arcs transform bbox unknown =
243
+
{ objects; arcs; transform; bbox; unknown }
244
+
245
+
let objects t = t.objects
246
+
let arcs t = t.arcs
247
+
let transform t = t.transform
248
+
let bbox t = t.bbox
249
+
let unknown t = t.unknown
250
+
251
+
let jsont =
252
+
let kind = "Topology" in
253
+
Jsont.Object.map ~kind (fun () -> make)
254
+
|> Jsont.Object.mem "type" (Jsont.enum [ (kind, ()) ]) ~enc:(Fun.const ())
255
+
|> Jsont.Object.mem "objects" Geometry.objects_jsont ~enc:objects
256
+
|> Jsont.Object.mem "arcs" Arcs.jsont ~enc:arcs
257
+
|> Jsont.Object.opt_mem "transform" Transform.jsont ~enc:transform
258
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
259
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
260
+
|> Jsont.Object.finish
261
+
end
262
+
263
+
(* Command line interface *)
264
+
265
+
let ( let* ) = Result.bind
266
+
let strf = Printf.sprintf
267
+
268
+
let log_if_error ~use = function
269
+
| Ok v -> v
270
+
| Error e ->
271
+
let lines = String.split_on_char '\n' e in
272
+
Format.eprintf "@[%a @[<v>%a@]@]@." Jsont.Error.puterr ()
273
+
(Format.pp_print_list Format.pp_print_string)
274
+
lines;
275
+
use
276
+
277
+
let with_infile file f =
278
+
(* XXX add something to bytesrw. *)
279
+
let process file ic =
280
+
try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic))
281
+
with Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
282
+
in
283
+
try
284
+
match file with
285
+
| "-" -> process file In_channel.stdin
286
+
| file -> In_channel.with_open_bin file (process file)
287
+
with Sys_error e -> Error e
288
+
289
+
let trip ~file ~format ~locs ~dec_only =
290
+
log_if_error ~use:1 @@ with_infile file
291
+
@@ fun r ->
292
+
log_if_error ~use:1
293
+
@@
294
+
let* t = Jsont_bytesrw.decode ~file ~locs Topology.jsont r in
295
+
if dec_only then Ok 0
296
+
else
297
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
298
+
let* () = Jsont_bytesrw.encode ~format ~eod:true Topology.jsont t w in
299
+
Ok 0
300
+
301
+
open Cmdliner
302
+
open Cmdliner.Term.Syntax
303
+
304
+
let topojson =
305
+
Cmd.v (Cmd.info "topojson" ~doc:"round trip TopoJSON")
306
+
@@
307
+
let+ file =
308
+
let doc = "$(docv) is the TopoJSON file. Use $(b,-) for stdin." in
309
+
Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
310
+
and+ locs =
311
+
let doc = "Preserve locations (better errors)." in
312
+
Arg.(value & flag & info [ "l"; "locs" ] ~doc)
313
+
and+ format =
314
+
let fmt = [ ("indent", Jsont.Indent); ("minify", Jsont.Minify) ] in
315
+
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt) in
316
+
Arg.(
317
+
value
318
+
& opt (enum fmt) Jsont.Minify
319
+
& info [ "f"; "format" ] ~doc ~docv:"FMT")
320
+
and+ dec_only =
321
+
let doc = "Decode only." in
322
+
Arg.(value & flag & info [ "d" ] ~doc)
323
+
in
324
+
trip ~file ~format ~locs ~dec_only
325
+
326
+
let main () = Cmd.eval' topojson
327
+
let () = if !Sys.interactive then () else exit (main ())
+36
test/trials.ml
+36
test/trials.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Message = struct
7
+
type t = { content : string; public : bool }
8
+
9
+
let make content public = { content; public }
10
+
let content msg = msg.content
11
+
let public msg = msg.public
12
+
13
+
let jsont : t Jsont.t =
14
+
Jsont.Object.map make
15
+
|> Jsont.Object.mem "content" Jsont.string ~enc:content
16
+
|> Jsont.Object.mem "public" Jsont.bool ~enc:public
17
+
|> Jsont.Object.finish
18
+
end
19
+
20
+
type ('ret, 'f) app =
21
+
| Fun : 'f -> ('ret, 'f) app
22
+
| App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app
23
+
24
+
let ret : 'f -> ('ret, 'f) app = fun f -> Fun f
25
+
let app : ('ret, 'a -> 'b) app -> 'a -> ('ret, 'b) app = fun f a -> App (f, a)
26
+
let g ~i ~s = string_of_int i ^ s
27
+
let t0 : (string, string) app = app (app (ret (fun i s -> g ~i ~s)) 2) "bla"
28
+
29
+
(* That works but it's not the tructure that we want. *)
30
+
31
+
let ( let+ ) : 'a -> ('a -> 'b) -> ('ret, 'b) app = fun v f -> App (Fun f, v)
32
+
let ( and+ ) : 'a -> 'b -> 'a * 'b = fun x y -> (x, y)
33
+
34
+
let t1 : (string, string) app =
35
+
let+ i = 2 and+ s = "bla" in
36
+
g ~i ~s