My working unpac space for OCaml projects in development
Merge opam/patches/jsont
+13202
+236
vendor/opam/jsont/B0.ml
+236
vendor/opam/jsont/B0.ml
···
1
+
open B0_kit.V000
2
+
open Result.Syntax
3
+
4
+
(* Library names *)
5
+
6
+
let b0_std = B0_ocaml.libname "b0.std"
7
+
let bytesrw = B0_ocaml.libname "bytesrw"
8
+
let cmdliner = B0_ocaml.libname "cmdliner"
9
+
let brr = B0_ocaml.libname "brr"
10
+
11
+
let jsont = B0_ocaml.libname "jsont"
12
+
let jsont_bytesrw = B0_ocaml.libname "jsont.bytesrw"
13
+
let jsont_brr = B0_ocaml.libname "jsont.brr"
14
+
15
+
(* Libraries *)
16
+
17
+
let jsont_lib =
18
+
let srcs = [ `Dir ~/"src" ] in
19
+
B0_ocaml.lib jsont ~name:"jsont-lib" ~srcs
20
+
21
+
let jsont_bytesrw_lib =
22
+
let srcs = [ `Dir ~/"src/bytesrw" ] in
23
+
let requires = [bytesrw; jsont] in
24
+
B0_ocaml.lib jsont_bytesrw ~srcs ~requires ~exports:requires
25
+
26
+
let jsont_brr_lib =
27
+
let srcs = [ `Dir ~/"src/brr" ] in
28
+
let requires = [brr; jsont] in
29
+
B0_ocaml.lib jsont_brr ~srcs ~requires ~exports:requires
30
+
31
+
(* Tools *)
32
+
33
+
let jsont_tool =
34
+
let srcs = [ `File ~/"test/jsont_tool.ml" ] in
35
+
let requires = [cmdliner; bytesrw; jsont_bytesrw; jsont] in
36
+
B0_ocaml.exe "jsont" ~public:true ~doc:"The jsont tool" ~srcs ~requires
37
+
38
+
(* Tests *)
39
+
40
+
let test ?(requires = []) = B0_ocaml.test ~requires:(jsont :: requires)
41
+
42
+
let quickstart =
43
+
let doc = "Quick start examples" in
44
+
test ~/"test/quickstart.ml" ~run:false ~requires:[jsont_bytesrw] ~doc
45
+
46
+
let cookbook =
47
+
test ~/"test/cookbook.ml" ~run:false ~doc:"Cookbook examples"
48
+
49
+
let trials =
50
+
test ~/"test/trials.ml" ~run:false ~doc:"Experiments"
51
+
52
+
let topojson =
53
+
let doc = "Jsont modelling of TopoJSON" in
54
+
let requires = [cmdliner; bytesrw; jsont_bytesrw] in
55
+
test ~/"test/topojson.ml" ~run:false ~doc ~requires
56
+
57
+
let geojson =
58
+
let doc = "Jsont modelling of GeoJSON" in
59
+
let requires = [cmdliner; bytesrw; jsont_bytesrw] in
60
+
test ~/"test/geojson.ml" ~run:false ~doc ~requires
61
+
62
+
let jsonrpc =
63
+
let doc = "Jsont modelling of JSON-RPC" in
64
+
test ~/"test/json_rpc.ml" ~run:false ~doc
65
+
66
+
let test_common =
67
+
[ `File ~/"test/test_common.ml"; `File ~/"test/test_common_samples.ml" ]
68
+
69
+
let test_bytesrw =
70
+
let doc = "Test Jsont_bytesrw codec" in
71
+
let srcs = test_common in
72
+
let requires = [b0_std; jsont_bytesrw] in
73
+
test ~/"test/test_bytesrw.ml" ~run:true ~srcs ~requires ~doc
74
+
75
+
let test_jsont =
76
+
let doc = "Test Jsont.Json codec" in
77
+
let srcs = test_common in
78
+
let requires = [b0_std; jsont_bytesrw] in
79
+
test ~/"test/test_json.ml" ~run:true ~srcs ~requires ~doc
80
+
81
+
let test_brr =
82
+
let doc = "Test Jsont_brr codec in the browser" in
83
+
let srcs = `File ~/"test/test_brr.ml" :: test_common in
84
+
let requires = [b0_std; brr; jsont; jsont_brr] in
85
+
let meta = B0_meta.(empty |> tag test) in
86
+
B0_jsoo.html_page "test_brr" ~doc ~meta ~srcs ~requires
87
+
88
+
(* Seriot JSON test suite *)
89
+
90
+
let seriot_suite_repo = "https://github.com/nst/JSONTestSuite.git"
91
+
let seriot_suite = ~/"tmp/JSONTestSuite"
92
+
let download_seriot_suite =
93
+
let doc = "Download the Seriot test suite to tmp/" in
94
+
B0_unit.of_action "download-seriot-suite" ~doc @@ fun env _ ~args:_ ->
95
+
let* git = B0_env.get_cmd env (Cmd.tool "git") in
96
+
let suite = B0_env.in_scope_dir env seriot_suite in
97
+
let* created = Os.Dir.create ~make_path:true suite in
98
+
if created
99
+
then Os.Cmd.run Cmd.(git % "clone" % seriot_suite_repo %% path suite)
100
+
else Os.Cmd.run Cmd.(git % "-C" %% path suite % "pull")
101
+
102
+
let test_seriot_suite =
103
+
let doc = "Run the Seriot test suite" in
104
+
let requires = [b0_std; cmdliner; jsont_bytesrw] in
105
+
test ~/"test/test_seriot_suite.ml" ~doc ~requires
106
+
107
+
(* Expectation tests *)
108
+
109
+
let expect =
110
+
let doc = "Test jsont expectations" in
111
+
let meta = B0_meta.(empty |> tag test |> tag run) in
112
+
B0_unit.of_action' "expect" ~meta ~units:[jsont_tool] ~doc @@
113
+
B0_expect.action_func ~base:(Fpath.v "test/expect") @@ fun ctx ->
114
+
let jsont = B0_expect.get_unit_exe_file_cmd ctx jsont_tool in
115
+
let expect_valid_file ctx json file =
116
+
let runs = (* command, output suffix *)
117
+
[ Cmd.(arg "fmt" % "-fpretty"), ".pretty.json";
118
+
Cmd.(arg "fmt" % "-findent"), ".indent.json";
119
+
Cmd.(arg "fmt" % "-fminify"), ".minify.json";
120
+
Cmd.(arg "fmt" % "-fpreserve"), ".layout.json";
121
+
Cmd.(arg "locs"), ".locs" ]
122
+
in
123
+
let test_run ctx jsont file (cmd, ext) =
124
+
let cmd = Cmd.(cmd %% path file) in
125
+
let cwd = B0_expect.base ctx and stdout = Fpath.(file -+ ext) in
126
+
B0_expect.stdout ctx ~cwd ~stdout Cmd.(jsont %% cmd)
127
+
in
128
+
List.iter (test_run ctx json file) runs
129
+
in
130
+
let expect_invalid_file ctx jsont file =
131
+
let cwd = B0_expect.base ctx and stderr = Fpath.(file -+ ".stderr") in
132
+
B0_expect.stderr ctx ~cwd ~stderr Cmd.(jsont % "fmt" %% path file)
133
+
in
134
+
let valid_files, invalid_files =
135
+
let base_files = B0_expect.base_files ctx ~rel:true ~recurse:false in
136
+
let input f = Fpath.get_ext ~multi:true f = ".json" in
137
+
let files = List.filter input base_files in
138
+
let is_valid f =
139
+
not (String.starts_with ~prefix:"invalid" (Fpath.basename f))
140
+
in
141
+
List.partition is_valid files
142
+
in
143
+
List.iter (expect_valid_file ctx jsont) valid_files;
144
+
List.iter (expect_invalid_file ctx jsont) invalid_files;
145
+
()
146
+
147
+
(* Paper *)
148
+
149
+
let paper = B0_meta.Key.make_tag "paper"
150
+
151
+
let soup_code =
152
+
let doc = "Soup paper code and tests" in
153
+
let srcs = [ `File ~/"paper/soup.ml"; `File ~/"paper/soup_test.ml" ] in
154
+
let meta = B0_meta.(empty |> tag test |> tag paper) in
155
+
B0_ocaml.exe "soup-code" ~srcs ~requires:[b0_std] ~meta ~doc
156
+
157
+
let soup =
158
+
let doc = "Soup paper" in
159
+
let base = Fpath.v "soup.tex" in
160
+
let build b =
161
+
let m = B0_build.memo b in
162
+
let pdflatex =
163
+
let vars = ["TEXINPUTS"] in
164
+
B0_memo.tool m (B0_memo.Tool.make ~vars (Fpath.v "pdflatex"))
165
+
in
166
+
let docdir = B0_build.in_scope_dir b ~/"paper" in
167
+
let pdf = B0_build.in_current_dir b (Fpath.(base -+ ".pdf")) in
168
+
let reads = [Fpath.(docdir / "jfp.cls"); Fpath.(docdir // base) ] in
169
+
let writes = [pdf; Fpath.(pdf -+ ".aux"); Fpath.(pdf -+ ".log")] in
170
+
let cwd = B0_build.current_dir b in
171
+
let env =
172
+
Os.Env.(empty |> add "TEXINPUTS" (Fpath.to_string docdir ^ "//:"))
173
+
in
174
+
let run_tex =
175
+
pdflatex Cmd.(arg "-file-line-error" % "-halt-on-error" %
176
+
"-interaction=errorstopmode" %% path base)
177
+
in
178
+
B0_memo.ready_files m reads;
179
+
B0_memo.spawn m ~cwd ~env ~reads ~writes:[] run_tex ~k:(fun _ _ ->
180
+
(* Let's hope it reaches the fix point :-) *)
181
+
B0_memo.spawn m ~cwd ~env ~reads ~writes run_tex);
182
+
Fut.return ()
183
+
in
184
+
let show_pdf e u ~args:_ = (* TODO b0: B0_show_pdf action ? *)
185
+
let pdf = Fpath.(B0_env.unit_dir e u // base -+ ".pdf") in
186
+
let* view = B0_pdf_viewer.find ~search:(B0_env.get_cmd e) () in
187
+
let* () = B0_pdf_viewer.show view pdf in
188
+
Ok Os.Exit.ok
189
+
in
190
+
let meta =
191
+
B0_meta.empty
192
+
|> ~~ B0_unit.Action.key (`Fun ("show-pdf", show_pdf))
193
+
|> B0_meta.tag paper
194
+
in
195
+
B0_unit.make ~meta ~doc "soup" build
196
+
197
+
(* Packs *)
198
+
199
+
let soup_pack =
200
+
B0_pack.make "soup" ~doc:"Soup paper and code" ~locked:true @@
201
+
[ soup; soup_code ]
202
+
203
+
let default =
204
+
let meta =
205
+
B0_meta.empty
206
+
|> ~~ B0_meta.authors ["The jsont programmers"]
207
+
|> ~~ B0_meta.maintainers ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
208
+
|> ~~ B0_meta.homepage "https://erratique.ch/software/jsont"
209
+
|> ~~ B0_meta.online_doc "https://erratique.ch/software/jsont/doc"
210
+
|> ~~ B0_meta.licenses ["ISC"]
211
+
|> ~~ B0_meta.repo "git+https://erratique.ch/repos/jsont.git"
212
+
|> ~~ B0_meta.issues "https://github.com/dbuenzli/jsont/issues"
213
+
|> ~~ B0_meta.description_tags ["json"; "codec"; "org:erratique"; ]
214
+
|> ~~ B0_opam.build
215
+
{|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"
216
+
"--with-cmdliner" "%{cmdliner:installed}%"
217
+
"--with-bytesrw" "%{bytesrw:installed}%"
218
+
"--with-brr" "%{brr:installed}%"]]|}
219
+
|> ~~ B0_opam.depopts
220
+
["cmdliner", "";
221
+
"brr", "";
222
+
"bytesrw", ""]
223
+
|> ~~ B0_opam.conflicts [ "cmdliner", {|< "1.3.0"|};
224
+
"brr", {|< "0.0.6"|}; ]
225
+
|> ~~ B0_opam.depends
226
+
[ "ocaml", {|>= "4.14.0"|};
227
+
"ocamlfind", {|build|};
228
+
"ocamlbuild", {|build|};
229
+
"topkg", {|build & >= "1.1.0"|};
230
+
"b0", {|dev & with-test|};
231
+
]
232
+
|> B0_meta.tag B0_opam.tag
233
+
in
234
+
B0_pack.make "default" ~doc:"The jsont package" ~meta ~locked:true @@
235
+
(* TODO b0: we should have something more convenient *)
236
+
List.filter (Fun.negate (B0_unit.has_tag paper)) (B0_unit.list ())
+1
vendor/opam/jsont/BRZO
+1
vendor/opam/jsont/BRZO
···
1
+
(srcs-x pkg tmp)
+34
vendor/opam/jsont/CHANGES.md
+34
vendor/opam/jsont/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.
+35
vendor/opam/jsont/DEVEL.md
+35
vendor/opam/jsont/DEVEL.md
···
1
+
This project uses (perhaps the development version of) [`b0`] for
2
+
development. Consult [b0 occasionally] for quick hints on how to
3
+
perform common development tasks.
4
+
5
+
[`b0`]: https://erratique.ch/software/b0
6
+
[b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html
7
+
8
+
# Testing
9
+
10
+
b0 test
11
+
12
+
# Testing the codec with Nicolas Seriot's test suite
13
+
14
+
b0 -- download-seriot-suite
15
+
b0 test
16
+
17
+
# Benchmarking
18
+
19
+
## Decode only
20
+
21
+
hyperfine 'json_xs -t none < tmp/parcels.json'
22
+
hyperfine 'jsontrip -dec tmp/parcels.json'
23
+
hyperfine "$(b0 --path -- jsont) fmt -d tmp/parcels.json"
24
+
hyperfine "$(b0 --path -- geojson) -d tmp/parcels.json"
25
+
26
+
## Decode and minify
27
+
28
+
hyperfine 'json_xs -t json < tmp/parcels.json'
29
+
hyperfine 'jq -c . tmp/parcels.json'
30
+
hyperfine 'ydump -std -c tmp/parcels.json'
31
+
hyperfine 'jsontrip tmp/parcels.json'
32
+
hyperfine "$(b0 --path -- jsont) fmt -fminify tmp/parcels.json"
33
+
hyperfine "$(b0 --path -- geojson) tmp/parcels.json"
34
+
35
+
+15
vendor/opam/jsont/LICENSE.md
+15
vendor/opam/jsont/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
vendor/opam/jsont/README.md
+70
vendor/opam/jsont/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/
+163
vendor/opam/jsont/attic/caret.ml
+163
vendor/opam/jsont/attic/caret.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* This syntax/idea does not work well with JSON it worked well with
7
+
s-expressions because of their uniform nature e.g. to insert
8
+
bindings.
9
+
10
+
That would still work on arrays though. Maybe we could add
11
+
something at some point. *)
12
+
13
+
module Path : sig
14
+
15
+
16
+
(** {1:carets Carets} *)
17
+
18
+
(** Carets.
19
+
20
+
A path and a spatial localisation. *)
21
+
module Caret : sig
22
+
23
+
(** {1:caret Carets} *)
24
+
25
+
type path := t
26
+
27
+
type pos =
28
+
| Before (** The void before the data indexed by a path. *)
29
+
| Over (** The data indexed by a path. *)
30
+
| After (** The void after the data indexed by a path. *)
31
+
(** The type for caret positions. *)
32
+
33
+
type t = pos * path
34
+
(** The type for carets. A path and a caret position. *)
35
+
36
+
val of_string : string -> (t, string) result
37
+
(** [of_string s] parses a caret according to
38
+
the {{!path_caret_syntax}caret syntax} .*)
39
+
40
+
val pp : t fmt
41
+
(** [pp] formats carets. *)
42
+
end
43
+
44
+
val over : t -> Caret.t
45
+
(** [over p] is the data at the path [p]. *)
46
+
47
+
val before : t -> Caret.t
48
+
(** [before p] is the void before the path [p]. *)
49
+
50
+
val after : t -> Caret.t
51
+
(** [after p] is the void after the path [p]. *)
52
+
53
+
(** {1:path_caret_syntax Path & caret syntax}
54
+
55
+
Path and carets provide a way for end users to address JSON and
56
+
edit locations.
57
+
58
+
A {e path} is a sequence of member and list indexing
59
+
operations. Applying the path to a JSON value leads to either a
60
+
JSON value or nothing if one of the indices does not exist, or
61
+
an error if ones tries to index a non-indexable value.
62
+
63
+
A {e caret} is a path and a spatial specification for the JSON
64
+
construct found by the path. The caret indicates either the void
65
+
{e before} that JSON construct, the JSON value itself ({e over}) or
66
+
the void {e after} it.
67
+
68
+
Here are a few examples of paths and carets, syntactically the
69
+
charater ['v'] is used to denote the caret's insertion point before or
70
+
after a path. There's no distinction between a path and an over caret.
71
+
72
+
{@json[
73
+
{
74
+
"ocaml": {
75
+
"libs": ["jsont", "brr", "cmdliner"]
76
+
}
77
+
}
78
+
]}
79
+
80
+
{@shell[
81
+
ocaml.libs # value of member "libs" of member "ocaml"
82
+
ocaml.v[libs] # void before the "libs" member
83
+
ocaml.[libs]v # void after "libs" member
84
+
85
+
ocaml.libs.[0] # first element of member "libs" of member "ocaml"
86
+
ocaml.libs.v[0] # void before first element
87
+
ocaml.libs.[0]v # void after first element
88
+
89
+
ocaml.libs.[-1] # last element of member "libs" of member "ocaml"
90
+
ocaml.libs.v[-1] # before last element (if any)
91
+
ocaml.libs.[-1]v # after last element (if any)
92
+
]}
93
+
94
+
More formally a {e path} is a [.] seperated list of indices.
95
+
96
+
An {e index} is written [[i]]. [i] can a zero-based list index
97
+
with negative indices counting from the end of the list ([-1] is
98
+
the last element). Or [i] can be an object member name [n]. If
99
+
there is no ambiguity, the surrounding brackets can be dropped.
100
+
101
+
A {e caret} is a path whose last index brackets can be prefixed or
102
+
suffixed by an insertion point, represented by the character
103
+
['v']. This respectively denote the void before or after the
104
+
JSON construct found by the path.
105
+
106
+
{b Notes.}
107
+
{ul
108
+
{- The syntax has no form of quoting at the moment this
109
+
means key names can't contain, [\[], [\]], or start with a number.}
110
+
{- It would be nice to be able to drop the dots in order
111
+
to be compatible with {{:https://www.rfc-editor.org/rfc/rfc9535}
112
+
JSONPath} syntax.}} *)
113
+
end = struct
114
+
115
+
116
+
(* Carets *)
117
+
118
+
module Caret = struct
119
+
type path = t
120
+
type pos = Before | Over | After
121
+
type t = pos * path
122
+
let pp ppf = function
123
+
| Over, p -> pp ppf p
124
+
| Before, (c :: p)->
125
+
pp ppf p;
126
+
(if p <> [] then Fmt.char ppf '.');
127
+
Fmt.char ppf 'v'; pp_bracketed_index ppf c
128
+
| After, (c :: p) ->
129
+
pp ppf p;
130
+
(if p <> [] then Fmt.char ppf '.');
131
+
pp_bracketed_index ppf c; Fmt.char ppf 'v'
132
+
| _ -> ()
133
+
134
+
(* Parsing *)
135
+
136
+
let of_string s =
137
+
let rec loop p s i max =
138
+
if i > max then Over, p else
139
+
let next = i + 1 in
140
+
match s.[i] with
141
+
| 'v' when next <= max && s.[next] = '[' ->
142
+
let next, p = parse_index p s next max in
143
+
parse_eoi s next max; Before, p
144
+
| c ->
145
+
let next, p = parse_index p s i max in
146
+
if next > max then Over, p else
147
+
if s.[next] = 'v'
148
+
then (parse_eoi s (next + 1) max; After, p) else
149
+
if s.[next] <> '.' then err_unexp_char next s else
150
+
if next + 1 <= max then loop p s (next + 1) max else
151
+
err_unexp_eoi next
152
+
in
153
+
try
154
+
if s = "" then Ok (Over, []) else
155
+
let start = if s.[0] = '.' then 1 else 0 in
156
+
Ok (loop [] s start (String.length s - 1))
157
+
with Failure e -> Error e
158
+
end
159
+
160
+
let over p = Caret.Over, p
161
+
let after p = Caret.After, p
162
+
let before p = Caret.Before, p
163
+
end
+59
vendor/opam/jsont/attic/json_stat.ml
+59
vendor/opam/jsont/attic/json_stat.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* https://json-stat.org/ *)
7
+
8
+
open Jsonit
9
+
10
+
module Int_map = Map.Make (Int)
11
+
module String_map = Map.Make (String)
12
+
13
+
type 'a vec = Array of 'a list | Sparse of 'a Int_map.t
14
+
15
+
type status =
16
+
| All of string
17
+
| Vec of string vec
18
+
19
+
type index = (* ?? *)
20
+
| Array of string list
21
+
| Map of int String_map.t
22
+
23
+
type category =
24
+
{ index : index;
25
+
label : string String_map.t }
26
+
27
+
type date =
28
+
(* https://262.ecma-international.org/6.0/#sec-date-time-string-format *)
29
+
string
30
+
31
+
module Dimension_id = struct
32
+
type t =
33
+
{ category : Json.obj;
34
+
label : string option;
35
+
extension : Json.obj option; }
36
+
end
37
+
38
+
39
+
type dataset =
40
+
{ id : string list;
41
+
size : int list;
42
+
value : float vec;
43
+
dimension : Dimension_id.t String_map.t;
44
+
status : status vec option;
45
+
label : string option;
46
+
source : string option;
47
+
updated : date option;
48
+
extension : Json.obj option; }
49
+
50
+
type collection = unit
51
+
52
+
type class' =
53
+
| Dataset of dataset
54
+
| Dimension of Dimension_id.t
55
+
| Collection of collection
56
+
57
+
type t =
58
+
{ version : string;
59
+
class' : class'; }
+536
vendor/opam/jsont/doc/cookbook.mld
+536
vendor/opam/jsont/doc/cookbook.mld
···
1
+
{0 [Jsont] cookbook}
2
+
3
+
A few conventions and recipes to describe JSON data with
4
+
{!Jsont}.
5
+
6
+
{1:conventions Conventions}
7
+
8
+
{2:naming Naming {!Jsont.t} values}
9
+
10
+
Given an OCaml type [t] its JSON type value should be called
11
+
[t_jsont]. If your type follows the [M.t] module convention use
12
+
[M.jsont].
13
+
14
+
{1:tips General tips}
15
+
16
+
Note that constructing {!Jsont.t} values has a cost. In particular
17
+
when object descriptions are {!Jsont.Object.finish}ed a few checks are
18
+
performed on the definition. Hence it's better to construct them as
19
+
toplevel values or at least make sure you are not repeatedly
20
+
constructing them dynamically in a tight loop.
21
+
22
+
{2:general_erroring Erroring}
23
+
24
+
Jsont types are full of your functions that you specify to implement
25
+
the decoding and encoding process (e.g. base map decoding and encoding
26
+
functions, object map constructors, object map member projectors,
27
+
etc.). In general in any of these functions it is always safe to error
28
+
by raising the {!Jsont.exception-Error} exception if you need to.
29
+
30
+
Use the functions in the {!Jsont.module-Error} to format error
31
+
messages. They usually require to specify a {!Jsont.Meta.t} value to
32
+
precisely locate the error. If you have none to provide simply use
33
+
{!Jsont.Meta.none}.
34
+
35
+
{1:dealing_with_null Dealing with [null] values}
36
+
37
+
Nullable JSON values are naturally mapped to ocaml [option] types. The
38
+
{!Jsont.val-option} combinator does exactly that.
39
+
40
+
It is also possible to map JSON [null]s to a default value with
41
+
{!Jsont.null}. This can then be combined with {!Jsont.val-any} to compose
42
+
with other JSON types.
43
+
44
+
For example the following maps JSON [null]s to [""] and JSON strings
45
+
to [string] on decoding. On encoding we unconditionally map back [""]
46
+
to [null]:
47
+
48
+
{[
49
+
let string_null_is_empty =
50
+
let null = Jsont.null "" in
51
+
let enc = function "" -> null | _ -> Jsont.string in
52
+
Jsont.any ~dec_null:null ~dec_string:Jsont.string ~enc ()
53
+
]}
54
+
55
+
See also {!non_finite_numbers} and the tangentially related topic of
56
+
{!optional_members}.
57
+
58
+
{1:dealing_with_numbers Dealing with numbers}
59
+
60
+
JSON is utterly broken to interchange numbers reliably as the standard
61
+
provides no constraints on their representation. Generally interopable
62
+
implementations, in particular the most widely deployed and formally
63
+
specified ECMAScript implementation, use IEEE 754 [binary64] values to
64
+
represent finite JSON numbers and [null] values to represent
65
+
non-finite one. This has the following consequences.
66
+
67
+
{2:integer_numbers Integer numbers}
68
+
69
+
For representing integers by JSON numbers one is limited to the range
70
+
\[-2{^53};2{^53}\] which are the only integers represented
71
+
precisely in IEEE 754 [binary64]. If you want to serialize numbers
72
+
beyond this range you need to represent them by a JSON string. These
73
+
scheme can be seen in the wild:
74
+
{ul
75
+
{- Integers are unconditionally represented by strings. In this case
76
+
{!Jsont.int_as_string} or {!Jsont.int64_as_string} can be used.}
77
+
{- Integers are represented by numbers or strings depending on their
78
+
magnitude. In this case {!Jsont.int} or {!Jsont.int64}
79
+
can be used.}
80
+
{- The integer range of interest can be fully represented in a JSON number.
81
+
In this case {!Jsont.int8}, {!Jsont.uint8}, {!Jsont.int16}, etc. can be
82
+
used.}}
83
+
84
+
{2:non_finite_numbers Non-finite numbers}
85
+
86
+
JSON numbers cannot represent IEEE 754 [binary64] numbers: infinities
87
+
and NaNs cannot be represented. The formally defined
88
+
{{:https://tc39.es/ecma262/multipage/structured-data.html#sec-serializejsonproperty}ECMAScript's
89
+
[JSON.stringify]} function replaces these values by [null].
90
+
91
+
For this reason in [Jsont] the domain of {!Jsont.Base.number} maps is
92
+
JSON numbers {e or JSON null}. In the decoding direction a null is
93
+
mapped to {!Float.nan} and in the encoding direction any float not
94
+
satisfying {!Float.is_finite} is mapped to a JSON null.
95
+
96
+
If you can agree with a third party on a better encoding, the
97
+
{!Jsont.any_float} or {!Jsont.float_as_hex_string} provide
98
+
lossless representations of IEEE 754 [binary64] values in JSON.
99
+
100
+
{1:base_types Transforming base types}
101
+
102
+
The {!Jsont.map} combinator is a general map over {!Jsont.t} types.
103
+
It should rather be used to alter the representation of existing
104
+
{!Jsont.t} values. For transforming base types it is better to use the
105
+
base maps of {!Jsont.Base} as more context is made available to the
106
+
functions, notably when erroring.
107
+
108
+
{2:transform_strings Transforming strings}
109
+
110
+
A few simple JSON string transformers like {!Jsont.enum} or
111
+
{!Jsont.binary_string} are provided.
112
+
113
+
If you need to devise your own maps from your own [M.{of,to}_string]
114
+
functions that return [result] or raise [Faiulre _] you can adapt them
115
+
with {{!Jsont.Base.decenc}these functions}. For example:
116
+
{[
117
+
let m_jsont =
118
+
let dec = Jsont.Base.dec_result M.result_of_string in
119
+
let enc = Jsont.Base.enc M.to_string in
120
+
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
121
+
122
+
let m_jsont' =
123
+
let dec = Jsont.Base.dec_failure M.of_string_or_failure in
124
+
let enc = Jsont.Base.enc M.to_string in
125
+
Jsont.Base.string (Jsont.Base.map ~kind:"M.t" ~dec ~enc ())
126
+
]}
127
+
128
+
If you are dealing with result decoders you can also simply
129
+
use {!Jsont.of_of_string}:
130
+
131
+
{[
132
+
let m_jsont'' =
133
+
Jsont.of_of_string ~kind:"M.t" M.result_of_string ~enc:M.to_string
134
+
]}
135
+
136
+
which is a shortcut for the [m_jsont] written above.
137
+
138
+
{1:dealing_with_arrays Dealing with arrays}
139
+
140
+
JSON arrays can be directly mapped to OCaml {{!Jsont.list}lists},
141
+
{{!Jsont.array}arrays}, {{!Jsont.bigarray}bigarray} or bespoke
142
+
low-dimensional {{!Jsont.t2}tuples}. If your JSON is an array of
143
+
objects keyed by some identifier you may find
144
+
{!Jsont.array_as_string_map} handy.
145
+
146
+
If none of that fits you can always devise your own {!Jsont.Array.val-map}.
147
+
148
+
{1:dealing_with_objects Dealing with objects}
149
+
150
+
{2:objects_as_records Objects as records}
151
+
152
+
Suppose our JSON object is:
153
+
154
+
{@json[
155
+
{ "name": "Jane Doe"
156
+
"age": 56 }
157
+
]}
158
+
159
+
We represent it with an OCaml record as follows:
160
+
161
+
{[
162
+
module Person = struct
163
+
type t = { name : string; age : int }
164
+
let make name age = { name; age }
165
+
let name p = p.name
166
+
let age p = p.age
167
+
let jsont =
168
+
Jsont.Object.map ~kind:"Person" make
169
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
170
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
171
+
|> Jsont.Object.finish
172
+
end
173
+
]}
174
+
175
+
{2:objects_as_maps Objects as key-value maps}
176
+
177
+
JSON objects can be used as maps from strings to a single type
178
+
of value ({{:https://github.com/topojson/topojson-specification/blob/7939fe0834f36af8b935ec1827cb0abdd1e34d36/README.md#215-objects}example}).
179
+
Such maps can be easily converted to OCaml as follows:
180
+
181
+
{[
182
+
module String_map = Map.Make (String)
183
+
184
+
let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t =
185
+
fun ?kind t ->
186
+
Jsont.Object.map ?kind Fun.id
187
+
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id
188
+
|> Jsont.Object.finish
189
+
]}
190
+
191
+
Since the pattern is common this is directly exposed as
192
+
{!Jsont.Object.as_string_map}.
193
+
194
+
{2:optional_members Optional members}
195
+
196
+
By default members specified via {!Jsont.Object.mem} are mandatory and
197
+
decoding errors if the member is absent.
198
+
199
+
For those cases where the member is optional a default [dec_absent] value must
200
+
be specified to use on decoding when absent. For encoding an
201
+
[enc_omit] function can be specified to determine whether the member
202
+
should be omitted on encoding.
203
+
204
+
In the following example we use an option type to denote the potential
205
+
absence of the [age] member:
206
+
207
+
{[
208
+
module Person_opt_age = struct
209
+
type t = { name : string; age : int option }
210
+
let make name age = { name; age }
211
+
let name p = p.name
212
+
let age p = p.age
213
+
let jsont =
214
+
Jsont.Object.map ~kind:"Person" make
215
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
216
+
|> Jsont.Object.mem "age" Jsont.(some int)
217
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:age
218
+
|> Jsont.Object.finish
219
+
end
220
+
]}
221
+
222
+
When absence is represented by [None] like here the
223
+
{!Jsont.Object.opt_mem} function can be used. It's stricly equivalent to
224
+
the above but more concise.
225
+
226
+
{2:unknown_members Unknown object members}
227
+
228
+
In JSON objects maps, there are three different ways to handle
229
+
object members that have not been declared by a {!Jsont.Object.mem}
230
+
or {!Jsont.Object.opt_mem}.
231
+
232
+
{3:skipping Skipping}
233
+
234
+
By default {!Jsont.Object.val-map} skips unknown object members.
235
+
236
+
{3:erroring Erroring}
237
+
238
+
To error on unknown members use {!Jsont.Object.val-error_unknown}:
239
+
{[
240
+
module Person_strict = struct
241
+
type t = { name : string; age : int; }
242
+
let make name age = { name; age }
243
+
let name p = p.name
244
+
let age p = p.age
245
+
let jsont =
246
+
Jsont.Object.map ~kind:"Person" make
247
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
248
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
249
+
|> Jsont.Object.error_unknown
250
+
|> Jsont.Object.finish
251
+
end
252
+
]}
253
+
254
+
{3:keeping Keeping}
255
+
256
+
If a JSON data schema allows foreign members or to partially model an
257
+
object, unknown members can be collected into a generic
258
+
{!Jsont.Json.t} object and stored in an OCaml field by using
259
+
{!Jsont.Object.keep_unknown} and {!Jsont.json_mems}:
260
+
261
+
{[
262
+
module Person_keep = struct
263
+
type t = { name : string; age : int; unknown : Jsont.json ; }
264
+
let make name age unknown = { name; age; unknown }
265
+
let name p = p.name
266
+
let age p = p.age
267
+
let unknown v = v.unknown
268
+
let jsont =
269
+
Jsont.Object.map ~kind:"Person" make
270
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
271
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
272
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
273
+
|> Jsont.Object.finish
274
+
end
275
+
]}
276
+
277
+
The value of the [unknown] field can be further queried with other
278
+
JSON types and {!Jsont.Json.val-decode}. It is also possible to define
279
+
your own data structure to keep unknown members, see
280
+
{!Jsont.Object.Mems}. See also {!objects_as_maps}.
281
+
282
+
{2:cases Object types or classes}
283
+
284
+
Sometimes JSON objects have a distinguished case member, called
285
+
["type"], ["class"] or ["version"] whose value define the rest of the
286
+
object.
287
+
288
+
The {!Jsont.Object.Case} module handles this pattern. Each case is
289
+
described by a {!Jsont.Object.type-map} object description and the
290
+
{!Jsont.Object.case_mem} allows to chose between them according to the
291
+
value of the case member.
292
+
293
+
In OCaml there are two main ways to represent these case objects.
294
+
Either by an enclosing variant type with one case for each object kind:
295
+
{[
296
+
type t = C1 of C1.t | C2 of C2.t | …
297
+
]}
298
+
or with a record which holds common fields an a field that holds the cases:
299
+
{[
300
+
type type' = C1 of C1.t | C2 of C2.t | …
301
+
type t = { type' : type'; … (* other common fields *) }
302
+
]}
303
+
From {!Jsont}'s perspective there is not much difference.
304
+
305
+
We show both modellings on a hypothetic [Geometry] object which has a
306
+
["name"] member and a ["type"] string case member indicating whether
307
+
the object is a ["Circle"] or a ["Rect"]. Except for the position of
308
+
the [name] field, not much changes in each modelling.
309
+
310
+
Using an enclosing variant type:
311
+
312
+
{[
313
+
module Geometry_variant = struct
314
+
module Circle = struct
315
+
type t = { name : string; radius : float; }
316
+
let make name radius = { name; radius }
317
+
let name c = c.name
318
+
let radius c = c.radius
319
+
let jsont =
320
+
Jsont.Object.map ~kind:"Circle" make
321
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
322
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
323
+
|> Jsont.Object.finish
324
+
end
325
+
326
+
module Rect = struct
327
+
type t = { name : string; width : float; height : float }
328
+
let make name width height = { name; width; height }
329
+
let name r = r.name
330
+
let width r = r.width
331
+
let height r = r.height
332
+
let jsont =
333
+
Jsont.Object.map ~kind:"Rect" make
334
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
335
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
336
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
337
+
|> Jsont.Object.finish
338
+
end
339
+
340
+
type t = Circle of Circle.t | Rect of Rect.t
341
+
let circle c = Circle c
342
+
let rect r = Rect r
343
+
let jsont =
344
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
345
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
346
+
let enc_case = function
347
+
| Circle c -> Jsont.Object.Case.value circle c
348
+
| Rect r -> Jsont.Object.Case.value rect r
349
+
in
350
+
let cases = Jsont.Object.Case.[make circle; make rect] in
351
+
Jsont.Object.map ~kind:"Geometry" Fun.id
352
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
353
+
|> Jsont.Object.finish
354
+
end
355
+
]}
356
+
357
+
Using a record with a [type'] field:
358
+
359
+
{[
360
+
module Geometry_record = struct
361
+
module Circle = struct
362
+
type t = { radius : float; }
363
+
let make radius = { radius }
364
+
let radius c = c.radius
365
+
let jsont =
366
+
Jsont.Object.map ~kind:"Circle" make
367
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
368
+
|> Jsont.Object.finish
369
+
end
370
+
371
+
module Rect = struct
372
+
type t = { width : float; height : float }
373
+
let make width height = { width; height }
374
+
let width r = r.width
375
+
let height r = r.height
376
+
let jsont =
377
+
Jsont.Object.map ~kind:"Rect" make
378
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
379
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
380
+
|> Jsont.Object.finish
381
+
end
382
+
383
+
type type' = Circle of Circle.t | Rect of Rect.t
384
+
let circle c = Circle c
385
+
let rect r = Rect r
386
+
387
+
type t = { name : string; type' : type' }
388
+
let make name type' = { name; type' }
389
+
let name g = g.name
390
+
let type' g = g.type'
391
+
392
+
let jsont =
393
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
394
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
395
+
let enc_case = function
396
+
| Circle c -> Jsont.Object.Case.value circle c
397
+
| Rect r -> Jsont.Object.Case.value rect r
398
+
in
399
+
let cases = Jsont.Object.Case.[make circle; make rect] in
400
+
Jsont.Object.map ~kind:"Geometry" make
401
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
402
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
403
+
|> Jsont.Object.finish
404
+
end
405
+
]}
406
+
407
+
{2:cases_untagged Untagged object types}
408
+
409
+
Sometimes objects types are not determined by a specific {{!cases}case
410
+
member} but rather by the presence or absence of certain members. In
411
+
this case the easiest is to make object members optional with
412
+
{!Jsont.Object.opt_mem} and sort out their presence and absence
413
+
manually in the decoding function given to {!Jsont.Object.val-map}.
414
+
415
+
For example a response message that has always an [id] member and a
416
+
[result] member in case of success and an mutually exclusive [error]
417
+
member in case of error can be modelled as follows:
418
+
{[
419
+
module Response = struct
420
+
type t =
421
+
{ id : int;
422
+
value : (Jsont.json, string) result }
423
+
424
+
let make id result error =
425
+
let pp_mem = Jsont.Repr.pp_code in
426
+
match result, error with
427
+
| Some result, None -> { id; value = Ok result }
428
+
| None, Some error -> { id; value = Error error }
429
+
| Some _ , Some _ ->
430
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
431
+
pp_mem "result" pp_mem "error"
432
+
| None, None ->
433
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
434
+
pp_mem "result" pp_mem "error"
435
+
436
+
let result r = match r.value with Ok v -> Some v | Error _ -> None
437
+
let error r = match r.value with Ok _ -> None | Error e -> Some e
438
+
439
+
let jsont =
440
+
Jsont.Object.map make
441
+
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id)
442
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:result
443
+
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:error
444
+
|> Jsont.Object.finish
445
+
end
446
+
]}
447
+
448
+
A {{:https://www.jsonrpc.org/specification#response_object}JSON-RPC
449
+
response object} has such a structure. A full modelling of the data
450
+
JSON-RPC data format with [Jsont] can be found
451
+
{{:https://erratique.ch/repos/jsont/tree/test/json_rpc.ml}here}.
452
+
453
+
{2:flattening Flattening nested objects}
454
+
455
+
If you are only interested in extracting data it may be useful to
456
+
flatten some objects whose members are too nested for your needs.
457
+
458
+
For that just remember that nothing says that JSON objects
459
+
cannot be mapped to OCaml functions. For examples to gather this kind
460
+
of data for a group of person into a single record:
461
+
462
+
{@json[
463
+
{
464
+
"info" : { "id" : 1, "name": "untitled" }
465
+
"persons" : [ … ]
466
+
}
467
+
]}
468
+
469
+
You can use the following structure:
470
+
471
+
{[
472
+
module Group = struct
473
+
type t = { id : int; name : string; persons : Person.t list }
474
+
let make id name persons = { id; name; persons }
475
+
476
+
let info_jsont =
477
+
Jsont.Object.map make
478
+
|> Jsont.Object.mem "id" Jsont.int
479
+
|> Jsont.Object.mem "name" Jsont.string
480
+
|> Jsont.Object.finish
481
+
482
+
let jsont =
483
+
Jsont.Object.map (fun k persons -> k persons)
484
+
|> Jsont.Object.mem "info" info_jsont
485
+
|> Jsont.Object.mem "persons" (Jsont.list Person.jsont)
486
+
|> Jsont.Object.finish
487
+
end
488
+
]}
489
+
490
+
This however will not allow you to use [jsont] to encode. If you wish
491
+
to do so it's likely better to follow the JSON structure and hide the
492
+
annoying access structure under an abstract type behind a nice API.
493
+
494
+
{1:recursion Dealing with recursive JSON}
495
+
496
+
To describe recursive JSON values you need to define your description
497
+
in a [lazy] expression and use {!Jsont.rec'} to refer to the value
498
+
you are defining. This results in the following structure:
499
+
500
+
{[
501
+
let jsont : t Jsont.t =
502
+
let rec t = lazy ( … Jsont.rec' t … ) in
503
+
Lazy.force t
504
+
]}
505
+
506
+
For example a tree encoded as a JSON object with:
507
+
{@json[
508
+
{ "value": …,
509
+
"children": […] }
510
+
]}
511
+
512
+
Is modelled by:
513
+
514
+
{[
515
+
module Tree = struct
516
+
type 'a t = Node of 'a * 'a t list
517
+
let make v children = Node (v, children)
518
+
let value (Node (v, _)) = v
519
+
let children (Node (_, children)) = children
520
+
let jsont value_type =
521
+
let rec t = lazy
522
+
(Jsont.Object.map ~kind:"Tree" make
523
+
|> Jsont.Object.mem "value" value_type ~enc:value
524
+
|> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children
525
+
|> Jsont.Object.finish)
526
+
in
527
+
Lazy.force t
528
+
end
529
+
]}
530
+
531
+
The
532
+
{{:https://erratique.ch/repos/jsont/tree/test/topojson.ml}[topojson.ml]}
533
+
and
534
+
{{:https://erratique.ch/repos/jsont/tree/test/geojson.ml}[geojson.ml]}
535
+
examples in the source repository provide more extensive examples of
536
+
recursive definition.
+112
vendor/opam/jsont/doc/index.mld
+112
vendor/opam/jsont/doc/index.mld
···
1
+
{0 Jsont {%html: <span class="version">%%VERSION%%</span>%}}
2
+
3
+
Jsont is an OCaml library for declarative JSON data manipulation. It
4
+
provides:
5
+
6
+
- Combinators for describing JSON data using the OCaml values of your
7
+
choice. The descriptions can be used by generic functions to
8
+
decode, encode, query and update JSON data without having to
9
+
construct a generic JSON representation.
10
+
- A {{!Jsont_bytesrw}JSON codec} with optional text location tracking and layout
11
+
preservation. The codec is compatible with effect-based concurrency.
12
+
13
+
The descriptions are independent from the codec and can be used by
14
+
third-party processors or codecs.
15
+
16
+
{1:manuals Manuals}
17
+
18
+
The following manuals are available.
19
+
20
+
{ul
21
+
{- The {{!quick_start}quick start} should do so.}
22
+
{- The {{!cookbook}[Jsont] cookbook} has a few conventions and JSON
23
+
data modelling recipes.}}
24
+
25
+
The {{:https://erratique.ch/repos/jsont/tree/test}test directory}
26
+
in the source repository of Jsont has a few more examples.
27
+
28
+
{1:jsont Library [jsont]}
29
+
30
+
{!modules:Jsont}
31
+
32
+
{1:jsont_bytesrw Library [jsont.bytesrw]}
33
+
34
+
This library depends on the {!bytesrw} library and exports the [jsont] library.
35
+
36
+
{!modules:Jsont_bytesrw}
37
+
38
+
{1:jsont_brr Library [jsont.brr]}
39
+
40
+
This library depends on the {!brr} library and exports the [jsont] library.
41
+
42
+
{!modules:
43
+
Jsont_brr}
44
+
45
+
{1:quick_start Quick start}
46
+
47
+
Given JSON for task items encoded in JSON as follows:
48
+
{[
49
+
let data =
50
+
{|
51
+
{ "task": "Make new release",
52
+
"status": "todo",
53
+
"tags": ["work", "softwre"] }|}
54
+
]}
55
+
56
+
First we can correct that typo in the ["tags"] list with:
57
+
58
+
{[
59
+
let () =
60
+
let p = Jsont.Path.(root |> mem "tags" |> nth 1) in
61
+
let update = Jsont.(set_path string p "software") in
62
+
let correct = Jsont_bytesrw.recode_string ~layout:true update data in
63
+
print_endline (Result.get_ok correct)
64
+
]}
65
+
66
+
Now to work with the data in OCaml without pain we can model it by:
67
+
68
+
{[
69
+
module Status = struct
70
+
type t = Todo | Done | Cancelled
71
+
let assoc = ["todo", Todo; "done", Done; "cancelled", Cancelled ]
72
+
let jsont = Jsont.enum ~kind:"Status" assoc
73
+
end
74
+
75
+
module Item = struct
76
+
type t = { task : string; status : Status.t; tags : string list; }
77
+
let make task status tags = { task; status; tags }
78
+
let task i = i.task
79
+
let status i = i.status
80
+
let tags i = i.tags
81
+
let jsont =
82
+
Jsont.Object.map ~kind:"Item" make
83
+
|> Jsont.Object.mem "task" Jsont.string ~enc:task
84
+
|> Jsont.Object.mem "status" Status.jsont ~enc:status
85
+
|> Jsont.Object.mem "tags" Jsont.(list string) ~enc:tags
86
+
~dec_absent:[] ~enc_omit:(( = ) [])
87
+
|> Jsont.Object.finish
88
+
end
89
+
]}
90
+
91
+
Lists of task items can be serialized to strings with, for example,
92
+
{!Jsont_bytesrw}:
93
+
94
+
{[
95
+
let items = Jsont.list Item.jsont
96
+
let items_of_json s = Jsont_bytesrw.decode_string items s
97
+
let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is
98
+
]}
99
+
100
+
If you are using [js_of_ocaml] the browser's built-in JavaScript
101
+
parser can be used with {!Jsont_brr} from the [jsont.brr] library:
102
+
103
+
{[
104
+
let items_of_json s = Jsont_brr.decode items s
105
+
let items_to_json is = Jsont_brr.encode items is
106
+
]}
107
+
108
+
The {{!page-cookbook}cookbook} has more JSON modelling recipes, the
109
+
{{:https://erratique.ch/repos/jsont/tree/test/topojson.ml}[topojson.ml]},
110
+
{{:https://erratique.ch/repos/jsont/tree/test/geojson.ml}[geojson.ml]},
111
+
{{:https://erratique.ch/repos/jsont/tree/test/json_rpc.ml}[json_rpc.ml]},
112
+
in the source repository provide full examples of JSON schema modelisations.
+59
vendor/opam/jsont/jsont.opam
+59
vendor/opam/jsont/jsont.opam
···
1
+
opam-version: "2.0"
2
+
name: "jsont"
3
+
synopsis: "Declarative JSON data manipulation for OCaml"
4
+
description: """\
5
+
Jsont is an OCaml library for declarative JSON data manipulation. It
6
+
provides:
7
+
8
+
- Combinators for describing JSON data using the OCaml values of your
9
+
choice. The descriptions can be used by generic functions to
10
+
decode, encode, query and update JSON data without having to
11
+
construct a generic JSON representation.
12
+
- A JSON codec with optional text location tracking and layout
13
+
preservation. The codec is compatible with effect-based concurrency.
14
+
15
+
The descriptions are independent from the codec and can be used by
16
+
third-party processors or codecs.
17
+
18
+
Jsont is distributed under the ISC license. It has no dependencies.
19
+
The codec is optional and depends on the [`bytesrw`] library. The JavaScript
20
+
support is optional and depends on the [`brr`] library.
21
+
22
+
Homepage: <https://erratique.ch/software/jsont/>
23
+
24
+
[`bytesrw`]: https://erratique.ch/software/bytesrw
25
+
[`brr`]: https://erratique.ch/software/brr"""
26
+
maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
27
+
authors: "The jsont programmers"
28
+
license: "ISC"
29
+
tags: ["json" "codec" "org:erratique"]
30
+
homepage: "https://erratique.ch/software/jsont"
31
+
doc: "https://erratique.ch/software/jsont/doc"
32
+
bug-reports: "https://github.com/dbuenzli/jsont/issues"
33
+
depends: [
34
+
"ocaml" {>= "4.14.0"}
35
+
"ocamlfind" {build}
36
+
"ocamlbuild" {build}
37
+
"topkg" {build & >= "1.1.0"}
38
+
"b0" {dev & with-test}
39
+
]
40
+
depopts: ["cmdliner" "brr" "bytesrw"]
41
+
conflicts: [
42
+
"cmdliner" {< "1.3.0"}
43
+
"brr" {< "0.0.6"}
44
+
]
45
+
build: [
46
+
"ocaml"
47
+
"pkg/pkg.ml"
48
+
"build"
49
+
"--dev-pkg"
50
+
"%{dev}%"
51
+
"--with-cmdliner"
52
+
"%{cmdliner:installed}%"
53
+
"--with-bytesrw"
54
+
"%{bytesrw:installed}%"
55
+
"--with-brr"
56
+
"%{brr:installed}%"
57
+
]
58
+
dev-repo: "git+https://erratique.ch/repos/jsont.git"
59
+
x-maintenance-intent: ["(latest)"]
+59
vendor/opam/jsont/opam
+59
vendor/opam/jsont/opam
···
1
+
opam-version: "2.0"
2
+
name: "jsont"
3
+
synopsis: "Declarative JSON data manipulation for OCaml"
4
+
description: """\
5
+
Jsont is an OCaml library for declarative JSON data manipulation. It
6
+
provides:
7
+
8
+
- Combinators for describing JSON data using the OCaml values of your
9
+
choice. The descriptions can be used by generic functions to
10
+
decode, encode, query and update JSON data without having to
11
+
construct a generic JSON representation.
12
+
- A JSON codec with optional text location tracking and layout
13
+
preservation. The codec is compatible with effect-based concurrency.
14
+
15
+
The descriptions are independent from the codec and can be used by
16
+
third-party processors or codecs.
17
+
18
+
Jsont is distributed under the ISC license. It has no dependencies.
19
+
The codec is optional and depends on the [`bytesrw`] library. The JavaScript
20
+
support is optional and depends on the [`brr`] library.
21
+
22
+
Homepage: <https://erratique.ch/software/jsont/>
23
+
24
+
[`bytesrw`]: https://erratique.ch/software/bytesrw
25
+
[`brr`]: https://erratique.ch/software/brr"""
26
+
maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
27
+
authors: "The jsont programmers"
28
+
license: "ISC"
29
+
tags: ["json" "codec" "org:erratique"]
30
+
homepage: "https://erratique.ch/software/jsont"
31
+
doc: "https://erratique.ch/software/jsont/doc"
32
+
bug-reports: "https://github.com/dbuenzli/jsont/issues"
33
+
depends: [
34
+
"ocaml" {>= "4.14.0"}
35
+
"ocamlfind" {build}
36
+
"ocamlbuild" {build}
37
+
"topkg" {build & >= "1.1.0"}
38
+
"b0" {dev & with-test}
39
+
]
40
+
depopts: ["cmdliner" "brr" "bytesrw"]
41
+
conflicts: [
42
+
"cmdliner" {< "1.3.0"}
43
+
"brr" {< "0.0.6"}
44
+
]
45
+
build: [
46
+
"ocaml"
47
+
"pkg/pkg.ml"
48
+
"build"
49
+
"--dev-pkg"
50
+
"%{dev}%"
51
+
"--with-cmdliner"
52
+
"%{cmdliner:installed}%"
53
+
"--with-bytesrw"
54
+
"%{bytesrw:installed}%"
55
+
"--with-brr"
56
+
"%{brr:installed}%"
57
+
]
58
+
dev-repo: "git+https://erratique.ch/repos/jsont.git"
59
+
x-maintenance-intent: ["(latest)"]
+40
vendor/opam/jsont/paper/README.md
+40
vendor/opam/jsont/paper/README.md
···
1
+
This is a [paper] written as a functional pearl about the general
2
+
technique used by the library. It was [rejected] by the [Journal of
3
+
Functional Progamming][jfp] but I don't have the time and energy to
4
+
significantly rewrite it (see below).
5
+
6
+
I think it's readable in its current form if you are an OCaml
7
+
programmer and either want to understand how the library works or to
8
+
apply the technique on other generic data formats.
9
+
10
+
[paper]: soup.pdf
11
+
[rejected]: jfp-reject.txt
12
+
[jfp]: https://www.cambridge.org/core/journals/journal-of-functional-programming
13
+
14
+
15
+
## Rewrite (if ever happens)
16
+
17
+
- Address reviewer comments and their misunderstandings.
18
+
19
+
Part of the problem is that we wanted to expose a real world
20
+
blueprint of a technique, have it as a pearl and limit the
21
+
exposition to fit on 15 pages (self-imposed).
22
+
23
+
Now we have the following conflicting complaints:
24
+
25
+
- It's too technical and detailed for a pearl. It's not "joyful" enough.
26
+
Indeed it's a very boring exposition of the full details it takes to
27
+
have an ergonomic system in ML for dealing with the serialisation disaster
28
+
that JSON is.
29
+
- There are not enough motivating examples and details about design choices
30
+
(though honestly there's not thousands ways to construct and deconstruct
31
+
an array) and we get complaints that we do not reference related works.
32
+
33
+
So if anything it should likely rather be turned into a regular
34
+
academic paper but I'm not sure it's worth the effort. The document
35
+
as it stands is likely already useful for a motivated individual.
36
+
37
+
- Like was eventually done in `jsont`, also have an optional
38
+
`unknowns_mems` in `Obj_cases` shapes. This makes the exposition
39
+
slightly more complex though as we need to talk about the overriding
40
+
behaviour.
+338
vendor/opam/jsont/paper/jfp-reject.txt
+338
vendor/opam/jsont/paper/jfp-reject.txt
···
1
+
Submitted: 2024-06-26
2
+
Decision: 2024-08-29
3
+
4
+
Dear Mr. Bünzli:
5
+
6
+
Manuscript ID JFP-2024-0027 entitled "An alphabet for your data soups"
7
+
which you submitted to the Journal of Functional Programming, has been
8
+
reviewed. The comments from reviewers are included at the bottom of
9
+
this letter.
10
+
11
+
In view of the criticisms of the reviewers, I must decline the
12
+
manuscript for publication in the Journal of Functional Programming at
13
+
this time. However, a *new* manuscript may be submitted which takes
14
+
into consideration these comments.
15
+
16
+
Please note that resubmitting your manuscript does not guarantee
17
+
eventual acceptance, and that your resubmission will be subject to
18
+
re-review by the reviewers before a decision is rendered.
19
+
20
+
You will be unable to make your revisions on the originally submitted
21
+
version of your manuscript. Instead, revise your manuscript and submit
22
+
it as a new paper.
23
+
24
+
If you decide to resubmit, please state the manuscript number of the
25
+
previous submission in your cover letter.
26
+
27
+
28
+
Sincerely,
29
+
Prof. Functional Pearls
30
+
Journal of Functional Programming
31
+
prof-pearls@online.de
32
+
33
+
Editors' Comments to Author
34
+
35
+
Reviewers' Comments to Author:
36
+
Referee: 1
37
+
38
+
Comments to the Author
39
+
40
+
This paper presents an OCaml combinator library for converting between
41
+
JSON data and ML typed values. The library may be a joy to use, but
42
+
this functional pearl doesn’t show that: Concrete examples of how to
43
+
use the library are scant; for instance, Section 3.5 lists three
44
+
“patterns found in JSON data schemas that we want to support”, but
45
+
only the first pattern is illustrated (“in Section 3”), and the “query
46
+
and update” combinators in Section 5 are not shown in use at all. The
47
+
library may be intellectually stimulating to build, but this
48
+
functional pearl doesn’t show that: Implementation code often appears
49
+
whose purpose is unclear (for instance, in Section 3.5.1).
50
+
51
+
I suggest the author think long and hard about what is instructive or
52
+
nifty or interesting (hereafter “joyful”) about building or using this
53
+
library. Then, pare down the library and the writing to only that
54
+
part. For instance, if “objects as uniform key-value maps” and
55
+
“objects as sums” are not joyful, then get rid of them. If query and
56
+
update are not joyful, then get rid of them and remove dec_skip as
57
+
well. On the other hand, if query and update are what’s joyful, then
58
+
do you really need to decode and encode JSON data in order to share
59
+
that joy? Finally, be sure to show what’s good with concrete examples,
60
+
early and often.
61
+
62
+
Referee: 2
63
+
64
+
Comments to the Author
65
+
# Summary
66
+
67
+
This pearl describes a richly typed eDSL to write bidirectional
68
+
maps between JSON with an underlying (unenforced, potentially
69
+
dynamic) format and ML values.
70
+
The core of the paper is dedicated to describing at length
71
+
the effort that goes into defining the GADT used to model
72
+
these maps.
73
+
A final section develops how one can reuse the machinery to
74
+
define query & update combinators operating directly over the
75
+
JSON objects.
76
+
77
+
# Assessment
78
+
79
+
I think this is interesting work however it currently feels
80
+
too brutally technical and without clear design / correctness
81
+
criteria to read like a pearl: « programs are fun, and they
82
+
teach important programming techniques and fundamental design
83
+
principle » (Jon Bentley on the definition of a programming
84
+
pearl cf. https://www.cs.ox.ac.uk/people/jeremy.gibbons/pearls/)
85
+
86
+
I would also like to see more of a discussion of the related work.
87
+
88
+
# Main comments
89
+
90
+
## Missing examples
91
+
92
+
If the main goal is well motivated by the important goal of
93
+
being able to program against a JSON "soup" in a structured
94
+
and typed manner, each construct is poorly justified.
95
+
96
+
It would be nice for each section to have some small examples
97
+
justifying why some of these definitions are so complex. Give
98
+
us concrete instances of these structures you are describing!
99
+
100
+
p5: Any case
101
+
This was really confusing to me at first until I understood
102
+
(?) that the idea is that e.g. decoding (Number n) at type
103
+
(Any m) amounts to decoding (Number n) at type (m.dec_number).
104
+
I think it would be useful to sprinkle some examples here instead
105
+
of just relying on "it embeds dynamic typing in our datatype".
106
+
I even wonder whether it'd be useful to show the code for
107
+
`decode_any` in parallel with the definition of `option`.
108
+
109
+
p9: Object shapes.
110
+
Again this lacks motivation IMO. Give us plenty of examples
111
+
showing why all of this complexity is needed!
112
+
113
+
The description of object cases is even more puzzling.
114
+
115
+
## Missing explanations
116
+
117
+
p7: dec_fun definition
118
+
Please give a one sentence definitition of type ids so that
119
+
we don't need to lookup the ocaml docs just to understand what
120
+
they are. Looking at the code for `Dict.t`, it seems to be a
121
+
unique `int` allowing you to test type equality.
122
+
123
+
AFAIU this means all the arguments need to have different
124
+
types. Why is that a sensible assumption?
125
+
126
+
But looking at obj_mem, `Type.Id.make ()` seems to suggest
127
+
it's not in fact a unique ID per type but rather an ID for
128
+
something that happens to have this type.
129
+
130
+
Again, this would be a lot easier to understand with a
131
+
proper explanation from the get go.
132
+
133
+
## Correction of type description
134
+
135
+
Given that the typed description induces an encoder and a
136
+
decoder, it would be nice to have a correctness theorem.
137
+
I suspect there is no hope to get `encode . decode = id`
138
+
(multiple possible representations of the same value) but
139
+
we definitely want to have `decode . encode = id`.
140
+
141
+
Correspondingly, I feel the presentation is missing the
142
+
precise characterisation of the invariants we expect the
143
+
users to respect. Ideally these could be expressed as
144
+
properties testable using something like quickcheck.
145
+
146
+
In particular, this means specifying:
147
+
148
+
p4: Map case
149
+
define "bidirectional map" more precisely: what sort of
150
+
properties do you expect? E.g. `dec` being a partial inverse
151
+
to `enc` but not the other way around? More than that? Less?
152
+
153
+
p5: Array case
154
+
Again here it'd be nice to have a property you expect to
155
+
hold for the component to be well behaved. I would expect
156
+
something along the lines of:
157
+
`dec_finish (enc (\ b, elt -> dec_add b ??? elt) dec_empty arr) = arr`
158
+
except that `dec_add` takes an index which is not available from
159
+
inside the `enc` fold.
160
+
161
+
## Missing related work section
162
+
163
+
You cited pickler combinators and alluded to generic programming
164
+
but I think it would be interesting to discuss more extensively
165
+
the fairly important tradition of writing "invertible parsers",
166
+
"bidirectional programs", "partial isomorphisms", etc. to
167
+
obtain pairs of a parser and a pretty printer e.g.
168
+
169
+
* There and back again: arrows for invertible programming by Alimarine
170
+
* Invertible syntax descriptions: unifying parsing and pretty printing by Rendel
171
+
* Correct-by-construction pretty-printing by Nils Anders Danielsson
172
+
* Generic packet descriptions by Van Geest
173
+
* FliPpr: A System for Deriving Parsers from Pretty-Printers by Matsuda
174
+
175
+
Some of these (Generic packet descriptions) include types of
176
+
formats that your approach cannot handle (cf. next point)
177
+
178
+
The query & update section naturally brings up the (unexplored?)
179
+
relationship to lenses & prisms.
180
+
181
+
182
+
## Missing discussion of possible extension
183
+
184
+
It would be interesting to have a discussion of some
185
+
features of common format specifications that are not
186
+
tackled by the current work.
187
+
188
+
E.g. some formats specify
189
+
- *computed* fields e.g. checksums, or
190
+
- *constrained* fields e.g. a payload whose length is specified
191
+
in another field.
192
+
193
+
Could these be accommodated? Or do you need to move to
194
+
a more powerful type system like in 'Generic packet
195
+
descriptions' by Van Geest mentioned above?
196
+
197
+
# Minor issues
198
+
199
+
p3: Typed representation
200
+
"laziest readers" -> find better wording (or is that meant
201
+
to be a pun for readers using a lazy ML?)
202
+
203
+
p5: Array case
204
+
Given that skip & add take an index, is it worth
205
+
adding a type alias `type index = int` to suggest
206
+
it's meant to be a non-negative number?
207
+
208
+
209
+
Referee: 3
210
+
211
+
Comments to the Author
212
+
213
+
---- Summary ----
214
+
215
+
This paper describes a library for working with JSON data. The key idea
216
+
is not to describe JSON directly (as in Section 2), but rather to define
217
+
a GADT describing the conversion between some OCaml type a and its JSON
218
+
representation (Section 3). Given such a description, it is easy to
219
+
define the actual encoding/decoding with respect to JSON and functions
220
+
to query/update JSON data.
221
+
222
+
---- Review ----
223
+
224
+
Conversion between algebraic datatypes and JSON is a well studied
225
+
problem: there are 100+ OCaml packages and 300+ Haskell packages for
226
+
interfacing with (some form of) JSON data. It is certainly an
227
+
interesting and important problem.
228
+
229
+
My main concern with this paper is that it descibes a solution (the GADT
230
+
is Section 3), without explicitly introducing the problem and motivating
231
+
the underlying design choices that lead to this solution. This is very
232
+
important, not only because there is already so much work in this area,
233
+
but this distinguishes a research paper from a library documentation.
234
+
Especially for a pearl, I am keen to read the _ideas_ that (naturally)
235
+
lead to this solution and not just the code that makes things tick.
236
+
237
+
Let me illustrate this point with a few examples:
238
+
239
+
* the GADT jsont has a separate constructor for 'map' -- essentially
240
+
used to map a conversion over another GADT value. This seems rather
241
+
arbitrary: was it necessary for important examples? Could there be an
242
+
alternative GADT that supports map as a defined operation, rather than
243
+
a separate constructor?
244
+
245
+
* Similarly, the case for arrays, given by the 'array_map' record, has
246
+
several functions to build and convert arrays. Why choose _these_
247
+
functions? Could there be others that are also useful? What
248
+
considerations lead to these primitives?
249
+
250
+
* The base_map type has conversions between a and b -- can these fail?
251
+
What (roundtrip) properties should they satisfy? There is an obvious
252
+
relation with lensest that should be mentioned at the very least.
253
+
254
+
* The most elaborate case is that for objects. Here the design is
255
+
pragmatic -- motivated by several typical use cases for objects (given
256
+
at the beginning of section 3.5). Once again, I managed to read along
257
+
with the code, but the principles that lead to this solution are left
258
+
implicit: why does mem_map have precisely these fields? The key
259
+
(heterogeneous) dictionary is in the appendix -- but what purpose does
260
+
'a Type.Id.t serve? The 'apply_dict' function can still fail
261
+
dynamically using Option.get -- is this a problem? If the library aims
262
+
to provide more (type) safety than working with JSON directly, these
263
+
issues and design choices need to be more carefully discussed.
264
+
265
+
This last point also shows up in section 5, where the various update and
266
+
delete functions can all still throw type errors; similarly, the
267
+
handling of the Any type (section 3.4) seems arbitrary and prone to
268
+
dynamic failure again. If there are so many places where (type) unsafety
269
+
can still sneak in -- what is achieved by the proposed solution? Could
270
+
these limitations be addressed by more fancy type features? And what
271
+
trade-off lead to this particular design?
272
+
273
+
I would strongly recommend Simon Peyton Jones' talk on "How to write
274
+
great research paper" -- one of the key points it to try to convey the
275
+
main ideas; the implementation should follow naturally.
276
+
277
+
The current introduction was not helpful in positioning the paper. Many
278
+
of the points made about 'this datatype' don't make much sense on first
279
+
reading -- I haven't seen the datatype yet and found it very hard to
280
+
appreciate these contributions. It would be very helpful to formulate
281
+
the design goals (and limitations!), independently of the actual
282
+
implementation. Making these concrete by means of examples would really
283
+
help -- phrases such as 'partially modelled data schemas', 'datatype
284
+
generic representations' or 'generic representation of the data model'
285
+
do not have much meaning without more context.
286
+
287
+
A good pearl does not need to exhaustively discuss related work, but
288
+
there are plenty of other papers and libraries that tackle similar
289
+
issues, including but not limited to the view-update problem (and
290
+
lenses), other (generic programming) solutions to JSON
291
+
encoding/decoding, and the many other libraries that tackle the same
292
+
issue.
293
+
294
+
This work and these ideas may yet lead to an interesting pearl, but the
295
+
article in its current form is not yet ready for publication.
296
+
297
+
---- Typos / minor suggestions ----
298
+
299
+
* General, there are no line numbers. The JFP style file requires these
300
+
for submissions -- they would make giving specific feedback much
301
+
easier.
302
+
303
+
* page 1 - 'directly on their own type system' -- I believe this is not
304
+
a property of dynamic languages in general, but rather the way
305
+
Javascript/Python support objects. Try to be more specific here.
306
+
307
+
* page 2 - use endashes (--) surrounded by spaces (the JFP default); or
308
+
emdashes (---) without spaces, but never mix these style.
309
+
310
+
* page 2 - it would be useful to give an example of the Json struct --
311
+
and illustrate why this solution is unsatisfactory to more clearly
312
+
motivate the solution presented in the next section.
313
+
314
+
* page 3 - I know enough OCaml to get by, but what does ~enc:content
315
+
mean? Why is the twiddle necessary here?
316
+
317
+
* page 4 - 'mapping unit values with m' sounds like m is a function,
318
+
while it isn't!
319
+
320
+
* page 4 - 'answer is rather negative' sounds odd, perhaps 'this is not the
321
+
case'? And if it isn't the case,
322
+
323
+
* page 4 - 'it is not directly evident in our simpler exposition...' -
324
+
this feels like a rather weak argument. I can understand the
325
+
importance of simplifying code for the sake of presentation -- but
326
+
apparently there are other design considerations at play that have not
327
+
yet been mentioned.
328
+
329
+
* page 6 - sentences like 'the JSON type json which maps any JSON value'
330
+
indicate that there may be a need for better terminology here.
331
+
332
+
* page 6 ' retaining efficient decodes' grammar - perhaps 'efficient decoding'?
333
+
334
+
* page 7 - contructor -> constructor
335
+
336
+
* 'must type as defined by the object map otherwise the decode errors' -
337
+
grammar -> 'all definitions must be typed in accordance with the
338
+
object map otherwise the decoding fails.'
+1
vendor/opam/jsont/paper/jfp.cls
+1
vendor/opam/jsont/paper/jfp.cls
···
1
+
\NeedsTeXFormat{LaTeX2e}
\ProvidesClass{jfp}[2022/06/27 V1.9 Standard LaTeX document class]
%
\newif\ifcopoddhead\global\copoddheadfalse
\newif\ifOA\global\OAfalse
\newif\ifnolineno\global\nolinenofalse
\newif\ifnatbiboff\global\natbibofffalse
\newif\ifeqnum\global\eqnumfalse
\newif\ifkeyedin\global\keyedinfalse
\newif\iffirstproof\global\firstprooffalse
\newif\ifrevises\global\revisesfalse
\newif\iffinals\global\finalsfalse
\newif\ifpreview\global\previewfalse
\newif\iffootlist\global\footlistfalse
\newif\iffigsizecheck\global\figsizecheckfalse
\newif\ifresearch\global\researchfalse
\newif\ifnoquery\global\noqueryfalse
\newif\ifguestedit\global\guesteditfalse
\newif\ifaubreakand\global\aubreakandfalse
\newif\ifnoundrule\global\noundrulefalse
\newif\if@twoauthors\global\@twoauthorsfalse
\newif\if@affsep\global\@affsepfalse
\newif\iflettersize\global\lettersizetrue%
\newif\iflegalsize\global\legalsizefalse%
\newif\iftabloidsize\global\tabloidsizefalse%
\newif\ifpuretex\global\puretexfalse%
\newif\ifsamjournal\global\samjournalfalse%
\newif\ifbkmerge\global\bkmergefalse%
\newif\ifcolorimage\global\colorimagefalse%
\newif\ifbwimage\global\bwimagefalse%
\newif\ifsinglepage\global\singlepagefalse
\newif\ifblankpage\global\blankpagefalse
\newif\ifrmqpage\global\rmqpagefalse
\newif\ifrevqpage\global\revqpagefalse
\newif\ifbklpage\global\bklpagefalse
\newif\ifbkfpage\global\bkfpagefalse
\newif\ifintrotag\global\introtagfalse
\newif\ifbotfig\global\botfigfalse
\newif\ifmono\global\monofalse
\newif\ifdraft\global\draftfalse
\newif\ifprint\global\printfalse
\newif\ifbakoma\global\bakomafalse
\newif\ifnoquery\global\noqueryfalse
\newif\ifauthft\global\authftfalse
\newif\iflist\global\listfalse
\newif\ifcback\global\cbackfalse
\newif\ifshowframe\global\showframefalse
\newif\ifbback\global\bbackfalse
\newif\ifunnumbered\global\unnumberedfalse
\newif\ifchapteronly\global\chapteronlyfalse
\newif\ifcontentonly\global\contentonlyfalse
\newif\ifchaptercontent\global\chaptercontentfalse
\newif\iftwofig\global\twofigfalse
\newif\ifsidebotfig\global\sidebotfigfalse
\newif\ifsidetopfig\global\sidetopfigfalse
\newif\iflof\global\loffalse
\newif\iflot\global\lotfalse
\newif\ifnolot
\newif\ifprintcontact\global\printcontactfalse
\newif\ifdcolalignleft\global\dcolalignleftfalse
\newif\ifrefcomma\global\refcommafalse
\newif\iffigureshow\global\figureshowfalse
\newif\iftableshow\global\tableshowfalse
\newif\ifsecnumclass\global\secnumclassfalse
\newif\iflastpagewrite\global\lastpagewritefalse
\newif\ifUnNumfigure\global\UnNumfigurefalse
\newif\ifUnNumtable\global\UnNumtablefalse
\newif\ifappendix\global\appendixfalse
\newif\ifMathRoman\global\MathRomanfalse
\newif\ifMathBold\global\MathBoldfalse
\newif\ifMathBoldIT\global\MathBoldITfalse
\newif\ifremovespaces\global\removespacesfalse
\newif\iffirstpageoff\global\firstpageofffalse
\newif\ifbkpscreate\global\bkpscreatefalse
\newif\ifnomensect\global\nomensectfalse
\newif\ifitcont\global\itcontfalse
\newif\iffigcontcheck\global\figcontcheckfalse
\newif\if@display%
\newif\if@author\global\@authortrue%
\newif\if@authoremail\global\@authoremailfalse%
\newif\if@references\global\@referencesfalse%
\newif\if@sluginfo\global\@sluginfofalse%
\newif\if@namedcontent\global\@namedcontentfalse%
\newif\if@list\global\@listfalse%%
\newif\if@numberedlist\@numberedlistfalse
\newif\if@nomenclature\@nomenclaturefalse
\newif\if@algorithm\global\@algorithmfalse
\newif\if@tablefootnote\global\@tablefootnotefalse
\newif\if@appendix\global\@appendixfalse
\newif\if@firstsection\@firstsectiontrue
\newif\if@inlinealgorithm
\newif\iffigtopcap\global\figtopcapfalse
\newif\if@rot@twoside
\newif\iflandoff\global\landofffalse
\newif\if@lastviper \@lastviperfalse
\newif\ifFoottext\global\Foottextfalse
\newif\iffootdisplay\global\footdisplayfalse
\newif\ifregistermark
\newif\ifpspdfcreate\global\pspdfcreatefalse
\newif\ifrepro\reprofalse
\newif\ifddraft
\newif\ifcontact
\newif\ifprinter
\newif\ifonline\global\onlinefalse
\newif\ifcountempty\global\countemptyfalse
\newif\ifpddata\global\pddatafalse
\newif\iffloatid\global\floatidfalse
\newif\ifmathtif\global\mathtiffalse%
\newif\ifAbstract\global\Abstractfalse
\newif\ifmergexml\global\mergexmlfalse
\newif\ifnoimage\global\noimagefalse
\newif\ifSecNo\global\SecNofalse
\newif\ifbookreview\global\bookreviewfalse%%
\newif\ifnoranges\global\norangesfalse%%
\newif\ifnodoi\global\nodoifalse%%
\newif\ifnokeyword\global\nokeywordfalse%%
\newif\ifnocopyright\global\nocopyrightfalse%%
\newif\ifnocopysymb\global\nocopysymbfalse%%
\newif\ifreviewer\global\reviewerfalse%%
\newif\ifcallpaper\global\callpaperfalse%%
\newif\iftexteditor\global\texteditorfalse%%
\newif\ifeditorial\global\editorialfalse%%
\newif\ifDhead\global\Dheadfalse%%
\newif\ifEPF\global\EPFfalse%
\newif\ifnoauthor\global\noauthorfalse%
\newif\ifdbleed\global\dbleedfalse%
\newif\ifsupertitle\global\supertitlefalse%
\newif\iffigsrcpresent\global\figsrcpresentfalse
\newif\ifcallforpaper\global\callforpaperfalse%
\newif\ifintexttbl\global\intexttblfalse
\newif\ifnoqrule\global\noqrulefalse
\newif\ifnoabstract\global\noabstractfalse%%
\newif\ifcorrigendum\global\corrigendumfalse%%
\newif\ifsupplementary\global\supplementaryfalse%
\newif\ifbkblurb\global\bkblurbfalse%%
\newif\ifsplissue\global\splissuefalse%
\newif\ifannouncement\global\announcementfalse%%
\newif\iferratum\global\erratumfalse
\newif\if@obituary\global\@obituaryfalse
\newif\if@puretex\global\@puretexfalse
\newif\if@final\@finalfalse
\newif\if@aa\global\@aafalse
\newif\if@rp\global\@rpfalse
\newif\if@issue\global\@issuefalse
\newif\if@ddraft\@ddraftfalse
\newif\if@editorial\@editorialfalse
\newif\if@puretex\global\@puretexfalse
\newif\if@colorinfo\global\@colorinfofalse
\newif\if@justnomen\global\@justnomenfalse
\newif\if@wfp\global\@wfpfalse
\newif\if@comm\global\@commfalse
\newif\if@figcenter\global\@figcenterfalse
\newif\if@smallformat\global\@smallformatfalse
\newif\if@cover\global\@coverfalse%
\newif\if@bwcover\global\@bwcoverfalse%
\newif\if@runonauthor
\newif\if@history\global\@historyfalse
\newif\if@corres\global\@corresfalse
\newif\if@reflink\global\@reflinkfalse
\newif\ifdhead\global\dheadfalse
\newif\ifauthor \authorfalse%
\newif\iffloutsidemargin\floutsidemarginfalse
\newif\ifflinsidemargin\flinsidemarginfalse
\newif\ifflleftsidemargin\flleftsidemarginfalse
\newif\ifflrightsidemargin\flrightsidemarginfalse
\newif\ifTheorem\global\Theoremfalse
\newif\iffloutsidetexttypewidthsep\floutsidetexttypewidthsepfalse
\newif\ifflinsidetexttypewidthsep\flinsidetexttypewidthsepfalse
\newif\ifflleftsidetexttypewidthsep\flleftsidetexttypewidthsepfalse
\newif\ifflrightsidetexttypewidthsep\flrightsidetexttypewidthsepfalse
\newif\ifExample\global\Examplefalse
\newif\ifrunon\runonfalse
\newif\if@thmdot\global\@thmdotfalse
\newif\ifswitchcols
\newif\ifauthor \authorfalse%
\newif\ifaffiliation \global\affiliationfalse%
\newif\if@oneoffnum\global\@oneoffnumfalse
\newif\ifunnumberedaffil\unnumberedaffilfalse
\newif\ifsymbolaffilcount\symbolaffilcountfalse
\newif\ifreview\global\reviewfalse
\newif\iflabelrightalign\labelrightaligntrue
\newif\iffnalpha\global\fnalphafalse
\newif\ifunnumlistitem\unnumlistitemfalse
\newif\ifFP\global\FPfalse
\newif\ifCO\global\COfalse
\newif\ifsidefigure\global\sidefigurefalse
\newif\ifrightsidefigure\global\rightsidefigurefalse
\newif\iftopcap\global\topcaptrue
\newif\ifbotcap\global\botcapfalse
\newif\ifcencap\global\cencapfalse
\newif\ifsidewaysfigure\sidewaysfigurefalse
\newif\ifmarginalfigure\marginalfigurefalse
\newif\ifTBhang\global\TBhangtrue
\newif\ifwithintabular\withintabularfalse
\newif\ifsidewaystable\sidewaystablefalse%
\newif\ifsidewbreak\sidewbreakfalse%
\newif\ifhangtab\global\hangtabfalse
\newif\ifremovetoprule\global\removetoprulefalse
\newif\ifremovebotrule\global\removebotrulefalse
\newif\ifunnumtable\unnumtablefalse
\newif\ifmarginaltable\marginaltablefalse
\newif\iftablewithshade\tablewithshadefalse
\newif\iftbsidecap\tbsidecapfalse
\newif\iftablerulebox\global\tableruleboxfalse%
\newif\ifkilltableabovespace\killtableabovespacefalse
\newif\ifnobotrule\global\nobotrulefalse%
\newif\ifnocaption\global\nocaptionfalse
\newif\ifframed\framedfalse
\newif\ifnotablenum
\newif\iftablefootnotenone\tablefootnotenonefalse
\newif\iftestbody\testbodytrue
\newif\ifbibchapter\global\bibchapterfalse
\newif\ifnumsqure\global\numsqurefalse
\newif\iffirstfm\global\firstfmtrue%
\newif\iffirstbm\global\firstbmfalse%
\newif\ifstartfm\global\startfmtrue%
\newif\ifdottedfmbmcontent\dottedfmbmcontentfalse%
\newif\iffixauthorcontent\fixauthorcontentfalse%
\newif\ifswitch@CH@bkm@no\global\switch@CH@bkm@nofalse%
\newif\iffixchapcontent\fixchapcontentfalse%
\newif\ifdottedchapcontent\dottedchapcontenttrue%
\newif\iffixfigurecontent\fixfigurecontentfalse%
\newif\ifdottedfigurecontent\dottedfigurecontenttrue%
\newif\iffixtablecontent\fixtablecontentfalse%
\newif\ifdottedtablecontent\dottedtablecontenttrue%
\newif\ifremoveaux\removeauxfalse%
\newif\ifspreadlong
\newif\ifcilayout\global\cilayoutfalse
\newif\ifmath\global\mathfalse
\newif\iftoptabcaption\global\toptabcaptionfalse
\newif\ifbottabcaption\global\bottabcaptiontrue
%
\@twosidetrue\@mparswitchtrue
\newcount\tempcount
\newcount\affcount\affcount0%
\newcount\afftempcount
\newcount\tempaffcount
\newcount\instcount\instcount0%
\newcount\insttempcount
\newcount\tempinstcount
\newcount\deptcount\deptcount0%
\newcount\depttempcount
\newcount\tempdeptcount
\newcount\streetcount\streetcount0%
\newcount\streettempcount
\newcount\tempstreetcount
\newcount\citycount\citycount0%
\newcount\citytempcount
\newcount\tempcitycount
\newcount\statecount\statecount0%
\newcount\statetempcount
\newcount\tempstatecount
\newcount\postcodecount\postcodecount0%
\newcount\postcodetempcount
\newcount\temppostcodecount
\newcount\countrycount\countrycount0%
\newcount\countrytempcount
\newcount\tempcountrycount
\newcount\refvaluecount
\newcount\temprefvaluecount
\newcount\refvaluetempcount
\newcount\enunheadcount
\newcount\tempenunheadcount
\newcount\enuntempcount
\newcount\algheadcount
\newcount\tempalgheadcount
\newcount\algtempcount
\newcount\authorcount\authorcount0%
\newcount\tempauthorcount\tempauthorcount0%
\newcount\authorcommacount\authorcommacount0%
\newcount\authortempcount\authortempcount0%
\newcount\keywordcount
\newcount\keytempcount
\newcount\tempkeywordcount
\newcount\minute
\newcount\hour
\newcount\authorcount \authorcount0%
\newcount\tempaffilcount
\newcount\authorcount \authorcount0%
\newcount\tempauthorcount \tempauthorcount0%
\newcount\affiliationcount \affiliationcount0%
\newcount\tempaffiliationcount \tempaffiliationcount0%
\newcount\tempcount
\newcount\affilcount
\newcount\affiltempcount
\newcount\tempaffilcount
\newcount\membercount
\newcount\membertempcount
\newcount\tempmembercount
\newcount\historycount
\newcount\historytempcount
\newcount\temphistorycount
\newcount\historycount
\newcount\historytempcount
\newcount\temphistorycount
\newcount\symtempcount
\newcount\tfootcount\global\tfootcount0
\newcount\temptfootcount%
\newcount\tbodycount\global\tbodycount0
\newcount\tgroupcount\tgroupcount0
\newcount\bcount
\newcount\ncount\ncount=1
\newcount\ccount\ccount=1
\newcount\acomcount
\newcount\tempacomcount
\newcount\acomtempcount
\newcount\TotalCharCount\TotalCharCount0
\newcount\seccount%
\newcount\authcount%
\newcount\SCOUNT
\newcount\HCOUNT
\newcount\fpcount
\newcount\viper@penalty
\newcount\AQpage\AQpage0%
\newcount\AQlpage\AQlpage0%
\newcounter{afrfilnote}
\newcounter {part}
\newcounter {chapter}
\newcounter {HLchapter}
\newcounter {section}[chapter]
\newcounter {subsection}[section]
\newcounter {subsubsection}[subsection]
\newcounter {paragraph}[subsubsection]
\newcounter {subparagraph}[paragraph]
\newcounter {HLsection}[HLchapter]%%%%
\newcounter {HLsubsection}[HLsection]%%%%
\newcounter {HLsubsubsection}[HLsubsection]%%%%
\newcounter {HLparagraph}[HLsubsubsection]%%%%
\newcounter {HLsubparagraph}[HLparagraph]%%%%
\newcounter {subsubparagraph}[subparagraph]%%%%
\newcounter {subsubsubparagraph}[subsubparagraph]%%%%
\newcounter {HLsubsubparagraph}%[HLsubparagraph]%%%%
\newcounter {HLsubsubsubparagraph}%[HLsubsubparagraph]%%%%
\newcounter{ncount}
\newcounter{figure}[chapter]
\newcounter{table}
\newcounter{samp}
\newcounter{abscount}
\newcounter{startendpage}
\newdimen\trimwidthval
\newdimen\trimwidthbleedval
\newdimen\trimheightval
\newdimen\trimheightbleedval
\newdimen\draftrule\draftrule0pt
\newdimen\trimrule\trimrule0pt
\newdimen\tempdimen%
\newdimen\normaltextheight%
\newdimen\blindfoliodrop%
\newdimen\enumdim%
\newdimen\figheight%
\newdimen\figwidth%
\newdimen\tabledim%
\newdimen\mathindent%
\newdimen\emathindent%
\newdimen\bibindent%
\newdimen\metaleftskip\metaleftskip0pt
\newdimen\metarightskip\metarightskip0pt
\newdimen\@partialpageht
\newdimen\storedboxheight
\newdimen\LabelSep \LabelSep4.7pt
\newdimen\leftmarginvii
\newdimen\leftmarginviii
\newdimen\leftmarginix
\newdimen\leftmarginx
\newdimen\enumdimwd
\newdimen\itemleftmargin
\newdimen\itemlabelsep
\newdimen\figcadimen
\newdimen\captionwidth
\newdimen\figindent
\newdimen\figwidthcapdimen
\newdimen\exfigdimwd
\newdimen\figdim
\newdimen\tabledim%
\newdimen\sidetskip\sidetskip=0pt%
\newdimen\sideverticalskip\sideverticalskip=0pt
\newdimen\tablecaptionheight
\newdimen\sidetskip\sidetskip0pt
\newdimen\sideverticalskip\sideverticalskip0pt
\newdimen\tablewidth
\newdimen\tablewidthshade
\newdimen\fboxtablewidth
\newdimen\tablewidth
\newdimen\extratableheight
\newdimen\tablebodywidth
\newdimen\tableheight
\newdimen\fboxgrtypewidth
\newdimen\toprulewidth
\newdimen\midrulewidth
\newdimen\botrulewidth
\newdimen\cmidrulewidth
\newdimen\belowrulesep
\newdimen\belowbottomsep
\newdimen\aboverulesep
\newdimen\abovetopsep
\newdimen\cmidrulesep
\newdimen\cmidrulekern
\newdimen\defaultaddspace
\newdimen\@thisrulewidth
\newdimen\foot@parindent
\newdimen\ptdraftrule
\newdimen\ptdraftrule
\newdimen\temptextheight
\newdimen\bibindent
\newdimen\bibleftmargin
\newdimen\bibitemsep
\newdimen\bibparsep
\newdimen\bibtext
\newdimen\biblabelsep
\newdimen\bibleftmargini
\newdimen\chapwidth%
\newdimen\secnwidth%
\newdimen\subsecnwidth%
\newdimen\subsubsecnwidth%
\newdimen\pldim%
\newdimen\authorcontentwidth%
\newdimen\@secmaxnumdim%
\newdimen\secnwidth%
\newdimen\@subsecmaxnumdim%
\newdimen\subsecnwidth%
\newdimen\@figuremaxnumdim%
\newdimen\figurecontwidth%
\newdimen\@tablemaxnumdim%
\newdimen\tablecontwidth%
\newdimen\tempdim
\newdimen\presentfigwidth
\newdimen\oldfigwidth
\newdimen\remainingtextwidth
\newdimen\letterwidth%
\newdimen\letterheight%
\newdimen\legalwidth%
\newdimen\legalheight%
\newdimen\tabloidwidth%
\newdimen\tabloidheight%
\newdimen\@tempdima%%
\newdimen\@tempdimb%%
\newdimen\@tempdimc%%
\newdimen\@tempdimd%%
\newdimen\@tempdime%%
\newdimen\deflistmaxskip
\newdimen\deflistskip%
\newdimen\myskip%
\newdimen\ht@viper
\newbox\hisbox
\newbox\tempbox%
\newbox\abstractbox%
\newbox\store@outputbox
\newbox\keywordbox
\newbox\subbox
\newbox\tabimagebox
\newbox\citybox
\newbox\statebox
\newbox\pscodebox
\newbox\countrybox
\newbox\addlinebox
\newbox\instbox
\newbox\instnamebox
\newbox\deptbox
\newbox\zipbox
\newbox\provincebox
\newbox\phonebox
\newbox\faxbox
\newbox\deflistbox
\newbox\boxBibH
\newbox\onlinefibox
\newbox\onlinefiibox
\newbox\v@aaa
\newbox\v@ccc
\newbox\authrun
\newbox\plainCOPbox%
\newbox\colorCOPbox%
\newbox\chap@tempbox%
\newbox\tempabox
\newbox\figcapbox
\newbox\figtempbox
\newbox\tabcapbox
\newbox\tablefootbox
\newbox\temptbox
\newbox\tempttbox
\newbox\temptttbox
\newbox\tempttttbox
\newbox\tabletempboxsecond
\newbox\tabletempboxthird
\newbox\boxcont
\newbox\titrun
\newskip\normalbaselineskip%
\newskip\tableleftskip%
\newskip\tablerightskip%
\newskip\tabnoteleftskip%
\newskip\tabnoterightskip%
\newskip\colmargin
\newskip\texttypewidthsep
\newskip\authorbelowskip
\newskip\headlineindent
\newskip\instindent
\newskip\topsepi
\newskip\topsepii
\newskip\topsepiii
\newskip\topsepiv
\newskip\topsepv
\newskip\topsepvi
\newskip\topsepvii
\newskip\topsepviii
\newskip\topsepix
\newskip\topsepx
\newskip\itemsepi
\newskip\itemsepii
\newskip\itemsepiii
\newskip\itemsepiv
\newskip\itemsepv
\newskip\itemsepvi
\newskip\itemsepvii
\newskip\itemsepviii
\newskip\itemsepix
\newskip\itemsepx
\newskip\listtextleftmargin
\newskip\listtextleftmarginii
\newskip\listtextleftmarginiii
\newskip\listtextleftmarginiv
\newskip\listtextleftmarginv
\newskip\listtextleftmarginvi
\newskip\listtextleftmarginvii
\newskip\listtextleftmarginviii
\newskip\listtextleftmarginix
\newskip\listtextleftmarginx
\newskip\listtextrightmargin
\newskip\listlabelleftskip
\newskip\listlabelleftskipii
\newskip\listlabelleftskipiii
\newskip\listlabelleftskipiv
\newskip\listlabelleftskipv
\newskip\listlabelleftskipvi
\newskip\listlabelleftskipvii
\newskip\listlabelleftskipviii
\newskip\listlabelleftskipix
\newskip\listlabelleftskipx
\newskip\abovelistskipi
\newskip\belowlistskipi
\newskip\abovelistskipii
\newskip\belowlistskipii
\newskip\abovelistskipiii
\newskip\belowlistskipiii
\newskip\abovelistskipiv
\newskip\belowlistskipiv
\newskip\abovelistskipv
\newskip\belowlistskipv
\newskip\abovelistskipvi
\newskip\belowlistskipvi
\newskip\abovelistskipvii
\newskip\belowlistskipvii
\newskip\abovelistskipviii
\newskip\belowlistskipviii
\newskip\abovelistskipix
\newskip\belowlistskipix
\newskip\abovelistskipx
\newskip\belowlistskipx
\newskip\labelsepi
\newskip\labelsepii
\newskip\labelsepiii
\newskip\labelsepiv
\newskip\labelsepv
\newskip\labelsepvi
\newskip\labelsepvii
\newskip\labelsepviii
\newskip\labelsepix
\newskip\labelsepx
\newskip\unnumlistitemindent
\newskip\unnumlisttextskip
\newskip\figcaptionleftskip
\newskip\figcaptionrightskip
\newskip\figleftskip
\newskip\figrightskip
\newskip\adjustskip
\newskip\sidetskip\sidetskip=0pt
\newskip\sideverticalskip\sideverticalskip=0pt
\newskip\fignumcapsep\fignumcapsep=5pt
\newskip\figcapdescsep\figcapdescsep=0pt
\newskip\tableleftskip%
\newskip\tablerightskip%
\newskip\tablecapleftskip%
\newskip\tablecaprightskip%
\newskip\sideverticalskip
\newskip\sidetskip
\newskip\addtotablewidth
\newskip\tablenumcapsep
\newskip\tablefootleftskip
\newskip\tablefootrightskip
\newskip\manshowtfootskip
\newskip\footnoteabovespace
\newskip\fixfmbmcontentwidth
\newskip\fixauthorcontentwidth
\newskip\fixchapcontentwidth
\newskip\enspacechapcontentwidth
\newskip\enspacefigurecontentwidth
\newskip\fixfigurecontentwidth
\newskip\fixtablecontentwidth
\newskip\enspacetablecontentwidth
\newskip\@mathmargin
\newskip\verbatimindent
\newskip\CRskip
\newlength\subtitleval
\newlength\abovecaptionskip
\newlength\belowcaptionskip
\newlength\trimwidth%
\newlength\trimheight%
\newlength\typewidth%
\newlength\typeheight%
%
\newtoks\authorrunning
\newtoks\titlerunning
\newtoks\CharCounttoks
\newwrite\@maintab%%
\newwrite\@mainndx
\DeclareOption{reviewer}{\global\reviewertrue}
\DeclareOption{OA}{\global\OAtrue}
\DeclareOption{showframe}{\global\showframetrue}
\DeclareOption{noundrule}{\global\noundruletrue}
\DeclareOption{callforpaper}{\global\callforpapertrue}
\DeclareOption{EPF}{\global\EPFtrue}
\DeclareOption{pdfcreate}{\global\pspdfcreatetrue}%
\DeclareOption{lettersize}{\lettersizetrue\legalsizefalse\tabloidsizefalse}%
\DeclareOption{legalsize}{\lettersizefalse\legalsizetrue\tabloidsizefalse}%
\DeclareOption{tabloidsize}{\lettersizefalse\legalsizefalse\tabloidsizetrue}%
\DeclareOption{registermark}{\registermarktrue}
\DeclareOption{keyedin}{\keyedintrue}
\DeclareOption{dbleed}{\global\dbleedtrue}
\DeclareOption{supertitle}{\global\supertitletrue}
\DeclareOption{bkmerge}{\global\bkmergetrue}
\DeclareOption{fp}{\global\firstprooftrue}
\DeclareOption{guestedit}{\global\guestedittrue}
\DeclareOption{research}{\global\researchtrue}
\DeclareOption{revises}{\global\revisestrue}
\DeclareOption{finals}{\global\finalstrue\global\noquerytrue}
\DeclareOption{issue}{\global\@issuetrue}
\DeclareOption{bakoma}{\global\bakomatrue\global\onlinetrue}
\DeclareOption{webpdf}{\global\onlinetrue\global\noquerytrue\global\figsizechecktrue}
\DeclareOption{colorimage}{\global\colorimagetrue\global\bwimagetrue}
\DeclareOption{bwimage}{\global\bwimagetrue}
\DeclareOption{preview}{\global\previewtrue\global\onlinetrue\global\noquerytrue}
\DeclareOption{ELD}{\global\onlinetrue\global\noquerytrue}
\DeclareOption{repro}{\reprotrue}
\DeclareOption{noquery}{\noquerytrue}
\DeclareOption{natbiboff}{\global\natbibofftrue}
\DeclareOption{eqnum}{\global\eqnumtrue}
\DeclareOption{countempty}{\countemptytrue}
\DeclareOption{draft}{\setlength\overfullrule{5pt}\draftrule.25pt\drafttrue\global\floatidtrue}
\DeclareOption{ddraft}{\setlength\overfullrule{5pt}\draftrule.25pt\drafttrue}
\DeclareOption{online}{\global\onlinetrue}
\DeclareOption{final}{\setlength\overfullrule{0pt}}
\DeclareOption{contact}{\setlength\overfullrule{0pt}\contacttrue}
\DeclareOption{nolinenum}{\global\nolinenotrue}
\DeclareOption{printer}{\setlength\overfullrule{0pt}\trimrule0pt\printertrue}
\DeclareOption{purexml}{\global\puretexfalse}
\DeclareOption{puretex}{\global\puretextrue}
\DeclareOption{mathtif}{\global\mathtiftrue\global\puretextrue}
\DeclareOption{bookreview}{\global\bookreviewtrue}
\DeclareOption{noranges}{\global\norangestrue}
\DeclareOption{nodoi}{\global\nodoitrue}
\DeclareOption{nokeyword}{\global\nokeywordtrue}
\DeclareOption{nocopyright}{\global\nocopyrighttrue}
\DeclareOption{nocopysymb}{\global\nocopysymbtrue}
\DeclareOption{singlepage}{\global\singlepagetrue}
\DeclareOption{callpaper}{\global\callpapertrue}
\DeclareOption{texteditor}{\global\texteditortrue}
\DeclareOption{editorial}{\global\editorialtrue}
\DeclareOption{noauthor}{\global\noauthortrue}
\DeclareOption{dhead}{\global\dheadtrue}
\DeclareOption{noabstract}{\global\noabstracttrue}
\DeclareOption{corrigendum}{\global\corrigendumtrue}
\DeclareOption{supplementary}{\global\supplementarytrue}
\DeclareOption{bkblurb}{\global\bkblurbtrue}
\DeclareOption{splissue}{\global\splissuetrue}
\DeclareOption{announcement}{\global\announcementtrue}
\DeclareOption{erratum}{\global\erratumtrue}
\ExecuteOptions{final}
\ProcessOptions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%Standard Packages
\usepackage{etex}
\usepackage{amsthm}
\usepackage{soul}
\usepackage{calc}
\usepackage{color}
\usepackage{ifxetex,ifluatex}
\definecolor{shadecolor}{cmyk}{0,0,0,.12}
\definecolor{absshadecolor}{cmyk}{0,0,0,.12}
\usepackage{framed}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%Standard Packages
\newcommand\contentsname{Contents}
\newcommand\listfigurename{List of Figures}
\newcommand\listtablename{List of Tables}
\newcommand\bibname{References}
\newcommand\indexname{Index}
\newcommand\figurename{Figure}
\newcommand\tablename{Table}
\newcommand\partname{Part}
\newcommand\chaptername{Chapter}
\newcommand\appendixname{Appendix}
%
\newcommand\today{\ifcase\month\or
January\or February\or March\or April\or May\or June\or
July\or August\or September\or October\or November\or December\fi
\space\number\day, \number\year}
%
\def\currenttime{%
\minute\time
\hour\minute
\divide\hour60
\the\hour:\multiply\hour60\advance\minute-\hour\the\minute}
%
%\def\jobtag{\@currname\ {\bf\uppercase{Sample Elements for Quick Reference}}}%%
%\def\jobtag{{\bf LaTeX Sample Elements for Quick Reference}}%%
%\def\@pushfilename{%
% \xdef\@currnamestack{%
% {\@currname}%
% {\@currext}%
% {\the\catcode`\@}%
% \@currnamestack}}%
%\@onlypreamble\@pushfilename%
%\@pushfilename%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Boxes & Dimensions %%%%%%%%%%%%%%%%%
%
\def\mdash{\unskip~--\ \ignorespaces}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Fonts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Credit Line font
\def\psplainfont{\fontsize{7.5}{9.5}\selectfont}
\def\doiplainfont{\fontsize{8.47}{10}\selectfont\rightskip0pt plus1fill}
%% headings
\def\rhfont{\fontsize{10}{10}\itshape\selectfont}
\def\foliofont{\fontsize{10}{10}\selectfont}
\def\myfoliofont{\fontsize{10.5}{10.5}\fontfamily{\sfdefault}\selectfont}
\def\dropfoliofont{\foliofont}
\def\jvolfont{\fontsize{10}{10}\bfseries\selectfont}
%% part
\def\PNfont{\fontsize{50}{50}\bfseries\selectfont\leftskip0pt plus1fill\rightskip-10pc plus1fill}
\def\PTfont{\fontsize{32}{38}\bfseries\selectfont\leftskip0pt plus1fill\rightskip-10pc plus1fill}%\leftskip.5pc plus1fill\rightskip.5pc plus1fill}
\def\PSTfont{\fontsize{13}{15}\bfseries\selectfont}%\leftskip.5pc plus1fill\rightskip.5pc plus1fill}
%% chapter
\def\abstractfont{\fontsize{9}{11}\selectfont}
\def\abstractheadfont{\fontsize{10}{12}\bfseries\selectfont\centering}
\def\keywordfont{\fontsize{9}{10}\selectfont}
\def\authorfont{\fontsize{10}{12}\selectfont\centering}
\def\continuedfont{\fontsize{8}{8}\itshape\selectfont}
%% section
\def\sectionfont{\fontsize{10}{12}\bfseries\selectfont\leftskip0pt plus1fill\rightskip0pt plus1fill}%\mathversion{sfsansbold}
\def\subsectionfont{\fontsize{10}{12}\bfseries\itshape\selectfont\leftskip0pt plus1fill\rightskip0pt plus1fill}
\def\subsubsectionfont{\fontsize{10}{12}\itshape\selectfont\leftskip0pt plus1fill\rightskip0pt plus1fill}%yet to check
\def\paragraphfont{\bfseries}%
\def\subparagraphfont{}%
\def\subsubparagraphfont{}%
%
\def\sectionnumfont{\sectionfont}
\def\subsectionnumfont{\subsectionfont}
%
%% figure
\def\figcaptionfont{\fontsize{9}{11}\selectfont}
\def\figcaptiondescfont{\fontsize{9}{11}\selectfont}
\def\figcaptionnumfont{\fontsize{9}{11}\selectfont}
\def\figattribfont{\fontsize{9}{11}\selectfont}
%% TABLE
\def\multilistfont{\fontsize{8.5}{10}\selectfont\leftskip\tableleftskip\rightskip\tablerightskip}%
\def\multilistheadfont{\fontsize{8.5}{10}\bfseries\selectfont\leftskip\tableleftskip\rightskip\tablerightskip}%
\def\tablefont{\fontsize{9}{11}\selectfont}%
\def\tablecaptionfont{\fontsize{9}{11}\selectfont}%
\def\tablecaptwofont{\fontsize{9}{11}\selectfont}%
\def\tablecaptionnumfont{\fontsize{10}{11}\selectfont\rm}%
\def\TCHfont{\fontsize{9}{11}\selectfont}%
\def\TSCHfont{}%
\def\tabnotefont{\fontsize{9}{10}\selectfont}% use plus 1fill if needed
%% Long-Table
\def\LTtablecaptionfont{\fontsize{9}{11}\itshape\selectfont}%
\def\LTtablenotefont{\fontsize{8.5}{10}\selectfont}%
%% BM
\def\indexfont{\footnotesize\raggedright}
\def\bibliofont{\fontsize{9}{11}\selectfont}
\def\appfont{\fontsize{9}{10}\selectfont}
%
\def\listfont{}
\def\listdevicefont{}
\def\extractfont{\fontsize{9}{11}\selectfont\leftskip12pt\rightskip\leftskip}
%
%
\def\supertitlefont{\fontsize{16}{18}\bfseries\selectfont\centering\mathversion{bold}}
\def\supertitleitfont{\fontsize{18}{20}\itshape\selectfont\centering\mathversion{normal}}
\def\Dheadeditorfont{\fontsize{14}{16}\itshape\selectfont\centering\mathversion{normal}}
%
\def\sixtnptfont{\fontsize{16}{20}\bfseries\selectfont}
\def\twlptfont{\fontsize{12}{12}\selectfont}
\def\twlveptfont{\fontsize{12}{14}\selectfont}
\def\twlbptfont{\fontsize{12}{12}\bfseries\selectfont}
\def\eightnfont{\fontsize{18}{20}\bfseries\selectfont}
\def\fortnfont{\fontsize{14}{16}\bfseries\selectfont}
\def\fortnrfont{\fontsize{14}{16}\selectfont}
\def\tenptfont{\fontsize{10}{10}\bfseries\selectfont}
\def\nineptfont{\fontsize{9}{9}\selectfont}
\def\ninetenfont{\fontsize{9}{10}\selectfont}
\def\ninehptfont{\fontsize{8.7}{9}\selectfont}
\def\eightptfont{\fontsize{8}{8}\selectfont}
\def\eighthptfont{\fontsize{8.5}{10}\bfseries\selectfont}
\def\sevenptfont{\fontsize{7}{8}\selectfont}
\def\sevenhptfont{\fontsize{7.5}{8.5}\selectfont}
\def\sixptfont{\fontsize{6}{7}\selectfont}
\def\sixhptfont{\fontsize{6.5}{8}\selectfont}
\def\sixedfont{\fontsize{6}{7}\selectfont\leftskip12pt\rightskip0pt plus1fill}
\def\sixhedfont{\fontsize{5.7}{7}\selectfont\leftskip12pt\rightskip0pt plus1fill}
\def\sixfont{\fontsize{6}{7}\selectfont}
\def\sevenaufont{\fontsize{7}{7}\itshape\selectfont}
\def\historyfont{\fontsize{7}{9}\fontfamily{\sfdefault}\selectfont}
\def\titlefont{\fontsize{18}{21}\selectfont\centering\itshape}%\bfseries
\def\corresfont{\fontsize{7}{9}\fontfamily{\sfdefault}\selectfont}
%\def\subtitlefont{\normalfont\iftitval\fontsize{12}{14}\selectfont\else\fontsize{18}{20}\selectfont\fi\itshape\centering}
\def\keyfont{\fontsize{8}{10}\fontfamily{\sfdefault}\selectfont}
\def\keyheadfont{\fontsize{8}{10}\fontfamily{\sfdefault}\selectfont}
\def\absheadfont{\fontsize{12}{12}\fontfamily{\sfdefault}\selectfont}
\def\acknowfont{\fontsize{7}{9}\selectfont}
\def\headifont{\fontsize{10}{12}\fontfamily{\sfdefault}\selectfont\leftskip0pt plus1fill\rightskip0pt plus1fill}
\def\refheadfont#1{#1}
\def\affilfont{\fontsize{8}{10}\selectfont\itshape\centering}
%
%%%%%%%%%%%%%%%%%%%%%%%%% Fonts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%% Fonts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\def\colorone{\special{color push cmyk 0.8 0.3 0.1 0}}%1
\def\colortwo{\special{color push cmyk 0.70 0 0.05 0.25}}%2
\def\colorthree{\special{color push cmyk 0.20 0.60 1.0 0}}%3
\def\colorfour{\special{color push cmyk 0 0 0.35 0}}%4%
\def\colorfive{\special{color push cmyk 1.0 0 0 0.30}}%5
\def\colorsix{\special{color push cmyk 0 0.15 0.60 0.05}}%6
\def\colorseven{\special{color push cmyk 0 1.0 0 0.40}}%7
\def\coloreight{\special{color push cmyk 0.80 0 0.70 0.35}}%8
\def\colornine{\special{color push cmyk 0.20 0 0.20 0.05}}%9
\def\colorten{\special{color push cmyk 0 1.0 1.0 0.60}}%10
\def\coloreleven{\special{color push cmyk 0.25 0 0.95 0.35}}%11
\def\colortwelve{\special{color push cmyk 1.0 0 0.35 0}}%12
\def\colorthirteen{\special{color push cmyk 0.15 0 0 0}}%13%
\def\colorfourteen{\special{color push cmyk 0 0 0.05 0.05}}%14
\def\colorfifteen{\special{color push cmyk 0 0 0.30 0.20}}%15%
\def\colorsixteen{\special{color push cmyk 0.50 0 0 0}}%16
\def\colorseventeen{\special{color push cmyk 0 0 0.12 0.08}}%17
\def\coloreighteen{\special{color push cmyk 0 0.30 1.0 0.20}}%18
%
\def\magentahundred{\special{color push cmyk 0 1.0 0 0}}%
\def\cyanhundred{\special{color push cmyk 1.0 0 0 0}}%
\def\cyanten{\special{color push cmyk 0.10 0 0 0}}%
\def\colorfourtenp{\special{color push cmyk 0 0 0.10 0}}%4%
\def\coloreighteentenp{\special{color push cmyk 0 0.03 0.10 0.02}}%18
\def\coloreighteenfiftyp{\special{color push cmyk 0 0.15 0.50 0.10}}%18
\def\colorseventenp{\special{color push cmyk 0 0.1 0 0.04}}%7
\def\colorsevenfiftyp{\special{color push cmyk 0 0.8 0 0.30}}%7
\def\coloreleventenp{\special{color push cmyk 0.025 0 0.095 0.035}}%11
\def\colorninetenp{\special{color push cmyk 0.05 0 0.05 0.010}}%9
\def\singlepagelabel{\global\singlepagetrue}
%
\def\endmark{}
%
\def\spreadout#1{%
\gdef\temp{#1}%
\dimen0 = \spreadoutfactor pt
\ifdim\dimen0=\z@\temp\else % If the spreadoutfactor
\expandafter\dospreadout\temp\endmark\kern-\dimen0\fi} % is zero, then we can use kern or hskip
% % with the title etc. Suppressed the extra space
% % after spreadout.
\def\dospreadout{%
\afterassignment\findospreadout
\let\next= }
%
\def\findospreadout{%
\ifx\next\endmark
\let\nextaction = \relax
\else
\let\nextaction = \dospreadout
\next
\kern\dimen0
\fi
\nextaction}
%
%
\def\@xipt{11}
\def\@xvpt{15}
\def\@xviiipt{18}
\def\@xxivpt{24}
%
\normalbaselineskip12\p@
%
\renewcommand\normalsize{%
\@setfontsize\normalsize{10}{13}
\abovedisplayskip6\p@% plus1pt minus1pt
\abovedisplayshortskip\abovedisplayskip
\belowdisplayshortskip\abovedisplayskip
\belowdisplayskip \abovedisplayskip
\let\@listi\@listI}
\def\biggg#1{{\hbox{$\left#1\vbox to20.5\p@{}\right.\n@space$}}}
\def\Biggg#1{{\hbox{$\left#1\vbox to23.5\p@{}\right.\n@space$}}}
\normalsize
%
\newcommand\small{%
\@setfontsize\small\@ixpt{11}%
\abovedisplayskip 8.5\p@ \@plus3\p@ \@minus4\p@
\abovedisplayshortskip \z@ \@plus2\p@
\belowdisplayshortskip 4\p@ \@plus2\p@ \@minus2\p@
\def\@listi{\leftmargin\leftmargini
\topsep 4\p@ \@plus2\p@ \@minus2\p@
\parsep 2\p@ \@plus\p@ \@minus\p@
\itemsep \parsep}%
\belowdisplayskip \abovedisplayskip
\setSmallDelims
}
%
\def\setSmallDelims{%
\def\big##1{{\hbox{$\left##1\vbox to7.5\p@{}\right.\n@space$}}}%
\def\Big##1{{\hbox{$\left##1\vbox to10.5\p@{}\right.\n@space$}}}%
\def\bigg##1{{\hbox{$\left##1\vbox to13.5\p@{}\right.\n@space$}}}%
\def\Bigg##1{{\hbox{$\left##1\vbox to16.5\p@{}\right.\n@space$}}}%
\def\biggg##1{{\hbox{$\left##1\vbox to19.5\p@{}\right.\n@space$}}}%
\def\Biggg##1{{\hbox{$\left##1\vbox to22.5\p@{}\right.\n@space$}}}%
}
%
\newcommand\footnotesize{%
\@setfontsize\footnotesize\@viiipt{9}%
\abovedisplayskip 6\p@ \@plus2\p@ \@minus4\p@
\abovedisplayshortskip \z@ \@plus\p@
\belowdisplayshortskip 3\p@ \@plus\p@ \@minus2\p@
\def\@listi{\leftmargin\leftmargini
\topsep 3\p@ \@plus\p@ \@minus\p@
\parsep 2\p@ \@plus\p@ \@minus\p@
\itemsep \parsep}%
\belowdisplayskip \abovedisplayskip
\setFootnotesizeDelims}
%
\def\setFootnotesizeDelims{%
\def\big##1{{\hbox{$\left##1\vbox to6.5\p@{}\right.\n@space$}}}%
\def\Big##1{{\hbox{$\left##1\vbox to9.5\p@{}\right.\n@space$}}}%
\def\bigg##1{{\hbox{$\left##1\vbox to12.5\p@{}\right.\n@space$}}}%
\def\Bigg##1{{\hbox{$\left##1\vbox to15.5\p@{}\right.\n@space$}}}%
\def\biggg##1{{\hbox{$\left##1\vbox to18.5\p@{}\right.\n@space$}}}%
\def\Biggg##1{{\hbox{$\left##1\vbox to21.5\p@{}\right.\n@space$}}}%
}
%
\newcommand\scriptsize{\@setfontsize\scriptsize\@vipt\@viipt}
\newcommand\tiny{\@setfontsize\tiny\@vpt\@vipt}
\newcommand\large{\@setfontsize\large\@xiipt{14}}
\newcommand\Large{\@setfontsize\Large\@xivpt{18}}
\newcommand\LARGE{\@setfontsize\LARGE\@xviipt{22}}
\newcommand\huge{\@setfontsize\huge\@xxpt{25}}
\newcommand\Huge{\@setfontsize\Huge\@xxvpt{30}}
%
\DeclareOldFontCommand{\rm}{\normalfont\rmfamily}{\mathrm}
\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf}
\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt}
\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf}
\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit}
\DeclareOldFontCommand{\sl}{\normalfont\slshape}{\@nomath\sl}
\DeclareOldFontCommand{\sc}{\normalfont\scshape}{\@nomath\sc}
\DeclareOldFontCommand{\bi}{\bfseries\itshape}{\bfseries\itshape}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Parameters %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\colmargin=0pc
\texttypewidthsep=0pc
%
\setlength\trimheight{702.7pt}%9.72in
\setlength\trimwidth{495pt}%6.85in
%
\setlength\normaltextheight{\textheight}%
\setlength\textwidth{359.8pt}%
\setlength\textheight{45\baselineskip}%
\setlength\typewidth{\textwidth}%
\setlength\typeheight{\textheight}%
%
\setlength\topmargin{35.7pt}%
\setlength\oddsidemargin{59.5pt}%
\setlength\evensidemargin{75pt}%
%
\setlength\headheight{12.5\p@}%
\setlength\headsep {14.5pt}% \typeheight - \textheight - \headheight
\setlength\topskip {10\p@}
%
\setlength\footskip{18.5pt}
\setlength\maxdepth{45\baselineskip}
%
%\blindfoliodrop\trimheight
%\advance\blindfoliodrop-\typeheight
%\advance\blindfoliodrop-\topmargin
%\advance\blindfoliodrop-\footskip
%\advance\blindfoliodrop18pt
%
\setlength\parindent{10pt}
%
\setlength\marginparwidth {.75in}
\setlength\marginparsep{6\p@}
\setlength\marginparpush{5\p@}
%
\setlength\footnotesep{\z@}
\setlength{\skip\footins}{12\p@ \@plus 3\p@ \@minus 3\p@}% \@plus 8\p@ \@minus 8\p@}% change + based on FN font height
\skip\@mpfootins = \skip\footins
%
\setlength\floatsep {12\p@ \@plus 2\p@ \@minus 2\p@}
\setlength\textfloatsep{10\p@ \@plus 2\p@ \@minus 4\p@}
\setlength\intextsep {12\p@ \@plus 2\p@ \@minus 2\p@}
\setlength\dblfloatsep {12\p@ \@plus 2\p@ \@minus 2\p@}
\setlength\dbltextfloatsep{20\p@ \@plus 2\p@ \@minus 4\p@}
\setlength\@fptop{0\p@}
\setlength\@fpsep{8\p@ \@plus 1fil}
\setlength\@fpbot{0\p@ \@plus 1fil}
\setlength\@dblfptop{0\p@}
\setlength\@dblfpsep{8\p@ \@plus 1fil}
\setlength\@dblfpbot{0\p@ \@plus 1fil}
%
\setlength\partopsep{0pt}
\setlength\lineskip{1\p@}% check if it can be flexible
\setlength\normallineskip{1\p@}%
\renewcommand\baselinestretch{}
\setlength\parskip{\z@}%{0\p@ \@plus \p@}
\@lowpenalty 51
\@medpenalty 151
\@highpenalty 301
%
\@beginparpenalty -\@lowpenalty
\@endparpenalty -\@lowpenalty
\@itempenalty -\@lowpenalty
%
\trimwidthval\the\trimwidth
\trimheightval\the\trimheight
\trimwidthbleedval\trimwidthval
\advance\trimwidthbleedval.25in
\trimheightbleedval\trimheightval
\advance\trimheightbleedval.25in
\def\thepaperwidth{\the\trimwidthval}
\def\thepaperheight{\the\trimheightval}
\def\thebleedpaperwidth{\the\trimwidthbleedval}
\def\thebleedpaperheight{\the\trimheightbleedval}
\def\papwidth{\ifdbleed\thebleedpaperwidth\else\thepaperwidth\fi}
\def\papheight{\ifdbleed\thebleedpaperheight\else\thepaperheight\fi}
\ifx\ifxetex\ifluatex
\ifnum\pdfoutput=0
\AtBeginDvi{\special{papersize=\papwidth,\papheight}}
\else%
\pdfpagewidth=\papwidth \pdfpageheight=\papheight%
\fi%
\else
\paperwidth=\papwidth \paperheight=\papheight%
\fi
%
\newsavebox{\JFP@linecount@bx}
\newlength\JFP@linecount@bxht
\newcount\JFP@linecount
\JFP@linecount\@ne\relax
\def\JFP@mk@linecount{%
\savebox{\JFP@linecount@bx}[4em][t]{\parbox[t]{4em}{%
\normalsize%
\setlength{\JFP@linecount@bxht}{0pt}%
\loop{\color{black}\scriptsize\the\JFP@linecount}\\
\global\advance\JFP@linecount by \@ne
\addtolength{\JFP@linecount@bxht}{\baselineskip}%
\ifdim\JFP@linecount@bxht<\textheight\repeat
{\color{black}\scriptsize\the\JFP@linecount}\hfill
\global\advance\JFP@linecount by \@ne}}}
\def\JFP@linecountL{\ifnolineno\else%
\JFP@mk@linecount%\newsavebox{\JFP@linecount@bx}
\begin{picture}(0,0)%\newlength\JFP@linecount@bxht
\put(-35,-27){\usebox{\JFP@linecount@bx}}%\newcount\JFP@linecount
\end{picture}\fi}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Parameters %%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\mycolor#1{#1\special{color pop}}
%
\def\cyan{\special{color push cmyk 1.0 0 0 0}}
\def\magenta{\special{color push cmyk 0 1.0 0 0}}
%%
\def\grayten{\special{color push cmyk 0 0 0 .10}}
%
\def\@addmarginpar{\@next\@marbox\@currlist{\@cons\@freelist\@marbox
\@cons\@freelist\@currbox}\@latexbug\@tempcnta\@ne
\if@twocolumn
\if@firstcolumn \@tempcnta\m@ne \fi
\else
\if@mparswitch
\ifodd\c@page \else\@tempcnta\m@ne \fi
\fi
\if@reversemargin \@tempcnta -\@tempcnta \fi
\fi
\ifnum\@tempcnta <\z@ \global\setbox\@marbox\box\@currbox \fi
\@tempdima\@mparbottom
\advance\@tempdima -\@pageht
\advance\@tempdima\ht\@marbox
\ifdim\@tempdima >\z@
\@latex@warning@no@line {Marginpar on page \thepage\space moved}%
\else
\@tempdima\z@
\fi
\global\@mparbottom\@pageht
\global\advance\@mparbottom\@tempdima
\global\advance\@mparbottom\dp\@marbox
\global\advance\@mparbottom\marginparpush
\advance\@tempdima -\ht\@marbox
\global\setbox \@marbox
\vbox {\vskip \@tempdima
\box \@marbox}%
\global \ht\@marbox \z@
\global \dp\@marbox \z@
\kern -\@pagedp
\nointerlineskip
\hb@xt@\columnwidth
{\ifnum \@tempcnta >\z@
% \hskip\columnwidth \hskip20pt\hskip\marginparsep
\hskip\typewidth\hskip6pt
\else
\hskip -\marginparsep \hskip -\marginparwidth
\hskip-\colmargin\hskip-\texttypewidthsep\hskip-6pt
\fi
\box\@marbox \hss}%
\nointerlineskip
\hbox{\vrule \@height\z@ \@width\z@ \@depth\@pagedp}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Macro 2: TheoremLike Env. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%\renewcommand\thetheorem{\thechapter.\arabic{theorem}}
%%
%\def\newtheorem#1{\@starthm{#1}\@ifnextchar[{\@othm{#1}}{\@nthm{#1}}}
%\def\@starthm#1{\@namedef{#1*}{\@beginstarthm{#1}}%
%\@namedef{end#1*}{\@endstarthm{#1}}}
%%
%\def\@starthm#1{\@namedef{#1*}{\@beginstarthm{#1}}%
%\@namedef{end#1*}{\@endstarthm}}
%%
%\def\@beginstarthm#1{\@ifnextchar[{\@opargbeginstarthm{#1}}{\@opargbeginstarthm{#1}[]}}
%%
%\def\@opargbeginstarthm#1[#2]{\list{}{\topsep12pt plus2pt
% \def\@tempaa{#2}%
% \labelwidth0pt\labelsep9.5pt
% \leftmargin0pt
% \listparindent\parindent
% \edef\@Tempa{\csname #1name\endcsname}
% \def\makelabel##1{##1.}}
% \item[\hskip \labelsep{\csname#1headfont\endcsname \@Tempa{}\ifx\@tempaa\@empty\else\ (#2)\fi}]\csname#1font\endcsname}
%%
%\def\@endstarthm{\endlist}
%%
%\def\@xnthm#1#2[#3]{%
% \expandafter\@ifdefinable\csname #1\endcsname
% {\@definecounter{#1}\@newctr{#1}[#3]%
% \expandafter\xdef\csname the#1\endcsname{%
% \expandafter\noexpand\csname the#3\endcsname \@thmcountersep
% \@thmcounter{#1}}%
% \global\@namedef{#1}{\@thm{#1}{#2}{#1}}%
% \global\@namedef{end#1}{\@endtheorem}}}
%\def\@ynthm#1#2{%
% \expandafter\@ifdefinable\csname #1\endcsname
% {\@definecounter{#1}%
% \expandafter\xdef\csname the#1\endcsname{\@thmcounter{#1}}%
% \global\@namedef{#1}{\@thm{#1}{#2}{#1}}%
% \global\@namedef{end#1}{\@endtheorem}}}
%\def\@othm#1[#2]#3{%
% \@ifundefined{c@#2}{\@nocounterr{#2}}%
% {\expandafter\@ifdefinable\csname #1\endcsname
% {\global\@namedef{the#1}{\@nameuse{the#2}}%
% \global\@namedef{#1}{\@thm{#2}{#3}{#1}}%
% \global\@namedef{end#1}{\@endtheorem}}}}
%\def\@thm#1#2#3{%
% \refstepcounter{#1}%
% \@ifnextchar[{\@ythm{#1}{#2}{#3}}{\@xthm{#1}{#2}{#3}}}
%%
%\def\@xthm#1#2#3{%
% \@opargbegintheorem{#2}{\csname the#1\endcsname}{}{#3}\ignorespaces}
%\def\@ythm#1#2#3[#4]{%
% \@opargbegintheorem{#2}{\csname the#1\endcsname}{#4}{#3}\ignorespaces}
%%
%\def\@endtheorem{\par\addvspace{12pt plus2pt}\endlist}%
%%
%\def\@opargbegintheorem#1#2#3#4{\par\addvspace{6pt plus2pt}%
%% \renewcommand\labelenumi{{\itshape(\theenumi)}}%
%% \def\labelenumii{{\upshape(\theenumii)}}%
% \def\@tempa{#3}%
% \noindent{\csname #4headfont\endcsname\ifx\@tempa\empty#1\ #2\hskip9.9pt\else#1\ #2\hskip4pt({\reset@font{\itshape\bfseries#3}})\hskip9.7pt\fi}%
% \csname #4font\endcsname\ignorespaces}%
%%
%\def\@endtheorem{\par\addvspace{6pt plus2pt}}%
%%
%\def\examplename{Example}
%\newtheorem{example}{\examplename}%[chapter]
%\def\theexample{\thechapter.\arabic{example}}
%\def\examplefont{\itshape}
%\def\exampleheadfont{\bfseries}
%%
%\def\theoremname{Theorem}
%\newtheorem{theorem}{\theoremname}%[chapter]
%\def\thetheorem{\thechapter.\arabic{theorem}}
%\def\theoremfont{\itshape}
%\def\theoremheadfont{\bfseries}
%%
%\def\lemmaname{Proposition}
%\newtheorem{lemma}[theorem]{Proposition}
%%\newtheorem{lemma}{\lemmaname}[chapter]
%\def\thelemma{\thechapter.\arabic{lemma}}
%\def\lemmafont{\itshape}
%\def\lemmaheadfont{\bfseries}
%%
%\def\th@plain{%
% \let\thm@indent\noindent % no indent
% \thm@headfont{\bfseries}% heading font is bold
% \thm@preskip0pt
% \thm@postskip0pt}
\renewenvironment{proof}{\par\addvspace{6pt}\noindent\textbf{Proof}\hskip5.5pt}{\hfill$\blacksquare$\par\addvspace{6pt}}
\def\doitext{doi:}
\def\voltext{vol.}
\def\journaltitle#1{\gdef\journal@title{#1}}%
\def\jnlPage#1#2{\gdef\first@page{\thepage}\gdef\last@page{#2}}
\def\cpr#1{\gdef\@copyline{#1}}
\def\doival#1{\gdef\@doi{\doilink{#1}}}
\def\jnlDoiYr#1{\gdef\@cpyear{#1}}
\def\volno#1{\gdef\volume@no{#1}}
\def\isstext{No.}
\def\edtext{e}
\def\edno#1{\gdef\@edno{#1}}\edno{}%
\def\totalpg#1{\gdef\@totalpg{#1}}\totalpg{}%
%\def\ps@myplain{\spaceskip0pt\let\@mkboth\@gobbletwo%
% \let\@evenfoot\@empty
% \let\@oddfoot\@empty
% \def\@evenhead{%
% \hbox to 0pt{\vbox{\vspace*{4pt}%
% {{\psplainfont {\itshape\ifx\jshorttitle\undefined\journal@title\else\jshorttitle\fi}\kern3pt(\cpyear), \textit{\voltext}\ \volume@no,\ \textit{pp.}\ \first@page\ifsinglepage\else--\last@page\fi.\quad {\copyright}\ \copyright@owner}\ \cpyear\hfill\thepage}\vskip2pt\vbox{\psplainfont \doitext\ \@doi}}}}%
% \def\@oddhead{%
% \hbox to 0pt{\vbox{\vspace*{4pt}%
% {\psplainfont {\itshape\ifx\jshorttitle\undefined\journal@title\else\jshorttitle\fi}\kern3pt(\cpyear), \textit{\voltext}\ \volume@no,\ \textit{pp.}\ \first@page\ifsinglepage\else--\last@page\fi.\quad {\copyright}\ \copyright@owner\ \cpyear\hfill\thepage}\vskip2pt\vbox{\psplainfont\doitext\ \@doi}}}}}
\def\ps@myplain{\let\@mkboth\@gobbletwo%
\def\@evenfoot{}%
\def\@oddfoot{}%
\def\@evenhead{\JFP@linecountL%
\hbox to 0pt{\vbox to 0pt{\vspace*{4.9pt}%
{{\psplainfont\global\copoddheadtrue{\it\journal@title},\ \@totalpg\ pages,\ \@cpyear.\hspace{5.5pt}{{{\rhcopyright}\ \@copyline\ \@cpyear}}\hfill{\raisebox{-1.9pt}{\foliofont\thepage}}\par\vskip2.5pt{\vbox{\psplainfont\doitext\@doi}}}}\vss}\hss}}% %JG
\def\@oddhead{\JFP@linecountL%
\hbox to 0pt{\vbox to 0pt{\vspace*{4.9pt}%
{{\psplainfont\global\copoddheadtrue{\it\journal@title}\if@issue\ {\bf\volume@no},\ {\edtext\@edno}\else\fi,\ \@totalpg\ pages,\ \@cpyear.\hspace{5.5pt}{{{\rhcopyright}\ \@copyline\ \@cpyear}}\hfill{\raisebox{-1.9pt}{\foliofont\thepage}}\par\vskip2.5pt{\vbox{\psplainfont\doitext\@doi}}}}\vss}\hss}}%JG
}%
\def\OAtext{the terms of the Creative Commons Attribution licence (\href{http://creativecommons.org/licenses/by/4.0/}{http://creativecommons.org/licenses/by/4.0/}), which permits\newline
unrestricted re-use, distribution, and reproduction in any medium, provided the original work is properly cited.}
\def\ps@openaccess{\let\@mkboth\@gobbletwo%
\def\@oddhead{%
\hbox to 0pt{\vbox{\vspace*{4.9pt}%
{{\psplainfont\global\copoddheadtrue{\it\journal@title}\if@issue\ {\bf\volume@no},\ {\edtext\@edno}\else\fi,\ \@totalpg\ pages,\ \@cpyear.\hspace{5.5pt}{{{\rhcopyright}\ \@copyline\ \@cpyear}}. This is an Open Access article, distributed under\hfill{\raisebox{-1.9pt}{\foliofont\thepage}}\par{\psplainfont\OAtext\@par}{\vbox{\psplainfont\doitext\@doi}}}}}}}
\let\@evenfoot\@empty%
\let\@oddfoot\@empty%
\let\@evenhead\@oddhead}
\def\labelstyle#1{\reset@font\textrm{#1}}
\def\statementfont{\itshape}
\def\statementhead#1{\noindent\textsc{\@statelab}\reset@font\textrm{#1}}
\def\enunhead#1{\unskip%
\global\advance\enunheadcount1%
\expandafter\protected@xdef\csname enunhead\the\enunheadcount\endcsname{#1}}%
%
%\def\@begintheorem#1#2[#3]{%
% \deferred@thm@head{\the\thm@headfont \thm@indent%
% \@ifempty{#1}{\let\thmname\@gobble}{\let\thmname\@iden}%
% \@ifempty{#2}{\let\thmnumber\@gobble}{\let\thmnumber\@iden}%
% \@ifempty{#3}{\let\thmnote\@gobble}{\let\thmnote\@iden}%
% \thm@swap\swappedhead\thmhead{#1}{}{#3}%
% \thmheadnl\ignorespaces\unskip\enskip}%
% \ignorespaces}
%
%\newtheorem{bfenun}{\csname enunhead\the\enuntempcount\endcsname}
%
%\def\thmdot{\global\@thmdottrue}
%\gdef\theoremdot{\global\@thmdottrue}
%\gdef\thmop{\if@thmdot .\else:\fi}
%
%\newtheoremstyle{mytheorem}% <name>
% {0pt}% <Space above>
% {0pt}% <Space below>
% {}% <Body font>
% {1em}% <Indent amount>
% {\itshape}% <Theorem head font>
% {}% <Punctuation after theorem head>
% {.5em}% <Space after theorem heading>
% {\thmname{#1}\thmnumber{\@ifnotempty{#1}{ }}%
% \thmnote{ {\the\thm@notefont\textit{(#3)}}}}%
%
%\theoremstyle{mytheorem}
%\newtheorem{itenun}{\csname enunhead\the\enuntempcount\endcsname}
\def\alghead#1{\unskip%
\global\advance\algheadcount1%
\expandafter\protected@xdef\csname alghead\the\algheadcount\endcsname{#1}}%
\let\save@clearpage\clearpage
\let\save@outputpage\@outputpage
\def\store@outputpage{%
\global\setbox\store@outputbox \vbox to \storedboxheight{%
\leftline{\box\@outputbox}\vss}%
\noindent%\fbox
{\box\store@outputbox}%
\par%\vrule width\textwidth height1pt
\global\let\@outputpage\save@outputpage}
%
\def\balancepage{\@ifnextchar[{\balancecolpagebreak}{\balancecolpagebreak[0pt]}}
\def\balancecolpagebreak[#1]{\ifvmode\vadjust\fi{\vskip-\baselineskip%\vskip-12pt
\leftline{\vrule width\typewidth height\draftrule depth0pt}%
\expandafter\ifdim#1=0pt\vfill\else\vskip#1\fi}\pagebreak}
%
\def\balanceandcontinue{%
\par
\ifdim\pagegoal=\maxdimen
\else
\global\let\@outputpage\store@outputpage
\ifdim\@colht=\pagegoal
\global\storedboxheight\pagetotal
\else
\global\storedboxheight\@colht
\global\advance\storedboxheight-\pagegoal
\global\advance\storedboxheight\pagetotal
% \global\advance\storedboxheight12pt
\fi
\fi
\onecolumn
\global\switchcolstrue}
%
\def\TwoColumn{\@ifnextchar[{\@TwoColumn}{\@TwoColumn[]}}
\def\@TwoColumn[#1]{%
\balanceandcontinue
\let\clearpage\relax
\def\@tempa{#1}%
\ifx\@tempa\@empty
\twocolumn
\else
#1\global\@partialpageht\pagetotal\twocolumn
\fi
\let\clearpage\save@clearpage}
%
\def \TTwocolumn {%
\clearpage
\global\columnwidth\textwidth
\global\advance\columnwidth-\columnsep
\global\divide\columnwidth\tw@
\global\hsize\columnwidth
\global\linewidth\columnwidth
\global\@twocolumntrue
\global\@firstcolumntrue
\col@number \tw@
\@ifnextchar [\@topnewpage\@floatplacement}
%
\def\OOnecolumn{%
% \clearpage
\global\columnwidth\textwidth
\global\hsize\columnwidth
\global\linewidth\columnwidth
\global\@twocolumnfalse
\col@number \@ne
\@floatplacement}
%
\def\twotoonecol#1{\TwoColumn[#1]}
%
\newcommand\abstractname{Abstract}
\newenvironment{abstract}{\@afterheading\@afterindentfalse%
\global\setbox\abstractbox\vbox
\bgroup%
\ifnoabstract\else%{\affilfont\printaffil\@par\printmember\vskip64.5pt}%
\vskip1.5pt\vbox{\hrule \@height .25pt \@width 30.05pc\vskip8.5pt
{\abstractheadfont\abstractname\vskip9.5pt}}\fi
\abstractfont\@afterheading\@afterindentfalse}
{\ifnoabstract\else\par\vspace{17.5pt}\hrule \@height .25pt \@width 30.05pc\fi\egroup}
%
\def\abstractsource#1{%
\vskip3pt\rightline{\upshape#1}}
%
\def\introhead#1{\section*{#1}}%
%
\def\subchapter#1{\gdef\@subchapter{#1}}
\subchapter{}%
%
\newcommand{\aunote}[1]{\unskip%
\ifx\printcorres\undefined\else\printcorres\fi%
\protect\footnotetext{\corresfont$\protect\linktarget{auddag}{\ddagger}$\,#1}%
\textsuperscript{\protect\linkref{au\auid}{\textrm{\auid}}\textrm{,}}$\protect\linkref{auddag}{\ddagger}$}
\def\authorand{\unskip\unskip\ignorespaces{}and\ }%
%\newif\ifsubtitle\global\subtitlefalse
%\newbox\subtbox
%\newcommand{\subtitle}[1]{\global\subtitletrue\global\setbox\subtbox\vbox{\subtitlefont#1\vskip21.3pt}
%\protected@write\@auxout{}{\gdef\string\subtcheck{}}}
\newbox\authbox
\newenvironment{authgrp}{\global\setbox\authbox\vbox\bgroup\authorfont}{\vskip11pt\egroup}
\newbox\affbox
\newenvironment{affgrp}{\global\setbox\affbox\vbox\bgroup\affilfont }{\vskip22pt\egroup}
\newcommand{\AUSP}[1]{\def\spreadoutfactor{1.3}\spreadout{#1}}
\def\sn#1{\AUSP{#1}\ }
\def\gn#1{\AUSP{#1}}
\def\aff#1{\protect\textsuperscript{#1}}
\newbox\hisbox
\newcommand{\history}[1]{\global\setbox\hisbox\vbox{\historyfont#1\vskip24.5pt}}
\def\rec#1{\textit{Received\ #1}}
\def\rev#1{\textit{revised\ #1}}
\def\acc#1{\textit{accepted\ #1}}
\def\author#1{\uppercase{#1}\ }
\newcommand{\affiliation}[1]{{\vskip3pt\affilfont#1\vskip8pt}}
%\def\titaltval{O}
%\renewcommand{\title}[2][]{\xdef\@titalt{#1}\ifx\@titalt\titaltval\global\titvaltrue\else\global\titvalfalse\fi\gdef\@title{#2}}
\newbox\keybox
\def\keyhead{\noindent Key Words:\ }
\newenvironment{keywords}
{\global\setbox\keybox\vbox\bgroup\leftskip30pt
{\keyheadfont\keyhead}\keyfont}
{\@@par\egroup}
\newbox\jclassbox
\def\jclasshead{\noindent 2010 Mathematics Subject Classification:\ }
\newenvironment{jclass}
{\global\setbox\jclassbox\vbox\bgroup\leftskip30pt\vskip8.5pt
{\keyheadfont\jclasshead}\keyfont}
{\@@par\egroup}
\def\corresp#1{\gdef\printcorresp{{\reset@font\corsymi\char121}\kern4pt#1}}
\newcommand\ls{\kern.15em\relax}
\newcommand\ns{\kern.55em\relax}
\newcommand\maketitle{\@ifnextchar [{\m@ketitleone}{\m@ketitleone[n]}}
%\newcommand{\maketitle}[1][]{\MakeTitle}
\def\m@ketitleone[#1]{\par\ifOA\thispagestyle{openaccess}\else\thispagestyle{myplain}\fi%%
\begingroup%
\parindent0pt%
\renewcommand\thefootnote{\@fnsymbol\c@footnote}%
\def\@makefnmark{\rlap{\@textsuperscript{\normalfont\@thefnmark}}}%
%\long\def\@makefntext##1{##1}%
\@maketitle{#1}%
\renewcommand\thefootnote{}%
\footnotetext{{\corresfont\ifx\printcorresp\undefined\else\printcorresp\fi}}%
% \footnotetext{\centerline{\corresfont\vbox to -3.5pt{\printcorres}}}%
\endgroup%
\setcounter{footnote}{0}%
\global\let\@maketitle\relax
\global\let\maketitle\relax
\advance\keywordcount0%
\advance\authorcount0}
\def\pe@rl#1{\centering%
\if t#1 {\tpe@rl}\else
\if T#1 {\Tpe@rl}\else
\if f#1 {\fpe@rl}\else
\if F#1 {\Fpe@rl}\else
\if e#1 {\edpe@rl}\else
\if E#1 {\Edpe@rl}\else
\if o#1 {\otherpearl}\else
\fi
\fi
\fi
\fi
\fi
\fi
\fi}%
\def\spe@rl{\normalfont\LARGE\rmfamily}
\def\epe@rl#1{\par\vspace*{16\p@}\xdef\@shorttitle{#1}}
\def\tpe@rl{\spe@rl T\ls H\ls E\ls O\ls R\ls E\ls T\ls
I\ls C\ls A\ls L\ns P\ls E\ls A\ls R\ls L\ls S%
\epe@rl{Theoretical pearls}%
}
\def\Tpe@rl{\spe@rl T\ls H\ls E\ls O\ls R\ls E\ls T\ls
I\ls C\ls A\ls L\ns P\ls E\ls A\ls R\ls L%
\epe@rl{Theoretical pearl}%
}
\def\fpe@rl{\spe@rl F\ls U\ls N\ls C\ls T\ls I\ls O\ls
N\ls A\ls L\ns P\ls E\ls A\ls R\ls L\ls S%
\epe@rl{Functional pearls}%
}
\def\Fpe@rl{\spe@rl F\ls U\ls N\ls C\ls T\ls I\ls O\ls
N\ls A\ls L\ns P\ls E\ls A\ls R\ls L%
\epe@rl{Functional pearl}%
}
\def\edpe@rl{\spe@rl E\ls D\ls U\ls C\ls A\ls T\ls I\ls O\ls N\ls A\ls L\ns
P\ls E\ls A\ls R\ls L\ls S%
\epe@rl{Educational pearls}%
}
\def\Edpe@rl{\spe@rl E\ls D\ls U\ls C\ls A\ls T\ls I\ls O\ls N\ls A\ls L\ns
P\ls E\ls A\ls R\ls L%
\epe@rl{Educational pearl}%
}
\def\otherpearl{\spe@rl
\@ifundefined{othrpearl}
{Please define {\normalfont\ttfamily\char92 othrpearl} to obtain\\ the correct title!}
{\othrpearl}%
\epe@rl{Short title--please redefine with {\normalfont\ttfamily\char92 shorttitle}}%
}
\sodef\titleso{}{3pt}{9pt}{0pt}%
\def\@maketitle#1{\@@par\ifbookreview\vspace*{10.5pt}\else\ifOA\vspace*{32pt}\else\vspace*{15pt}\fi\fi%
\setbox\tempbox\vbox{%
\pe@rl{#1}%
\titlefont\@title%
\vphantom{y}\ifonline\pdfbookmark{\@title}{HLtitle}\else\fi\@@par%
\ifbookreview\vskip30pt\else\vskip17.5pt\fi%
%{\unvbox\subtbox}
{\unvbox\authbox}%
%{\unvbox\hisbox}%
{\unvbox\abstractbox}%
{\unvbox\keybox}%
{\unvbox\jclassbox}}%
\unvbox\tempbox%
\vskip25pt%
\@afterheading%
\@afterindentfalse%
\setcounter{section}{0}}
\headlineindent=2.5cc
%%%%%%%%%%%%%%%%%%%%% Copyright %%%%%%%%%%%%%%%%%%%%
%
\def\Copyright#1{\gdef\@Copyright{#1}}
\Copyright{}%
%
%%%%%%%%%%%%%%%%%%%% Chapter Head %%%%%%%%%%%%%%%%%%%%
%
\def\dummycharacter{\vphantom{ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz}}
%
\def\chapfig#1{\gdef\@chapfig{\epsfbox{#1}}}\chapfig{Chap-01.eps}
%
\def\ai#1{\gdef\@ai{$^{\text{#1}}$}}\ai{}
\def\aii#1{\gdef\@aii{$^{\text{#1}}$}}\aii{}
\def\aiii#1{\gdef\@aiii{$^{\text{#1}}$}}\aiii{}
\def\aiv#1{\gdef\@aiv{$^{\text{#1}}$}}\aiv{}
\def\av#1{\gdef\@av{$^{\text{#1}}$}}\av{}
\def\avi#1{\gdef\@avi{$^{\text{#1}}$}}\avi{}
\def\avii#1{\gdef\@avii{$^{\text{#1}}$}}\avii{}
\def\aviii#1{\gdef\@aviii{$^{\text{#1}}$}}\aviii{}
\def\aix#1{\gdef\@aix{$^{\text{#1}}$}}\aix{}
\def\ax#1{\gdef\@ax{$^{\text{#1}}$}}\ax{}
%
\newcommand\theaffilnote{\arabic{afrfilnote}}
%
\setcounter{secnumdepth}{5}
\renewcommand\thepart {\Roman{part}}
\renewcommand\thechapter {\arabic{chapter}}
\renewcommand\thesection {\arabic{section}}
\renewcommand\thesubsection {\thesection.\arabic{subsection}}
\renewcommand\thesubsubsection {\thesubsection .\arabic{subsubsection}}
\renewcommand\theparagraph {\thesubsubsection.\arabic{paragraph}}
\renewcommand\thesubparagraph {\theparagraph.\arabic{subparagraph}}
%
\setcounter{HLsection}{1}%%%%
\setcounter{HLsubsection}{1}%%%
\setcounter{HLsubsubsection}{1}%
\renewcommand\theHLsection{\ifnum\c@secnumdepth=0\else\theHLchapter.\arabic{HLsection}\fi}%%%%
\renewcommand\theHLsubsection{\ifnum\c@secnumdepth=0\else\theHLsection.\arabic{HLsubsection}\fi}%%%%
\renewcommand\theHLsubsubsection{\ifnum\c@secnumdepth=0\else\theHLsubsection.\arabic{HLsubsubsection}\fi}%%%%
%
\def\@seccntformat#1{\csname the#1\endcsname\hspace*{4pt}}
%
\def\subsubsectionsymfont{\fontfamily{\zpdefault}\fontsize{10}{12}\selectfont}
\def\subsubsectionsym{\ignorespaces\hspace*{4pt}{\subsubsectionsymfont\mycolor{\colorfive n}}}
%
\def\reviewsymfont{\fontfamily{\zpdefault}\fontsize{12}{12}\selectfont}
\def\reviewsym{\mycolor{\colorseven\raise.65pt\hbox to 0pt{\vrule height7pt width1pt\hspace*{.5pt}\vrule height7pt width2pt\hspace*{.5pt}\vrule height7pt width3pt\hspace*{.5pt}\vrule height7pt width6pt}\hspace*{12pt}\reviewsymfont\char'347\hspace*{12pt}}}
\def\probhrulefill{\mycolor{\colorseven\leavevmode\leaders\hrule height1pt\hfill\kern\z@}}
%
\def\acknoheadfont{\sectionfont}
%
\newcommand\section{\@startsection {section}{1}{\z@}{-26pt \@plus -2pt \@minus -.2pt}{6.7pt}{\sectionfont}}%
\newcommand\subsection{\@startsection{subsection}{2}{\z@}{-21.5pt}{6.7pt}{\subsectionfont}}%
\newcommand\subsubsection{\@startsection{subsubsection}{3}{\z@}{-12pt}{6.7pt}{\subsubsectionfont}}%
\newcommand\paragraph{\@startsection{paragraph}{4}{\z@}{-13pt}{-1.5pt}{\paragraphfont}}%
\newcommand\subparagraph{\@startsection{subparagraph}{5}{\parindent}{-19pt \@plus -2pt \@minus -.2pt}{-1em}{\subparagraphfont}}%
\newcommand\subsubparagraph{\@startsection{subsubparagraph}{6}{\parindent}{-19pt \@plus -2pt \@minus -.2pt}{-1em}{\subsubparagraphfont}}%
%
\newcommand\referencehead{\@startsection {paragraph}{4}{\z@}{-24pt \@plus -2pt \@minus -.2pt}{6pt}{\referenceheadfont}}%
\newcommand\acknohead{\@startsection {section}{1}{\z@}{-24pt \@plus -2pt \@minus -.2pt}{6pt}{\acknoheadfont}}%
\def\secdot{\hspace*{2pt}}
\def\@seccntformat#1{\csname the#1\endcsname\secdot\ }
\newif\ifsecindent\global\secindentfalse
\def\@sect#1#2#3#4#5#6[#7]#8{%
\ifnum #2>\c@secnumdepth%
\let\@svsec\@empty%
\else%
\refstepcounter{#1}%
%\refstepcounter{HL#1}%
\protected@edef\@svsec{\@seccntformat{#1}\relax}%
\fi%
\@tempskipa #5\relax
\ifdim \@tempskipa>\z@
\begingroup #6\relax
\ifnum#2=1\global\secindenttrue%
\@hangfrom{\hskip #3\relax\@svsec}% {\csname #1numfont\endcsname\@svsec}
{\interlinepenalty \@M #8\par}%
\else
\ifnum#2=2\centering%
\@hangfrom{\hskip #3\relax\@svsec}% {\csname #1numfont\endcsname\@svsec}
{\interlinepenalty \@M #8\par}%
\else
\ifnum#2=3%
\@hangfrom{\hskip #3\relax\@svsec}% {\csname #1numfont\endcsname\@svsec}
{\interlinepenalty \@M #8\par}%
\else%
\@hangfrom{\hskip #3\relax\@svsec}% {\csname #1numfont\endcsname\@svsec}
{\interlinepenalty \@M #8\par}%
\fi\fi\fi
\endgroup%
\csname #1mark\endcsname{#7}\addcontentsline{toc}{#1}{\ifnum #2>\c@secnumdepth \else\protect\numberline{\csname the#1\endcsname}\fi#7}
\else
\def\@svsechd{#6\hskip #3\relax\@svsec #8.\kern3.5pt\csname #1mark\endcsname{#7}}
\fi
\@xsect{#5}}
%
\def\@ssect#1#2#3#4#5{%
\@tempskipa #3\relax
\ifdim \@tempskipa>\z@
\begingroup
#4{%
\@hangfrom{\hskip #1}%
\interlinepenalty \@M {#5}\@@par}%
\endgroup
\else
\def\@svsechd{#4{\hskip #1\relax #5}}%
\fi
\@xsect{#3}}
%
\def\@startsection#1#2#3#4#5#6{%
\if@noskipsec \leavevmode \fi
\par
\@tempskipa #4\relax
\@afterindentfalse
\ifdim \@tempskipa <\z@
\@tempskipa -\@tempskipa
\fi
\if@nobreak
\ifnum#2=2
\vskip-1pt
\fi
\ifnum#2=3
\vskip-1pt
\fi
\everypar{}%
\else
\addpenalty\@secpenalty\addvspace\@tempskipa
\fi
\@ifstar
{\@ssect{#3}{#4}{#5}{#6}}%
{\@dblarg{\@sect{#1}{#2}{#3}{#4}{#5}{#6}}}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Sectioning commands %%%%%%%%%%%%%%%%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Lists %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\topsepi12\p@ \@plus2\p@% \@minus.5\p@
\topsepii2pt% \@plus1\p@
\topsepiii2pt% \@plus1\p@
\topsepiv2pt% \@plus1\p@
\topsepv2pt% \@plus1\p@
\topsepvi2pt% \@plus1\p@
\topsepvii2pt% \@plus1\p@
\topsepviii2pt% \@plus1\p@
\topsepix2pt% \@plus1\p@
\topsepx2pt% \@plus1\p@
\itemsepi0pt
\itemsepii0pt
\itemsepiii0pt
\itemsepiv0pt
\itemsepv0pt
\itemsepvi0pt
\itemsepvii0pt
\itemsepviii0pt
\itemsepix0pt
\itemsepx0pt
%
\def\list#1#2{%
\ifnum \@listdepth >10\relax
\@toodeep
\else
\global\advance\@listdepth\@ne
\fi
\rightmargin\z@
\listparindent\z@
\itemindent\z@
\csname @list\romannumeral\the\@listdepth\endcsname
\def\@itemlabel{#1}%
\let\makelabel\@mklab
\@nmbrlistfalse
#2\relax
\@trivlist
\parskip\parsep
\parindent\listparindent
\advance\linewidth -\rightmargin
\advance\linewidth -\leftmargin
\advance\@totalleftmargin \leftmargin
\parshape \@ne \@totalleftmargin \linewidth
\ignorespaces}
%
\def\@listI{\leftmargin\leftmargini
\labelwidth\leftmargini
\advance\labelwidth-\labelsep
\parsep 0\p@%
\topsep \topsepi
\itemsep\itemsepi}%
\let\@listi\@listI
\@listi
\def\@listii {\leftmargin\leftmarginii
\labelwidth\leftmarginii
\advance\labelwidth-\labelsep
\topsep\topsepii
\parsep 0pt
\itemsep\itemsepii}
\def\@listiii {\leftmargin\leftmarginiii
\labelwidth\leftmarginiii
\advance\labelwidth-\labelsep
\topsep\topsepiii
\parsep 0pt
\itemsep\itemsepiii}
\def\@listiv {\leftmargin\leftmarginiv
\labelwidth\leftmarginiv
\advance\labelwidth-\labelsep}
\def\@listv {\leftmargin\leftmarginv
\labelwidth\leftmarginv
\advance\labelwidth-\labelsep}
\def\@listvi {\leftmargin\leftmarginvi
\labelwidth\leftmarginvi
\advance\labelwidth-\labelsep}
\def\@listvii {\leftmargin\leftmarginvii
\labelwidth\leftmarginvii
\advance\labelwidth-\labelsep}
\def\@listviii {\leftmargin\leftmarginviii
\labelwidth\leftmarginviii
\advance\labelwidth-\labelsep}
\def\@listix {\leftmargin\leftmarginix
\labelwidth\leftmarginix
\advance\labelwidth-\labelsep}
\def\@listx {\leftmargin\leftmarginx
\labelwidth\leftmarginx
\advance\labelwidth-\labelsep}
%
\setlength\leftmargini {2.5em}
\setlength\leftmarginii {2.2em}
\setlength\leftmarginiii {1.87em}
\setlength\leftmarginiv {1.7em}
\setlength\leftmarginv {1em}
\setlength\leftmarginvi {1em}
\setlength\leftmarginvii {1em}
\setlength\leftmarginviii {1em}
\setlength\leftmarginix {1em}
\setlength\leftmarginx {1em}
\setlength\leftmargin {\leftmargini}
%
\setlength \labelsep {\LabelSep}
\setlength \labelwidth{\leftmargini}
\addtolength\labelwidth{-\labelsep}
%
\newcommand\theenumv{\Alph{enumv}}
\newcommand\theenumvi{\Alph{enumvi}}
\newcommand\theenumvii{\roman{enumvii}}
\newcommand\theenumviii{\Alph{enumviii}}
\newcommand\theenumix{\Alph{enumix}}
\newcommand\theenumx{\roman{enumx}}
\renewcommand\theenumi{\arabic{enumi}}
\renewcommand\theenumii{\alph{enumii}}
\renewcommand\theenumiii{\roman{enumiii}}
\renewcommand\theenumiv{\Alph{enumiv}}
\renewcommand\theenumv{\Alph{enumv}}
\renewcommand\theenumvi{\Alph{enumvi}}
\renewcommand\theenumvii{\Alph{enumvii}}
\renewcommand\theenumviii{\Alph{enumviii}}
\renewcommand\theenumix{\Alph{enumix}}
\renewcommand\theenumx{\Alph{enumx}}
\newcommand\labelenumi{\theenumi.}
\newcommand\labelenumii{\theenumii.}
\newcommand\labelenumiii{\theenumiii.}
\newcommand\labelenumiv{\theenumiv.}
\newcommand\labelenumv{\theenumv.}
\newcommand\labelenumvi{\theenumvi.}
\newcommand\labelenumvii{\theenumvii.}
\newcommand\labelenumviii{\theenumviii.}
\newcommand\labelenumix{\theenumix.}
\newcommand\labelenumx{\theenumx.}
\renewcommand\p@enumii{\theenumi}
\renewcommand\p@enumiii{\theenumi(\theenumii)}
\renewcommand\p@enumiv{\p@enumiii\theenumiii}
\font\lcir = lcircle10 at 12pt
\newcommand\bulls{\raise1.5pt\hbox{\lcir\char'162}}
\def\textbullet{\leavevmode\raise2pt\hbox{\hskip2pt\bulls}}
\def\textendash{{\bf--}}
\def\textasteriskcentered{\leavevmode\raise-1.5pt\hbox{*}}
\def\textperiodcentered{\leavevmode\raise1.5pt\hbox{\bulls}}
\newcommand\labelitemi{\textbullet}
\newcommand\labelitemii{\normalfont\bfseries \textendash}
\newcommand\labelitemiii{\textasteriskcentered}
\newcommand\labelitemiv{\textperiodcentered}
\newcommand\labelitemv{\textperiodcentered}
\newcommand\labelitemvi{\textbullet}
\newcommand\labelitemvii{\normalfont\bfseries \textendash}
\newcommand\labelitemviii{\textasteriskcentered}
\newcommand\labelitemix{\textperiodcentered}
\newcommand\labelitemx{\textperiodcentered}
%
\newenvironment{description}
{\list{}{\labelwidth\z@ \itemindent-\leftmargin
\let\makelabel\descriptionlabel}}
{\endlist}
\newcommand\descriptionlabel[1]{\hspace\labelsep
\normalfont\bfseries #1}
%
\newenvironment{verse}
{\let\\=\@centercr
\list{}{\itemsep \z@
\itemindent -1.5em%
\listparindent\itemindent
\rightmargin \leftmargin
\advance\leftmargin 1.5em}%
\item[]}
{\endlist}
%
\newenvironment{OL}{\par\addvspace{9pt plus2pt}%
\def\listdevicefonti{\bf}
\def\listdevicefontii{\bf}
\def\listdevicefontiii{\bf}
\def\listdevicefontiv{\bf}
\def\listdevicefontv{\bf}
\def\listdevicefontvi{\bf}
\def\listdevicefontvii{\bf}
\def\listdevicefontviii{\bf}
\def\listdevicefontix{\bf}
\def\listdevicefontx{\bf}
\let\eqnarray\oleqnarray
%\let\[\eq
\mathindent\itemleftmargin
\renewcommand\labelenumv{(\theenumv)}
\renewcommand\labelenumvi{(\theenumvi)}
\renewcommand\labelenumvii{(\theenumvii)}
\labelsepi3.8pt
\labelsepii3.8pt
\labelsepiii3.8pt
\labelsepiv3.8pt
\labelsepv3.8pt
\labelsepvi3.8pt
\labelsepvii3.8pt
\abovelistskipi0pt%
\belowlistskipi0pt%
\abovelistskipii0pt%
\belowlistskipii0pt%
\abovelistskipiii0pt%
\belowlistskipiii0pt%
\abovelistskipiv0pt%
\belowlistskipiv0pt%
\abovelistskipv0pt%
\belowlistskipv0pt%
\abovelistskipvi0pt%
\belowlistskipvi0pt%
\abovelistskipvii0pt%
\belowlistskipvii0pt%
\abovelistskipviii0pt%
\belowlistskipviii0pt%
\abovelistskipix0pt%
\belowlistskipix0pt%
\abovelistskipx0pt%
\belowlistskipx0pt%
}{
\par\addvspace{9pt plus2pt}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Lists %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Enumerate list %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\listtextleftmargin 0pt%24pt
\listtextleftmarginii0pt% 24pt
\listtextleftmarginiii0pt% 24pt
\listtextleftmarginiv0pt% 24pt
\listtextleftmarginv0pt% 24pt
\listtextleftmarginvi0pt% 24pt
\listtextleftmarginvii0pt% 24pt
\listtextleftmarginviii0pt% 24pt
\listtextleftmarginix0pt% 24pt
\listtextleftmarginx0pt% 24pt
\listtextrightmargin0pt%.5pc
\listlabelleftskip0pt%3.3pt
\listlabelleftskipii0pt%3.3pt
\listlabelleftskipiii0pt%3.3pt
\listlabelleftskipiv0pt%3.3pt
\listlabelleftskipv0pt%3.3pt
\listlabelleftskipvi0pt%3.3pt
\listlabelleftskipvii0pt%3.3pt
\listlabelleftskipviii0pt%3.3pt
\listlabelleftskipix0pt%3.3pt
\listlabelleftskipx0pt%3.3pt
\abovelistskipi0pt%
\belowlistskipi6pt%
\abovelistskipii0pt% plus2pt
\belowlistskipii0pt% plus2pt
\abovelistskipiii0pt% plus2pt
\belowlistskipiii0pt% plus2pt
\abovelistskipiv0pt% plus2pt
\belowlistskipiv0pt% plus2pt
\abovelistskipv0pt% plus2pt
\belowlistskipv0pt% plus2pt
\abovelistskipvi0pt% plus2pt
\belowlistskipvi0pt% plus2pt
\abovelistskipvii0pt% plus2pt
\belowlistskipvii0pt% plus2pt
\abovelistskipviii0pt% plus2pt
\belowlistskipviii0pt% plus2pt
\abovelistskipix0pt% plus2pt
\belowlistskipix0pt% plus2pt
\abovelistskipx0pt% plus2pt
\belowlistskipx0pt% plus2pt
\labelsepi5.4pt
\labelsepii5.2pt
\labelsepiii\z@
\labelsepiv\z@
\labelsepv\z@
\labelsepvi\z@
\labelsepvii\z@
\labelsepviii\z@
\labelsepix\z@
\labelsepx\z@
%
\def\listdevicefonti{}
\def\listdevicefontii{}
\def\listdevicefontiii{}
\def\listdevicefontiv{}
\def\listdevicefontv{}
\def\listdevicefontvi{}
\def\listdevicefontvii{}
\def\listdevicefontviii{}
\def\listdevicefontix{}
\def\listdevicefontx{}
\def\listfont{}
\def\textlistlabel{}
%
\@definecounter{enumv}
\@definecounter{enumvi}
\@definecounter{enumvii}
\@definecounter{enumviii}
\@definecounter{enumix}
\@definecounter{enumx}
%
\def\enummax#1{%
\labelsep\csname labelsep\romannumeral\the\@enumdepth\endcsname
\ifdim\listtextleftmargin>\z@\labelsepi0pt\fi
\ifdim\listtextleftmarginii>\z@\labelsepii0pt\fi
\ifdim\listtextleftmarginiii>\z@\labelsepiii0pt\fi
\setbox\tempbox\hbox{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname#1\hskip\labelsep}%
\enumdim\wd\tempbox
\setbox\tempbox\hbox{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname#1}%
\enumdimwd\wd\tempbox
\expandafter\global\csname leftmargin\romannumeral\the\@enumdepth\endcsname\enumdim
\ifdim\listtextleftmargin>\z@
\leftmargini\listtextleftmargin
\ifdim\listlabelleftskip>\z@
\advance\leftmargini-\listlabelleftskip
\fi
\fi
\ifdim\listtextleftmarginii>\z@
\leftmarginii\listtextleftmarginii
\ifdim\listlabelleftskipii>\z@
\advance\leftmarginii-\listlabelleftskipii
\fi
\fi
\ifdim\listtextleftmarginiii>\z@
\leftmarginiii\listtextleftmarginiii
\ifdim\listlabelleftskipiii>\z@
\advance\leftmarginiii-\listlabelleftskipiii
\fi
\fi
\ifdim\listtextleftmarginiv>\z@
\leftmarginiv\listtextleftmarginiv
\ifdim\listlabelleftskipiv>\z@
\advance\leftmarginiv-\listlabelleftskipiv
\fi
\fi
\ifdim\listtextleftmarginv>\z@
\leftmarginv\listtextleftmarginv
\ifdim\listlabelleftskipv>\z@
\advance\leftmarginv-\listlabelleftskipv
\fi
\fi
\ifdim\listtextleftmarginvi>\z@
\leftmarginvi\listtextleftmarginvi
\ifdim\listlabelleftskipvi>\z@
\advance\leftmarginvi-\listlabelleftskipvi
\fi
\fi
\ifdim\listtextleftmarginvii>\z@
\leftmarginvii\listtextleftmarginvii
\ifdim\listlabelleftskipvii>\z@
\advance\leftmarginvii-\listlabelleftskipvii
\fi
\fi
\ifdim\listtextleftmarginviii>\z@
\leftmarginviii\listtextleftmarginviii
\ifdim\listlabelleftskipviii>\z@
\advance\leftmarginviii-\listlabelleftskipviii
\fi
\fi
\ifdim\listtextleftmarginix>\z@
\leftmarginix\listtextleftmarginix
\ifdim\listlabelleftskipix>\z@
\advance\leftmarginix-\listlabelleftskipix
\fi
\fi
\ifdim\listtextleftmarginx>\z@
\leftmarginx\listtextleftmarginx
\ifdim\listlabelleftskipx>\z@
\advance\leftmarginx-\listlabelleftskipx
\fi
\fi
\ifdim\listlabelleftskip>\z@
\advance\leftmargini\listlabelleftskip
\fi
\ifdim\listlabelleftskipii>\z@
\advance\leftmarginii\listlabelleftskipii
\fi
\ifdim\listlabelleftskipiii>\z@
\advance\leftmarginiii\listlabelleftskipiii
\fi
\ifdim\listlabelleftskipiv>\z@
\advance\leftmarginiv\listlabelleftskipiv
\fi
\ifdim\listlabelleftskipv>\z@
\advance\leftmarginv\listlabelleftskipv
\fi
\ifdim\listlabelleftskipvi>\z@
\advance\leftmarginvi\listlabelleftskipvi
\fi
\ifdim\listlabelleftskipvii>\z@
\advance\leftmarginvii\listlabelleftskipvii
\fi
\ifdim\listlabelleftskipviii>\z@
\advance\leftmarginviii\listlabelleftskipviii
\fi
\ifdim\listlabelleftskipix>\z@
\advance\leftmarginix\listlabelleftskipix
\fi
\ifdim\listlabelleftskipx>\z@
\advance\leftmarginx\listlabelleftskipx
\fi
}
%
\enummax{1.}
%
\def\enumerate{\@ifnextchar[{\@enumerate}{\@enumerate[\csname label\@enumctr\endcsname]}}%%
%
\def\@enumerate[#1]{\par
\ifnum \@enumdepth >10 \@toodeep
\else
\advance\@enumdepth\@ne
\edef\@enumctr{enum\romannumeral\the\@enumdepth}%
\setcounter{\@enumctr}{1}\enummax{#1}%
\list
{\csname label\@enumctr\endcsname}{\usecounter{\@enumctr}%
\topsep6.5pt%\csname abovelistskip\romannumeral\the\@enumdepth\endcsname
\itemsep\csname itemsep\romannumeral\the\@enumdepth\endcsname
\listfont %\listparindent18.25pt
\ifnum \@enumdepth=1
\rightmargin\listtextrightmargin
\advance\rightmargin\rightskip
\advance\leftmargin\leftskip
\advance\csname leftmargin\romannumeral\the\@itemdepth\endcsname\itemleftmargin
\tempdimen\leftmargini
\advance\tempdimen-\labelsep
\iffnalpha
\def\makelabel##1{{\hskip\listlabelleftskip{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname{\iflabelrightalign\hss\fi\textlistlabel##1}}}}%
\global\fnalphafalse
\else
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskip{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi\textlistlabel##1}}}}%
\fi
\else
\ifnum \@enumdepth=2
\tempdimen\leftmarginii
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipii{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=3
\tempdimen\leftmarginiii
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipiii{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=4
\tempdimen\leftmarginiv
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipiv{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=5
\tempdimen\leftmarginv
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipv{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=6
\tempdimen\leftmarginvi
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipvi{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=7
\tempdimen\leftmarginvii
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipvii{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=8
\tempdimen\leftmarginviii
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipviii{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=9
\tempdimen\leftmarginix
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipix{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\ifnum \@enumdepth=10
\tempdimen\leftmarginx
\advance\tempdimen-\labelsep
\def\makelabel##1{\hbox to \tempdimen{\hskip\listlabelleftskipx{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname\hbox to \enumdimwd{\iflabelrightalign\hss\fi##1}}}}%
\else
\def\makelabel##1{\hss\llap{\csname listdevicefont\romannumeral\the\@enumdepth\endcsname##1}}%
\fi
\fi
\fi
\fi
\fi
\fi
\fi
\fi
\fi
\fi}
\fi}
%
\def\endenumerate{\@topsepadd\csname belowlistskip\romannumeral\the\@enumdepth\endcsname\endlist}%
%
\newenvironment{arabiclist}{%
\abovelistskipi6\p@ plus2pt
\belowlistskipi6\p@ plus2pt
\labelsepi5pt
\def\theenumi{\arabic{enumi}}
\def\theenumii{\arabic{enumii}}%
\def\theenumiii{\arabic{enumiii}}%
\def\theenumiv{\arabic{enumiv}}%
\def\theenumv{\arabic{enumv}}%
\def\theenumvi{\arabic{enumvi}}%
\def\theenumvii{\arabic{enumvii}}%
\def\theenumviii{\arabic{enumviii}}%
\def\theenumix{\arabic{enumix}}%
\def\theenumx{\arabic{enumx}}%
\renewcommand\labelenumi{\theenumi.}
\renewcommand\labelenumii{\theenumii.}
\renewcommand\labelenumiii{\theenumiii.}
\begin{enumerate}}
{\end{enumerate}}
%
\def\bullsymfont{\fontfamily{\zpdefault}\fontsize{10}{12}\selectfont}
\def\bullsym{\raise-0.02pt\hbox{\bullsymfont\mycolor{\colorthree o}}}
%
\newenvironment{bulletlist}{%
\labelsepi6pt
\def\theenumi{\arabic{enumi}}
\def\theenumii{\alph{enumii}}%
\def\theenumiii{\arabic{enumiii}}%
\def\theenumiv{\arabic{enumiv}}%
\def\theenumv{\alph{enumv}}%
\def\theenumvi{\arabic{enumvi}}%
\def\theenumvii{\arabic{enumvii}}%
\def\theenumviii{\alph{enumviii}}%
\def\theenumix{\arabic{enumix}}%
\def\theenumx{\arabic{enumx}}%
\renewcommand\labelenumi{\textbullet}
\renewcommand\labelenumii{\textbullet}
\renewcommand\labelenumiii{\textbullet}
\begin{enumerate}\leftskip18pt}
{\end{enumerate}}
%
\def\learnsymfont{\fontfamily{ams}\fontsize{10}{12}\selectfont}
\def\learnsym{{\learnsymfont\mycolor{\colorseven I}}}
%
\newenvironment{learnbulletlist}{\par\raggedright%
\hsize\colmargin\linewidth\colmargin
\labelsepi5pt
\def\theenumi{\arabic{enumi}}
\def\theenumii{\alph{enumii}}%
\def\theenumiii{\arabic{enumiii}}%
\def\theenumiv{\arabic{enumiv}}%
\def\theenumv{\alph{enumv}}%
\def\theenumvi{\arabic{enumvi}}%
\def\theenumvii{\arabic{enumvii}}%
\def\theenumviii{\alph{enumviii}}%
\def\theenumix{\arabic{enumix}}%
\def\theenumx{\arabic{enumx}}%
\renewcommand\labelenumi{\learnsym}
\renewcommand\labelenumii{\learnsym}
\renewcommand\labelenumiii{\learnsym}
\begin{enumerate}}
{\end{enumerate}}
%
\newenvironment{wherelist}{%
\def\listdevicefonti{\upshape}
\listtextleftmargin 0pt
\abovelistskipi13\p@ plus2pt
\belowlistskipi13\p@ plus2pt
\begin{enumerate}}
{\end{enumerate}}
%
\newenvironment{romanlist}{%
\def\theenumi{\roman{enumi}}\def\theenumii{\roman{enumii}}%
\def\theenumiii{\roman{enumiii}}\def\theenumiv{\roman{enumiv}}%
\def\theenumv{\roman{enumv}}\def\theenumvi{\roman{enumvi}}%
\def\theenumvii{\roman{enumvii}}\def\theenumviii{\roman{enumviii}}%
\def\theenumix{\roman{enumix}}\def\theenumx{\roman{enumx}}%
\begin{enumerate}\leftskip8pt}
{\end{enumerate}}
%
\newenvironment{alphalist}{%
\itemsepi0pt
\labelsepi5pt
\labelsepii5pt
\labelsepiii5pt
%\labelrightalignfalse
\def\theenumi{\alph{enumi}}\def\theenumii{\alph{enumii}}%
\def\theenumiii{\alph{enumiii}}\def\theenumiv{\alph{enumiv}}%
\def\theenumv{\roman{enumv}}\def\theenumvi{\roman{enumvi}}%
\def\theenumvii{\roman{enumvii}}\def\theenumviii{\roman{enumviii}}%
\def\theenumix{\roman{enumix}}\def\theenumx{\roman{enumx}}%
\renewcommand\labelenumi{\theenumi.}
\renewcommand\labelenumii{\theenumii.}
\renewcommand\labelenumiii{\theenumiii.}
\begin{enumerate}\leftskip8pt}
{\end{enumerate}}
%
\newenvironment{fnalphalist}{%
\abovelistskipi0pt plus2pt
\belowlistskipi0pt plus2pt
\itemsepi-2pt
\labelsepi3.6pt
\global\fnalphatrue
\listlabelleftskip\fskip
\def\theenumi{\alph{enumi}}\def\theenumii{\alph{enumii}}%
\def\theenumiii{\alph{enumiii}}\def\theenumiv{\alph{enumiv}}%
\def\theenumv{\roman{enumv}}\def\theenumvi{\roman{enumvi}}%
\def\theenumvii{\roman{enumvii}}\def\theenumviii{\roman{enumviii}}%
\def\theenumix{\roman{enumix}}\def\theenumx{\roman{enumx}}%
\renewcommand\labelenumi{(\theenumi)}
\begin{enumerate}}
{\end{enumerate}}
%
\newenvironment{Romanlist}{%
\def\theenumi{\Roman{enumi}}\def\theenumii{\Roman{enumii}}%
\def\theenumiii{\Roman{enumiii}}\def\theenumiv{\Roman{enumiv}}%
\def\theenumv{\roman{enumv}}\def\theenumvi{\roman{enumvi}}%
\def\theenumvii{\roman{enumvii}}\def\theenumviii{\roman{enumviii}}%
\def\theenumix{\roman{enumix}}\def\theenumx{\roman{enumx}}%
\begin{enumerate}}
{\end{enumerate}}
\newenvironment{Alphalist}{%
\def\theenumi{\Alph{enumi}}\def\theenumii{\Alph{enumii}}%
\def\theenumiii{\Alph{enumiii}}\def\theenumiv{\Alph{enumiv}}%
\def\theenumv{\roman{enumv}}\def\theenumvi{\roman{enumvi}}%
\def\theenumvii{\roman{enumvii}}\def\theenumviii{\roman{enumviii}}%
\def\theenumix{\roman{enumix}}\def\theenumx{\roman{enumx}}%
\begin{enumerate}\leftskip8pt}
{\end{enumerate}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unnumlist %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\unnumlistitemindent=-18pt
%
\def\@item[#1]{%
\if@noparitem
\@donoparitem
\else
\if@inlabel
\indent \par
\fi
\ifhmode
\unskip\unskip \par
\fi
\if@newlist
\if@nobreak
\@nbitem
\else
\addpenalty\@beginparpenalty
\addvspace\@topsep
\addvspace{-\parskip}%
\fi
\else
\addpenalty\@itempenalty
\addvspace\itemsep
\fi
\global\@inlabeltrue
\fi
\everypar{%
\@minipagefalse
\global\@newlistfalse
\if@inlabel
\global\@inlabelfalse
{\setbox\z@\lastbox
\ifvoid\z@
\kern-\itemindent
\fi}%
\ifunnumlistitem\hspace*{\unnumlistitemindent}\fi\box\@labels
\penalty\z@
\fi
\if@nobreak
\@nobreakfalse
\clubpenalty \@M
\else
\clubpenalty \@clubpenalty
\everypar{}%
\fi}%
\if@noitemarg
\@noitemargfalse
\if@nmbrlist
\refstepcounter\@listctr
\fi
\fi
\sbox\@tempboxa{\makelabel{#1}}%
\global\setbox\@labels\hbox{%
\unhbox\@labels
\hskip \itemindent
\hskip -\labelwidth
\hskip -\labelsep
\ifdim \wd\@tempboxa >\labelwidth
\box\@tempboxa
\else
\hbox to\labelwidth {\unhbox\@tempboxa}%
\fi
\hskip \labelsep}%
\ignorespaces}
%
\unnumlisttextskip=18pt
\newenvironment{unnumlist}{%
\unnumlistitemtrue
\listtextleftmargin\unnumlisttextskip
\listtextleftmarginii\unnumlisttextskip
\listtextleftmarginiii\unnumlisttextskip
\listtextleftmarginiv\unnumlisttextskip
\listtextleftmarginv\unnumlisttextskip
\listtextleftmarginvi\unnumlisttextskip
\listtextleftmarginvii\unnumlisttextskip
\listtextleftmarginviii\unnumlisttextskip
\listtextleftmarginix\unnumlisttextskip
\listtextleftmarginx\unnumlisttextskip
\labelsepi0pt
\labelsepii0pt
\labelsepiii0pt
\labelsepiv0pt
\labelsepv0pt
\labelsepvi0pt
\labelsepvii0pt
\labelsepviii0pt
\labelsepix0pt
\labelsepx0pt
\def\theenumi{\arabic{enumi}}
\def\theenumii{\alph{enumii}}%
\def\theenumiii{\arabic{enumiii}}%
\def\theenumiv{\arabic{enumiv}}%
\def\theenumv{\alph{enumv}}%
\def\theenumvi{\arabic{enumvi}}%
\def\theenumvii{\arabic{enumvii}}%
\def\theenumviii{\alph{enumviii}}%
\def\theenumix{\arabic{enumix}}%
\def\theenumx{\arabic{enumx}}%
\renewcommand\labelenumi{}
\renewcommand\labelenumii{}
\renewcommand\labelenumiii{}
\renewcommand\labelenumiv{}
\renewcommand\labelenumv{}
\renewcommand\labelenumvi{}
\renewcommand\labelenumvii{}
\renewcommand\labelenumviii{}
\renewcommand\labelenumix{}
\renewcommand\labelenumx{}
\begin{enumerate}}
{\end{enumerate}
\global\unnumlistitemfalse}
%
\def\webadd#1{\par\addvspace{3pt}{\fontfamily{Courier}\fontsize{9}{12}\selectfont\hskip18pt#1}}
%
\itemleftmargin15.5\p@ % won't be active in enumerate
\itemlabelsep6\p@ % labelsep in itemize for all levels
\def\itemize{%
\ifnum \@itemdepth >3 \@toodeep\else\ifnum\@enumdepth>0\@itemdepth\@enumdepth\fi \advance\@itemdepth \@ne
\edef\@itemitem{labelitem\romannumeral\the\@itemdepth}%
\list{\csname\@itemitem\endcsname}%
{%
\topsep8pt%\csname abovelistskip\romannumeral\the\@itemdepth\endcsname%\fi
\itemsep\csname itemsep\romannumeral\the\@itemdepth\endcsname
\labelsep\itemlabelsep
\listfont
\setbox\tempbox\hbox{\csname\@itemitem\endcsname}
\csname leftmargin\romannumeral\the\@itemdepth\endcsname\wd\tempbox
\advance\csname leftmargin\romannumeral\the\@itemdepth\endcsname\itemlabelsep
\ifnum\@itemdepth=\@ne\ifnum\@enumdepth=0 % if not inside an enumerate
\rightmargin\listtextrightmargin
\advance\rightmargin\rightskip
\advance\csname leftmargin\romannumeral\the\@itemdepth\endcsname\itemleftmargin
\advance\leftmargini\leftskip
\else
\advance\csname leftmargin\romannumeral\the\@itemdepth\endcsname\itemleftmargin
\advance\leftmarginii\leftskip
\fi\fi
\leftmargin\csname leftmargin\romannumeral\the\@itemdepth\endcsname
\def\makelabel##1{\hss\llap{##1}}}
\fi}%
%
\def\enditemize{%
\@topsepadd\csname belowlistskip\romannumeral\the\@itemdepth\endcsname%\fi
\endlist}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%% enumroman (i) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\newenvironment{xbllist}{%
\abovelistskipii9pt plus2pt%
\belowlistskipii9pt plus2pt%
\itemlabelsep12.5\p@%
\itemsepi0pt
\def\listfont{}
\renewcommand\labelitemi{\textbullet}%
\renewcommand\labelitemii{\textbullet}%
\renewcommand\labelitemiii{\textbullet}%
\renewcommand\labelitemiv{\textbullet}%
\begin{itemize}}
{\end{itemize}}
\newenvironment{hyphenlist}{%
\renewcommand\labelitemi{\normalfont\bfseries \textendash}%
\renewcommand\labelitemii{\normalfont\bfseries \textendash}%
\renewcommand\labelitemiii{\normalfont\bfseries \textendash}%
\renewcommand\labelitemiv{\normalfont\bfseries \textendash}%
\begin{itemize}}
{\end{itemize}}
%
\newenvironment{asterisklist}{%
\renewcommand\labelitemi{\textasteriskcentered}%
\renewcommand\labelitemii{\textasteriskcentered}%
\renewcommand\labelitemiii{\textasteriskcentered}%
\renewcommand\labelitemiv{\textasteriskcentered}%
\begin{itemize}}
{\end{itemize}}
%
\newenvironment{caselist}{%
\def\textlistlabel{Case\ }%
\begin{enumerate}}
{\end{enumerate}}
%
\newenvironment{steplist}{%
\def\textlistlabel{Step\ }%
\begin{enumerate}}
{\end{enumerate}}
%
\newenvironment{labellist}{%
\begin{description}}
{\end{description}}
%
\def\setitemindent#1{\settowidth{\labelwidth}{#1}%
\let\setit@m=Y%
\leftmargini\labelwidth
\advance\leftmargini\labelsep
\def\@listi{\leftmargin\leftmargini
\labelwidth\leftmargini\advance\labelwidth by -\labelsep
\parsep=\parskip
\topsep=\medskipamount
\itemsep=\parskip \advance\itemsep by -\parsep}}
\def\setitemitemindent#1{\settowidth{\labelwidth}{#1}%
\let\setit@m=Y%
\leftmarginii\labelwidth
\advance\leftmarginii\labelsep
\def\@listii{\leftmargin\leftmarginii
\labelwidth\leftmarginii\advance\labelwidth by -\labelsep
\parsep=\parskip
\topsep=6\p@
\itemsep=\parskip \advance\itemsep by -\parsep}}
\def\description{\@ifnextchar[{\@describe}{\list{}{\labelwidth\z@
\let\makelabel\descriptionlabel}}}
\def\describelabel#1{#1\hfil}
\def\@describe[#1]{
\def\@mklab##1{##1\hfill}
\labelsep=12pt
\ifnum\@listdepth=0
\setitemindent{#1}
\else
\ifnum
\@listdepth=1
\setitemitemindent{#1}
\fi\fi
\list{}{\let\makelabel\describelabel}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%% npara %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\NPARfont{}
\newenvironment{npara}{\par%\addvspace{9pt plus2pt}%
\NPARfont
% \hsize\textwidth%27pc
\setcounter{ncount}{0}%
\def\item{\par\addtocounter{ncount}{1}\arabic{ncount}.\hskip2.6pt\ignorespaces}}
{\par}%\addvspace{9pt plus2pt}\@endparenv}%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%% splist %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\marginfont{\fontsize{9}{10}\selectfont\bfseries\raggedright}
\newcommand{\comment}[1]{%
\setlength\overfullrule{0pt}%
\ifodd\c@page
\marginpar{%
\parbox{8pc}{\par\vskip-1.5pt\marginfont please check.\par}}%
\fboxsep.1pt\fbox{#1}%
\else
\marginpar{%
\parbox{8pc}{\par\vskip-1.5pt\marginfont please check.\par}}
\fboxsep.1pt\fbox{#1}\fi}
%
\setlength{\intextsep}{20\p@ \@plus 2\p@ \@minus 2\p@}
%
\setcounter{topnumber}{5}
\renewcommand\topfraction{.9}
\setcounter{bottomnumber}{5}
\renewcommand\bottomfraction{.9}
\setcounter{totalnumber}{5}
\renewcommand\textfraction{.09}
\renewcommand\floatpagefraction{.901}
\setcounter{dbltopnumber}{1}
\renewcommand\dbltopfraction{.9}
\renewcommand\dblfloatpagefraction{.901}
%
\setlength\abovecaptionskip{4\p@}
\setlength\belowcaptionskip{\z@}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Figures %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\figcaptiondesc#1{\gdef\@figcaptiondesc{#1}}
\figcaptiondesc{}
%
\renewcommand\thefigure{\@arabic\c@figure}
\def\fps@figure{tbp}
\def\ftype@figure{1}
\def\ext@figure{lof}
\def\figurehead#1{\gdef\@figurehead{#1}}\figurehead{}
\def\fnum@figure{Fig. \thefigure}
\newenvironment{figure}
{\global\figureshowtrue\@float{figure}}
{\end@float%
\global\figureshowfalse%
\global\webcolorfalse%
\global\sidefigurefalse%
\global\rightsidefigurefalse}
\def\@float#1{%
\@ifnextchar[%
{\@xfloat{#1}}%
{\edef\reserved@a{\noexpand\@xfloat{#1}[\csname fps@#1\endcsname]}%
\reserved@a}}
\newenvironment{figure*}
{\@dblfloat{figure}}
{\end@dblfloat}
%
\newenvironment{Figure}
{\par\addvspace{12pt plus2pt}\def\@captype{figure}}
{\par\addvspace{12pt plus2pt}}
%
\newenvironment{Figure*}
{\par\addvspace{12pt plus2pt}\def\@captype{figure}}
{\par\addvspace{12pt plus2pt}}
%
\def\figlabelfont{\fontsize{10}{12}\selectfont}
\def\figlabel#1{\gdef\@figlabel{#1}}
\figlabel{}
%
\figcaptionleftskip0pt
\figcaptionrightskip0pt
\figindent0pt
\figwidthcapdimen12pt
\figleftskip0pt
\figrightskip0pt
\adjustskip0pt
%
\def\figpunct{.}
\providecommand\centerfirst{%
\let\\\@centercr
\edef\caption@normaladjust{%
\leftskip\the\leftskip
\rightskip\the\rightskip
\parfillskip\the\parfillskip\relax}%
\leftskip\z@\@plus -1fil%
\rightskip\z@\@plus 1fil%
\parfillskip\z@skip
\noindent\hskip\z@\@plus 2fil%
\@setpar{\@@par\@restorepar\caption@normaladjust}}
\providecommand\centerlast{%
\let\\\@centercr
\leftskip\z@\@plus 1fil%
\rightskip\z@\@plus -1fil%
\parfillskip\z@\@plus 1.96fil\relax}
\def\@makefigurecaption#1#2{\figcaptionfont%
\global\setbox\figcapbox\hbox{{{\figcaptionnumfont#1\figpunct\hskip\fignumcapsep}\hskip\figcapdescsep#2\par}}
\ifdim\wd\figcapbox>\hsize
{{\figcaptionnumfont#1\figpunct\hskip\fignumcapsep}\hskip\figcapdescsep#2\par}%
\else
\hfil{{\figcaptionnumfont#1\figpunct\hskip\fignumcapsep}\hskip\figcapdescsep#2\par}\hfil%
\fi}
\def\ArtPiece#1{\epsfbox{#1}}%
%
\def\figurebox#1#2#3{%
\@ifnextchar[{\@figurebox{#1}{#2}{#3}}{\@figurebox{#1}{#2}{#3}[]}}
%
\def\@figurebox#1#2#3[#4]{%
\gdef\CO{CO}
\gdef\FP{FP}
\gdef\@thirdarg{#3}%
\gdef\@frtharg{#4}%
\ifx\@frtharg\empty
\global\figheight=#1
\global\figwidth=#2
\ifx\@thirdarg\empty \FPfalse\COfalse\fi
\else
%%% for CO and FPO figure conditions
\ifx\@thirdarg\empty \FPfalse\COfalse
\else
\ifx\@thirdarg\FP \FPtrue
\else
\ifx\@thirdarg\CO \COtrue
\else
\fi
\fi
\fi
%%%
% \setbox\figtempbox=\hbox{\epsfbox{\ArtDir \ifCO #3-\else\ifFP#3-\fi\fi#4}}%
\setbox\figtempbox=\hbox{\includegraphics{#4}}%
\global\figwidth=\wd\figtempbox
\global\figheight=\ht\figtempbox
\fi
\ifsidewaysfigure
\figrightskip0pt plus1fill\figleftskip0pt plus1fill%%%centering figure
\vbox to 0pt{\rightskip\figrightskip\leftskip\figleftskip{\figbox}}
\else
\ifsidefigure
\ifrightsidefigure
\figleftskip0pt plus1fill
\vbox to 0pt{\rightskip\figrightskip\leftskip\figleftskip{\figbox}}
\else
\vbox to 0pt{\rightskip\figrightskip\leftskip\figleftskip{\figbox}}
\fi
\else
\ifdim\figwidth > \textwidth
\ifrightsidefigure
\vbox to 0pt{\centerline{\figbox}}%%\figleftskip or \figrightskip is for figurebox movement%%
\else
\vbox to 0pt{\centerline{\figbox}}%%\figleftskip or \figrightskip is for figurebox movement%%
\fi
\else
\vbox to 0pt{\centerline{\figbox}}%%\figleftskip or \figrightskip is for figurebox movement%%
\fi
\fi
\fi
% \vbox to 0pt{\centerline{\figbox}}%
%%% for marginal note
\vskip-\baselineskip
\ifodd\c@page
\vtop to \figheight{\vfill\llap{\marginfont\ifFP 4-Color Artwork
\else\ifCO 4-Color Artwork
\else\fi\fi\hskip0.5pc}\vfill}%
\else
\vtop to \figheight{\vfill\llap{\marginfont\ifFP 4-Color Artwork
\else\ifCO 4-Color Artwork
\else\fi\fi\hskip0.5pc}\vfill}%
\fi
%%%
}%
%%%%
\def\fpofigbox#1{\FPtrue\def\@fpo{#1}}
%
\def\whiteink{\special{color push cmyk 0 0 0 0.0}}
\def\blackink{\special{color push cmyk 0 0 0 1.0}}
%
\def\@startpbox#1{\vtop\bgroup \setlength\hsize{#1}\@arrayparboxrestore}
\def\@endpbox{\@finalstrut\@arstrutbox\par\vspace*{-\baselineskip}\egroup\hfil}
\let\@@startpbox=\@startpbox
\let\@@endpbox=\@endpbox
%
\def\figbox{%
\ifx\@frtharg\empty%
\noindent\vbox{\mycolor{\grayten\hsize\figwidth%
\hrule height\figheight\hbox to\figwidth{\hfill\vbox to\figheight{\hsize\figwidth\vfill}}}}%
% \noindent\vbox{\hsize\figwidth%
% \hrule\hbox to\figwidth{\vrule\hfill\vbox to\figheight{\hsize\figwidth\vfill}\vrule}\hrule}%
\else%
\noindent\vbox{\vskip.8pt\hsize\figwidth%
\hbox to\figwidth{\vbox to\figheight{\hsize\figwidth\box\figtempbox}}}%
\fi%
\ifCO\else\ifFP\vbox to 0pt{\vskip-.6\figheight\llap{\hbox to \figwidth{%
\hfill\blackink\vrule height20pt width220pt depth5pt\whiteink
\llap{\fontsize{26}{26}\selectfont\bfseries FPO scaled at \@fpo\%}\blackink\hfill}}}%
\FPfalse\fi\fi%
}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Styles of Figures
%
\sideverticalskip=0pt
\sidetskip=0pt
%
\def\FigName{figure}
%
\newif\ifwebcolor\global\webcolorfalse
\def\webcolr{\global\webcolortrue}
\def\webcolortext{(Colour online)\ }
\long\def\@makecaption#1#2{%
\ifx\FigName\@captype
\vskip\abovecaptionskip
\@makefigurecaption{#1}{\ifwebcolor\webcolortext\else\fi#2}%
\vskip0pt
\else
\@maketablecaption{#1}{#2}%
\vskip\belowcaptionskip
\fi}
%
\renewcommand\thetable{\arabic{table}}
%
\def\fps@table{tbp}
\def\ftype@table{2}
\def\ext@table{lot}
\def\fnum@table{\tablename\ \thetable}
%
\def\tablefootnote#1{
\global\advance\tfootcount1\expandafter\gdef\csname tablefootnote\the\tfootcount\endcsname{#1}}
%
%\newenvironment{table}
% {\global\tableshowtrue\@float{table}}
% {\@@tabcap\vskip9.5pt\hrule\end@float\global\tableshowfalse}
\newenvironment{table}
{\global\tableshowtrue\@float{table}}
{\end@float\global\tableshowfalse}
%
\def\tablebelowspace#1{\gdef\@tablebelowspace{#1}}\tablebelowspace{}
%
\newenvironment{table*}
{\let\footnote\tablefootnote%%
\@dblfloat{table}}
{%
\ifx\@tablebelowspace\@empty%
\else%
\vspace*{\@tablebelowspace}\tablebelowspace{}%
\fi%
\end@dblfloat\global\tablefootnotenonefalse\global\killtableabovespacefalse}
%
\newenvironment{intexttable}
{\begin{table}[h]}
{\end{table}}
%
\gdef\base{10pt}
\gdef\colbase{10pt}
%
\newenvironment{Table}
{\par\addvspace{12pt plus2pt}\def\@captype{table}}
{\par\addvspace{12pt plus2pt}}
%
\newenvironment{boxtextTable}[1][\relax]%
{\par\addvspace{12pt plus2pt}\def\@captype{table}}
{\par\addvspace{12pt plus2pt}}
%
\newenvironment{Table*}
{\par\addvspace{12pt plus2pt}\def\@captype{table}}
{\par\addvspace{12pt plus2pt}}
%
\def\tableabovespace#1{\gdef\@tableabovespace{#1}}\tableabovespace{}
%
\def\tnumspace{\hbox{\ }}
\def\tspace{}
%
\def\tablecontinued{{\fontsize{7.5}{10}\bfseries\itshape\selectfont (Continued)}}
\def\tableexplanation#1{\itshape\selectfont #1}
\def\tableexplanationskip{\hskip8.5pt}
%
\def\tablefig#1{\gdef\@tablefig{#1}}\tablefig{des-tableshade}
%
\overfullrule0pt
%
\tablenumcapsep=-3.5pt
%
\def\tablecolshade#1#2#3#4{%
\vbox to 0pt{\parindent0pt\vspace*{#2pt}\vspace*{-7.8pt}\hbox to 0pt{\vbox{\hspace*{#1pt}\hspace*{-6pt}\hbox{\vcolor{\grayten\vrule height#3pt width#4pt depth0pt}}}}}}%
%
\def\tableshade#1{\gdef\@tableshade{#1}}\tableshade{0pt}%
\def\tableruleheight#1{\gdef\@tableruleheight{#1}}\tableruleheight{138pt}%
%
\newbox\tabbox
\def\rowsepspace{\\[-15pt]\\}
%
\def\mextraskip#1{\gdef\@mextraskip{#1}}\mextraskip{0pt}
%
\extratableheight0pt
%
\def\adjusttableboxheight#1{\global\extratableheight#1}\adjusttableboxheight{0pt}
\def\tableboxheight#1{\gdef\@tableboxheight{#1}}\tableboxheight{0pt}
%
\tablebodywidth0pt
\tableheight0pt
%
\def\tablebodystartleftskip#1{\gdef\@tablebodystartleftskip{#1}}\tablebodystartleftskip{0pt}
\def\tablebodystartrightskip#1{\gdef\@tablebodystartrightskip{#1}}\tablebodystartrightskip{0pt}
%
\def\@maketablecaption#1#2{%
\global\setbox\tabbox\hbox{\tablecaptionfont\ifunnumtable\else{\tablecaptionnumfont#1}\fi\figpunct\kern4pt #2\vphantom{y}}%
\unhbox\tabbox}
%
\def\tbl#1#2{%
\global\setbox\tempbox\hbox{\tablefont#2}%
\global\setbox\temptbox\hbox{\tablecaptionfont#1}%
\global\setbox\temptbox\hbox{{\tablecaptionfont\ifunnumtable\else\noindent{\tablecaptionnumfont\fnum@table\hskip\tablenumcapsep}\fi#1\vphantom{y}\par}}%
\global\tablewidth\wd\tempbox%
{\box\tempbox}%
\caption{#1}}%
%
\def\TCH#1{\TCHfont#1}%
%
\def\x{@{\extracolsep{\fill}}}
%
\def\hhrulefill{\hbox\bgroup\leavevmode\leaders\hrule\hfill\kern\z@\egroup}
%
\long\def\multicolumn#1#2#3{\multispan{#1}\begingroup
\@mkpream{#2}%
\def\@sharp{#3}%\setbox\tempbox\hbox{#3}\raise-5pt\hbox to 0pt{\hfill\hbox{\vrule height.5pt width\wd\tempbox depth0pt}}
\set@typeset@protect
\let\@startpbox\@@startpbox\let\@endpbox\@@endpbox
\@arstrut \@preamble\hbox{}\endgroup\ignorespaces}
%
\def\@cline#1-#2\@nil{%
\omit
\@multicnt#1%
\advance\@multispan\m@ne
\ifnum\@multicnt=\@ne\@firstofone{&\omit}\fi
\@multicnt#2%
\advance\@multicnt-#1%
\advance\@multispan\@ne
\leaders\hrule\@height\arrayrulewidth\hfill
\cr
\noalign{\vskip-\arrayrulewidth}}
%
%%%%%%%%%%%%%%% B-Table Rules %%%%%%%%%%%%%%
%
\usepackage{booktabs}
\newenvironment{tabnote}{\tabnotefont\par}
{\par\global\manshowtfootskip=0pt}
%
\def\vcolor#1{#1\special{color pop}}
\def\grayten{\special{color push cmyk 0 0 0 0.1}}
%
\def\TBCOLSH#1#2#3#4{\vbox to 0pt{\vspace*{#1pt}\vspace*{-12pt}\hbox to 0pt{\hspace*{#2pt}\vbox{\hbox{\vcolor{\grayten\vrule height#3pt width#4pt depth0pt}}}}}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Math %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\setlength\arraycolsep{5\p@}
\setlength\tabcolsep{6\p@}
\setlength\arrayrulewidth{.4\p@}
\setlength\doublerulesep{2\p@}
\setlength\tabbingsep{\labelsep}
\setlength\fboxsep{3\p@}
\setlength\fboxrule{.4\p@}
%
\setlength\columnsep{24\p@}
\setlength\columnseprule{0\p@}
%
\newdimen\belowtoprulesep
\heavyrulewidth=.5pt
\lightrulewidth=.25pt
\cmidrulewidth=.25pt
\belowrulesep=4pt
\belowtoprulesep=2pt
\belowbottomsep=0pt
\aboverulesep=3.2pt
\abovetopsep=0pt
\cmidrulesep=\doublerulesep
\doublerulesep=2pt
%
\def\toprule{\noalign{\ifnum0=`}\fi
\@aboverulesep=\abovetopsep
\global\@belowrulesep=\belowtoprulesep %global cos for use in the next noalign
\global\@thisruleclass=\@ne
\@ifnextchar[{\@BTrule}{\@BTrule[\heavyrulewidth]}}
\def\topline{\toprule}
\def\botline{\bottomrule}
\ifeqnum
\renewcommand\theequation{\arabic{equation}}
\else
\@addtoreset{equation}{section}
\renewcommand\theequation{\thesection.\arabic{equation}}
\fi
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Footnote %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\renewcommand\footnoterule{%
\kern-3\p@
\hrule\@width0pt
\kern2.6\p@}
\@addtoreset{footnote}{chapter}
\foot@parindent18pt
\newcommand\@makefntext[1]{%
\ifpddata%
\else%
\ifFoottext%
\else%
\rule{6pc}{.5pt}\vskip5pt
\fi\fi%
\noindent
\hb@xt@\foot@parindent{\hss\@makefnmark}#1}
\def\@makefnmark{%
\ifpddata%
\setcounter{footnote}{0}%
\else%
\hbox{\@textsuperscript{\normalfont\@thefnmark}}%
\fi}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Footnote %%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Page styles %%%%%%%%%%%%%%%%%%%%%%%%%%%%
\def\oddfolio{{\foliofont\thepage}}
\def\evenfolio{{\foliofont\thepage}}
%
\def\lefttitle#1{\gdef\@versorh{#1}}\lefttitle{}
\def\righttitle#1{\gdef\@rectorh{#1}}\righttitle{}
%
\def\ps@headings{%
\let\@oddfoot\@empty%
\let\@evenfoot\@empty%
\def\@oddhead{\JFP@linecountL%
\hbox to \typewidth{\hfill{\rhfont\@rectorh}\hfill{\oddfolio}}%
}%
\def\@evenhead{\JFP@linecountL%
\hbox to \textwidth{{\evenfolio}\hfill{\rhfont\@versorh}\hfill}%
}%
\let\@mkboth\markboth
\def\chaptermark##1{\markboth{\@versorh}{\@rectorh}}%
% \def\sectionmark##1{\markright{##1}}%
}%
\def\mrhfont{\fontfamily{\sfdefault}\fontsize{9}{9}\bfseries\selectfont}
\def\mfoliofont{\fontfamily{\sfdefault}\fontsize{9}{9}\bfseries\selectfont}
\def\moddfolio{{\mfoliofont\thepage}}
\def\mevenfolio{{\mfoliofont\thepage}}
\def\ps@empty{%
\def\@oddfoot{}%
\let\@evenfoot\@oddfoot
\def\@evenhead{}%
\def\@oddhead{}%
\let\@mkboth\markboth
\let\chaptermark\@gobble
\let\sectionmark\@gobble}
\def\ps@rotatepage{%
\def\@oddfoot{\hfill\oddfolio\hfill}%
\def\@evenfoot{\hfill\evenfolio\hfill}
\def\@evenhead{}%
\def\@oddhead{}%
\let\@mkboth\markboth
\let\chaptermark\@gobble
\let\sectionmark\@gobble}
%
\def\logo@Image@path{../Figures/Logo/LaTeX-Logo/}
%%%%%%%%%%%%%%%%%%%%%%%% Proof Readers Template %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\font\QEDlogofont=msam10 at 10.7pt
\def\QEDlogo{\hbox{\QEDlogofont\char'003}}
\def\QEDblogo{\hbox{\QEDlogofont\char'004}}
\def\sqbox{{\QEDlogofont\char'004}}
\def\prbox{\unskip\hskip4.5pt\ignorespaces{\fboxsep0pt\fbox{\vrule width5pt height5pt depth0pt}}\global\logofalse}
\def\@proof[#1]{\noindent{\itshape#1.\hskip9.5pt}\ignorespaces}
\ptdraftrule0pt
%%%%%%%%%%%%%%%%%%%%%%%% Proof Readers Template %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\ptdraftrule0pt
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Bibliography Section %%%%%%%%%%%%%%%%%%
\def\surname#1{#1}
\def\givenname#1{#1}
\def\middlename#1{#1}
\def\pubname#1{#1}
\def\corporate#1{#1}
\def\booktitle#1{#1}
\def\jmonth#1{#1}
\def\articletitle#1{#1}
\def\edition#1{#1}
\def\firstpage#1{#1}
\def\lastpage#1{#1}
\def\issue#1{#1}
\def\volume#1{#1}
\def\bibyear#1{#1}
\def\jaddress{\unskip,\ }
\def\comma{,}
\def\semicolon{;}
\def\fullstop{.}
\def\nocomma{\def\comma{\unskip\ignorespaces}}
\def\nofullstop{\def\fullstop{}}
%%%%% TRUE FOR CHAPTER TITLE AND FALSE FOR SECTION TITLE %%%%%%%%
%%%%%%%% Unnumberd References %%%%%%%%%%%
\setlength\bibleftmargin {9pt}
\setlength\bibitemsep {2pt}
\setlength\bibparsep {0pt}
%%%%%%%% Numbered Within Squre Bracket %%%%%%%%%%%
\setlength\biblabelsep {10pt}
\setlength\bibleftmargini {5.75pt}
%%%%%%%% Numbered With Dot %%%%%%%%%%%%%%%
\def\firstsectionhead{\vspace*{8.7pt}\bibitem{}\ \vspace*{-20pt}}
\setlength\bibtext {5pt}
%
\def\referenceheadfont{\fontsize{10}{12}\bfseries\selectfont\leftskip0pt plus1fill\rightskip11pt plus1fill}
%
\newenvironment{thebibliography}[1]
{\let\section\referencehead
\bibliofont
\pdfbookmark{References}{HL\bibname}
\def\@tempa{#1}%
\if@unnumref
\list{}%
{\labelwidth0pt\labelsep0pt
\leftmargin\bibleftmargin%12
\itemindent-\bibleftmargin
\itemsep\bibitemsep
\parsep\bibparsep
\usecounter{enumiv}%
\let\p@enumiv\@empty
\renewcommand\theenumiv{\arabic{enumiv}}}%
\else
\setbox\tempbox\hbox{\@tempa.}
\tempdimen\wd\tempbox
\advance\bibtext\tempdimen
\ifnumsqure
\else
\def\@biblabel##1{\hbox to \bibtext{\hbox to \tempdimen{\hfill##1.}\hfil}}\fi%
\list{\@biblabel{\arabic{enumiv}}}%
{\settowidth\labelwidth{\@biblabel{#1}}%
\labelsep0pt\leftmargin\labelsep
\advance\leftmargin\bibtext
\ifnumsqure
\advance\leftmargin\bibleftmargini
\labelsep\biblabelsep\fi
\itemindent0pt
\itemsep\bibitemsep
\parsep\bibparsep
\usecounter{enumiv}%
\let\p@enumiv\@empty
\renewcommand\theenumiv{\arabic{enumiv}}}%
\fi
\sloppy\clubpenalty10000\widowpenalty10000%
\sfcode`\.=\@m}
{\def\@noitemerr
{\@latex@warning{Empty `thebibliography' environment}}%
\endlist}
\newcommand\newblock{}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Bibliography Section %%%%%%%%%%%%%%%%
\usepackage[authoryear]{natbib}
\bibpunct{(}{)}{;}{a}{,}{,}
\setlength{\bibsep}{0.3mm}
\def\bibfont{\bibliofont}
\renewenvironment{thebibliography}[1]{%
\bibsection
\parindent\z@
\bibpreamble
\bibfont
\list{\@biblabel{\the\c@NAT@ctr}}{\@bibsetup{#1}\global\c@NAT@ctr\z@}%
\ifNAT@openbib
\renewcommand\newblock{\par}%
\else
\renewcommand\newblock{\hskip .11em \@plus.33em \@minus.07em}%
\fi\itemindent-9pt\leftskip-1pt\itemsep0pt
\sloppy\clubpenalty4000\widowpenalty4000
\sfcode`\.\@m
\let\NAT@bibitem@first@sw\@firstoftwo
\let\citeN\cite \let\shortcite\cite
\let\citeasnoun\cite
}{%
\bibitem@fin
\bibpostamble
\def\@noitemerr{%
\PackageWarning{natbib}{Empty `thebibliography' environment}%
}%
\endlist
\bibcleanup
}%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Bibliography Section %%%%%%%%%%%%%%%%
%
\newcommand\@pnumwidth{.5pc}%
\newcommand\@tocrmarg{2em}%
\newcommand\@minitocrmarg{1.5pc}%
\newcommand\@dotsep{4.5}%
\setcounter{tocdepth}{3}%
\newcommand\tableofcontents{%
\title{\contentsname}%
\markboth{\contentsname}{\contentsname}%
\@starttoc{toc}}%
\newcommand*\l@title[2]{%
\ifnum \c@tocdepth >\m@ne
\addpenalty{-\@highpenalty}%
\vskip 1.0em \@plus\p@
\setlength\@tempdima{1.5em}%
\begingroup
\parindent \z@ \rightskip \@pnumwidth
\parfillskip -\@pnumwidth
\leavevmode \bfseries
\advance\leftskip\@tempdima
\hskip -\leftskip
#1\nobreak\hfil \nobreak\hb@xt@\@pnumwidth{\hss #2}\par
\penalty\@highpenalty
\endgroup
\fi}
\newcommand*\l@section{\@dottedtocline{1}{1.5em}{2.3em}}
\newcommand*\l@subsection{\@dottedtocline{2}{3.8em}{3.2em}}
\newcommand*\l@subsubsection{\@dottedtocline{3}{7.0em}{4.1em}}
\newcommand*\l@paragraph{\@dottedtocline{4}{10em}{5em}}
\newcommand*\l@subparagraph{\@dottedtocline{5}{12em}{6em}}
%
\def\Copyright{\leavevmode\fontsize{6.5}{11}\selectfont{\ooalign{\hfil\raise-.25pt\hbox{\fontsize{5}{11}\selectfont C\hskip.5pt}%
\hfil\crcr\mathhexbox20D}}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Appendix %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\newcommand\appendix{\par
\setcounter{chapter}{0}%
\setcounter{section}{0}%
%\renewcommand\@chapapp{\appendixname}%
\renewcommand\thechapter{\Alph{chapter}}}
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Appendix %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\alphabet#1{\par\vskip.5\baselineskip{\bf#1}\par\vskip.5\baselineskip}
%
\def\indmatter#1{\gdef\@indmatter{#1}}
\indmatter{}
%
\newenvironment{theindex}{\cleardoublepage%
\columnseprule \z@
\columnsep 12\p@
\markboth{\indexname}{\indexname}
\tempdimen\normalbaselineskip
\advance\tempdimen-\baselineskip
\twocolumn[\@makeschapterhead{\indexname}\vskip\tempdimen\vskip3pt
\ifx\@indmatter\@empty\else\noindent{\indexfont\@indmatter\par\vskip\baselineskip}\fi%
]%
\thispagestyle{plain}
\parindent\z@\indexfont
\let\item\@idxitem}
{\par\indmatter{}}
\newcommand\@idxitem {\par\hangindent3em}
\newcommand\subitem {\par\hangindent3em\hspace*{1em}}
\newcommand\subsubitem{\par\hangindent3em\hspace*{2em}}
\newcommand\indexspace{\par \vskip\baselineskip}
%%%%%%%%%%%%%%%%%%%% File Version %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\ifprinter
\def\draftnote{\vphantom{\vbox to 0pt{\vskip-12pt
\hbox{\ \footnotesize\jobname\vphantom{pq}\qquad\jobtag\qquad\today\qquad\currenttime\qquad Char Count= \@TotalChars
\ifmathtif\else\@questionmark\fi\hfil}}}%
\def\comment{}
\def\Qauthor#1{}
\def\QtoAuthor#1{}
\def\QtoClient#1{}
\def\QtoQC#1{}
\def\QtoGL#1{}
\def\qtoa#1{}
\else
\def\draftnote{\vbox to 0pt{\vskip-12pt}}%
\def\Qauthor#1{\marginpar{{\raggedright\footnotesize\bf #1\endgraf}}}
\fi
\let\qtoa\Qauthor
%%%%%%%%%%%%%%%%%%%% Character count %%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\gray{\special{color push cmyk 0 0 0 0.5}}
\def\@questionmark{\vbox to 0pt{\rotatebox{40}{\hbox to \textwidth{
\begin{picture}(0,0)\put(-340,-50){
\fontsize{90}{90}\selectfont Compile Again}\end{picture}\hss}}}}
\def\questionmark#1{\xdef\@questionmark{#1}}%
%
\def\@TotalChars{}
\def\TotalChars#1{\xdef\@TotalChars{#1}}%
%
\def\cropmarks{\nointerlineskip\vbox to 0pt{\offinterlineskip\vss
\hbox to \trimwidth{\vbox to 0pt{\draftnote}\hfill}}}%
\def\croprules{%
\nointerlineskip\vbox to 0pt{\offinterlineskip
\vskip4pt\cropmarks
\vskip\topmargin
\hbox to \trimwidth{\hskip\@themargin\hbox to \textwidth{\hss%
\vrule height0pt depth\typeheight width.1pt%
\vrule height.1pt depth0pt width\textwidth
\vrule height0pt depth\typeheight width.1pt\hss}}%
\hbox to \trimwidth{\hskip\@themargin\hbox to \textwidth{\hss%
\vrule height.1pt depth0pt width\textwidth\hss}\hss}}}
%
\gdef\@placewidthart{}
%
\figwidth0pt
\figheight0pt
%
\def\authorname{}
\def\jobno{}
\def\chapno{}
%
\def\changeh#1.#2pt{}
%
\def\ArtPiece#1#2#3{%
\fboxrule.1pt
\fboxsep0pt
\oldfigwidth\figwidth
\gdef\figtemp{#1}%
% \addtocounter{figure}{1}
%%%% for scaling
\gdef\figtempscale{#3}%\ifx\figtempscale\empty\figtempcount100\else\figtempcount\figtempscale\fi\multiply\figtempcount10
%%%% to add to figheight
\setbox\tempbox=\vbox{\epsfbox{#1}}%
\figheight\ht\tempbox
%%%% to add to figwidth
\setbox\tempbox=\hbox{\epsfbox{#1}}%
\advance\figwidth\wd\tempbox
\presentfigwidth\wd\tempbox
\remainingtextwidth\textwidth
\advance\remainingtextwidth-\oldfigwidth
\advance\remainingtextwidth-\presentfigwidth
\tempdim\oldfigwidth\advance\tempdim\presentfigwidth
%\ifdim\tempdim>\textwidth\par\vskip6pt \figwidth0pt
\ifdim\remainingtextwidth<0pt\par\vskip6pt %\figwidth0pt
\else
%%%% testing whether line is full
\fi
\setbox\tempbox=\hbox{\fbox{\epsfbox{#1}\hss}}%
\xdef\@placewidthart{\@placewidthart\unhbox\tempbox}%
\leavevmode\vbox{\hsize\presentfigwidth\parindent0pt\leftskip0pt plus1fill\rightskip\leftskip{}
\@placewidthart\par
\vskip3pt
% Fig. #2\par
Figure: \figtemp\par
Reduction: \figtempscale\%\par
Height:\the\figheight\par
Width: \the\presentfigwidth\par
\jobno\quad \chapno \quad\authorname}\unskip\hskip10pt}
%
%%%%%%%%%%%%%%%%%%% End File Version %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Trimmarks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%\def\trimmarks{%
% \vbox to 0pt{%
% \vskip-25pt\parindent0pt
% \draftnote\offinterlineskip}%
% \ifdraft
% \vbox to 0pt{\hsize\trimwidth\offinterlineskip
% \parindent0pt\leftskip0pt\rightskip0pt
% \fboxsep0pt\fboxrule\draftrule
% \fbox{\vbox{\vskip\trimheight\hskip\trimwidth}}}%
%%
% \vbox to 0pt{\hsize\trimwidth\offinterlineskip
% \parindent0pt\leftskip0pt\rightskip0pt
% \vbox to \trimheight{\offinterlineskip\parindent0pt
% \hbox to \trimwidth{\vbox to 2pc{\vskip-3.5pc\hbox{\vrule height2pc width\trimrule}}\raisebox{2pc}{\hbox{\hskip-3.5pc\vrule width2pc height\trimrule}}\hfill
% \raisebox{2pc}{\vrule width2pc height\trimrule\hskip-3.75pc}
% \vbox to 2pc{\vskip-3.5pc\hbox{\vrule height2pc width\trimrule}}%
% }\vfill
% \hbox to \trimwidth{\hbox{\hskip-3.5pc\vrule height\trimrule width2pc}\vbox to 3pc{\vspace*{4.5pc}\hbox{\hskip1.5pc\vrule width\trimrule height2pc}}\hfill
% \vbox to 3.5pc{\vskip5pc\hbox{\vrule height2pc width\trimrule}}\rlap{\hskip1.5pc\vrule width2pc height\trimrule}}}}%
%%
% \else
% \vbox to 0pt{\hsize\trimwidth\offinterlineskip
% \parindent0pt\leftskip0pt\rightskip0pt
% \vbox to \trimheight{\offinterlineskip\parindent0pt
% \ifregistermark
% \vbox to 0pt{\vspace*{-43.35pt}\hbox to \trimwidth{\hss\epsfbox{logo-02.eps}\hss}}
% \fi
% \hbox to \trimwidth{\vbox to 2pc{\vskip-3.5pc\hbox{\vrule height2pc width\trimrule}}\raisebox{2pc}{\hbox{\hskip-3.5pc\vrule width2pc height\trimrule}}\hfill
% \raisebox{2pc}{\vrule width2pc height\trimrule\hskip-3.75pc}
% \vbox to 2pc{\vskip-3.5pc\hbox{\vrule height2pc width\trimrule}}%
% }\vfill
% \ifregistermark{\hbox to \trimwidth{\hskip-43pt\epsfbox{logo-01.eps}\hfill\epsfbox{logo-01.eps}\hskip-43pt}}\fi
% \vfill
% \hbox to \trimwidth{\hbox{\hskip-3.5pc\vrule height\trimrule width2pc}%
% \vbox to 3pc{\vspace*{4.5pc}\hbox{\hskip1.5pc\vrule width\trimrule height2pc}}\hfill
% \vbox to 3.5pc{\vskip5pc\hbox{\vrule height2pc width\trimrule}}\rlap{\hskip1.5pc\vrule width2pc height\trimrule}}
% \ifregistermark\vbox to 0pt{\vspace*{18.15pt}\hbox to \trimwidth{\hss\epsfbox{logo-02.eps}\hss}}\fi}}
%\fi
%\insidedraftrules}
%
\def\insidedraftrules{\vbox to 0pt{%
\offinterlineskip\parindent0pt
\vskip \topmargin
\tempdimen\normaltextheight
\advance\tempdimen\headheight
\advance\tempdimen\headsep
\moveright\@themargin
\vbox{\vbox to 0pt{\vskip\headheight\vskip\headsep
\vrule height\draftrule width\textwidth}
\hbox{\fboxsep0pt\fboxrule\draftrule
\fbox{\vbox to \tempdimen
{\hsize\textwidth\hskip\textwidth}}}}}}%
%
\def\insidedraftrules{\overfullrule0pt%
\iffloutsidemargin
% \addtolength\evensidemargin{-\colmargin}
\addtolength\oddsidemargin{0pt}
\fi
\ifflinsidemargin
\addtolength\evensidemargin{-\colmargin}
\addtolength\oddsidemargin{\colmargin}
\fi
\ifflinsidetexttypewidthsep
\addtolength\oddsidemargin{\texttypewidthsep}
\addtolength\evensidemargin{-\texttypewidthsep}
\fi
\ifflleftsidemargin
% \addtolength\evensidemargin{-2pc}
\addtolength\oddsidemargin{\colmargin}
\fi
\ifflleftsidetexttypewidthsep
% \addtolength\evensidemargin{-2pc}
\addtolength\oddsidemargin{\texttypewidthsep}
\fi
\ifflrightsidemargin
\addtolength\evensidemargin{-\colmargin}
\fi
\ifflrightsidetexttypewidthsep
\addtolength\evensidemargin{-\texttypewidthsep}
\fi
\vbox to 0pt{%
\offinterlineskip\parindent0pt
\vskip \topmargin
\tempdimen\normaltextheight
\advance\tempdimen\headheight
\advance\tempdimen\headsep
\advance\tempdimen-0.4pt
\moveright\@themargin
\ifodd\c@page
\hbox to \textwidth{\hss\hbox to \typewidth{%
\vbox to \tempdimen{\hrule height\draftrule
\vbox to 0pt{\vskip\headheight\vskip\headsep%\vskip-6pt
%\hbox{\vrule height\draftrule width\typewidth}
}%
\hbox to \typewidth{\vrule width\draftrule
\hfill\vrule height\tempdimen width\draftrule%
\iffloutsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule\hskip-.3pt%
\fi%
\iffloutsidemargin%
\hskip\colmargin\vrule height\tempdimen width\draftrule\hskip-.3pt%
\fi%
\ifflinsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule%
\fi%
\ifflinsidemargin%
\hskip\textwidth\hskip-.5pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflleftsidetexttypewidthsep%
\hskip\texttypewidthsep\hskip0pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflleftsidemargin%
\hskip\textwidth\hskip-.5pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflrightsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule\hskip-.5pt%
\fi%
\ifflrightsidemargin%
\hskip\colmargin\vrule height\tempdimen width\draftrule\hskip-.3pt%
\fi%
}%
\hrule height\draftrule}}%
\iffloutsidemargin%
\hskip-\colmargin%
\fi%
\iffloutsidetexttypewidthsep%
\hskip-\texttypewidthsep%
\fi%
\ifflinsidemargin%
% \hskip-\colmargin%
\fi%
\ifflleftsidemargin%
% \hskip-\colmargin%
\fi%
\ifflrightsidemargin%
\hskip-\colmargin%
\fi%
\ifflrightsidetexttypewidthsep%
\hskip-\texttypewidthsep%
\fi%
}%
\else%
\hbox to \textwidth{\hss\hbox to \typewidth{%
\vbox to \tempdimen{\hrule height\draftrule%
\vbox to 0pt{\vskip\headheight\vskip\headsep%\vskip-6pt
%\hbox{\vrule height\draftrule width\typewidth}%
}%
\hbox to \typewidth{\vrule width\draftrule%
\hfill\vrule height\tempdimen width\draftrule%
\iffloutsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule%
\fi%
\iffloutsidemargin%
\hskip\textwidth\hskip-.5pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflinsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule%
\fi%
\ifflinsidemargin%
\hskip\colmargin\ifflinsidetexttypewidthsep\hskip-.3pt\fi\vrule height\tempdimen width\draftrule\hskip-.3pt%
\fi%
\ifflleftsidetexttypewidthsep%
\hskip\texttypewidthsep\hskip0pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflleftsidemargin%
\hskip\textwidth\hskip-.5pt\vrule height\tempdimen width\draftrule%
\fi%
\ifflrightsidetexttypewidthsep%
\hskip\texttypewidthsep\vrule height\tempdimen width\draftrule\hskip-.5pt%
\fi%
\ifflrightsidemargin%
\hskip\colmargin\vrule height\tempdimen width\draftrule\hskip-.3pt%
\fi%
}%
\hrule height\draftrule}}%
\iffloutsidemargin%
% \hskip-\colmargin%
\fi%
\ifflinsidemargin%
\hskip-\colmargin%
\fi%
\ifflinsidetexttypewidthsep
\hskip-\texttypewidthsep%
\fi
\ifflleftsidemargin%
% \hskip-\colmargin%
\fi%
\ifflrightsidemargin%
\hskip-\colmargin%
\fi%
\ifflrightsidetexttypewidthsep%
\hskip-\texttypewidthsep%
\fi%
}%
\fi}}%
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Trimmarks %%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Output Routine %%%%%%%%%%%%%%%%%%%%%%%%%%
%
\def\@outputpage{%
\begingroup % the \endgroup is put in by \aftergroup
\let \protect \noexpand
\@resetactivechars
\@parboxrestore
\shipout \vbox{%
\set@typeset@protect
\aftergroup \endgroup
\aftergroup \set@typeset@protect
% correct? or just restore by ending
% the group?
\if@specialpage
\global\@specialpagefalse\@nameuse{ps@\@specialstyle}%
\fi
\if@twoside
\ifodd\count\z@ \let\@thehead\@oddhead \let\@thefoot\@oddfoot
\let\@themargin\oddsidemargin
\else \let\@thehead\@evenhead
\let\@thefoot\@evenfoot \let\@themargin\evensidemargin
\fi
\fi
\reset@font
\normalsize
\normalsfcodes
\let\label\@gobble
\let\index\@gobble
\let\glossary\@gobble
\baselineskip\z@skip \lineskip\z@skip \lineskiplimit\z@
\@begindvi%\trimmarks
\vskip \topmargin
\moveright\@themargin \vbox {%
\setbox\@tempboxa \vbox to\headheight{%
\vfil
\color@hbox
\normalcolor
\hb@xt@\textwidth{\@thehead}%
\color@endbox
}% %% 22 Feb 87
\dp\@tempboxa \z@
\box\@tempboxa
\vskip \headsep
\box\@outputbox
\baselineskip \footskip
\color@hbox
\normalcolor
\hb@xt@\textwidth{\@thefoot}%
\color@endbox
}%
}%
\global \@colht \textheight
\stepcounter{page}%
\let\firstmark\botmark
}
%
%%%%%%%%%%%%%%%%%%%%%%%% Misc. %%%%%%%%%%%%%%%%%%%%%%%
%
\def\@@question#1{\hbox to \hsize{\hfill
\rlap{\hskip\marginparsep
\vbox to 0pt{\hsize\marginparwidth
\footnotesize
\raggedright#1\endgraf\vss}}}}
\def\@question#1{\ifvmode
\@@question{#1}%
\else
\vadjust{\vbox to 0pt{%
\vskip-7.5pt\@@question{#1}\vskip7.5pt}}
\fi}
%
\def\QtoAuthor#1{\@question{{\bf Author:\ #1}}}
\def\QtoClient#1{\@question{{\bf Client/PM:\ #1}}}
\def\QtoQC#1{\@question{{\bf QC:\ #1}}}
\def\QtoGL#1{\@question{{\bf GL:\ #1}}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% End Output Routine %%%%%%%%%%%%%%%%%%%%%%
%
\def\spreadlong#1{\ifodd\c@page\wlog{Ignoring spreadlong}
\else
\spreadlongtrue\gdef\@spreadlong{#1}%
\enlargethispage{#1}%
\fi}
%
\advance\voffset-82pt%
\advance\hoffset-72.1pt%
\def\endash{--}
%
\let\paperheight\trimheight %JG
\usepackage{hyperref}%
\hypersetup{
colorlinks=true,
linkcolor=blue,
anchorcolor=blue,
citecolor=blue,
urlcolor=blue,
filecolor=blue,
bookmarksopenlevel=3,
bookmarksopen=true,
pdfborderstyle={/S/U/W 0},
pdfstartview={FitH 800},
breaklinks=true}
\usepackage{bookmark}[2011/12/02]
\usepackage{etoolbox}
\ifnatbiboff\else
\patchcmd{\NAT@citex}
{\@citea\NAT@hyper@{%
\NAT@nmfmt{\NAT@nm}%
\hyper@natlinkbreak{\NAT@aysep\NAT@spacechar}{\@citeb\@extra@b@citeb}%
\NAT@date}}
{\@citea\NAT@nmfmt{\NAT@nm}%
\NAT@aysep\NAT@spacechar\NAT@hyper@{$\NAT@date$}}{}{}
\fi
%
%% Patch case where name and year are separated by opening bracket
\patchcmd{\NAT@citex}
{\@citea\NAT@hyper@{%
\NAT@nmfmt{\NAT@nm}%
\hyper@natlinkbreak{\NAT@spacechar\NAT@@open\if*#1*\else#1\NAT@spacechar\fi}%
{\@citeb\@extra@b@citeb}%
\NAT@date}}
{\@citea\NAT@nmfmt{\NAT@nm}%
\NAT@spacechar\NAT@@open\if*#1*\else#1\NAT@spacechar\fi\NAT@hyper@{$\NAT@date$}}
{}{}
%\fi
\usepackage{amsmath}
\usepackage[nameinlink,capitalize]{cleveref}
\newcommand*{\eqautoref}[2][Equation]{%
\hyperref[{#2}]{#1 (\ref*{#2})}%
\protected@write\@auxout{}{\gdef\string\geteqautoref{\string\autoval[#2]<linkname>#1</linkname>(<linkval>\csname r@#2\endcsname</linkval>)}}}
\newcommand*{\qautoref}[2][]{%
\hyperref[{#2}]{#1 \ref*{#2}}%
\protected@write\@auxout{}{\gdef\string\getqautoref{\string\autoval[#2]<linkname>#1</linkname><linkval>\csname r@#2\endcsname</linkval>}}}
\renewcommand{\sectionautorefname}{Section}
\renewcommand{\subsectionautorefname}{\sectionautorefname}
\renewcommand{\subsubsectionautorefname}{\sectionautorefname}
\renewcommand\footnoterule{%
\kern-3\p@
\hrule \@width .4\columnwidth height \z@
\kern 3\p@}
\newif\iftitlefn
%%
\newbox\tempbox
\newdimen\@footmax
\def\footmax#1{%
\setbox\tempbox\hbox{\footnotesize$^{#1}$}%
\global\@footmax\wd\tempbox\global\advance\@footmax.5em}
%
\footmax{0}
%%
\renewcommand\@makefntext[1]{%
\leavevmode\@hangfrom{\hb@xt@ \@footmax{\hss$^{\@thefnmark}\ \ $}}\footnotesize#1}
%%
\def\tbnlreffont{}
\def\tnlref#1{\ifonline\textcolor{blue}{\hyperlink{tbn-\thetable}{\hbox{\tbnlreffont#1}}}\else\tbnlreffont#1\fi}
\def\tnlget#1{\ifonline\hypertarget{tbn-\thetable}{\scriptscriptstyle#1}\else#1\fi}
\def\linkref#1#2{\ifonline\textcolor{blue}{\hyperlink{#1}{#2}}\else#2\fi}
\def\linktarget#1#2{\ifonline\hypertarget{#1}{#2}\else#2\fi}
\newif\ifsingleeqn\global\singleeqnfalse
%
\hbadness=10000
\vbadness=10000
\brokenpenalty=10000
\doublehyphendemerits=1000000
\finalhyphendemerits=1000000
\clubpenalty=10000
\widowpenalty=10000
\hyphenpenalty=50
\lefthyphenmin=3
\righthyphenmin=3
\uchyph=0
\clubpenalty10000
\widowpenalty10000
\tolerance=1
\emergencystretch=\maxdimen
\pagestyle{headings}%
\pagenumbering{arabic} % Arabic page numbers
\frenchspacing
\jot=2.5pt
\medmuskip=3.5mu
\thickmuskip=3.5mu
\thinmuskip=3.5mu
\sloppy%
\ifx\ifxetex\ifluatex
\renewcommand{\sfdefault}{phv}%
\def\rhcopyright{\copyright}
\usepackage{breakurl}
\else
\usepackage{fontspec}%
\DeclareTextCommand{\nobreakspace}{T1}{\leavevmode\nobreak\ }
\def\rhcopyright{\textcopyright}
\fi
\usepackage{newtxtext,newtxmath}
\def\abstractindent{18pt}
\def\spanrule#1{\\[-7pt]#1\\[-5pt]}
%
\def\LT@makecaption#1#2#3{%%
\LT@mcol\LT@cols c{\addtocounter{table}{-1}%
\hbox to\z@{%
\hss\parbox[t]\LTcapwidth{%%
\sbox\@tempboxa{\Set@LT@caption{#1}{#2}{#3}}%%
\ifdim\wd\@tempboxa>\hsize%%
\Set@LT@caption{#1}{#2}{#3}%%
\else%%
%\hbox to\hsize{\hss\box\@tempboxa\hss}%%
\Set@LT@caption{#1}{#2}{\centering#3}
\fi%%
\endgraf%
\vskip\belowcaptionskip%
\vskip-2\p@}\hss}}}%
%%
\gdef\do@cont@cap{{\tablecaptionnumfont \tablename\ \thetable}\break \LTtablecaptionfont {Continued}}%
%%%%%%%%%%% Font Definition Begin %%%%%%%%%%%%%%%%%%%%%%%
%
\gdef\do@cont@cap{{\tablecaptionnumfont \tablename\ \thetable}\break \LTtablecaptionfont ({\it Continued})}%
%
\def\Dheadeditor#1{\gdef\@Dheadeditor{#1}}\Dheadeditor{}
%
\def\@TiTle{}
%%%
\def\aulabel{Au:\ }
%%%%%%%%%%%%%%%% For continued Table %%%%%%%%%
%
\renewenvironment{tabnote}{\tabnotefont\par}
{\par\global\manshowtfootskip=0pt}
%
\ifpuretex
\def\gt{>}
\def\lt{<}
\else
\fi
\newcounter{cor}
\font\corsym=cmsy10 at 18pt
\font\corsymi=cmsy9 at 9pt
\def\cor{{\reset@font\corsym\char121}}
\ifbakoma\else
\patchcmd{\@mn@margintest}{\@tempswafalse}{\@tempswatrue}{}{}
\patchcmd{\@mn@margintest}{\@tempswafalse}{\@tempswatrue}{}{}
\fi
\def\elink#1{\ifonline\textcolor{blue}{\href{mailto:#1}{\color{blue}#1}}\else#1\fi}
%\newcommand{\email}{\textit{email address:}\ }%
\newcommand{\email}{\textit{e-mail:}\ }%
\def\doilink#1{\ifonline\href{https://doi.org/#1}{\textcolor{blue}{#1}}\else#1\fi}
\def\arxlink#1{\ifonline\href{https://arxiv.org/abs/#1}{\textcolor{blue}{#1}}\else#1\fi}
\def\emaillink#1{\ifonline\href{mailto:#1}{\textcolor{blue}{#1}}\else#1\fi}
\def\httplink#1{\ifonline\href{#1}{\textcolor{blue}{\refuri #1}}\else{\refuri #1}\fi}
\definecolor{snamecol}{rgb}{1,.64,1}
\def\LDAUTH#1{\ifnoquery{#1}\else\fboxsep0pt\fboxrule0pt\fcolorbox{snamecol}{snamecol}{#1}\fi}%
\newcounter{bibetem}
\def\thebibetem{\arabic{bibetem}}
\def\bibitem@fin{\refstepcounter{bibetem}%
\@ifxundefined\@bibstop{}{\csname bibitem@\@bibstop\endcsname}%
}%
\newenvironment{quote}
{\par\addvspace{5pt plus2pt}\itshape\leftskip0pt plus1fill\rightskip0pt plus 0fill}
{\par\addvspace{5pt plus2pt}}
%\newenvironment{quote}
% {\par\vskip5pt\itshape\leftskip0pt plus1fill\rightskip0pt plus 0fill}
% {\par}
\newenvironment{quotation}
{\list{}{\listparindent\parindent
\topsep6pt plus2pt\itemindent\listparindent
\leftmargin\z@ \rightmargin\leftmargin
\parsep \z@ \@plus 1\p@}\item[]%
\normalfont\small\rmfamily}
{\endlist}
%\newenvironment{quotation}
% {\list{}{\vskip6pt\listparindent\parindent
% \topsep6pt\itemindent\listparindent
% \leftmargin\z@ \rightmargin\leftmargin
% \parsep \z@ \@plus 1\p@}\item[]%
% \normalfont\small\rmfamily}
% {\endlist}
\newcommand{\citeb}[2][]{\hyperref[#1]{#2}}
%%%%%%%%%%%%%%%%%%%PHD-Abstract%%%%%%%%%%%%%%%%%%
\def\phdabsheadfont{\fontsize{12}{13}\itshape\selectfont}
\newcommand{\phdheader}{\newpage\hrule\@par\addvspace{10pt}\begin{center}}
\newcommand{\phdtitle}[1]{\phdheader {\phdabsheadfont{#1}}\\[10pt]}
\def\phdstudent#1{\authorfont{#1}\@par}
\def\phdinstitution#1{\authorfont{#1}\@par\vspace*{10pt}}
\newcommand{\phddate}[1]{\scriptsize{Date: #1}; }
\newcommand{\phdadvisor}[1]{\scriptsize{Advisor: #1} \\}
\newcommand{\phdurl}[1]{\scriptsize{URL: \url{#1}}\end{center}}
\newenvironment{phdabstract}{\@par\addvspace{5pt}}{\@par\addvspace{20pt}\hrule}
\endinput%
%%% Changes History
%%% V1.1
%%%% Changes done based on the update mentioned by Charlotte mail dated Tuesday, January 21, 2020 17:32
%%% arraycolsep changed to 1.5pt to 5pt
%%% Line Numbering activated
%%% Section Numbering activated till paragraph
%%% Quotation environment declared
%%% V1.2
%%%% Changes done based on the update mentioned by Charlotte mail dated Thursday, May 28, 2020 18:39
%%% \maketitle command modified to get the heading like "Functional Pearl" and similarly for other special categories of paper
%%% V1.3
%%%% Changes done based on the update mentioned by Charlotte mail dated Wednesday, 10 June 2020 20:01
%%% \email address text and spacing around the “quote" and “quotation" environments is stretchable at the top and fixed at the bottom
%%% V1.4
%%%% Changes done based on the update mentioned by Charlotte mail dated Thursday, 12 July 2020 15:24
%%% \@pushfilename command was commented to support JFP class file in Ubuntu 20.04
%%% amsmath package used before cleveref package to avoid compilation error generating from TeXLive 2019 and later.
%%%
%%% V1.5
%%%% Changes done based on the update mentioned by Charlotte mail dated July 28, 2021 4:47 PM
%%% \subtitle command was commented
%%% \title command was modified with single argument.
%%% V1.6
%%%% Changes done based on the update mentioned by Charlotte mail dated November 8, 2021 8:57 PM
%%% nolinenum class option defined to remove the linenumbers
%%% V1.7
%%%% Changes done based on the update mentioned by Charlotte mail dated 28 January 2022 19:44 PM
%%% bst file updated for software and online entry in bib
%%% full stop updated after the title in incollection entries
%%% V1.8
%%%% Changes done based on the update mentioned by Charlotte mail dated 23 June 2022 19:26 PM
%%% Table of Contents macro modified to remove \UnicodeCharacter and the "occupational therapy" head (hardwired into the class file)
%%% V1.9
%%%% Changes done based on the update mentioned by Charlotte mail dated 07 March 2023 9:42 PM
%%% Class file to support for LuaLaTex/XeLaTeX manuscript preparation.
+468
vendor/opam/jsont/paper/soup.ml
+468
vendor/opam/jsont/paper/soup.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 Daniel C. Bünzli. All rights reserved.
3
+
SPDX-License-Identifier: CC0-1.0
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Definitions from the soup.tex paper *)
7
+
8
+
module Type = struct (* Can be deleted with OCaml >= 5.1 *)
9
+
type (_, _) eq = Equal : ('a, 'a) eq
10
+
module Id = struct
11
+
type _ id = ..
12
+
module type ID = sig type t type _ id += Id : t id end
13
+
type 'a t = (module ID with type t = 'a)
14
+
15
+
let make (type a) () : a t =
16
+
(module struct type t = a type _ id += Id : t id end)
17
+
18
+
let provably_equal
19
+
(type a b) ((module A) : a t) ((module B) : b t) : (a, b) eq option
20
+
=
21
+
match A.Id with B.Id -> Some Equal | _ -> None
22
+
23
+
let uid (type a) ((module A) : a t) =
24
+
Obj.Extension_constructor.id (Obj.Extension_constructor.of_val A.Id)
25
+
end
26
+
end
27
+
28
+
module String_map = Map.Make (String)
29
+
30
+
(* Generic representation *)
31
+
32
+
module Json = struct
33
+
type t =
34
+
| Null of unit | Bool of bool | Number of float | String of string
35
+
| Array of t list | Obj of obj and obj = mem list and mem = string * t
36
+
end
37
+
38
+
(* The finally tagged datatype *)
39
+
40
+
type ('ret, 'f) dec_fun =
41
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
42
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
43
+
44
+
type ('a, 'b) base_map = { dec : 'a -> 'b; enc : 'b -> 'a; }
45
+
46
+
type _ jsont =
47
+
| Null : (unit, 'b) base_map -> 'b jsont
48
+
| Bool : (bool, 'b) base_map -> 'b jsont
49
+
| Number : (float, 'b) base_map -> 'b jsont
50
+
| String : (string, 'b) base_map -> 'b jsont
51
+
| Array : ('a, 'elt, 'builder) array_map -> 'a jsont
52
+
| Obj : ('o, 'o) obj_map -> 'o jsont
53
+
| Any : 'a any_map -> 'a jsont
54
+
| Map : ('a, 'b) map -> 'b jsont
55
+
| Rec : 'a jsont Lazy.t -> 'a jsont
56
+
57
+
and ('array, 'elt, 'builder) array_map =
58
+
{ elt : 'elt jsont;
59
+
dec_empty : 'builder;
60
+
dec_skip : 'builder -> int -> bool;
61
+
dec_add : 'builder -> int -> 'elt -> 'builder;
62
+
dec_finish : 'builder -> 'array;
63
+
enc : 'acc. ('acc -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; }
64
+
65
+
and ('o, 'dec) obj_map =
66
+
{ dec : ('o, 'dec) dec_fun;
67
+
mem_decs : mem_dec String_map.t;
68
+
mem_encs : 'o mem_enc list;
69
+
shape : 'o obj_shape; }
70
+
71
+
and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec
72
+
and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
73
+
and ('o, 'a) mem_map =
74
+
{ name : string;
75
+
type' : 'a jsont;
76
+
id : 'a Type.Id.t;
77
+
dec_absent : 'a option;
78
+
enc : 'o -> 'a;
79
+
enc_omit : 'a -> bool; }
80
+
81
+
and 'o obj_shape =
82
+
| Obj_basic : ('o, 'mems, 'builder) unknown_mems -> 'o obj_shape
83
+
| Obj_cases : ('o, 'cases, 'tag) obj_cases -> 'o obj_shape
84
+
85
+
and ('o, 'mems, 'builder) unknown_mems =
86
+
| Unknown_skip : ('o, unit, unit) unknown_mems
87
+
| Unknown_error : ('o, unit, unit) unknown_mems
88
+
| Unknown_keep :
89
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems) ->
90
+
('o, 'mems, 'builder) unknown_mems
91
+
92
+
and ('mems, 'a, 'builder) mems_map =
93
+
{ mems_type : 'a jsont;
94
+
id : 'mems Type.Id.t;
95
+
dec_empty : 'builder;
96
+
dec_add : string -> 'a -> 'builder -> 'builder;
97
+
dec_finish : 'builder -> 'mems;
98
+
enc : 'acc. (string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc }
99
+
100
+
and ('o, 'cases, 'tag) obj_cases =
101
+
{ tag : ('o, 'tag) mem_map; (* 'o is irrelevant, 'tag is not stored *)
102
+
tag_compare : 'tag -> 'tag -> int;
103
+
id : 'cases Type.Id.t;
104
+
cases : ('cases, 'tag) case list;
105
+
enc : 'o -> 'cases;
106
+
enc_case : 'cases -> ('cases, 'tag) case_value; }
107
+
108
+
and ('cases, 'tag) case =
109
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
110
+
111
+
and ('cases, 'case, 'tag) case_map =
112
+
{ tag : 'tag;
113
+
obj_map : ('case, 'case) obj_map;
114
+
dec : 'case -> 'cases; }
115
+
116
+
and ('cases, 'tag) case_value =
117
+
| Case_value :
118
+
('cases, 'case, 'tag) case_map * 'case -> ('cases, 'tag) case_value
119
+
120
+
and 'a any_map =
121
+
{ dec_null : 'a jsont option;
122
+
dec_bool : 'a jsont option;
123
+
dec_number : 'a jsont option;
124
+
dec_string : 'a jsont option;
125
+
dec_array : 'a jsont option;
126
+
dec_obj : 'a jsont option;
127
+
enc : 'a -> 'a jsont; }
128
+
129
+
and ('a, 'b) map =
130
+
{ dom : 'a jsont;
131
+
map : ('a, 'b) base_map }
132
+
133
+
(* Errors *)
134
+
135
+
let type_error () = failwith "type error"
136
+
let unexpected_member n = failwith ("Unexpected member " ^ n)
137
+
let missing_member n = failwith ("Missing member " ^ n)
138
+
let unknown_case_tag () = failwith "Unknown case tag"
139
+
140
+
(* Any examples *)
141
+
142
+
let option : 'a jsont -> 'a option jsont = fun t ->
143
+
let none = Null { dec = Fun.const None; enc = Fun.const () } in
144
+
let some = Map { dom = t; map = {dec = Option.some; enc = Option.get}}in
145
+
let enc = function None -> none | Some _ -> some in
146
+
let none = Some none and some = Some some in
147
+
Any { dec_null = none; dec_bool = some; dec_number = some;
148
+
dec_string = some; dec_array = some; dec_obj = some; enc; }
149
+
150
+
let json : Json.t jsont = (* left as an exercise in the paper *)
151
+
let null =
152
+
Null { dec = (fun () -> Json.Null ());
153
+
enc = (function Json.Null () -> () | j -> type_error ()) }
154
+
in
155
+
let bool =
156
+
Bool { dec = (fun b -> Json.Bool b);
157
+
enc = (function Json.Bool b -> b | j -> type_error ()) }
158
+
in
159
+
let number =
160
+
Number { dec = (fun n -> Json.Number n);
161
+
enc = (function Json.Number n -> n | j -> type_error ()) }
162
+
in
163
+
let string =
164
+
String { dec = (fun s -> Json.String s);
165
+
enc = (function Json.String s -> s | j -> type_error ()) }
166
+
in
167
+
let rec array =
168
+
let dec_empty = [] and dec_add a _i v = v :: a in
169
+
let dec_finish elts = Json.Array (List.rev elts) in
170
+
let dec_skip _ _ = false in
171
+
let enc f acc = function
172
+
| Json.Array vs -> List.fold_left f acc vs | _ -> type_error ()
173
+
in
174
+
Array { elt = Rec json; dec_empty; dec_add; dec_skip; dec_finish; enc }
175
+
and obj =
176
+
let mems_id = Type.Id.make () in
177
+
let mems =
178
+
let dec_empty = [] in
179
+
let dec_add n v ms = (n, v) :: ms in
180
+
let dec_finish ms = Json.Obj (List.rev ms) in
181
+
let enc f j acc = match j with
182
+
| Json.Obj ms -> List.fold_left (fun acc (n, v) -> f n v acc) acc ms
183
+
| _ -> type_error ()
184
+
in
185
+
{ mems_type = Rec json; id = mems_id; dec_empty; dec_add; dec_finish; enc}
186
+
in
187
+
Obj { dec = Dec_app (Dec_fun Fun.id, mems_id);
188
+
mem_decs = String_map.empty; mem_encs = [];
189
+
shape = Obj_basic (Unknown_keep (mems, Fun.id)) }
190
+
and json =
191
+
let enc = function
192
+
| Json.Null _ -> null | Json.Bool _ -> bool | Json.Number _ -> number
193
+
| Json.String _ -> string | Json.Array _ -> array | Json.Obj _ -> obj
194
+
in
195
+
lazy (Any { dec_null = Some null; dec_bool = Some bool;
196
+
dec_number = Some number; dec_string = Some string;
197
+
dec_array = Some array; dec_obj = Some obj; enc })
198
+
in
199
+
Lazy.force json
200
+
201
+
(* Heterogeneous key-value maps *)
202
+
203
+
module Dict = struct
204
+
module M = Map.Make (Int)
205
+
type binding = B : 'a Type.Id.t * 'a -> binding
206
+
type t = binding M.t
207
+
let empty = M.empty
208
+
let add k v m = M.add (Type.Id.uid k) (B (k, v)) m
209
+
let find : type a. a Type.Id.t -> t -> a option =
210
+
fun k m -> match M.find_opt (Type.Id.uid k) m with
211
+
| None -> None
212
+
| Some B (k', v) ->
213
+
match Type.Id.provably_equal k k' with
214
+
| Some Type.Equal -> Some v | None -> assert false
215
+
end
216
+
217
+
type ('ret, 'f) app =
218
+
| Fun : 'f -> ('ret, 'f) app
219
+
| App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app
220
+
221
+
let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f =
222
+
fun dec dict -> match dec with
223
+
| Dec_fun f -> f
224
+
| Dec_app (f,arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict))
225
+
226
+
(* Decode *)
227
+
228
+
let rec decode : type a. a jsont -> Json.t -> a =
229
+
fun t j -> match t with
230
+
| Null map -> (match j with Json.Null v -> map.dec v | _ -> type_error ())
231
+
| Bool map -> (match j with Json.Bool b -> map.dec b | _ -> type_error ())
232
+
| Number map ->
233
+
(match j with
234
+
| Json.Number n -> map.dec n | Json.Null _ -> map.dec Float.nan
235
+
| _ -> type_error ())
236
+
| String map -> (match j with Json.String s -> map.dec s | _ -> type_error ())
237
+
| Array map ->
238
+
(match j with Json.Array vs -> decode_array map vs | j -> type_error ())
239
+
| Obj map ->
240
+
(match j with Json.Obj mems -> decode_obj map mems | j -> type_error ())
241
+
| Map map -> map.map.dec (decode map.dom j)
242
+
| Any map -> decode_any t map j
243
+
| Rec t -> decode (Lazy.force t) j
244
+
245
+
and decode_array : type a e b. (a, e, b) array_map -> Json.t list -> a =
246
+
fun map vs ->
247
+
let add (i, a) v =
248
+
i + 1, (if map.dec_skip a i then a else map.dec_add a i (decode map.elt v))
249
+
in
250
+
map.dec_finish (snd (List.fold_left add (0, map.dec_empty) vs))
251
+
252
+
and decode_obj : type o. (o, o) obj_map -> Json.obj -> o =
253
+
fun map mems ->
254
+
apply_dict map.dec @@
255
+
decode_obj_map map String_map.empty String_map.empty Dict.empty mems
256
+
257
+
and decode_obj_map : type o.
258
+
(o, o) obj_map -> mem_dec String_map.t -> mem_dec String_map.t -> Dict.t ->
259
+
Json.obj -> Dict.t
260
+
=
261
+
fun map mem_miss mem_decs dict mems ->
262
+
let u n _ _ = invalid_arg (n ^ "member defined twice") in
263
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
264
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
265
+
match map.shape with
266
+
| Obj_cases cases -> decode_obj_case cases mem_miss mem_decs dict [] mems
267
+
| Obj_basic u ->
268
+
match u with
269
+
| Unknown_skip -> decode_obj_basic u () mem_miss mem_decs dict mems
270
+
| Unknown_error -> decode_obj_basic u () mem_miss mem_decs dict mems
271
+
| Unknown_keep (map, _) ->
272
+
decode_obj_basic u map.dec_empty mem_miss mem_decs dict mems
273
+
274
+
and decode_obj_basic : type o map builder.
275
+
(o, map, builder) unknown_mems -> builder -> mem_dec String_map.t ->
276
+
mem_dec String_map.t -> Dict.t -> Json.obj -> Dict.t
277
+
=
278
+
fun u umap mem_miss mem_decs dict -> function
279
+
| [] ->
280
+
let dict = match u with
281
+
| Unknown_skip | Unknown_error -> dict
282
+
| Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish umap) dict
283
+
in
284
+
let add_default _ (Mem_dec m) dict = match m.dec_absent with
285
+
| Some v -> Dict.add m.id v dict | None -> missing_member m.name
286
+
in
287
+
String_map.fold add_default mem_miss dict
288
+
| (n, v) :: mems ->
289
+
match String_map.find_opt n mem_decs with
290
+
| Some (Mem_dec m) ->
291
+
let dict = Dict.add m.id (decode m.type' v) dict in
292
+
let mem_miss = String_map.remove n mem_miss in
293
+
decode_obj_basic u umap mem_miss mem_decs dict mems
294
+
| None ->
295
+
match u with
296
+
| Unknown_skip -> decode_obj_basic u umap mem_miss mem_decs dict mems
297
+
| Unknown_error -> unexpected_member n
298
+
| Unknown_keep (map, _) ->
299
+
let umap = map.dec_add n (decode map.mems_type v) umap in
300
+
decode_obj_basic u umap mem_miss mem_decs dict mems
301
+
302
+
and decode_obj_case : type o cases tag.
303
+
(o, cases, tag) obj_cases -> mem_dec String_map.t -> mem_dec String_map.t ->
304
+
Dict.t -> Json.obj -> Json.obj -> Dict.t
305
+
=
306
+
fun cases mem_miss mem_decs dict delay mems ->
307
+
let decode_case_tag tag =
308
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
309
+
match List.find_opt eq_tag cases.cases with
310
+
| None -> unknown_case_tag ()
311
+
| Some (Case case) ->
312
+
let mems = List.rev_append delay mems in
313
+
let dict = decode_obj_map case.obj_map mem_miss mem_decs dict mems in
314
+
Dict.add cases.id (case.dec (apply_dict case.obj_map.dec dict)) dict
315
+
in
316
+
match mems with
317
+
| [] ->
318
+
(match cases.tag.dec_absent with
319
+
| Some t -> decode_case_tag t | None -> missing_member cases.tag.name)
320
+
| (n, v as mem) :: mems ->
321
+
if n = cases.tag.name then decode_case_tag (decode cases.tag.type' v) else
322
+
match String_map.find_opt n mem_decs with
323
+
| None -> decode_obj_case cases mem_miss mem_decs dict (mem :: delay) mems
324
+
| Some (Mem_dec m) ->
325
+
let dict = Dict.add m.id (decode m.type' v) dict in
326
+
let mem_miss = String_map.remove n mem_miss in
327
+
decode_obj_case cases mem_miss mem_decs dict delay mems
328
+
329
+
and decode_any : type a. a jsont -> a any_map -> Json.t -> a =
330
+
fun t map j ->
331
+
let dec t m j = match m with Some t -> decode t j | None -> type_error () in
332
+
match j with
333
+
| Json.Null _ -> dec t map.dec_null j
334
+
| Json.Bool _ -> dec t map.dec_bool j
335
+
| Json.Number _ -> dec t map.dec_number j
336
+
| Json.String _ -> dec t map.dec_string j
337
+
| Json.Array _ -> dec t map.dec_array j
338
+
| Json.Obj _ -> dec t map.dec_obj j
339
+
340
+
(* Encode *)
341
+
342
+
let rec encode : type a. a jsont -> a -> Json.t =
343
+
fun t v -> match t with
344
+
| Null map -> Json.Null (map.enc v)
345
+
| Bool map -> Json.Bool (map.enc v)
346
+
| Number map -> Json.Number (map.enc v)
347
+
| String map -> Json.String (map.enc v)
348
+
| Array map ->
349
+
let encode_elt a elt = (encode map.elt elt) :: a in
350
+
Json.Array (List.rev (map.enc encode_elt [] v))
351
+
| Obj map -> Json.Obj (List.rev (encode_obj map v []))
352
+
| Any map -> encode (map.enc v) v
353
+
| Map map -> encode map.dom (map.map.enc v)
354
+
| Rec t -> encode (Lazy.force t) v
355
+
356
+
and encode_obj : type o. (o, o) obj_map -> o -> Json.obj -> Json.obj =
357
+
fun map o obj ->
358
+
let encode_mem obj (Mem_enc map) =
359
+
let v = map.enc o in
360
+
if map.enc_omit v then obj else (map.name, encode map.type' v) :: obj
361
+
in
362
+
let obj = List.fold_left encode_mem obj map.mem_encs in
363
+
match map.shape with
364
+
| Obj_basic (Unknown_keep (map, enc)) ->
365
+
let encode_mem n v obj = (n, encode map.mems_type v) :: obj in
366
+
map.enc encode_mem (enc o) obj
367
+
| Obj_basic _ -> obj
368
+
| Obj_cases cases ->
369
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
370
+
let obj =
371
+
if cases.tag.enc_omit case.tag then obj else
372
+
(cases.tag.name, encode cases.tag.type' case.tag) :: obj
373
+
in
374
+
encode_obj case.obj_map c obj
375
+
376
+
(* Object construction *)
377
+
378
+
let obj_mem :
379
+
string -> 'a jsont -> enc:('o -> 'a) ->
380
+
('o, 'a -> 'b) obj_map -> ('o, 'b) obj_map
381
+
=
382
+
fun name type' ~enc obj_map ->
383
+
let id = Type.Id.make () in
384
+
let dec_absent = None and enc_omit = Fun.const false in
385
+
let mm = { name; type'; id; dec_absent; enc; enc_omit } in
386
+
let dec = Dec_app (obj_map.dec, mm.id) in
387
+
let mem_decs = String_map.add mm.name (Mem_dec mm) obj_map.mem_decs in
388
+
let mem_encs = Mem_enc mm :: obj_map.mem_encs in
389
+
{ obj_map with dec; mem_decs; mem_encs; }
390
+
391
+
let bool = Bool { dec = Fun.id; enc = Fun.id }
392
+
let string = String { dec = Fun.id; enc = Fun.id }
393
+
let obj_finish o = Obj { o with mem_encs = List.rev o.mem_encs }
394
+
let obj_map : 'dec -> ('o, 'dec) obj_map = fun make ->
395
+
let dec = Dec_fun make and shape = Obj_basic Unknown_skip in
396
+
{ dec; mem_decs = String_map.empty; mem_encs = []; shape }
397
+
398
+
module Message = struct
399
+
type t = { content : string; public : bool }
400
+
let make content public = { content; public }
401
+
let content msg = msg.content
402
+
let public msg = msg.public
403
+
let jsont : t jsont =
404
+
obj_map make
405
+
|> obj_mem "content" string ~enc:content
406
+
|> obj_mem "public" bool ~enc:public
407
+
|> obj_finish
408
+
end
409
+
410
+
(* Queries and updates *)
411
+
412
+
type 'a query = 'a jsont
413
+
let query : 'a query -> Json.t -> 'a = decode
414
+
415
+
let get_mem : string -> 'a query -> 'a query = fun name q ->
416
+
obj_map Fun.id |> obj_mem name q ~enc:Fun.id |> obj_finish
417
+
418
+
let get_nth : int -> 'a query -> 'a query = fun nth q ->
419
+
let dec_empty = None and dec_add _ _ v = Some v in
420
+
let dec_skip _ k = nth <> k in
421
+
let dec_finish = function None -> failwith "too short" | Some v -> v in
422
+
let enc f acc v = f acc v (* Singleton array with the query result *) in
423
+
Array { elt = q; dec_empty; dec_add; dec_skip; dec_finish; enc }
424
+
425
+
let update_mem : string -> 'a jsont -> Json.t jsont = fun name q ->
426
+
let dec = function
427
+
| Json.Obj ms ->
428
+
let update (n, v as m) =
429
+
if n = name then (n, encode q (decode q v)) else m
430
+
in
431
+
Json.Obj (List.map update ms)
432
+
| _ -> failwith "type error"
433
+
in
434
+
Map { dom = json; map = { dec; enc = Fun.id } }
435
+
436
+
let delete_mem : string -> Json.t query = fun name ->
437
+
let dec = function
438
+
| Json.Obj ms -> Json.Obj (List.filter (fun (n, _) -> n <> name) ms)
439
+
| _ -> type_error ()
440
+
in
441
+
Map { dom = json; map = { dec; enc = Fun.id } }
442
+
443
+
let const : 'a jsont -> 'a -> 'a jsont = fun t v ->
444
+
let dec _ = v and enc _ = encode t v in
445
+
Map { dom = json; map = { dec; enc } }
446
+
447
+
(* Implementations not in the paper *)
448
+
449
+
let map : ('a -> 'b) -> ('b -> 'a) -> 'a jsont -> 'b jsont =
450
+
fun f g t -> Map { dom = t; map = { dec = f; enc = g }}
451
+
452
+
let update_nth : int -> 'a jsont -> Json.t jsont = fun nth q ->
453
+
let dec = function
454
+
| Json.Array vs ->
455
+
let update i v = if i = nth then encode q (decode q v) else v in
456
+
Json.Array (List.mapi update vs)
457
+
| _ -> failwith "type error"
458
+
in
459
+
Map { dom = json; map = { dec; enc = Fun.id } }
460
+
461
+
let delete_nth : int -> Json.t query = fun nth ->
462
+
let dec = function
463
+
| Json.Array vs ->
464
+
let add (i, acc) v = i + 1, (if i = nth then acc else v :: acc) in
465
+
Json.Array (List.rev (snd (List.fold_left add (0, []) vs)))
466
+
| _ -> type_error ()
467
+
in
468
+
Map { dom = json; map = { dec; enc = Fun. id }}
vendor/opam/jsont/paper/soup.pdf
vendor/opam/jsont/paper/soup.pdf
This is a binary file and will not be displayed.
+1115
vendor/opam/jsont/paper/soup.tex
+1115
vendor/opam/jsont/paper/soup.tex
···
1
+
\documentclass[nolinenum]{jfp}
2
+
\usepackage[T1]{fontenc}
3
+
\usepackage[scaled=0.9]{beramono}
4
+
\usepackage{graphicx}
5
+
\usepackage{listings}
6
+
\usepackage{hyperref}
7
+
\usepackage{relsize}
8
+
\usepackage{multicol}
9
+
10
+
\begin{document}
11
+
12
+
\lstset{
13
+
columns=[c]fixed ,
14
+
basicstyle=\relscale{0.85}\ttfamily\linespread{1.1}\selectfont,
15
+
keywordstyle=\bfseries,
16
+
mathescape=true,
17
+
upquote=true,
18
+
commentstyle=\slshape,
19
+
breaklines=true,
20
+
showstringspaces=false}
21
+
22
+
\lstdefinelanguage{ocaml}{language=[objective]caml,
23
+
% Fixes double quotes in char literals
24
+
literate={'"'}{\textquotesingle "\textquotesingle}3
25
+
{'\\"'}{\textquotesingle \textbackslash"\textquotesingle}4
26
+
{;}{\textbf{;}}1
27
+
{|}{\textbf{|}}1
28
+
{type'}{type'}5 % gets rid of bold
29
+
}
30
+
31
+
%%\journaltitle{JFP}
32
+
%%\cpr{Cambridge University Press}
33
+
%%\doival{10.1017/xxxxx}
34
+
%\righttitle{Journal of Functional Programming}
35
+
\righttitle{}
36
+
\journaltitle{\textbf{WARNING, REJECTED by the JFP}
37
+
but may still be useful}
38
+
\cpr{Daniel C. Bünzli}
39
+
\doival{xx.xxxx/xxxxx Document style kept for now, because layout
40
+
was tailored for it. revision 1}
41
+
42
+
\newcommand{\thetitle}{An alphabet for your data soups}
43
+
44
+
\title{\thetitle}
45
+
\lefttitle{\thetitle}
46
+
47
+
\totalpg{\pageref{lastpage01}}
48
+
\jnlDoiYr{2024}
49
+
50
+
\newcommand{\json}{\textsc{json}}
51
+
\newcommand{\ocaml}{\textsc{ocaml}}
52
+
\newcommand{\ml}{\textsc{ml}}
53
+
\newcommand{\code}[1]{{\lstinline[language=ocaml]{#1}}}
54
+
55
+
\begin{authgrp}
56
+
\renewcommand*{\thefootnote}{\fnsymbol{footnote}}
57
+
\author{Daniel C. Bünzli}%
58
+
\footnote{Funded by the Swiss National Science
59
+
Foundation (grant \oldstylenums{\textsc{pp00p1\_211010}},\emph{
60
+
The Epistemology of Climate Change –– Understanding the Climate Challenge})
61
+
and a grant from the
62
+
\href{https://ocaml-sf.org/}{OCaml Software Foundation}.
63
+
}%
64
+
\affiliation{Institute of Philosophy, University of Bern, Switzerland\\
65
+
(\email{daniel.buenzli@erratique.ch})}
66
+
67
+
\end{authgrp}
68
+
69
+
\begin{abstract}
70
+
Dealing with ubiquitous but poorly typed and structured data models
71
+
like \json{} in \ml{} languages is unpleasant. But it doesn't have
72
+
to be. We show how to define a generalized algebraic datatype whose
73
+
values denote bidirectional maps between subsets of values of a data
74
+
model and the \ml{} values of your choice. With suitable combinators
75
+
these maps are quick and pleasant to define in a declarative
76
+
style. The result can be used by generic functions that decode,
77
+
encode, query and update data soups with nicely typed values.
78
+
\end{abstract}
79
+
80
+
\maketitle[F]
81
+
\section{Introduction}
82
+
83
+
Processing generic data models like \json{} in \ml{} languages is
84
+
unpleasant. \ml{} values can be converted to these data models with
85
+
pickler combinators \citep{picklers} or datatype-generic programming
86
+
techniques \citep{datatypegeneric}. However, partially or fully
87
+
modelling \emph{their} data schemas remains cumbersome. Using a
88
+
generic type for the data model works well in dynamically typed
89
+
languages because it directly maps on their own type systems. But in
90
+
\ml{} this representation is unnatural and frustrating to use.
91
+
92
+
Instead, we show how to define a generalized algebraic datatype whose
93
+
values denote bidirectional maps between subsets of values of the data
94
+
model and the \ml{} values you want to use. With appropriate
95
+
combinators to construct them, these descriptions can be made quick to
96
+
define in the \emph{decoding} and \emph{encoding} direction possibly
97
+
eliding one if not immediately useful. The values of this datatype can
98
+
be used by generic functions that:
99
+
100
+
\begin{itemize}
101
+
\item Directly decode or encode the data model to the \ml{} values of
102
+
your choice without constructing values of a generic
103
+
representation of the data model.\footnote{For
104
+
\json{}, since the shape of an object may depend on one of its
105
+
members and that members are unordered, some form of generic
106
+
buffering may be needed to decode certain data schemas.}
107
+
\item Query and update data of partially modelled data schemas with
108
+
arbitrary \ml{} values.
109
+
\item Automatically construct them from other datatype-generic
110
+
representations you may already have defined for your \ml{} types.
111
+
\end{itemize}
112
+
113
+
Like pickler combinators \citep{picklers}, the definition of these
114
+
values can be made pleasantly declarative. The decoding and encoding
115
+
bureaucracy is left to the generic functions that interpret the
116
+
datatype. One way of understanding the datatype is to devise pickler
117
+
combinators for the data model~––~rather than for the values of the
118
+
\ml{} language~--~ but leave out the specific value coding machinery
119
+
open for interpretation. Another way is to see it as a tagged final
120
+
coding of the data model. Concretely the datatype allows to interpose
121
+
your own functions at each data model value decoding and encoding
122
+
step. These functions can be lossy or creative which naturally leads
123
+
to data queries and data updates.
124
+
125
+
In what follows we focus on presenting the datatype. Providing an
126
+
ergonomic set of combinators to construct its values is important but
127
+
less difficult. Definitions
128
+
are kept as simple as possible to expose the essence of this
129
+
\emph{finally tagged} representation. A practical
130
+
implementation\footnote{One can be found at
131
+
\url{https://erratique.ch/software/jsont}} should enrich these
132
+
definitions with documentation strings for data schema documentation
133
+
generation, text locations for human friendly error reporting and
134
+
text layout information for layout preserving updates.
135
+
136
+
We use \ocaml{} \citep{ocaml} for the \ml{} language and \json{}
137
+
\citep{json} for the data model, but as we conclude in
138
+
\autoref{sec:recipe} with the recipe, this technique is independent of
139
+
them. For conciseness we use exceptions to represent partial functions
140
+
but signatures can be changed to use explicit \code{result} or
141
+
\code{either} return types where needed. No effects are needed from
142
+
the \ml{} language.
143
+
144
+
\section{A generic representation}
145
+
\label{sec:genrep}
146
+
147
+
First we define the type \code{Json.t}, a generic representation for
148
+
\json{} values in \ml{}. In essence nothing more than an abstract
149
+
syntax tree for \json{} text with one case for each sort of value.
150
+
151
+
\begin{lstlisting}[language=ocaml]
152
+
module Json = struct
153
+
type t =
154
+
| Null of unit | Bool of bool | Number of float | String of string
155
+
| Array of t list | Obj of obj and obj = mem list and mem = string * t
156
+
end
157
+
\end{lstlisting}
158
+
159
+
As can be seen later, the type \code{Json.t} remains useful. However it is
160
+
the type that is unacceptable to work with in \ml{}. Given a fixed
161
+
data schema to process we do not want to manipulate this soup of
162
+
values:
163
+
164
+
\begin{itemize}
165
+
\item We want objects to be represented by proper record or variant types.
166
+
Not by \code{Json.obj} association lists that must be dynamically name
167
+
checked for expectations.
168
+
\item We want to get typed values on array element and object
169
+
member access. Not generic \code{Json.t} values that must be dynamically
170
+
type checked for expectations.
171
+
\end{itemize}
172
+
173
+
\section{A typed representation to interpret}
174
+
\label{sec:jsont}
175
+
176
+
To replace these generic values by the \ml{} values we want, we
177
+
introduce the type \code{'a jsont} whose values denote subsets of
178
+
\json{} values and their bidirectional map to \ml{} values of type
179
+
\code{'a}.
180
+
181
+
We call these values ``\json{} types''. They belong to the following
182
+
generalized algebraic datatype whose cases and elided definitions are
183
+
detailed in subsequent sections. The \code{Rec} case is bureaucracy
184
+
the laziest readers do not need to care about, it types recursives
185
+
\json{} values if your \ml{} is strict.
186
+
187
+
\begin{lstlisting}[language=ocaml]
188
+
type ('a, 'b) base_map = $\ldots$
189
+
type ('a, 'elt, 'builder) array_map = $\ldots$
190
+
and ('o, 'dec) obj_map = $\ldots$
191
+
and 'a any_map = $\ldots$
192
+
and ('a, 'b) map = $\ldots$
193
+
and _ jsont =
194
+
| Null : (unit, 'b) base_map -> 'b jsont
195
+
| Bool : (bool, 'b) base_map -> 'b jsont
196
+
| Number : (float, 'b) base_map -> 'b jsont
197
+
| String : (string, 'b) base_map -> 'b jsont
198
+
| Array : ('a, 'elt, 'builder) array_map -> 'a jsont
199
+
| Obj : ('o, 'o) obj_map -> 'o jsont
200
+
| Any : 'a any_map -> 'a jsont
201
+
| Map : ('a, 'b) map -> 'b jsont
202
+
| Rec : 'a jsont Lazy.t -> 'a jsont
203
+
\end{lstlisting}
204
+
%
205
+
Except for \code{Any}, \code{Map} and \code{Rec}, the cases of the type
206
+
\code{'a jsont} are in direct correspondence with those of
207
+
\code{Json.t}. But rather than storing data in the cases we have
208
+
functions to bidirectionally map them to values of a type
209
+
\code{'a}. The \code{'a jsont} values are used alongside decoding and
210
+
encoding processes to directly check and transform the shape of the
211
+
data.
212
+
213
+
For instance we can implement (see \hyperref[sec:appendix]{Appendix}
214
+
and \autoref{sec:convert}) these two functions which decode and encode
215
+
generic \code{Json.t} values with \ml{} values:
216
+
\begin{lstlisting}[language=ocaml]
217
+
val decode : 'a jsont -> Json.t -> 'a
218
+
val encode : 'a jsont -> 'a -> Json.t
219
+
\end{lstlisting}
220
+
221
+
Representing \json{} data with \ml{} values becomes a matter of
222
+
defining suitable \code{'a jsont} values. For example this
223
+
kind of \json{} object for messages:
224
+
%
225
+
\begin{lstlisting}[language=c]
226
+
{ "content": "J'aime pas la soupe", "public": true }
227
+
\end{lstlisting}
228
+
%
229
+
can be represented in \ml{} by a record with two fields. Using the
230
+
record's natural constructor and field accessors, combinators whose
231
+
implementation is given in \autoref{sec:mem_map}, and \ocaml's reverse
232
+
function application operator \code{|>}, this kind of object is described by:
233
+
234
+
\begin{lstlisting}[language=ocaml]
235
+
module Message = struct
236
+
type t = { content : string; public : bool }
237
+
let make content public = { content; public }
238
+
let content msg = msg.content
239
+
let public msg = msg.public
240
+
let jsont : t jsont =
241
+
obj_map make
242
+
|> obj_mem "content" string ~enc:content
243
+
|> obj_mem "public" bool ~enc:public
244
+
|> obj_finish
245
+
end
246
+
\end{lstlisting}
247
+
248
+
\subsection{Base cases}
249
+
\label{sec:base_cases}
250
+
251
+
Every base case carries a value of type \code{base_map}:
252
+
%
253
+
\begin{lstlisting}[language=ocaml]
254
+
type ('a, 'b) base_map =
255
+
{ dec : 'a -> 'b;
256
+
enc : 'b -> 'a; }
257
+
\end{lstlisting}
258
+
%
259
+
Values of this type describe bidirectional maps from values of type
260
+
\code{'a} to \code{'b}. They are used to transform the canonical \ml{}
261
+
type \code{'a} chosen for a \json{} base type to the one we want to
262
+
use. The base cases are as follows:
263
+
264
+
\begin{itemize}
265
+
\item
266
+
\code{Null m} maps \json{} nulls to type \code{'a} by mapping
267
+
\code{unit} values with \code{m}.
268
+
%
269
+
\item
270
+
\code{Bool m} maps \json{} booleans to type \code{'a} by mapping
271
+
\code{bool} values with \code{m}.
272
+
%
273
+
\item
274
+
\code{Number m} maps \json{} numbers or
275
+
nulls%%
276
+
\footnote{The semantics of \json{} numbers is left to be desired.
277
+
Interoperable \json{} implementations map \json{} numbers to
278
+
\textsc{ieee} 754 \code{binary64} values. But they are \emph{not} such
279
+
values: \textsc{nan} and infinities cannot be represented. As of
280
+
writing, the most widely deployed and formally defined \json{}
281
+
encoder, namely \textsc{ecmascript}'s \mbox{\code{JSON.stringify}}
282
+
\citep{ecmascript}, lossily encodes any non-finite floating point value by
283
+
\code{null}.}
284
+
%%
285
+
to type \code{'a} by mapping \code{float} values with \code{m}.
286
+
%
287
+
\item
288
+
\code{String m} maps unescaped \json{} strings to type \code{'a} by
289
+
mapping \code{string} values with \code{m}.
290
+
\end{itemize}
291
+
292
+
Most of the time the map \code{m} used with base cases is the identity
293
+
map. But having maps on base types is part of the strategy to
294
+
interpose functions in every coding context. This is particulary
295
+
useful for \json{} strings which are \json{}'s universal type: all
296
+
sorts of enumerations, better represented by variants in \ml{}, can be
297
+
found in them. More amusing, to reliably interchange \mbox{64-bit}
298
+
integers with \json{} you need to encode them in strings.%%
299
+
\footnote{Again, interoperable \json{} implementations map
300
+
\json{} numbers to \textsc{ieee} 754 \code{binary64} values. Hence the
301
+
only integers that can be interchanged safely without precision loss
302
+
are those in the range $[-2^{53};2^{53}]$.}
303
+
304
+
\subsection{Map case}
305
+
\label{sec:map_case}
306
+
307
+
The elided type \code{map} used by \code{Map} is:
308
+
\begin{lstlisting}[language=ocaml]
309
+
and ('a, 'b) map =
310
+
{ dom : 'a jsont;
311
+
map : ('a, 'b) base_map; }
312
+
\end{lstlisting}
313
+
%
314
+
A \code {Map m} value changes the \ml{} type of the \json{} type
315
+
\code{m.dom} from \code{'a} to \code{'b}. It is a tool for composing
316
+
\code{jsont} values. If the reader wonders whether it is not simpler
317
+
to expose a base case like \code{String m} by the value \code{\{dom =
318
+
String;} \code{ map = m\}}, the answer is rather negative. It is not
319
+
directly evident in our simpler exposition but having maps in base
320
+
cases provides the proper coding context for erroring or text
321
+
layout preserving. This context may be more difficult to recover or no
322
+
longer be available to generic functions when they get to process the
323
+
\code{Map} case which is not syntactically related to \json{} text.
324
+
325
+
\pagebreak
326
+
327
+
\subsection{Array case}
328
+
\label{sec:array_case}
329
+
330
+
The elided type \code{array_map} used by \code{Array} is:
331
+
%
332
+
\begin{lstlisting}[language=ocaml]
333
+
and ('array, 'elt, 'builder) array_map =
334
+
{ elt : 'elt jsont;
335
+
dec_empty : 'builder;
336
+
dec_skip : 'builder -> int -> bool;
337
+
dec_add : 'builder -> int -> 'elt -> 'builder;
338
+
dec_finish : 'builder -> 'array;
339
+
enc : 'acc. ('acc -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; }
340
+
\end{lstlisting}
341
+
%
342
+
An \code{Array m} value maps \json{} arrays of uniform \json{} type
343
+
\code{m.elt} to values of type \code{'array} built using values of
344
+
type \code{'builder}. The record \code{m} explains how to construct
345
+
and deconstruct an \code{'array} value. For decoding, we start with
346
+
the value \code{m.dec_empty}, the element in the \json{} array at
347
+
index \code{i} is added with \code{m.dec_add}, unless
348
+
\code{m.dec_skip} is \code{true} on \code{i} (the purpose of
349
+
\code{dec_skip} will become clear later), and the final array is
350
+
returned by \code{m.dec_finish}. For encoding, the \code{m.enc}
351
+
function folds over the elements of an \code{'array} value to encode
352
+
them to the \json{} array.
353
+
354
+
\subsection{Any case}
355
+
\label{sec:any_case}
356
+
357
+
The elided type \code{any_map} used by \code{Any} is:
358
+
%
359
+
\begin{lstlisting}[language=ocaml]
360
+
and 'a any_map =
361
+
{ dec_null : 'a jsont option;
362
+
dec_bool : 'a jsont option;
363
+
dec_number : 'a jsont option;
364
+
dec_string : 'a jsont option;
365
+
dec_array : 'a jsont option;
366
+
dec_obj : 'a jsont option;
367
+
enc : 'a -> 'a jsont; }
368
+
\end{lstlisting}
369
+
%
370
+
An \code{Any m} value maps sets of \json{} values with multiple sorts
371
+
to values of type \code{'a}. It embeds dynamic typing in our
372
+
datatype. It also allows to decode and encode with different sorts
373
+
of \json{} values. For decoding a \json{} value of sort \code{t},
374
+
a generic function uses the \json{} type \code{m.dec_t} or errors if
375
+
\code{None}. For encoding, the \code{m.enc} function returns the
376
+
\json{} type to use with the value.
377
+
378
+
Given a \json{} type value \code{t} the following \code{option}
379
+
combinator uses \code{Any} to make it nullable in \json{}. The result
380
+
of \code{option t} is a \json{} type that maps \json{} null values to
381
+
\code{None} and otherwise maps \json{} values as \code{t} does but
382
+
with successful results wrapped by \code{Some}.
383
+
%
384
+
\begin{lstlisting}[language=ocaml]
385
+
let option : 'a jsont -> 'a option jsont = fun t ->
386
+
let none = Null { dec = Fun.const None; enc = Fun.const () } in
387
+
let some = Map { dom = t; map = {dec = Option.some; enc = Option.get}}in
388
+
let enc = function None -> none | Some _ -> some in
389
+
let none = Some none and some = Some some in
390
+
Any { dec_null = none; dec_bool = some; dec_number = some;
391
+
dec_string = some; dec_array = some; dec_obj = some; enc; }
392
+
\end{lstlisting}
393
+
394
+
The \code{Any} case also allows to devise the \json{} type \code{json}
395
+
which maps any \json{} value to its generic representation:
396
+
%
397
+
\begin{lstlisting}[language=ocaml]
398
+
let json : Json.t jsont = $\ldots$
399
+
\end{lstlisting}
400
+
%
401
+
Its definition is left as an exercice for the reader but
402
+
this value is a must for partial data schema modelling.
403
+
404
+
\subsection{Obj case}
405
+
\label{sec:obj_case}
406
+
407
+
Mapping objects is more involved and the design is less
408
+
self-evident. Challenges are that members in \json{} objects are
409
+
unordered, that the shape of an object may depend on the value of one
410
+
if its members\footnote{This is not a built-in mechanism of the data
411
+
model but out-of-band constraints mandated by data schemas.} and that
412
+
duplicate member names is undefined behaviour.\footnote{But
413
+
\textsc{ecmascript}'s formally defined decoder
414
+
\mbox{\code{JSON.parse}} \citep{ecmascript} mandates ``last one takes
415
+
over.''} This means that we cannot rely on a fixed member ordering to
416
+
construct the \ml{} value of an object and worse, that we may have to
417
+
wait for its last member to type check it.
418
+
419
+
To narrow the design space, we focus on a few patterns found in
420
+
\json{} data schemas that we want to support without fuss while
421
+
retaining efficient decodes for object shapes that are known beforehand.
422
+
These patterns are:
423
+
%
424
+
\begin{enumerate}
425
+
\item Objects as records. Member names and their types are
426
+
known beforehand. Members are required or optional in which
427
+
case they can have a default value.
428
+
\item Objects as uniform key-value maps. Member names of the object
429
+
are unknown but their values are all of the same type. This
430
+
must compose with pattern 1. as with the \json{} type \code{json}
431
+
(\autoref{sec:any_case})
432
+
it enables partial object modelling
433
+
and supports data schemas that allow foreign members in their
434
+
objects.
435
+
\item Objects as sums. There is a distinguished \emph{case member},
436
+
for example named \code{"type"}, \code{"class"} or \code{"version"},
437
+
and its value further determines an object shape described using
438
+
pattern 1., 2. or 3.
439
+
\end{enumerate}
440
+
%
441
+
Finally we want \json{} object maps to be defined through functions that are
442
+
already naturally provided for our \ml{} types: constructors and
443
+
accessors.
444
+
445
+
If the shape of an object cannot be captured by these patterns, it is
446
+
always possible to map it to a uniform \code{Json.t} key-value map using
447
+
pattern 2. followed by a \code{Map} to sort things out. This provides
448
+
an ultimate escape hatch at the cost of unconditionnaly going through
449
+
the generic representation.
450
+
451
+
\subsubsection{(De)constructing arbitrary \ml{} values for \json{} objects}
452
+
453
+
We want to represent \json{} objects by arbitrary \ml{} values of type
454
+
\code{'o} which hold member values with their own distinct types
455
+
\code{'a}$_1$, \code{'a}$_2$, etc.
456
+
457
+
For encoding this is easily tackled by having one projection function
458
+
of type \code{'o -> 'a}$_i$ for each object member. For decoding we
459
+
need to provide a constructor function with one argument per member
460
+
value that returns a value of type \code{'o}. To manipulate this
461
+
constructor we use a datatype morally equivalent to this
462
+
representation of a function application:
463
+
\pagebreak
464
+
\begin{lstlisting}[language=ocaml]
465
+
type ('ret, 'f) app =
466
+
| Fun : 'f -> ('ret, 'f) app
467
+
| App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app
468
+
\end{lstlisting}
469
+
%
470
+
In a value of type \code{app} we can lift an arbitrary function
471
+
\code{f} returning \code{'ret} with the \code{Fun} case and instrument
472
+
each argument application with \code{App} cases until \code{f} is
473
+
fully ``applied'' to a value of type \code{('ret, 'ret)} \code{app}.
474
+
We store object constructors in a similar data type but since we do not
475
+
have the argument values yet we use a type witness\footnote{Available
476
+
in the \ocaml{} standard library in \code{Type.Id} since \ocaml{} 5.1}
477
+
to serve as a placeholder for the member value:
478
+
%
479
+
\begin{lstlisting}[language=ocaml]
480
+
type ('ret, 'f) dec_fun =
481
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
482
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
483
+
\end{lstlisting}
484
+
%
485
+
This allows to decode unordered and individually typed member values
486
+
as they come, store them by type witness in an heterogeneous
487
+
dictionary \code{Dict.t} (see implementation in the
488
+
\hyperref[sec:appendix]{Appendix}) and, once we have collected all
489
+
member values in the dictionary, we can invoke the constructor to get
490
+
the \ml{} value for the object with this function:
491
+
%
492
+
\begin{lstlisting}[language=ocaml]
493
+
let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f =
494
+
fun dec dict -> match dec with
495
+
| Dec_fun f -> f
496
+
| Dec_app (f,arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict))
497
+
\end{lstlisting}
498
+
%
499
+
For fully known object shapes this mechanism allows decoders to
500
+
directly decode objects and their unordered member values to the
501
+
representations we want to use in \ml{}.
502
+
503
+
\subsubsection{Object maps}
504
+
\label{sec:obj_map}
505
+
506
+
The elided type \code{obj_map} used by \code{Obj} is:
507
+
508
+
\begin{lstlisting}[language=ocaml]
509
+
and ('o, 'dec) obj_map =
510
+
{ dec : ('o, 'dec) dec_fun;
511
+
mem_decs : mem_dec String_map.t;
512
+
mem_encs : 'o mem_enc list;
513
+
shape : 'o obj_shape; }
514
+
\end{lstlisting}
515
+
%
516
+
An \code{Obj m} value maps a \json{} object to a value of type
517
+
\code{'o}. The \code{m.dec} field holds the constructor function for
518
+
\code{'o} values. The \code{Obj} case in the definition of
519
+
\code{jsont} (\autoref{sec:jsont}) constrains the \code{'dec}
520
+
parameter to be equal to \code{'o} which ensures that the contructor
521
+
is fully ``applied''. Remaining fields of the record are described in
522
+
subsequent sections.
523
+
524
+
\subsubsection{Member maps}
525
+
\label{sec:mem_map}
526
+
527
+
The \code{m.mem_decs} and \code{m.mem_encs} fields of \code{obj_map}
528
+
describe members of the object that are known beforehand. Both fields
529
+
hold the same values of type \code{mem_map} but they are sorted
530
+
differently and their type parameters are hidden in slighly different
531
+
ways to accomodate decoding and encoding processes. These types are
532
+
defined by:
533
+
\pagebreak
534
+
\begin{lstlisting}[language=ocaml]
535
+
and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec
536
+
and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
537
+
and ('o, 'a) mem_map =
538
+
{ name : string;
539
+
type' : 'a jsont;
540
+
id : 'a Type.Id.t;
541
+
dec_absent : 'a option;
542
+
enc : 'o -> 'a;
543
+
enc_omit : 'a -> bool; }
544
+
\end{lstlisting}
545
+
%
546
+
A value \code{mm} of type \code{mem_map} maps a member \code{'a} of a
547
+
\json{} object mapped to \code{'o}. \code{mm.name} is the member
548
+
name. \code{mm.type'} is the \json{} type of its value. \code{mm.id}
549
+
is the type witness to represent the member value in the constructor
550
+
of \code{'o}. \code{mm.dec_absent} is a value to use if the member is
551
+
absent on decodes; \code{None} means error on absence. \code{mm.enc}
552
+
is the function to get back the member value from \code{'o} for
553
+
encoding. \code{mm.enc_omit} is a predicate on the value returned by
554
+
\code{mm.enc} to decide whether it should be omitted on encoding;
555
+
usually this tests for equality with the value mentioned in
556
+
\code{mm.dec_absent}.
557
+
558
+
A member map \code{mm} needs to be added to an object map \code{m} in
559
+
\code{m.mem_decs}, \code{m.mem_encs} and the \code{mm.id} type witness
560
+
must be applied to the object constructor in \code{m.dec}. This is the
561
+
duty of combinators. For example this one describes a required member
562
+
and adds it to an object map:
563
+
564
+
\begin{lstlisting}[language=ocaml]
565
+
let obj_mem :
566
+
string -> 'a jsont -> enc:('o -> 'a) ->
567
+
('o, 'a -> 'b) obj_map -> ('o, 'b) obj_map
568
+
=
569
+
fun name type' ~enc obj_map ->
570
+
let id = Type.Id.make () in
571
+
let dec_absent = None and enc_omit = Fun.const false in
572
+
let mm = { name; type'; id; dec_absent; enc; enc_omit } in
573
+
let dec = Dec_app (obj_map.dec, mm.id) in
574
+
let mem_decs = String_map.add mm.name (Mem_dec mm) obj_map.mem_decs in
575
+
let mem_encs = Mem_enc mm :: obj_map.mem_encs in
576
+
{ obj_map with dec; mem_decs; mem_encs; }
577
+
\end{lstlisting}
578
+
%
579
+
At this point we can provide the full implementations of the combinators
580
+
used in the message object modelling example given in \autoref{sec:jsont}.
581
+
%
582
+
\begin{lstlisting}[language=ocaml]
583
+
let bool = Bool { dec = Fun.id; enc = Fun.id }
584
+
let string = String { dec = Fun.id; enc = Fun.id }
585
+
let obj_finish o = Obj { o with mem_encs = List.rev o.mem_encs }
586
+
let obj_map : 'dec -> ('o, 'dec) obj_map = fun make ->
587
+
let dec = Dec_fun make and shape = Obj_basic Unknown_skip in
588
+
{ dec; mem_decs = String_map.empty; mem_encs = []; shape }
589
+
\end{lstlisting}
590
+
591
+
\pagebreak
592
+
\subsubsection{Object shapes}
593
+
\label{sec:obj_shape}
594
+
595
+
The last field of the \code{obj_map} type to describe is the
596
+
\code{shape} field of type \code{obj_shape}:
597
+
\begin{lstlisting}[language=ocaml]
598
+
and 'o obj_shape =
599
+
| Obj_basic : ('o, 'mems, 'builder) unknown_mems -> 'o obj_shape
600
+
| Obj_cases : ('o, 'cases, 'tag) obj_cases -> 'o obj_shape
601
+
\end{lstlisting}
602
+
%
603
+
This value indicates whether the members described in the object map
604
+
are the final word on the shape of the object:
605
+
606
+
\begin{itemize}
607
+
\item \code{Obj_basic u} indicates that the object's members are fully
608
+
known and the way to handle unknown member is described by \code{u}, see \autoref{sec:unknown_mems}.
609
+
\item \code{Obj_cases cases} indicates that there is a case
610
+
member described in \code{cases}. Each case member value
611
+
gives another \code{obj_map} value which further describe the object, see
612
+
\autoref{sec:obj_cases}.
613
+
\end{itemize}
614
+
%
615
+
The \code{obj_shape} type definition turns object map values into a
616
+
decision tree with \code{Obj_cases} nodes, branches labelled by case
617
+
member values and with \code{Obj_basic} leaves. Each path in this tree
618
+
describes a complete object whose members depend on case member
619
+
values found in the data. We assume that the combinators constructing
620
+
these values enforce the constraint that no member is defined twice in
621
+
a path from the root to a leaf.
622
+
623
+
Note that once you get an \code{Obj_basic} shape, all data dependent
624
+
shapes have been determined and members can be directly decoded to
625
+
their type without buffering them.
626
+
627
+
628
+
\subsubsection{Unknown members}
629
+
\label{sec:unknown_mems}
630
+
631
+
The type \code{unknown_mems} used by \code{Obj_basic} shapes is:
632
+
633
+
\begin{lstlisting}[language=ocaml]
634
+
and ('o, 'mems, 'builder) unknown_mems =
635
+
| Unknown_skip : ('o, unit, unit) unknown_mems
636
+
| Unknown_error : ('o, unit, unit) unknown_mems
637
+
| Unknown_keep :
638
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems) ->
639
+
('o, 'mems) unknown_mems
640
+
\end{lstlisting}
641
+
%
642
+
A value \code{u} of type \code{unknown_mems} maps to \code{'mems} the
643
+
unknown members of a \json{} object mapped to \code{'o}. It
644
+
respectively indicates to skip, error, or keep them. In the latter
645
+
case the \code{Unknown_keep (m, enc)} value describes with \code{enc} how
646
+
to get them back from \code{'o} for encoding and with \code{m}, how to map
647
+
them to a value of type \code{'mems}. The values \code{enc} and
648
+
\code{m} are kept separate because the type \code{'o} is bespoke while
649
+
unknown member maps can be reused across object maps. The value
650
+
\code{m} is of this type:
651
+
%
652
+
\begin{lstlisting}[language=ocaml]
653
+
and ('mems, 'a, 'builder) mems_map =
654
+
{ mems_type : 'a jsont;
655
+
id : 'mems Type.Id.t;
656
+
dec_empty : 'builder;
657
+
dec_add : string -> 'a -> 'builder -> 'builder;
658
+
dec_finish : 'builder -> 'mems
659
+
enc : 'acc. (string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc }
660
+
\end{lstlisting}
661
+
%
662
+
This record maps unknown members of uniform \json{} type
663
+
\code{m.mems_type} to a value of type \code{'mems} built using values
664
+
of types \code{'builder}. Use the \json{} type \code{json}
665
+
(\autoref{sec:any_case}) in \code{m.mems_type} for partial object
666
+
modelling or objects that need to preserve foreign
667
+
members. \code{m.id} is the type witness to represent the \code{'mems}
668
+
value in the object constructor. For decoding, we start with the value
669
+
\code{m.dec_empty}, unknown members are added with \code{m.dec_add}
670
+
and the final \code{'mems} value is returned by
671
+
\code{m.dec_finish}. For encoding \code{m.enc} allows to recover from
672
+
\code{'mems} the unknown members to encode them in the \json{} object.
673
+
674
+
675
+
\subsubsection{Object cases}
676
+
\label{sec:obj_cases}
677
+
678
+
Type type \code{obj_cases} used by \code{Obj_cases} shapes is:
679
+
680
+
\begin{lstlisting}[language=ocaml]
681
+
and ('o, 'cases, 'tag) obj_cases =
682
+
{ tag : ('o, 'tag) mem_map; (* 'o is irrelevant, 'tag is not stored *)
683
+
tag_compare : 'tag -> 'tag -> int;
684
+
id : 'cases Type.Id.t;
685
+
cases : ('cases, 'tag) case list;
686
+
enc : 'o -> 'cases;
687
+
enc_case : 'cases -> ('cases, 'tag) case_value; }
688
+
\end{lstlisting}
689
+
%
690
+
A value \code{m} of type \code{obj_cases} maps to \code{'cases} the
691
+
object cases of an object mapped to \code{'o}. Cases are selected by
692
+
the value of a case member of type \code{'tag} described in
693
+
\code{m.tag}. Tag values are not stored in \code{'o} (the decoded case
694
+
value is) so the \code{'o} parameter, \code{m.tag.id} and
695
+
\code{m.tag.enc} are unused here. \code{m.tag_compare} allows to
696
+
compare case tags. \code{m.id} is the type witness to represent the
697
+
cases in the constructor of \code{'o}. \code{m.cases} is the list of
698
+
cases. This is not a function on \code{'tag} values in order to make
699
+
the description enumerable (e.g. for schema documentation
700
+
generation). The type \code{case} hides the \code{'case}
701
+
parameter of the type \code{case_map} which describes cases:
702
+
703
+
\begin{lstlisting}[language=ocaml]
704
+
and ('cases, 'tag) case =
705
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
706
+
707
+
and ('cases, 'case, 'tag) case_map =
708
+
{ tag : 'tag;
709
+
obj_map : ('case, 'case) obj_map;
710
+
dec : 'case -> 'cases; }
711
+
\end{lstlisting}
712
+
%
713
+
A value \code{cm} of type \code{case_map} describes a case of type
714
+
\code{'case} part of the type \code{'cases}. \code{cm.tag} is the tag
715
+
value that identifies the case in the data. \code{cm.obj_map} describes the
716
+
additional shape this case gives to the object. \code{cm.dec} injects
717
+
the decoded case into the type that gathers them.
718
+
719
+
For encoding cases, the \code{m.enc} function of \code{obj_cases}
720
+
gets back the case from \code{'o}. To find out how to encode it, the
721
+
function \code{m.enc_case} is used. It returns a value of type
722
+
\code{case_value} which has a the actual case value and its map
723
+
for encoding:
724
+
725
+
\begin{lstlisting}[language=ocaml]
726
+
and ('cases, 'tag) case_value =
727
+
| Case_value :
728
+
('cases, 'case, 'tag) case_map * 'case -> ('cases, 'tag) case_value
729
+
\end{lstlisting}
730
+
%
731
+
The \code{m.enc_case} function is the only ad-hoc function that needs
732
+
to be devised specifically for \code{jsont} values. All the other
733
+
functions to describe objects are natural constructors and accessors
734
+
of \ml{} types.
735
+
736
+
The design for object cases allows to map them to a record type
737
+
which has common fields for all cases and a field for the cases:
738
+
%
739
+
\begin{lstlisting}[language=ocaml]
740
+
type type' = C1 of C1.t | C2 of C2.t $\ldots$
741
+
type t =
742
+
{ $\ldots$ (* Fields common to all cases *); type' : type'; }
743
+
\end{lstlisting}
744
+
%
745
+
but they can also be described individually and mapped to
746
+
a ``toplevel'' variant type if \code{'cases} coincides with \code{'o}:
747
+
%
748
+
\begin{lstlisting}[language=ocaml]
749
+
type t = C1 of C1.t | C2 of C2.t $\ldots$
750
+
\end{lstlisting}
751
+
752
+
\section{Decode and encode}
753
+
\label{sec:convert}
754
+
755
+
Given a \code{jsont} value we can decode and encode \json{} with \ml{}
756
+
values without constructing generic \code{Json.t} values; except
757
+
transiently for decoding object instances with data dependent shapes
758
+
and poorly ordered members. Implementing a \json{} codec is beyond the
759
+
scope of this paper but the \hyperref[sec:appendix]{Appendix} has
760
+
implementations for \code{decode} and \code{encode} functions that convert
761
+
\ml{} values with generic \code{Json.t} values.
762
+
763
+
For \code{decode} we took care not to assume full in-memory access to
764
+
an object's members. It thus shows how a decoder can proceed to
765
+
provide best-effort on-the-fly decoding. Except for case members, the
766
+
last occurence of duplicate members takes over, however all definitions
767
+
must type as defined by the object map otherwise the decode
768
+
errors. These limitations on duplicate members could be lifted with a
769
+
more complex decoder but it may not be worth the trouble. The case for
770
+
objects is more intricate than we would like it to be, but we blame
771
+
\json{}'s loose specification for that.
772
+
773
+
Otherwise the implementation of these functions mostly consists in
774
+
recursing on the \code{jsont} values to boringly invoke the menagerie
775
+
of functions that are packed therein.
776
+
777
+
\section{Query and update}
778
+
\label{sec:queryx}
779
+
780
+
Since we can now interpose our functions in every coding context we
781
+
get a very flexible data processing system. A type for data queries
782
+
and a function to execute them can be as simple as:
783
+
784
+
\begin{lstlisting}[language=ocaml]
785
+
type 'a query = 'a jsont
786
+
let query : 'a query -> Json.t -> 'a = decode
787
+
\end{lstlisting}
788
+
%
789
+
In this view, queries are just transforming decodes. Their encoding
790
+
direction can be made to fail or defined with anything that feels
791
+
sensitive to encode the query result to.
792
+
793
+
To navigate the structure of \json{} values to apply a query on a
794
+
subtree, the following composable indexing combinators can be used:
795
+
796
+
\begin{lstlisting}[language=ocaml]
797
+
let get_mem : string -> 'a query -> 'a query = fun name q ->
798
+
obj_map Fun.id |> obj_mem name q ~enc:Fun.id |> obj_finish
799
+
800
+
let get_nth : int -> 'a query -> 'a query = fun nth q ->
801
+
let dec_empty = None and dec_add _ _ v = Some v in
802
+
let dec_skip _ k = nth <> k in
803
+
let dec_finish = function None -> failwith "too short" | Some v -> v in
804
+
let enc f acc v = f acc v (* Singleton array with the query result *) in
805
+
Array { elt = q; dec_empty; dec_add; dec_skip; dec_finish; enc }
806
+
\end{lstlisting}
807
+
%
808
+
The \code{get_nth} combinator explains the presence of \code{dec_skip}
809
+
in the \code{array_map} type (\autoref{sec:array_case}). The query
810
+
\code{q} only needs to succeed on the \code{nth} element. Without
811
+
\code{dec_skip} we would apply it on every element of the array which
812
+
is undesirable. The \code{dec_skip} field is the only bit in the
813
+
design that was specifically added to support queries. For objects,
814
+
skipping unknown members is quite natural to have in order to support data
815
+
schema evolution.
816
+
817
+
Typed updates of \json{} data is easy to specify as \code{Json.t}
818
+
returning \json{} types. Decoders invoking such queries return updated
819
+
\json{} as \code{Json.t} values. Here is a kernel of composable
820
+
combinators to peform updates:
821
+
822
+
\begin{lstlisting}[language=ocaml]
823
+
val update_mem : string -> 'a jsont -> Json.t jsont
824
+
val update_nth : int -> 'a jsont -> Json.t jsont
825
+
val delete_mem : string -> Json.t jsont
826
+
val delete_nth : int -> Json.t jsont
827
+
val const : 'a jsont -> 'a -> 'a jsont
828
+
\end{lstlisting}
829
+
%
830
+
The \code{update_mem} and \code{update_nth} combinators apply
831
+
on the member or index value the decoder of the given \json{} type
832
+
and replace it with the encoding of the result. Chaining update
833
+
combinators allows to navigate arbitrarily nested \json{} to apply an
834
+
update. All these combinators are simple \code{Map} over the \json{}
835
+
type \code{json} (\autoref{sec:any_case}) with suitable uses of
836
+
\code{encode} and \code{decode}. The implementations of
837
+
\code{update_mem}, \code{delete_mem} and \code{const} are:
838
+
839
+
\begin{lstlisting}[language=ocaml]
840
+
let update_mem : string -> 'a jsont -> Json.t jsont = fun name q ->
841
+
let dec = function
842
+
| Json.Obj ms ->
843
+
let update (n, v as m) =
844
+
if n = name then (n, encode q (decode q v)) else m
845
+
in
846
+
Json.Obj (List.map update ms)
847
+
| _ -> failwith "type error"
848
+
in
849
+
Map { dom = json; map = { dec; enc = Fun.id } }
850
+
851
+
let delete_mem : string -> Json.t jsont = fun name ->
852
+
let dec = function
853
+
| Json.Obj ms -> Json.Obj (List.filter (fun (n, _) -> n <> name) ms)
854
+
| _ -> type_error ()
855
+
in
856
+
Map { dom = json; map = { dec; enc = Fun.id } }
857
+
858
+
let const : 'a jsont -> 'a -> 'a jsont = fun t v ->
859
+
let dec _ = v and enc _ = encode t v in
860
+
Map { dom = json; map = { dec; enc } }
861
+
\end{lstlisting}
862
+
\section{The recipe}
863
+
\label{sec:recipe}
864
+
865
+
None of what was presented here is specific to the \json{} data
866
+
model. A datatype similar to \code{jsont} (\autoref{sec:jsont}) can be
867
+
devised for any data model. The recipe is as follows.
868
+
%
869
+
\begin{itemize}
870
+
\item A base case is needed for every base type of the model. Having
871
+
maps in these cases allows to accurately represent their coding contexts.
872
+
(\autoref{sec:base_cases})
873
+
\item An \code{Array}-like case is needed for mapping the model's type for
874
+
arrays. (\autoref{sec:array_case})
875
+
\item An \code{Obj}-like case is needed for mapping the model's type for
876
+
key-value maps or records. The \ml{} ingredients here are:
877
+
projection functions for encoding and, for decoding, a constructor
878
+
function instrumented by a datatype representing function applications
879
+
using type witnesses to indirectly refer to argument values.
880
+
(\autoref{sec:obj_case})
881
+
\item An \code{Any}-like case is needed if the model is dynamically
882
+
typed. It is used to map implicit sums of the model's types to
883
+
a uniform \ml{} type. (\autoref{sec:any_case})
884
+
\item The \code{Map} case is needed for composing map values.
885
+
(\autoref{sec:map_case})
886
+
\item The \code{Rec} case is needed in a strict \ml{} for representing
887
+
recursive values of the data model. (\autoref{sec:jsont})
888
+
\end{itemize}
889
+
%
890
+
And with this we hope to have made your future data soups more edible
891
+
in \ml{}.
892
+
893
+
\appendix
894
+
895
+
\begin{thebibliography}{}
896
+
\bibitem[\protect\citename{Bray, }2017]{json}
897
+
Bray, T., Ed. (2017)
898
+
The JavaScript Object Notation (JSON) Data Interchange Format.
899
+
{\it RFC 8259}.
900
+
\url{https://doi.org/10.17487/RFC8259}
901
+
902
+
\bibitem[\protect\citename{Guo, }2023]{ecmascript}
903
+
Guo, S., Ficarra M., Gibbons, K., Eds (2023)
904
+
ECMAScript® 2023 Language Specification. ECMA-262.
905
+
\url{https://262.ecma-international.org/14.0/}
906
+
\bibitem[\protect\citename{Gibbons, }2007]{datatypegeneric}
907
+
Gibbons, J. (2007)
908
+
Datatype-Generic Programming. {\it Lecture Notes in Computer Science}.
909
+
vol 4719.
910
+
\url{https://doi.org/10.1007/978-3-540-76786-2\_1}
911
+
912
+
\bibitem[\protect\citename{Kennedy, }2004]{picklers}
913
+
Kennedy, A. J., (2004)
914
+
Pickler combinators. {\it Journal of Functional Programming}.
915
+
14(6), 727-739.
916
+
\url{https://doi.org/10.1017/S0956796804005209}
917
+
918
+
\bibitem[\protect\citename{Leroy {\it et al.}, }2023]{ocaml}
919
+
Leroy, X., Doligez, D., Frisch, A., Garrigue, J., Rémy, D.,
920
+
Sivaramakrishnan, KC, \& Vouillon, J. (2023)
921
+
The OCaml system release 5.1. Documentation and user’s manual.
922
+
\mbox{\url{https://ocaml.org/manual}}
923
+
\end{thebibliography}
924
+
925
+
926
+
\section*{Appendix}
927
+
\label{sec:appendix}
928
+
929
+
\ocaml{} 5.1 implementation of the \code{decode} and \code{encode}
930
+
functions mentioned in \autoref{sec:convert}.
931
+
932
+
\lstset{basicstyle=\relscale{0.84}\ttfamily\linespread{1.1}\selectfont}
933
+
\begin{lstlisting}[language=ocaml]
934
+
935
+
module String_map = Map.Make (String)
936
+
937
+
(* Errors *)
938
+
939
+
let type_error () = failwith "type error"
940
+
let unexpected_member n = failwith ("Unexpected member " ^ n)
941
+
let missing_member n = failwith ("Missing member " ^ n)
942
+
let unknown_case_tag () = failwith "Unknown case tag"
943
+
944
+
945
+
946
+
(* Heterogeneous key-value maps *)
947
+
948
+
module Dict = struct
949
+
module M = Map.Make (Int)
950
+
type binding = B : 'a Type.Id.t * 'a -> binding
951
+
type t = binding M.t
952
+
let empty = M.empty
953
+
let add k v m = M.add (Type.Id.uid k) (B (k, v)) m
954
+
let find : type a. a Type.Id.t -> t -> a option =
955
+
fun k m -> match M.find_opt (Type.Id.uid k) m with
956
+
| None -> None
957
+
| Some B (k', v) ->
958
+
match Type.Id.provably_equal k k' with
959
+
| Some Type.Equal -> Some v | None -> assert false
960
+
end
961
+
962
+
(* Decode *)
963
+
964
+
let rec decode : type a. a jsont -> Json.t -> a =
965
+
fun t j -> match t with
966
+
| Null map -> (match j with Json.Null v -> map.dec v | _ -> type_error ())
967
+
| Bool map -> (match j with Json.Bool b -> map.dec b | _ -> type_error ())
968
+
| Number map ->
969
+
(match j with
970
+
| Json.Number n -> map.dec n | Json.Null _ -> map.dec Float.nan
971
+
| _ -> type_error ())
972
+
| String map -> (match j with Json.String s -> map.dec s | _ -> type_error ())
973
+
| Array map ->
974
+
(match j with Json.Array vs -> decode_array map vs | j -> type_error ())
975
+
| Obj map ->
976
+
(match j with Json.Obj mems -> decode_obj map mems | j -> type_error ())
977
+
| Map map -> map.map.dec (decode map.dom j)
978
+
| Any map -> decode_any t map j
979
+
| Rec t -> decode (Lazy.force t) j
980
+
981
+
and decode_array : type a e b. (a, e, b) array_map -> Json.t list -> a =
982
+
fun map vs ->
983
+
let add (i, a) v =
984
+
i + 1, (if map.dec_skip a i then a else map.dec_add a i (decode map.elt v))
985
+
in
986
+
map.dec_finish (snd (List.fold_left add (0, map.dec_empty) vs))
987
+
988
+
and decode_obj : type o. (o, o) obj_map -> Json.obj -> o =
989
+
fun map mems ->
990
+
apply_dict map.dec @@
991
+
decode_obj_map map String_map.empty String_map.empty Dict.empty mems
992
+
993
+
and decode_obj_map : type o.
994
+
(o, o) obj_map -> mem_dec String_map.t -> mem_dec String_map.t -> Dict.t ->
995
+
Json.obj -> Dict.t
996
+
=
997
+
fun map mem_miss mem_decs dict mems ->
998
+
let u n _ _ = invalid_arg (n ^ "member defined twice") in
999
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
1000
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
1001
+
match map.shape with
1002
+
| Obj_cases cases -> decode_obj_case cases mem_miss mem_decs dict [] mems
1003
+
| Obj_basic u ->
1004
+
match u with
1005
+
| Unknown_skip -> decode_obj_basic u () mem_miss mem_decs dict mems
1006
+
| Unknown_error -> decode_obj_basic u () mem_miss mem_decs dict mems
1007
+
| Unknown_keep (map, _) ->
1008
+
decode_obj_basic u map.dec_empty mem_miss mem_decs dict mems
1009
+
1010
+
and decode_obj_basic : type o map builder.
1011
+
(o, map, builder) unknown_mems -> builder -> mem_dec String_map.t ->
1012
+
mem_dec String_map.t -> Dict.t -> Json.obj -> Dict.t
1013
+
=
1014
+
fun u umap mem_miss mem_decs dict -> function
1015
+
| [] ->
1016
+
let dict = match u with
1017
+
| Unknown_skip | Unknown_error -> dict
1018
+
| Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish umap) dict
1019
+
in
1020
+
let add_default _ (Mem_dec m) dict = match m.dec_absent with
1021
+
| Some v -> Dict.add m.id v dict | None -> missing_member m.name
1022
+
in
1023
+
String_map.fold add_default mem_miss dict
1024
+
| (n, v) :: mems ->
1025
+
match String_map.find_opt n mem_decs with
1026
+
| Some (Mem_dec m) ->
1027
+
let dict = Dict.add m.id (decode m.type' v) dict in
1028
+
let mem_miss = String_map.remove n mem_miss in
1029
+
decode_obj_basic u umap mem_miss mem_decs dict mems
1030
+
| None ->
1031
+
match u with
1032
+
| Unknown_skip -> decode_obj_basic u umap mem_miss mem_decs dict mems
1033
+
| Unknown_error -> unexpected_member n
1034
+
| Unknown_keep (map, _) ->
1035
+
let umap = map.dec_add n (decode map.mems_type v) umap in
1036
+
decode_obj_basic u umap mem_miss mem_decs dict mems
1037
+
1038
+
and decode_obj_case : type o cases tag.
1039
+
(o, cases, tag) obj_cases -> mem_dec String_map.t -> mem_dec String_map.t ->
1040
+
Dict.t -> Json.obj -> Json.obj -> Dict.t
1041
+
=
1042
+
fun cases mem_miss mem_decs dict delay mems ->
1043
+
let decode_case_tag tag =
1044
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
1045
+
match List.find_opt eq_tag cases.cases with
1046
+
| None -> unknown_case_tag ()
1047
+
| Some (Case case) ->
1048
+
let mems = List.rev_append delay mems in
1049
+
let dict = decode_obj_map case.obj_map mem_miss mem_decs dict mems in
1050
+
Dict.add cases.id (case.dec (apply_dict case.obj_map.dec dict)) dict
1051
+
in
1052
+
match mems with
1053
+
| [] ->
1054
+
(match cases.tag.dec_absent with
1055
+
| Some t -> decode_case_tag t | None -> missing_member cases.tag.name)
1056
+
| (n, v as mem) :: mems ->
1057
+
if n = cases.tag.name then decode_case_tag (decode cases.tag.type' v) else
1058
+
match String_map.find_opt n mem_decs with
1059
+
| None -> decode_obj_case cases mem_miss mem_decs dict (mem :: delay) mems
1060
+
| Some (Mem_dec m) ->
1061
+
let dict = Dict.add m.id (decode m.type' v) dict in
1062
+
let mem_miss = String_map.remove n mem_miss in
1063
+
decode_obj_case cases mem_miss mem_decs dict delay mems
1064
+
1065
+
1066
+
and decode_any : type a. a jsont -> a any_map -> Json.t -> a =
1067
+
fun t map j ->
1068
+
let dec t m j = match m with Some t -> decode t j | None -> type_error () in
1069
+
match j with
1070
+
| Json.Null _ -> dec t map.dec_null j
1071
+
| Json.Bool _ -> dec t map.dec_bool j
1072
+
| Json.Number _ -> dec t map.dec_number j
1073
+
| Json.String _ -> dec t map.dec_string j
1074
+
| Json.Array _ -> dec t map.dec_array j
1075
+
| Json.Obj _ -> dec t map.dec_obj j
1076
+
1077
+
(* Encode *)
1078
+
1079
+
let rec encode : type a. a jsont -> a -> Json.t =
1080
+
fun t v -> match t with
1081
+
| Null map -> Json.Null (map.enc v)
1082
+
| Bool map -> Json.Bool (map.enc v)
1083
+
| Number map -> Json.Number (map.enc v)
1084
+
| String map -> Json.String (map.enc v)
1085
+
| Array map ->
1086
+
let encode_elt a elt = (encode map.elt elt) :: a in
1087
+
Json.Array (List.rev (map.enc encode_elt [] v))
1088
+
| Obj map -> Json.Obj (List.rev (encode_obj map v []))
1089
+
| Any map -> encode (map.enc v) v
1090
+
| Map map -> encode map.dom (map.map.enc v)
1091
+
| Rec t -> encode (Lazy.force t) v
1092
+
1093
+
and encode_obj : type o. (o, o) obj_map -> o -> Json.obj -> Json.obj =
1094
+
fun map o obj ->
1095
+
let encode_mem obj (Mem_enc map) =
1096
+
let v = map.enc o in
1097
+
if map.enc_omit v then obj else (map.name, encode map.type' v) :: obj
1098
+
in
1099
+
let obj = List.fold_left encode_mem obj map.mem_encs in
1100
+
match map.shape with
1101
+
| Obj_basic (Unknown_keep (map, enc)) ->
1102
+
let encode_mem n v obj = (n, encode map.mems_type v) :: obj in
1103
+
map.enc encode_mem (enc o) obj
1104
+
| Obj_basic _ -> obj
1105
+
| Obj_cases cases ->
1106
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
1107
+
let obj =
1108
+
if cases.tag.enc_omit case.tag then obj else
1109
+
(cases.tag.name, encode cases.tag.type' case.tag) :: obj
1110
+
in
1111
+
encode_obj case.obj_map c obj
1112
+
\end{lstlisting}
1113
+
1114
+
\label{lastpage01}
1115
+
\end{document}
+142
vendor/opam/jsont/paper/soup_test.ml
+142
vendor/opam/jsont/paper/soup_test.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 Daniel C. Bünzli. All rights reserved.
3
+
SPDX-License-Identifier: CC0-1.0
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Tests for soup.ml *)
7
+
8
+
open B0_testing
9
+
10
+
open Soup
11
+
12
+
(* More combinators *)
13
+
14
+
let number = Number { dec = Fun.id; enc = Fun.id }
15
+
let array elt =
16
+
let dec_empty = [] and dec_add a _i v = v :: a in
17
+
let dec_finish elts = List.rev elts in
18
+
let dec_skip _ _ = false in
19
+
let enc f acc vs = List.fold_left f acc vs in
20
+
Array { elt; dec_empty; dec_add; dec_skip; dec_finish; enc }
21
+
22
+
(* Test data *)
23
+
24
+
let content = "J'aime pas la soupe" and public = true
25
+
let json_msg0 = Json.(Obj ["public", Bool public; "content", String content])
26
+
let json_msg1 =
27
+
Json.(Obj ["content", String "Heyho!"; "public", Bool public; "time",
28
+
Number 1.])
29
+
30
+
let json_msg3 =
31
+
Json.(Obj ["public", Bool public; "content", String (content ^ "!")])
32
+
33
+
let json_msgs = Json.Array [json_msg0; json_msg1]
34
+
35
+
(* Tests *)
36
+
37
+
let test_trip () =
38
+
Test.test "generic trip test" @@ fun () ->
39
+
let dec = decode json json_msgs in
40
+
let trip = encode json dec in
41
+
if json_msgs <> trip
42
+
then (Test.log_fail "json_msgs <> trip"; assert false);
43
+
()
44
+
45
+
let test_msg () =
46
+
Test.test "Message modelling and queries tests" @@ fun () ->
47
+
let msg = { Message.content; public } in
48
+
let msg' = decode Message.jsont json_msg0 in
49
+
if msg <> msg' then (Test.log_fail "msg <> msg'"; assert false);
50
+
let q n = get_nth n @@ get_mem "time" number in
51
+
assert (query (q 1) json_msgs = 1.);
52
+
Test.failure @@ (fun () -> query (q 0) json_msgs);
53
+
let json_msgs' =
54
+
let q =
55
+
update_nth 0 @@ update_mem "content" @@
56
+
map (fun s -> s ^ "!") Fun.id string
57
+
in
58
+
query (delete_nth 1) (query q json_msgs)
59
+
in
60
+
if json_msgs' <> Json.Array[json_msg3]
61
+
then (Test.log_fail "json_msgs''"; assert false);
62
+
let json_msgs' =
63
+
let q =
64
+
update_nth 0 @@ update_mem "content" (const string (content ^ "!"))
65
+
in
66
+
(query q json_msgs)
67
+
in
68
+
if json_msgs' <> Json.Array[json_msg3;json_msg1]
69
+
then (Test.log_fail "json_msgs''"; assert false);
70
+
()
71
+
72
+
module Cases = struct
73
+
74
+
type point = { x : float; y : float }
75
+
type line = { p0 : point; p1 : point }
76
+
type type' = Point of point | Line of line
77
+
type geom = { name : string; type' : type' }
78
+
79
+
(* more data *)
80
+
81
+
let ml_geom =
82
+
{ name = "Hey";
83
+
type' = Line { p0 = { x = 0.; y = 1.}; p1 = { x = 2.; y = 3.}} }
84
+
85
+
let json_geom = (* out of order *)
86
+
Json.(Obj ["name", String "Hey";
87
+
"p0", Obj ["x", Number 0.; "y", Number 1.];
88
+
"p1", Obj ["y", Number 3.; "x", Number 2.];
89
+
"type", String "line"; ])
90
+
91
+
(* JSON types *)
92
+
93
+
let point_jsont =
94
+
obj_map (fun x y -> { x; y })
95
+
|> obj_mem "x" number ~enc:(fun p -> p.x)
96
+
|> obj_mem "y" number ~enc:(fun p -> p.y)
97
+
98
+
let line_jsont =
99
+
let point = obj_finish point_jsont in
100
+
obj_map (fun p0 p1 -> { p0; p1 })
101
+
|> obj_mem "p0" point ~enc:(fun p -> p.p0)
102
+
|> obj_mem "p1" point ~enc:(fun p -> p.p1)
103
+
104
+
let case_point =
105
+
{ tag = "point"; obj_map = point_jsont; dec = fun p -> Point p }
106
+
107
+
let case_line =
108
+
{ tag = "line"; obj_map = line_jsont; dec = fun l -> Line l }
109
+
110
+
let cases =
111
+
{ tag = { name = "type"; type' = string; id = Type.Id.make ();
112
+
dec_absent = None; enc = (fun _ -> assert false);
113
+
enc_omit = (fun _ -> assert false); };
114
+
tag_compare = String.compare;
115
+
id = Type.Id.make ();
116
+
cases = [Case case_point; Case case_line];
117
+
enc = (fun g -> g.type');
118
+
enc_case = (function
119
+
| Point p -> Case_value (case_point, p)
120
+
| Line l -> Case_value (case_line, l)) }
121
+
122
+
let geom_jsont : geom jsont =
123
+
let obj = obj_map (fun name type' -> { name; type' }) in
124
+
let obj = obj_mem "name" string obj ~enc:(fun g -> g.name) in
125
+
obj_finish @@
126
+
{ obj with shape = Obj_cases cases; dec = Dec_app (obj.dec, cases.id) }
127
+
end
128
+
129
+
let test_cases () =
130
+
Test.test "cases" @@ fun () ->
131
+
let g = decode Cases.geom_jsont Cases.json_geom in
132
+
if Cases.ml_geom <> g then (Test.log_fail "Cases.geom.ml <> g"; assert false);
133
+
()
134
+
135
+
let main () =
136
+
Test.main @@ fun () ->
137
+
test_trip ();
138
+
test_msg ();
139
+
test_cases ();
140
+
()
141
+
142
+
let () = if !Sys.interactive then () else exit (main ())
+34
vendor/opam/jsont/pkg/META
+34
vendor/opam/jsont/pkg/META
···
1
+
description = "Declarative JSON data manipulation for OCaml"
2
+
version = "%%VERSION_NUM%%"
3
+
requires = ""
4
+
archive(byte) = "jsont.cma"
5
+
archive(native) = "jsont.cmxa"
6
+
plugin(byte) = "jsont.cma"
7
+
plugin(native) = "jsont.cmxs"
8
+
exists_if = "jsont.cma jsont.cmxa"
9
+
10
+
package "brr" (
11
+
directory = "brr"
12
+
description = "The jsont.brr library"
13
+
version = "%%VERSION_NUM%%"
14
+
requires = "brr jsont"
15
+
exports = "brr jsont"
16
+
archive(byte) = "jsont_brr.cma"
17
+
archive(native) = "jsont_brr.cmxa"
18
+
plugin(byte) = "jsont_brr.cma"
19
+
plugin(native) = "jsont_brr.cmxs"
20
+
exists_if = "jsont_brr.cma jsont_brr.cmxa"
21
+
)
22
+
23
+
package "bytesrw" (
24
+
directory = "bytesrw"
25
+
description = "The jsont.bytesrw library"
26
+
version = "%%VERSION_NUM%%"
27
+
requires = "bytesrw jsont"
28
+
exports = "bytesrw jsont"
29
+
archive(byte) = "jsont_bytesrw.cma"
30
+
archive(native) = "jsont_bytesrw.cmxa"
31
+
plugin(byte) = "jsont_bytesrw.cma"
32
+
plugin(native) = "jsont_bytesrw.cmxs"
33
+
exists_if = "jsont_bytesrw.cma jsont_bytesrw.cmxa"
34
+
)
+20
vendor/opam/jsont/pkg/pkg.ml
+20
vendor/opam/jsont/pkg/pkg.ml
···
1
+
#!/usr/bin/env ocaml
2
+
#use "topfind"
3
+
#require "topkg"
4
+
open Topkg
5
+
6
+
let cmdliner = Conf.with_pkg "cmdliner"
7
+
let bytesrw = Conf.with_pkg "bytesrw"
8
+
let brr = Conf.with_pkg "brr"
9
+
let () =
10
+
Pkg.describe "jsont" @@ fun c ->
11
+
let cmdliner = Conf.value c cmdliner in
12
+
let bytesrw = Conf.value c bytesrw in
13
+
let brr = Conf.value c brr in
14
+
Ok [ Pkg.mllib ~api:["Jsont"] "src/jsont.mllib";
15
+
Pkg.mllib ~cond:bytesrw
16
+
~dst_dir:"bytesrw" "src/bytesrw/jsont_bytesrw.mllib";
17
+
Pkg.mllib ~cond:brr ~dst_dir:"brr" "src/brr/jsont_brr.mllib";
18
+
Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld";
19
+
Pkg.doc "doc/cookbook.mld" ~dst:"odoc-pages/cookbook.mld";
20
+
Pkg.bin ~cond:(cmdliner && bytesrw) "test/jsont_tool" ~dst:"jsont"; ]
+6
vendor/opam/jsont/src/brr/dune
+6
vendor/opam/jsont/src/brr/dune
+323
vendor/opam/jsont/src/brr/jsont_brr.ml
+323
vendor/opam/jsont/src/brr/jsont_brr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Jsont.Repr
7
+
8
+
(* Converting between Jsont.Error.t and Jv.Error.t values *)
9
+
10
+
let error_to_jv_error e = Jv.Error.v (Jstr.of_string (Jsont.Error.to_string e))
11
+
let jv_error_to_error e =
12
+
let ctx = Jsont.Error.Context.empty and meta = Jsont.Meta.none in
13
+
Jsont.Error.make_msg ctx meta (Jstr.to_string (Jv.Error.message e))
14
+
15
+
(* Browser JSON codec *)
16
+
17
+
let indent = Jstr.v " "
18
+
let json = Jv.get Jv.global "JSON"
19
+
let json_parse s = Jv.call json "parse" [|Jv.of_jstr s|]
20
+
let json_stringify ~format v =
21
+
let args = match format with
22
+
| Jsont.Minify -> [| v |]
23
+
| Jsont.Indent | Jsont.Layout -> [|v; Jv.null; Jv.of_jstr indent|]
24
+
in
25
+
Jv.to_jstr (Jv.call json "stringify" args)
26
+
27
+
(* Computing the sort of a Jv.t value *)
28
+
29
+
let type_bool = Jstr.v "boolean"
30
+
let type_object = Jstr.v "object"
31
+
let type_number = Jstr.v "number"
32
+
let type_string = Jstr.v "string"
33
+
let type_array = Jv.get Jv.global "Array"
34
+
35
+
let jv_sort jv =
36
+
if Jv.is_null jv then Jsont.Sort.Null else
37
+
let t = Jv.typeof jv in
38
+
if Jstr.equal t type_bool then Jsont.Sort.Bool else
39
+
if Jstr.equal t type_number then Jsont.Sort.Number else
40
+
if Jstr.equal t type_string then Jsont.Sort.String else
41
+
if Jstr.equal t type_object
42
+
then (if Jv.is_array jv then Jsont.Sort.Array else Jsont.Sort.Object) else
43
+
Jsont.Error.msgf Jsont.Meta.none "Not a JSON value: %s" (Jstr.to_string t)
44
+
45
+
(* Getting the members of a Jv.t object in various ways *)
46
+
47
+
let jv_mem_names jv = Jv.call (Jv.get Jv.global "Object") "keys" [| jv |]
48
+
let jv_mem_name_list jv = Jv.to_list Jv.to_string (jv_mem_names jv)
49
+
let jv_mem_name_map : Jv.t -> Jstr.t String_map.t = fun jv ->
50
+
(* The map maps OCaml strings their corresponding JavaScript string *)
51
+
let rec loop ns i max m =
52
+
if i > max then m else
53
+
let n = Jv.Jarray.get ns i in
54
+
loop ns (i + 1) max (String_map.add (Jv.to_string n) (Jv.to_jstr n) m)
55
+
in
56
+
let ns = jv_mem_names jv in
57
+
loop ns 0 (Jv.Jarray.length ns - 1) String_map.empty
58
+
59
+
(* Decoding *)
60
+
61
+
let error_push_array map i e =
62
+
Jsont.Repr.error_push_array Jsont.Meta.none map (i, Jsont.Meta.none) e
63
+
64
+
let error_push_object map n e =
65
+
Jsont.Repr.error_push_object Jsont.Meta.none map (n, Jsont.Meta.none) e
66
+
67
+
let type_error t ~fnd =
68
+
Jsont.Repr.type_error Jsont.Meta.none t ~fnd
69
+
70
+
let find_all_unexpected ~mem_decs mems =
71
+
let unexpected (n, _jname) = match String_map.find_opt n mem_decs with
72
+
| None -> Some (n, Jsont.Meta.none) | Some _ -> None
73
+
in
74
+
List.filter_map unexpected mems
75
+
76
+
let rec decode : type a. a Jsont.Repr.t -> Jv.t -> a =
77
+
fun t jv -> match t with
78
+
| Null map ->
79
+
(match jv_sort jv with
80
+
| Null -> map.dec Jsont.Meta.none ()
81
+
| fnd -> type_error t ~fnd)
82
+
| Bool map ->
83
+
(match jv_sort jv with
84
+
| Bool -> map.dec Jsont.Meta.none (Jv.to_bool jv)
85
+
| fnd -> type_error t ~fnd)
86
+
| Number map ->
87
+
(match jv_sort jv with
88
+
| Number -> map.dec Jsont.Meta.none (Jv.to_float jv)
89
+
| Null -> map.dec Jsont.Meta.none Float.nan
90
+
| fnd -> type_error t ~fnd)
91
+
| String map ->
92
+
(match jv_sort jv with
93
+
| String -> map.dec Jsont.Meta.none (Jv.to_string jv)
94
+
| fnd -> type_error t ~fnd)
95
+
| Array map ->
96
+
(match jv_sort jv with
97
+
| Array -> decode_array map jv
98
+
| fnd -> type_error t ~fnd)
99
+
| Object map ->
100
+
(match jv_sort jv with
101
+
| Object -> decode_object map jv
102
+
| fnd -> type_error t ~fnd)
103
+
| Map map -> map.dec (decode map.dom jv)
104
+
| Any map -> decode_any t map jv
105
+
| Rec t -> decode (Lazy.force t) jv
106
+
107
+
and decode_array :
108
+
type a e b. (a, e, b) array_map -> Jv.t -> a
109
+
=
110
+
fun map jv ->
111
+
let len = Jv.Jarray.length jv in
112
+
let b = ref (map.dec_empty ()) in
113
+
for i = 0 to len - 1 do
114
+
try
115
+
if map.dec_skip i !b then () else
116
+
b := map.dec_add i (decode map.elt (Jv.Jarray.get jv i)) !b
117
+
with Jsont.Error e -> error_push_array map i e
118
+
done;
119
+
map.dec_finish Jsont.Meta.none len !b
120
+
121
+
and decode_object : type o. (o, o) object_map -> Jv.t -> o =
122
+
fun map jv ->
123
+
let names = jv_mem_name_map jv in
124
+
let umems = Unknown_mems None in
125
+
let dict = decode_object_map map umems String_map.empty Dict.empty names jv in
126
+
apply_dict map.dec dict
127
+
128
+
and decode_object_map : type o.
129
+
(o, o) object_map -> unknown_mems_option -> mem_dec String_map.t -> Dict.t ->
130
+
Jstr.t String_map.t -> Jv.t -> Dict.t
131
+
=
132
+
fun map umems mem_decs dict names jv ->
133
+
let u _ _ _ = assert false (* They should be disjoint by contruction *) in
134
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
135
+
match map.shape with
136
+
| Object_cases (umems', cases) ->
137
+
let umems' = Unknown_mems umems' in
138
+
let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in
139
+
decode_object_cases map umems cases mem_decs dict names jv
140
+
| Object_basic umems' ->
141
+
let umems' = Unknown_mems (Some umems') in
142
+
let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in
143
+
match umems with
144
+
| Unknown_mems (Some Unknown_skip | None) ->
145
+
let u = Unknown_skip in
146
+
decode_object_basic
147
+
map u () mem_decs dict (String_map.bindings names) jv
148
+
| Unknown_mems (Some (Unknown_error as u)) ->
149
+
decode_object_basic
150
+
map u () mem_decs dict (String_map.bindings names) jv
151
+
| Unknown_mems (Some (Unknown_keep (umap, _) as u)) ->
152
+
let umap = umap.dec_empty () and names = String_map.bindings names in
153
+
decode_object_basic map u umap mem_decs dict names jv
154
+
155
+
and decode_object_basic : type o p m b.
156
+
(o, o) object_map -> (p, m, b) unknown_mems -> b ->
157
+
mem_dec String_map.t -> Dict.t -> (string * Jstr.t) list -> Jv.t -> Dict.t
158
+
=
159
+
fun map umems umap mem_decs dict names jv -> match names with
160
+
| [] ->
161
+
Jsont.Repr.finish_object_decode map Jsont.Meta.none umems umap mem_decs dict
162
+
| (n, jname) :: names ->
163
+
match String_map.find_opt n mem_decs with
164
+
| Some (Mem_dec m) ->
165
+
let dict =
166
+
try Dict.add m.id (decode m.type' (Jv.get' jv jname)) dict with
167
+
| Jsont.Error e -> error_push_object map n e
168
+
in
169
+
let mem_decs = String_map.remove n mem_decs in
170
+
decode_object_basic map umems umap mem_decs dict names jv
171
+
| None ->
172
+
match umems with
173
+
| Unknown_skip ->
174
+
decode_object_basic map umems umap mem_decs dict names jv
175
+
| Unknown_error ->
176
+
let fnd =
177
+
(n, Jsont.Meta.none) :: find_all_unexpected ~mem_decs names
178
+
in
179
+
Jsont.Repr.unexpected_mems_error Jsont.Meta.none map ~fnd
180
+
| Unknown_keep (mmap, _) ->
181
+
let umap =
182
+
let v = try decode mmap.mems_type (Jv.get' jv jname) with
183
+
| Jsont.Error e -> error_push_object map n e
184
+
in
185
+
mmap.dec_add Jsont.Meta.none n v umap
186
+
in
187
+
decode_object_basic map umems umap mem_decs dict names jv
188
+
189
+
and decode_object_cases : type o cs t.
190
+
(o, o) object_map -> unknown_mems_option -> (o, cs, t) object_cases ->
191
+
mem_dec String_map.t -> Dict.t -> Jstr.t String_map.t -> Jv.t -> Dict.t
192
+
=
193
+
fun map umems cases mem_decs dict names jv ->
194
+
let decode_case_tag tag =
195
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
196
+
match List.find_opt eq_tag cases.cases with
197
+
| None ->
198
+
Jsont.Repr.unexpected_case_tag_error Jsont.Meta.none map cases tag
199
+
| Some (Case case) ->
200
+
let mems = String_map.remove cases.tag.name names in
201
+
let dict =
202
+
decode_object_map case.object_map umems mem_decs dict mems jv
203
+
in
204
+
Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
205
+
in
206
+
match String_map.find_opt cases.tag.name names with
207
+
| Some jname ->
208
+
(try decode_case_tag (decode cases.tag.type' (Jv.get' jv jname)) with
209
+
| Jsont.Error e -> error_push_object map cases.tag.name e)
210
+
| None ->
211
+
match cases.tag.dec_absent with
212
+
| Some tag -> decode_case_tag tag
213
+
| None ->
214
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
215
+
let fnd = jv_mem_name_list jv in
216
+
Jsont.Repr.missing_mems_error Jsont.Meta.none map ~exp ~fnd
217
+
218
+
and decode_any : type a. a t -> a any_map -> Jv.t -> a =
219
+
fun t map jv ->
220
+
let case t map sort jv = match map with
221
+
| Some t -> decode t jv | None -> type_error t ~fnd:sort
222
+
in
223
+
match jv_sort jv with
224
+
| Null as s -> case t map.dec_null s jv
225
+
| Bool as s -> case t map.dec_bool s jv
226
+
| Number as s -> case t map.dec_number s jv
227
+
| String as s -> case t map.dec_string s jv
228
+
| Array as s -> case t map.dec_array s jv
229
+
| Object as s -> case t map.dec_object s jv
230
+
231
+
let decode t jv = decode (Jsont.Repr.of_t t) jv
232
+
let decode_jv' t jv = try Ok (decode t jv) with Jsont.Error e -> Error e
233
+
let decode_jv t jv = Result.map_error error_to_jv_error (decode_jv' t jv)
234
+
let decode' t s = try Ok (decode t (json_parse s)) with
235
+
| Jv.Error e -> Error (jv_error_to_error e) | Jsont.Error e -> Error e
236
+
237
+
let decode t json = Result.map_error error_to_jv_error (decode' t json)
238
+
239
+
(* Encoding *)
240
+
241
+
let rec encode : type a. a t -> a -> Jv.t =
242
+
fun t v -> match t with
243
+
| Null map -> map.enc v; Jv.null
244
+
| Bool map -> Jv.of_bool (map.enc v)
245
+
| Number map -> Jv.of_float (map.enc v)
246
+
| String map -> Jv.of_string (map.enc v)
247
+
| Array map ->
248
+
let add map a i vi = try Jv.Jarray.set a i (encode map.elt vi); a with
249
+
| Jsont.Error e -> error_push_array map i e
250
+
in
251
+
map.enc (add map) (Jv.Jarray.create 0) v
252
+
| Object map -> encode_object map ~do_unknown:true v (Jv.obj [||])
253
+
| Any map -> encode (map.enc v) v
254
+
| Map map -> encode map.dom (map.enc v)
255
+
| Rec t -> encode (Lazy.force t) v
256
+
257
+
and encode_object :
258
+
type o. (o, o) Jsont.Repr.object_map -> do_unknown:bool -> o -> Jv.t -> Jv.t
259
+
=
260
+
fun map ~do_unknown o jv ->
261
+
let encode_mem map o jv (Mem_enc mmap) =
262
+
try
263
+
let v = mmap.enc o in
264
+
if mmap.enc_omit v then jv else
265
+
(Jv.set' jv (Jstr.of_string mmap.name) (encode mmap.type' v); jv)
266
+
with
267
+
| Jsont.Error e -> error_push_object map mmap.name e
268
+
in
269
+
let jv = List.fold_left (encode_mem map o) jv map.mem_encs in
270
+
match map.shape with
271
+
| Object_basic (Unknown_keep (umap, enc)) when do_unknown ->
272
+
encode_unknown_mems map umap (enc o) jv
273
+
| Object_basic _ -> jv
274
+
| Object_cases (u, cases) ->
275
+
let Case_value (case, v) = cases.enc_case (cases.enc o) in
276
+
let jv =
277
+
try
278
+
if cases.tag.enc_omit case.tag then jv else
279
+
let tag = encode cases.tag.type' case.tag in
280
+
Jv.set' jv (Jstr.of_string cases.tag.name) tag; jv
281
+
with
282
+
| Jsont.Error e -> error_push_object map cases.tag.name e
283
+
in
284
+
match u with
285
+
| Some (Unknown_keep (umap, enc)) ->
286
+
(* Feels nicer to encode unknowns at the end *)
287
+
let jv = encode_object case.object_map ~do_unknown:false v jv in
288
+
encode_unknown_mems map umap (enc o) jv
289
+
| _ -> encode_object case.object_map ~do_unknown v jv
290
+
291
+
and encode_unknown_mems : type o mems a builder.
292
+
(o, o) object_map -> (mems, a, builder) mems_map -> mems -> Jv.t -> Jv.t =
293
+
fun map umap mems jv ->
294
+
let encode_mem map meta name v jv =
295
+
try Jv.set' jv (Jstr.of_string name) (encode umap.mems_type v); jv with
296
+
| Jsont.Error e -> error_push_object map name e
297
+
in
298
+
umap.enc (encode_mem map) mems jv
299
+
300
+
let encode t v = encode (Jsont.Repr.of_t t) v
301
+
let encode_jv' t v = try Ok (encode t v) with Jsont.Error e -> Error e
302
+
let encode_jv t v = Result.map_error error_to_jv_error (encode_jv' t v)
303
+
let encode' ?(format = Jsont.Minify) t v =
304
+
try Ok (json_stringify ~format (encode t v)) with
305
+
| Jv.Error e -> Error (jv_error_to_error e)
306
+
| Jsont.Error e -> Error e
307
+
308
+
let encode ?format t v =
309
+
Result.map_error error_to_jv_error (encode' ?format t v)
310
+
311
+
(* Recode *)
312
+
313
+
let recode ?format t s = match decode t s with
314
+
| Error _ as e -> e | Ok v -> encode ?format t v
315
+
316
+
let recode' ?format t s = match decode' t s with
317
+
| Error _ as e -> e | Ok v -> encode' ?format t v
318
+
319
+
let recode_jv t jv = match decode_jv t jv with
320
+
| Error _ as e -> e | Ok v -> encode_jv t v
321
+
322
+
let recode_jv' t s = match decode_jv' t s with
323
+
| Error _ as e -> e | Ok v -> encode_jv' t v
+68
vendor/opam/jsont/src/brr/jsont_brr.mli
+68
vendor/opam/jsont/src/brr/jsont_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
9
+
fast enough for medium sized structures. Get in touch if you run
10
+
into problems, 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}[JSON.parse]} and
14
+
{{:https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify}[JSON.stringify]} to convert to JavaScript values
15
+
which are then converted with {!decode_jv} and {!encode_jv}. Parse
16
+
locations and layout preservation are unsupported. *)
17
+
18
+
(** {1:decode Decode} *)
19
+
20
+
val decode : 'a Jsont.t -> Jstr.t -> ('a, Jv.Error.t) result
21
+
(** [decode t s] decodes the JSON data [s] according to [t]. *)
22
+
23
+
val decode' : 'a Jsont.t -> Jstr.t -> ('a, Jsont.Error.t) result
24
+
(** [decode' t s] is like {!val-decode} but preserves the error structure. *)
25
+
26
+
val decode_jv : 'a Jsont.t -> Jv.t -> ('a, Jv.Error.t) result
27
+
(** [decode_jv t v] decodes the JavaScript value [v] according to [t]. *)
28
+
29
+
val decode_jv' : 'a Jsont.t -> Jv.t -> ('a, Jsont.Error.t) result
30
+
(** [decode_jv'] is like {!decode_jv'} but preserves the error structure. *)
31
+
32
+
(** {1:encode Encode} *)
33
+
34
+
val encode :
35
+
?format:Jsont.format -> 'a Jsont.t -> 'a -> (Jstr.t, Jv.Error.t) result
36
+
(** [encode t v] encodes [v] to JSON according to [t]. [format]
37
+
specifies how the JSON is formatted, defaults to
38
+
{!Jsont.Minify}. The {!Jsont.Layout} format is unsupported,
39
+
{!Jsont.Indent} is used instead. *)
40
+
41
+
val encode' :
42
+
?format:Jsont.format -> 'a Jsont.t -> 'a -> (Jstr.t, Jsont.Error.t) result
43
+
(** [encode'] is like {!val-encode} but preserves the error structure.
44
+
[format] specifies how the JSON is formatted, defaults to
45
+
{!Jsont.Minify}. The {!Jsont.Layout} format is unsupported,
46
+
{!Jsont.Indent} is used instead. *)
47
+
48
+
val encode_jv : 'a Jsont.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 Jsont.t -> 'a -> (Jv.t, Jsont.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 : ?format:Jsont.format -> 'a Jsont.t -> Jstr.t ->
57
+
(Jstr.t, Jv.Error.t) result
58
+
(** [recode] is {!val-decode} followed by {!val-encode}. *)
59
+
60
+
val recode' : ?format:Jsont.format -> 'a Jsont.t -> Jstr.t ->
61
+
(Jstr.t, Jsont.Error.t) result
62
+
(** [recode] is {!val-decode'} followed by {!val-encode'}. *)
63
+
64
+
val recode_jv : 'a Jsont.t -> Jv.t -> (Jv.t, Jv.Error.t) result
65
+
(** [recode] is {!val-decode} followed by {!val-encode}. *)
66
+
67
+
val recode_jv' : 'a Jsont.t -> Jv.t -> (Jv.t, Jsont.Error.t) result
68
+
(** [recode] is {!val-decode_jv'} followed by {!encode_jv'}. *)
+1
vendor/opam/jsont/src/brr/jsont_brr.mllib
+1
vendor/opam/jsont/src/brr/jsont_brr.mllib
···
1
+
Jsont_brr
+7
vendor/opam/jsont/src/bytesrw/dune
+7
vendor/opam/jsont/src/bytesrw/dune
+1069
vendor/opam/jsont/src/bytesrw/jsont_bytesrw.ml
+1069
vendor/opam/jsont/src/bytesrw/jsont_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 Jsont.Repr
8
+
9
+
(* XXX add these things to Stdlib.Uchar *)
10
+
11
+
let uchar_max_utf_8_byte_length = 4
12
+
let[@inline] uchar_utf_8_byte_decode_length = function
13
+
| '\x00' .. '\x7F' -> 1
14
+
| '\x80' .. '\xC1' -> 0
15
+
| '\xC2' .. '\xDF' -> 2
16
+
| '\xE0' .. '\xEF' -> 3
17
+
| '\xF0' .. '\xF4' -> 4
18
+
| _ -> 0
19
+
20
+
(* Character classes *)
21
+
22
+
let[@inline] is_digit u = 0x0030 (* 0 *) <= u && u <= 0x0039 (* 9 *)
23
+
let[@inline] is_number_start u = is_digit u || u = 0x002D (* - *)
24
+
let[@inline] is_surrogate u = 0xD800 <= u && u <= 0xDFFF
25
+
let[@inline] is_hi_surrogate u = 0xD800 <= u && u <= 0xDBFF
26
+
let[@inline] is_lo_surrogate u = 0xDC00 <= u && u <= 0xDFFF
27
+
let[@inline] is_control u =
28
+
(0x0000 <= u && u <= 0x001F) || (* C0 control characters *)
29
+
u = 0x007F || (* Delete *)
30
+
(0x0080 <= u && u <= 0x009F) || (* C1 control characters *)
31
+
u = 0x2028 (* Line separator *) ||
32
+
u = 0x2029 (* Paragraph separator *) ||
33
+
u = 0x200E (* left-to-right mark *) ||
34
+
u = 0x200F (* right-to-left mark *)
35
+
36
+
let sot = 0x1A0000 (* start of text U+10FFFF + 1 *)
37
+
let eot = 0x1A0001 (* end of text U+10FFFF + 2 *)
38
+
39
+
let pp_code = Jsont.Repr.pp_code
40
+
let pp_quchar ppf u =
41
+
pp_code ppf @@
42
+
if u = sot then "start of text" else
43
+
if u = eot then "end of text" else
44
+
if is_control u || is_surrogate u then Printf.sprintf "U+%04X" u else
45
+
let u = Uchar.of_int u in
46
+
let b = Stdlib.Bytes.make (Uchar.utf_8_byte_length u) '\x00' in
47
+
Stdlib.(ignore (Bytes.set_utf_8_uchar b 0 u); (Bytes.unsafe_to_string b))
48
+
49
+
(* Decoder *)
50
+
51
+
type decoder =
52
+
{ file : string;
53
+
meta_none : Jsont.Meta.t; (* A meta with just [file] therein. *)
54
+
locs : bool; (* [true] if text locations should be computed. *)
55
+
layout : bool; (* [true] if text layout should be kept. *)
56
+
reader : Bytes.Reader.t; (* The source of bytes. *)
57
+
mutable i : Stdlib.Bytes.t; (* Current input slice. *)
58
+
mutable i_max : int; (* Maximum byte index in [i]. *)
59
+
mutable i_next : int; (* Next byte index to read in [i]. *)
60
+
mutable overlap : Stdlib.Bytes.t; (* Buffer for overlapping decodes. *)
61
+
mutable u : int; (* Current Unicode scalar value or sot or eot. *)
62
+
mutable byte_count : int; (* Global byte count. *)
63
+
mutable line : int; (* Current line number. *)
64
+
mutable line_start : int; (* Current line global byte position. *)
65
+
token : Buffer.t;
66
+
ws : Buffer.t; (* Bufferizes whitespace when layout is [true]. *) }
67
+
68
+
let make_decoder ?(locs = false) ?(layout = false) ?(file = "-") reader =
69
+
let overlap = Stdlib.Bytes.create uchar_max_utf_8_byte_length in
70
+
let token = Buffer.create 255 and ws = Buffer.create 255 in
71
+
let meta_none = Jsont.Meta.make (Jsont.Textloc.(set_file none) file) in
72
+
{ file; meta_none; locs; layout; reader;
73
+
i = overlap (* overwritten by initial refill *);
74
+
i_max = 0; i_next = 1 (* triggers an initial refill *);
75
+
overlap; u = sot; byte_count = 0; line = 1; line_start = 0; token; ws }
76
+
77
+
(* Decoder positions *)
78
+
79
+
let[@inline] get_line_pos d = d.line, d.line_start
80
+
81
+
let get_last_byte d =
82
+
if d.u <= 0x7F then d.byte_count - 1 else
83
+
if d.u = sot || d.u = eot then d.byte_count else
84
+
(* On multi-bytes uchars we want to point on the first byte. *)
85
+
d.byte_count - Uchar.utf_8_byte_length (Uchar.of_int d.u)
86
+
87
+
(* Decoder errors *)
88
+
89
+
let error_meta d =
90
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
91
+
let last_byte = first_byte and last_line = first_line in
92
+
Jsont.Meta.make @@
93
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line ~last_line
94
+
95
+
let error_meta_to_current ~first_byte ~first_line d =
96
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
97
+
Jsont.Meta.make @@
98
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line ~last_line
99
+
100
+
let err_here d fmt = Jsont.Error.msgf (error_meta d) fmt
101
+
let err_to_here ~first_byte ~first_line d fmt =
102
+
Jsont.Error.msgf (error_meta_to_current ~first_byte ~first_line d) fmt
103
+
104
+
let err_malformed_utf_8 d =
105
+
if d.i_next > d.i_max
106
+
then err_here d "UTF-8 decoding error: unexpected end of bytes"
107
+
else err_here d "UTF-8 decoding error: invalid byte %a"
108
+
pp_code (Printf.sprintf "%x02x" (Bytes.get_uint8 d.i d.i_next))
109
+
110
+
let err_exp d = err_here d "Expected %a but found %a"
111
+
let err_exp_while d = err_here d "Expected %a while parsing %a but found %a"
112
+
113
+
let err_exp_eot d = err_exp d pp_quchar eot pp_quchar d.u
114
+
let err_not_json_value d = err_exp d pp_code "JSON value" pp_quchar d.u
115
+
116
+
let current_json_sort d = match d.u with
117
+
| 0x0066 (* f *) | 0x0074 (* t *) -> Jsont.Sort.Bool
118
+
| 0x006E (* n *) -> Jsont.Sort.Null
119
+
| 0x007B (* { *) -> Jsont.Sort.Object
120
+
| 0x005B (* [ *) -> Jsont.Sort.Array
121
+
| 0x0022 (* DQUOTE *) -> Jsont.Sort.String
122
+
| u when is_number_start u -> Jsont.Sort.Number
123
+
| _ -> err_not_json_value d
124
+
125
+
let type_error d t =
126
+
Jsont.Repr.type_error (error_meta d) t ~fnd:(current_json_sort d)
127
+
128
+
(* Errors for constants *)
129
+
130
+
let err_exp_in_const ~first_byte ~first_line d ~exp ~fnd ~const =
131
+
err_to_here ~first_byte ~first_line d
132
+
"Expected %a while parsing %a but found: %a"
133
+
pp_quchar exp pp_code const pp_quchar fnd
134
+
135
+
(* Errors for numbers *)
136
+
137
+
let err_float_parse meta tok =
138
+
Jsont.Error.msgf meta "Could not parse %S to a %a" tok pp_code "float"
139
+
140
+
let err_exp_digit d =
141
+
err_exp_while d pp_code "decimal digit" pp_code "number" pp_quchar d.u
142
+
143
+
(* Errors for strings *)
144
+
145
+
let err_exp_hex_digit d =
146
+
err_exp_while d pp_code "hex digit" pp_code "character escape" pp_quchar d.u
147
+
148
+
let err_exp_lo_surrogate d u =
149
+
err_exp_while d pp_code "low surrogate" pp_code "character escape" pp_quchar u
150
+
151
+
let err_unpaired_lo_surrogate d u =
152
+
err_here d "Unpaired low surrogate %a in %a" pp_quchar u pp_code "string"
153
+
154
+
let err_unpaired_hi_surrogate d u =
155
+
err_here d "Unpaired high surrogate %a in %a" pp_quchar u pp_code "string"
156
+
157
+
let err_exp_esc ~first_byte ~first_line d u =
158
+
err_to_here ~first_byte ~first_line d "Expected %a while parsing %a found %a"
159
+
pp_code "escape character" pp_code "escape" pp_quchar u
160
+
161
+
let err_unclosed_string ~first_byte ~first_line d =
162
+
err_to_here ~first_byte ~first_line d "Unclosed %a" pp_code "string"
163
+
164
+
let err_illegal_ctrl_char ~first_byte ~first_line d =
165
+
err_to_here ~first_byte ~first_line d "Illegal control character %a in %a"
166
+
pp_quchar d.u pp_code "string"
167
+
168
+
(* Errors for arrays *)
169
+
170
+
let err_exp_comma_or_eoa d ~fnd =
171
+
err_here d "Expected %a or %a after %a but found %a"
172
+
pp_code "," pp_code "]" pp_code "array element" pp_quchar fnd
173
+
174
+
let err_unclosed_array d = err_here d "Unclosed %a" pp_code "array"
175
+
let err_exp_comma_or_eoo d =
176
+
err_here d "Expected %a or %a after %a but found: %a"
177
+
pp_code "," pp_code "}" pp_code "object member" pp_quchar d.u
178
+
179
+
(* Errors for objects *)
180
+
181
+
let err_exp_mem d =
182
+
err_here d "Expected %a but found %a"
183
+
pp_code "object member" pp_quchar d.u
184
+
185
+
let err_exp_mem_or_eoo d =
186
+
err_here d "Expected: %a or %a but found %a"
187
+
pp_code "object member" pp_code "}" pp_quchar d.u
188
+
189
+
let err_exp_colon d =
190
+
err_here d "Expected %a after %a but found %a"
191
+
pp_code ":" pp_code "member name" pp_quchar d.u
192
+
193
+
let err_unclosed_object d (map : ('o, 'o) Jsont.Repr.object_map) =
194
+
err_here d "Unclosed %a"
195
+
Jsont.Repr.pp_kind (Jsont.Repr.object_map_kinded_sort map)
196
+
197
+
(* Decode next character in d.u *)
198
+
199
+
let[@inline] is_eoslice d = d.i_next > d.i_max
200
+
let[@inline] is_eod d = d.i_max = - 1 (* Only happens on Slice.eod *)
201
+
let[@inline] available d = d.i_max - d.i_next + 1
202
+
let[@inline] set_slice d slice =
203
+
d.i <- Bytes.Slice.bytes slice;
204
+
d.i_next <- Bytes.Slice.first slice;
205
+
d.i_max <- d.i_next + Bytes.Slice.length slice - 1
206
+
207
+
let rec setup_overlap d start need = match need with
208
+
| 0 ->
209
+
let slice = match available d with
210
+
| 0 -> Bytes.Reader.read d.reader
211
+
| length -> Bytes.Slice.make d.i ~first:d.i_next ~length
212
+
in
213
+
d.i <- d.overlap; d.i_next <- 0; d.i_max <- start; slice
214
+
| need ->
215
+
if is_eoslice d then set_slice d (Bytes.Reader.read d.reader);
216
+
if is_eod d
217
+
then (d.byte_count <- d.byte_count - start; err_malformed_utf_8 d);
218
+
let available = available d in
219
+
let take = Int.min need available in
220
+
for i = 0 to take - 1 do
221
+
Bytes.set d.overlap (start + i) (Bytes.get d.i (d.i_next + i))
222
+
done;
223
+
d.i_next <- d.i_next + take; d.byte_count <- d.byte_count + take;
224
+
setup_overlap d (start + take) (need - take)
225
+
226
+
let rec nextc d =
227
+
let a = available d in
228
+
if a <= 0 then
229
+
(if is_eod d
230
+
then d.u <- eot
231
+
else (set_slice d (Bytes.Reader.read d.reader); nextc d))
232
+
else
233
+
let b = Bytes.get d.i d.i_next in
234
+
if a < uchar_max_utf_8_byte_length &&
235
+
a < uchar_utf_8_byte_decode_length b then begin
236
+
let s = setup_overlap d 0 (uchar_utf_8_byte_decode_length b) in
237
+
nextc d; set_slice d s
238
+
end else
239
+
d.u <- match b with
240
+
| '\x00' .. '\x09' | '\x0B' | '\x0E' .. '\x7F' as u -> (* ASCII fast path *)
241
+
d.i_next <- d.i_next + 1; d.byte_count <- d.byte_count + 1;
242
+
Char.code u
243
+
| '\x0D' (* CR *) ->
244
+
d.i_next <- d.i_next + 1; d.byte_count <- d.byte_count + 1;
245
+
d.line_start <- d.byte_count; d.line <- d.line + 1;
246
+
0x000D
247
+
| '\x0A' (* LF *) ->
248
+
d.i_next <- d.i_next + 1; d.byte_count <- d.byte_count + 1;
249
+
d.line_start <- d.byte_count;
250
+
if d.u <> 0x000D then d.line <- d.line + 1;
251
+
0x000A
252
+
| _ ->
253
+
let udec = Bytes.get_utf_8_uchar d.i d.i_next in
254
+
if not (Uchar.utf_decode_is_valid udec) then err_malformed_utf_8 d else
255
+
let u = Uchar.to_int (Uchar.utf_decode_uchar udec) in
256
+
let ulen = Uchar.utf_decode_length udec in
257
+
d.i_next <- d.i_next + ulen; d.byte_count <- d.byte_count + ulen;
258
+
u
259
+
260
+
(* Decoder tokenizer *)
261
+
262
+
let[@inline] token_clear d = Buffer.clear d.token
263
+
let[@inline] token_pop d = let t = Buffer.contents d.token in (token_clear d; t)
264
+
let[@inline] token_add d u =
265
+
if u <= 0x7F
266
+
then Buffer.add_char d.token (Char.unsafe_chr u)
267
+
else Buffer.add_utf_8_uchar d.token (Uchar.unsafe_of_int u)
268
+
269
+
let[@inline] accept d = token_add d d.u; nextc d
270
+
271
+
let token_pop_float d ~meta =
272
+
let token = token_pop d in
273
+
match float_of_string_opt token with
274
+
| Some f -> f | None -> err_float_parse meta token (* likely [assert false] *)
275
+
276
+
(* Decoder layout and position tracking *)
277
+
278
+
let[@inline] ws_pop d =
279
+
if not d.layout then "" else
280
+
(let t = Buffer.contents d.ws in Buffer.clear d.ws; t)
281
+
282
+
let textloc_to_current ~first_byte ~first_line d =
283
+
if not d.locs then Jsont.Textloc.none else
284
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
285
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line ~last_line
286
+
287
+
let textloc_prev_ascii_char ~first_byte ~first_line d =
288
+
(* N.B. when we call that the line doesn't move and the char was on
289
+
a single byte *)
290
+
if not d.locs then Jsont.Textloc.none else
291
+
let last_byte = get_last_byte d and last_line = get_line_pos d in
292
+
let last_byte = last_byte - 1 in
293
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line ~last_line
294
+
295
+
let meta_make d ?ws_before ?ws_after textloc =
296
+
if not d.locs && not d.layout then d.meta_none else
297
+
Jsont.Meta.make ?ws_before ?ws_after textloc
298
+
299
+
(* Decoding *)
300
+
301
+
let false_uchars = [| 0x0066; 0x0061; 0x006C; 0x0073; 0x0065 |]
302
+
let true_uchars = [| 0x0074; 0x0072; 0x0075; 0x0065 |]
303
+
let null_uchars = [| 0x006E; 0x0075; 0x006C; 0x006C |]
304
+
let ascii_str us = String.init (Array.length us) (fun i -> Char.chr us.(i))
305
+
306
+
let[@inline] is_ws u =
307
+
if u > 0x20 then false else match Char.unsafe_chr u with
308
+
| ' ' | '\t' | '\r' | '\n' -> true
309
+
| _ -> false
310
+
311
+
let[@inline] read_ws d =
312
+
while is_ws d.u do
313
+
if d.layout then (Buffer.add_char d.ws (Char.unsafe_chr d.u));
314
+
nextc d
315
+
done
316
+
317
+
let read_json_const d const = (* First character was checked. *)
318
+
let ws_before = ws_pop d in
319
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
320
+
for i = 1 to Array.length const - 1 do
321
+
nextc d;
322
+
if not (Int.equal d.u const.(i))
323
+
then err_exp_in_const ~first_byte ~first_line d ~exp:const.(i) ~fnd:d.u
324
+
~const:(ascii_str const)
325
+
done;
326
+
let textloc = textloc_to_current d ~first_byte ~first_line in
327
+
let ws_after = (nextc d; read_ws d; ws_pop d) in
328
+
meta_make d ~ws_before ~ws_after textloc
329
+
330
+
let[@inline] read_json_false d = read_json_const d false_uchars
331
+
let[@inline] read_json_true d = read_json_const d true_uchars
332
+
let[@inline] read_json_null d = read_json_const d null_uchars
333
+
let read_json_number d = (* [is_number_start d.u] = true *)
334
+
let[@inline] read_digits d = while is_digit d.u do accept d done in
335
+
let[@inline] read_int d = match d.u with
336
+
| 0x0030 (* 0 *) -> accept d
337
+
| u when is_digit u -> accept d; read_digits d
338
+
| u -> err_exp_digit d
339
+
in
340
+
let[@inline] read_opt_frac d = match d.u with
341
+
| 0x002E (* . *) ->
342
+
accept d; if is_digit d.u then read_digits d else err_exp_digit d
343
+
| _ -> ()
344
+
in
345
+
let[@inline] read_opt_exp d = match d.u with
346
+
| 0x0065 (* e *) | 0x0045 (* E *) ->
347
+
token_add d d.u; nextc d;
348
+
(match d.u with
349
+
| 0x002D (* - *) | 0x002B (* + *) -> token_add d d.u; nextc d
350
+
| _ -> ());
351
+
if is_digit d.u then read_digits d else err_exp_digit d
352
+
| _ -> ()
353
+
in
354
+
let first_byte = get_last_byte d in
355
+
let first_line = get_line_pos d in
356
+
let ws_before = ws_pop d in
357
+
token_clear d;
358
+
if d.u = 0x002D (* - *) then accept d;
359
+
read_int d;
360
+
read_opt_frac d;
361
+
read_opt_exp d;
362
+
let textloc = textloc_prev_ascii_char d ~first_byte ~first_line in
363
+
let ws_after = read_ws d; ws_pop d in
364
+
meta_make d ~ws_before ~ws_after textloc
365
+
366
+
let read_json_string d = (* d.u is 0x0022 *)
367
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
368
+
let rec read_uescape d hi uc count =
369
+
if count > 0 then match d.u with
370
+
| u when 0x0030 <= u && u <= 0x0039 ->
371
+
nextc d; read_uescape d hi (uc * 16 + u - 0x30) (count - 1)
372
+
| u when 0x0041 <= u && u <= 0x0046 ->
373
+
nextc d; read_uescape d hi (uc * 16 + u - 0x37) (count - 1)
374
+
| u when 0x0061 <= u && u <= 0x0066 ->
375
+
nextc d; read_uescape d hi (uc * 16 + u - 0x57) (count - 1)
376
+
| u -> err_exp_hex_digit d
377
+
else match hi with
378
+
| Some hi -> (* combine high and low surrogate. *)
379
+
if not (is_lo_surrogate uc) then err_exp_lo_surrogate d uc else
380
+
let u = (((hi land 0x3FF) lsl 10) lor (uc land 0x3FF)) + 0x10000 in
381
+
token_add d u
382
+
| None ->
383
+
if not (is_surrogate uc) then token_add d uc else
384
+
if uc > 0xDBFF then err_unpaired_lo_surrogate d uc else
385
+
if d.u <> 0x005C (* \ *) then err_unpaired_hi_surrogate d uc else
386
+
(nextc d;
387
+
if d.u <> 0x0075 (* u *) then err_unpaired_hi_surrogate d uc else
388
+
(nextc d; read_uescape d (Some uc) 0 4))
389
+
in
390
+
let read_escape d = match d.u with
391
+
| 0x0022 (* DQUOTE *) | 0x005C (* \ *) | 0x002F (* / *) -> accept d
392
+
| 0x0062 (* b *) -> token_add d 0x0008 (* backspace *); nextc d
393
+
| 0x0066 (* f *) -> token_add d 0x000C (* form feed *); nextc d
394
+
| 0x006E (* n *) -> token_add d 0x000A (* line feed *); nextc d
395
+
| 0x0072 (* r *) -> token_add d 0x000D (* carriage return *); nextc d
396
+
| 0x0074 (* t *) -> token_add d 0x0009 (* tab *); nextc d
397
+
| 0x0075 (* u *) -> nextc d; read_uescape d None 0 4
398
+
| u -> err_exp_esc ~first_byte ~first_line d u
399
+
in
400
+
let rec loop d = match d.u with
401
+
| 0x005C (* \ *) -> nextc d; read_escape d; loop d
402
+
| 0x0022 (* DQUOTE *) -> ()
403
+
| u when u = eot -> err_unclosed_string ~first_byte ~first_line d
404
+
| u when 0x0000 <= u && u <= 0x001F ->
405
+
err_illegal_ctrl_char ~first_byte ~first_line d
406
+
| u -> accept d; loop d
407
+
in
408
+
let ws_before = ws_pop d in
409
+
nextc d; token_clear d; loop d;
410
+
let textloc = textloc_to_current d ~first_byte ~first_line in
411
+
let ws_after = nextc d; read_ws d; ws_pop d in
412
+
meta_make d ~ws_before ~ws_after textloc
413
+
414
+
let read_json_name d =
415
+
let meta = read_json_string d in
416
+
if d.u = 0x003A (* : *) then (nextc d; meta) else err_exp_colon d
417
+
418
+
let read_json_mem_sep d =
419
+
if d.u = 0x007D (* } *) then () else
420
+
if d.u = 0x002C (* , *)
421
+
then (nextc d; read_ws d; if d.u <> 0x0022 then err_exp_mem d)
422
+
else err_exp_comma_or_eoo d
423
+
424
+
let rec decode : type a. decoder -> a t -> a =
425
+
fun d t -> match (read_ws d; t) with
426
+
| Null map ->
427
+
(match d.u with
428
+
| 0x006E (* n *) -> map.dec (read_json_null d) ()
429
+
| _ -> type_error d t)
430
+
| Bool map ->
431
+
(match d.u with
432
+
| 0x0066 (* f *) -> map.dec (read_json_false d) false
433
+
| 0x0074 (* t *) -> map.dec (read_json_true d) true
434
+
| _ -> type_error d t)
435
+
| Number map ->
436
+
(match d.u with
437
+
| u when is_number_start u ->
438
+
let meta = read_json_number d in
439
+
map.dec meta (token_pop_float d ~meta)
440
+
| 0x006E (* n *) -> map.dec (read_json_null d) Float.nan
441
+
| _ -> type_error d t)
442
+
| String map ->
443
+
(match d.u with
444
+
| 0x0022 (* DQUOTE *) ->
445
+
let meta = read_json_string d in
446
+
map.dec meta (token_pop d)
447
+
| _ -> type_error d t)
448
+
| Array map ->
449
+
(match d.u with
450
+
| 0x005B (* [ *) -> decode_array d map
451
+
| _ -> type_error d t)
452
+
| Object map ->
453
+
(match d.u with
454
+
| 0x007B (* { *) -> decode_object d map
455
+
| _ -> type_error d t)
456
+
| Map map -> map.dec (decode d map.dom)
457
+
| Any map -> decode_any d t map
458
+
| Rec t -> decode d (Lazy.force t)
459
+
460
+
and decode_array : type a elt b. decoder -> (a, elt, b) array_map -> a =
461
+
fun d map ->
462
+
let ws_before = ws_pop d in
463
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
464
+
let b, len = match (nextc d; read_ws d; d.u) with
465
+
| 0x005D (* ] *) -> map.dec_empty (), 0
466
+
| _ ->
467
+
let b = ref (map.dec_empty ()) in
468
+
let i = ref 0 in
469
+
let next = ref true in
470
+
try
471
+
while !next do
472
+
begin
473
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
474
+
try
475
+
if map.dec_skip !i !b
476
+
then (decode d (of_t Jsont.ignore))
477
+
else (b := map.dec_add !i (decode d map.elt) !b)
478
+
with
479
+
| Jsont.Error e ->
480
+
let imeta = error_meta_to_current ~first_byte ~first_line d in
481
+
Jsont.Repr.error_push_array (error_meta d) map (!i, imeta) e
482
+
end;
483
+
incr i;
484
+
match (read_ws d; d.u) with
485
+
| 0x005D (* ] *) -> next := false
486
+
| 0x002C (* , *) -> nextc d; read_ws d
487
+
| u when u = eot -> err_unclosed_array d
488
+
| fnd -> err_exp_comma_or_eoa d ~fnd
489
+
done;
490
+
!b, !i
491
+
with
492
+
| Jsont.Error e -> Jsont.Error.adjust_context ~first_byte ~first_line e
493
+
in
494
+
let textloc = textloc_to_current d ~first_byte ~first_line in
495
+
let ws_after = nextc d; read_ws d; ws_pop d in
496
+
let meta = meta_make d ~ws_before ~ws_after textloc in
497
+
map.dec_finish meta len b
498
+
499
+
and decode_object : type a. decoder -> (a, a) object_map -> a =
500
+
fun d map ->
501
+
let ws_before = ws_pop d in
502
+
let first_byte = get_last_byte d and first_line = get_line_pos d in
503
+
let dict =
504
+
try
505
+
nextc d; read_ws d;
506
+
decode_object_map
507
+
d map (Unknown_mems None) String_map.empty String_map.empty []
508
+
Dict.empty
509
+
with
510
+
| Jsont.Error (ctx, meta, k) when Jsont.Error.Context.is_empty ctx ->
511
+
let meta =
512
+
(* This is for when Jsont.Repr.finish_object_decode raises. *)
513
+
if Jsont.Textloc.is_none (Jsont.Meta.textloc meta)
514
+
then error_meta_to_current d ~first_byte ~first_line
515
+
else meta
516
+
in
517
+
Jsont.Error.raise ctx meta k
518
+
| Jsont.Error e -> Jsont.Error.adjust_context ~first_byte ~first_line e
519
+
in
520
+
let textloc = textloc_to_current d ~first_byte ~first_line in
521
+
let ws_after = nextc d; read_ws d; ws_pop d in
522
+
let meta = meta_make d ~ws_before ~ws_after textloc in
523
+
let dict = Dict.add Jsont.Repr.object_meta_arg meta dict in
524
+
Jsont.Repr.apply_dict map.dec dict
525
+
526
+
and decode_object_delayed : type o.
527
+
decoder -> (o, o) object_map -> mem_dec String_map.t ->
528
+
mem_dec String_map.t -> Jsont.object' -> Dict.t ->
529
+
mem_dec String_map.t * Jsont.object' * Dict.t
530
+
=
531
+
fun d map mem_miss mem_decs delay dict ->
532
+
let rec loop d map mem_miss mem_decs rem_delay dict = function
533
+
| [] -> mem_miss, rem_delay, dict
534
+
| ((name, meta as nm), v as mem) :: delay ->
535
+
match String_map.find_opt name mem_decs with
536
+
| None -> loop d map mem_miss mem_decs (mem :: rem_delay) dict delay
537
+
| Some (Mem_dec m) ->
538
+
let dict =
539
+
try
540
+
let t = Jsont.Repr.unsafe_to_t m.type' in
541
+
let v = match Jsont.Json.decode' t v with
542
+
| Ok v -> v
543
+
| Error e -> raise_notrace (Jsont.Error e)
544
+
in
545
+
Dict.add m.id v dict
546
+
with
547
+
| Jsont.Error e ->
548
+
Jsont.Repr.error_push_object (error_meta d) map nm e
549
+
in
550
+
let mem_miss = String_map.remove name mem_miss in
551
+
loop d map mem_miss mem_decs rem_delay dict delay
552
+
in
553
+
loop d map mem_miss mem_decs [] dict delay
554
+
555
+
and decode_object_map : type o.
556
+
decoder -> (o, o) object_map -> unknown_mems_option ->
557
+
mem_dec String_map.t -> mem_dec String_map.t -> Jsont.object' -> Dict.t ->
558
+
Dict.t
559
+
=
560
+
fun d map umems mem_miss mem_decs delay dict ->
561
+
let u n _ _ = assert false in
562
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
563
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
564
+
match map.shape with
565
+
| Object_cases (umems', cases) ->
566
+
let umems' = Unknown_mems umems' in
567
+
let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in
568
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
569
+
| Object_basic umems' ->
570
+
let mem_miss, delay, dict =
571
+
decode_object_delayed d map mem_miss mem_decs delay dict
572
+
in
573
+
let umems' = Unknown_mems (Some umems') in
574
+
let umems,dict = Jsont.Repr.override_unknown_mems ~by:umems umems' dict in
575
+
match umems with
576
+
| Unknown_mems (Some Unknown_skip | None) ->
577
+
decode_object_basic d map Unknown_skip () mem_miss mem_decs dict
578
+
| Unknown_mems (Some (Unknown_error as u)) ->
579
+
if delay = []
580
+
then decode_object_basic d map u () mem_miss mem_decs dict else
581
+
let fnd = List.map fst delay in
582
+
Jsont.Repr.unexpected_mems_error (error_meta d) map ~fnd
583
+
| Unknown_mems (Some (Unknown_keep (umap, _) as u)) ->
584
+
let add_delay umems ((n, meta as nm), v) =
585
+
try
586
+
let t = Jsont.Repr.unsafe_to_t umap.mems_type in
587
+
let v = match Jsont.Json.decode' t v with
588
+
| Ok v -> v
589
+
| Error e -> raise_notrace (Jsont.Error e)
590
+
in
591
+
umap.dec_add meta n v umems
592
+
with
593
+
| Jsont.Error e ->
594
+
Jsont.Repr.error_push_object (error_meta d) map nm e
595
+
in
596
+
let umems = List.fold_left add_delay (umap.dec_empty ()) delay in
597
+
decode_object_basic d map u umems mem_miss mem_decs dict
598
+
599
+
and decode_object_basic : type o p mems builder.
600
+
decoder -> (o, o) object_map -> (p, mems, builder) unknown_mems -> builder ->
601
+
mem_dec String_map.t -> mem_dec String_map.t -> Dict.t -> Dict.t
602
+
=
603
+
fun d map u umap mem_miss mem_decs dict -> match d.u with
604
+
| 0x007D (* } *) ->
605
+
let meta = d.meta_none (* we add a correct one in decode_object *) in
606
+
Jsont.Repr.finish_object_decode map meta u umap mem_miss dict
607
+
| 0x0022 ->
608
+
let meta = read_json_name d in
609
+
let name = token_pop d in
610
+
begin match String_map.find_opt name mem_decs with
611
+
| Some (Mem_dec mem) ->
612
+
let mem_miss = String_map.remove name mem_miss in
613
+
let dict = try Dict.add mem.id (decode d mem.type') dict with
614
+
| Jsont.Error e ->
615
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
616
+
in
617
+
read_json_mem_sep d;
618
+
decode_object_basic d map u umap mem_miss mem_decs dict
619
+
| None ->
620
+
match u with
621
+
| Unknown_skip ->
622
+
let () = try decode d (Jsont.Repr.of_t Jsont.ignore) with
623
+
| Jsont.Error e ->
624
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
625
+
in
626
+
read_json_mem_sep d;
627
+
decode_object_basic d map u umap mem_miss mem_decs dict
628
+
| Unknown_error ->
629
+
let fnd = [name, meta] in
630
+
Jsont.Repr.unexpected_mems_error (error_meta d) map ~fnd
631
+
| Unknown_keep (umap', _) ->
632
+
let umap =
633
+
try umap'.dec_add meta name (decode d umap'.mems_type) umap with
634
+
| Jsont.Error e ->
635
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
636
+
in
637
+
read_json_mem_sep d;
638
+
decode_object_basic d map u umap mem_miss mem_decs dict
639
+
end
640
+
| u when u = eot -> err_unclosed_object d map
641
+
| fnd -> err_exp_mem_or_eoo d
642
+
643
+
and decode_object_case : type o cases tag.
644
+
decoder -> (o, o) object_map -> unknown_mems_option ->
645
+
(o, cases, tag) object_cases -> mem_dec String_map.t ->
646
+
mem_dec String_map.t -> Jsont.object' -> Dict.t -> Dict.t
647
+
=
648
+
fun d map umems cases mem_miss mem_decs delay dict ->
649
+
let decode_case_tag ~sep map umems cases mem_miss mem_decs nmeta tag delay =
650
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
651
+
match List.find_opt eq_tag cases.cases with
652
+
| None ->
653
+
(try Jsont.Repr.unexpected_case_tag_error (error_meta d) map cases tag
654
+
with Jsont.Error e ->
655
+
Jsont.Repr.error_push_object
656
+
(error_meta d) map (cases.tag.name, nmeta) e)
657
+
| Some (Case case) ->
658
+
if sep then read_json_mem_sep d;
659
+
let dict =
660
+
decode_object_map d case.object_map umems mem_miss mem_decs delay dict
661
+
in
662
+
Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
663
+
in
664
+
match d.u with
665
+
| 0x007D (* } *) ->
666
+
(match cases.tag.dec_absent with
667
+
| Some tag ->
668
+
decode_case_tag ~sep:false map umems cases mem_miss mem_decs
669
+
d.meta_none tag delay
670
+
| None ->
671
+
let fnd = (List.map (fun ((n, _), _) -> n) delay) in
672
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
673
+
Jsont.Repr.missing_mems_error (error_meta d) map ~exp ~fnd)
674
+
| 0x0022 ->
675
+
let meta = read_json_name d in
676
+
let name = token_pop d in
677
+
if String.equal name cases.tag.name then
678
+
let tag = try decode d cases.tag.type' with
679
+
| Jsont.Error e ->
680
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
681
+
in
682
+
decode_case_tag
683
+
~sep:true map umems cases mem_miss mem_decs meta tag delay
684
+
else
685
+
begin match String_map.find_opt name mem_decs with
686
+
| Some (Mem_dec mem) ->
687
+
let mem_miss = String_map.remove name mem_miss in
688
+
let dict = try Dict.add mem.id (decode d mem.type') dict with
689
+
| Jsont.Error e ->
690
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
691
+
in
692
+
read_json_mem_sep d;
693
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
694
+
| None ->
695
+
(* Because JSON can be out of order we don't know how to decode
696
+
this yet. Generic decode *)
697
+
let v = try decode d (Jsont.Repr.of_t Jsont.json) with
698
+
| Jsont.Error e ->
699
+
Jsont.Repr.error_push_object (error_meta d) map (name, meta) e
700
+
in
701
+
let delay = ((name, meta), v) :: delay in
702
+
read_json_mem_sep d;
703
+
decode_object_case d map umems cases mem_miss mem_decs delay dict
704
+
end
705
+
| u when u = eot -> err_unclosed_object d map
706
+
| fnd -> err_exp_mem_or_eoo d
707
+
708
+
and decode_any : type a. decoder -> a t -> a any_map -> a =
709
+
fun d t map ->
710
+
let case d t map = match map with
711
+
| None -> type_error d t | Some t -> decode d t
712
+
in
713
+
match d.u with
714
+
| 0x006E (* n *) -> case d t map.dec_null
715
+
| 0x0066 (* f *)
716
+
| 0x0074 (* t *) -> case d t map.dec_bool
717
+
| 0x0022 (* DQUOTE *) -> case d t map.dec_string
718
+
| 0x005B (* [ *) -> case d t map.dec_array
719
+
| 0x007B (* { *) -> case d t map.dec_object
720
+
| u when is_number_start u -> case d t map.dec_number
721
+
| _ -> err_not_json_value d
722
+
723
+
let decode' ?layout ?locs ?file t reader =
724
+
try
725
+
let d = make_decoder ?layout ?locs ?file reader in
726
+
let v = (nextc d; decode d (Jsont.Repr.of_t t)) in
727
+
if d.u <> eot then err_exp_eot d else Ok v
728
+
with Jsont.Error e -> Error e
729
+
730
+
let decode ?layout ?locs ?file t reader =
731
+
Result.map_error Jsont.Error.to_string (decode' ?layout ?locs ?file t reader)
732
+
733
+
let decode_string' ?layout ?locs ?file t s =
734
+
decode' ?layout ?locs ?file t (Bytes.Reader.of_string s)
735
+
736
+
let decode_string ?layout ?locs ?file t s =
737
+
decode ?layout ?locs ?file t (Bytes.Reader.of_string s)
738
+
739
+
(* Encoding *)
740
+
741
+
type encoder =
742
+
{ writer : Bytes.Writer.t; (* Destination of bytes. *)
743
+
o : Bytes.t; (* Buffer for slices. *)
744
+
o_max : int; (* Max index in [o]. *)
745
+
mutable o_next : int; (* Next writable index in [o]. *)
746
+
format : Jsont.format;
747
+
number_format : string; }
748
+
749
+
let make_encoder
750
+
?buf ?(format = Jsont.Minify) ?(number_format = Jsont.default_number_format)
751
+
writer
752
+
=
753
+
let o = match buf with
754
+
| Some buf -> buf
755
+
| None -> Bytes.create (Bytes.Writer.slice_length writer)
756
+
in
757
+
let len = Bytes.length o in
758
+
let number_format = string_of_format number_format in
759
+
let o_max = len - 1 and o_next = 0 in
760
+
{ writer; o; o_max; o_next; format; number_format }
761
+
762
+
let[@inline] rem_len e = e.o_max - e.o_next + 1
763
+
764
+
let flush e =
765
+
Bytes.Writer.write e.writer (Bytes.Slice.make e.o ~first:0 ~length:e.o_next);
766
+
e.o_next <- 0
767
+
768
+
let write_eot ~eod e = flush e; if eod then Bytes.Writer.write_eod e.writer
769
+
let write_char e c =
770
+
if e.o_next > e.o_max then flush e;
771
+
Stdlib.Bytes.set e.o e.o_next c; e.o_next <- e.o_next + 1
772
+
773
+
let rec write_substring e s first length =
774
+
if length = 0 then () else
775
+
let len = Int.min (rem_len e) length in
776
+
if len = 0 then (flush e; write_substring e s first length) else
777
+
begin
778
+
Bytes.blit_string s first e.o e.o_next len;
779
+
e.o_next <- e.o_next + len;
780
+
write_substring e s (first + len) (length - len)
781
+
end
782
+
783
+
let write_bytes e s = write_substring e s 0 (String.length s)
784
+
let write_sep e = write_char e ','
785
+
let write_indent e ~nest =
786
+
for i = 1 to nest do write_char e ' '; write_char e ' ' done
787
+
788
+
let write_ws_before e m = write_bytes e (Jsont.Meta.ws_before m)
789
+
let write_ws_after e m = write_bytes e (Jsont.Meta.ws_after m)
790
+
let write_json_null e = write_bytes e "null"
791
+
let write_json_bool e b = write_bytes e (if b then "true" else "false")
792
+
793
+
(* XXX we bypass the printf machinery as it costs quite quite a bit.
794
+
Would be even better if we could format directly to a bytes values
795
+
rather than allocating a string per number. *)
796
+
external format_float : string -> float -> string = "caml_format_float"
797
+
let write_json_number e f =
798
+
if Float.is_finite f
799
+
then write_bytes e (format_float e.number_format f)
800
+
else write_json_null e
801
+
802
+
let write_json_string e s =
803
+
let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in
804
+
let len = String.length s in
805
+
let flush e start i max =
806
+
if start <= max then write_substring e s start (i - start);
807
+
in
808
+
let rec loop start i max =
809
+
if i > max then flush e start i max else
810
+
let next = i + 1 in
811
+
match String.get s i with
812
+
| '\"' -> flush e start i max; write_bytes e "\\\""; loop next next max
813
+
| '\\' -> flush e start i max; write_bytes e "\\\\"; loop next next max
814
+
| '\n' -> flush e start i max; write_bytes e "\\n"; loop next next max
815
+
| '\r' -> flush e start i max; write_bytes e "\\r"; loop next next max
816
+
| '\t' -> flush e start i max; write_bytes e "\\t"; loop next next max
817
+
| c when is_control c ->
818
+
flush e start i max;
819
+
write_bytes e "\\u";
820
+
write_bytes e (Printf.sprintf "%04X" (Char.code c));
821
+
loop next next max
822
+
| c -> loop start next max
823
+
in
824
+
write_char e '"'; loop 0 0 (len - 1); write_char e '"'
825
+
826
+
let encode_null (map : ('a, 'b) Jsont.Repr.base_map) e v =
827
+
let () = map.enc v in
828
+
match e.format with
829
+
| Jsont.Minify | Jsont.Indent -> write_json_null e
830
+
| Jsont.Layout ->
831
+
let meta = map.enc_meta v in
832
+
write_ws_before e meta;
833
+
write_json_null e;
834
+
write_ws_after e meta
835
+
836
+
let encode_bool (map : ('a, 'b) Jsont.Repr.base_map) e v =
837
+
let b = map.enc v in
838
+
match e.format with
839
+
| Jsont.Minify | Jsont.Indent -> write_json_bool e b
840
+
| Jsont.Layout ->
841
+
let meta = map.enc_meta v in
842
+
write_ws_before e meta;
843
+
write_json_bool e b;
844
+
write_ws_after e meta
845
+
846
+
let encode_number (map : ('a, 'b) Jsont.Repr.base_map) e v =
847
+
let n = map.enc v in
848
+
match e.format with
849
+
| Jsont.Minify | Jsont.Indent -> write_json_number e n
850
+
| Jsont.Layout ->
851
+
let meta = map.enc_meta v in
852
+
write_ws_before e meta;
853
+
write_json_number e n;
854
+
write_ws_after e meta
855
+
856
+
let encode_string (map : ('a, 'b) Jsont.Repr.base_map) e v =
857
+
let s = map.enc v in
858
+
match e.format with
859
+
| Jsont.Minify | Jsont.Indent -> write_json_string e s
860
+
| Jsont.Layout ->
861
+
let meta = map.enc_meta v in
862
+
write_ws_before e meta;
863
+
write_json_string e s;
864
+
write_ws_after e meta
865
+
866
+
let encode_mem_indent ~nest e = write_char e '\n'; write_indent e ~nest
867
+
let encode_mem_name e meta n = match e.format with
868
+
| Jsont.Minify -> write_json_string e n; write_char e ':'
869
+
| Jsont.Indent -> write_json_string e n; write_bytes e ": "
870
+
| Jsont.Layout ->
871
+
write_ws_before e meta;
872
+
write_json_string e n;
873
+
write_ws_after e meta;
874
+
write_char e ':'
875
+
876
+
let rec encode : type a. nest:int -> a Jsont.Repr.t -> encoder -> a -> unit =
877
+
fun ~nest t e v -> match t with
878
+
| Null map -> encode_null map e v
879
+
| Bool map -> encode_bool map e v
880
+
| Number map -> encode_number map e v
881
+
| String map -> encode_string map e v
882
+
| Array map -> encode_array ~nest map e v
883
+
| Object map -> encode_object ~nest map e v
884
+
| Any map -> encode ~nest (map.enc v) e v
885
+
| Map map -> encode ~nest map.dom e (map.enc v)
886
+
| Rec t -> encode ~nest (Lazy.force t) e v
887
+
888
+
and encode_array : type a elt b.
889
+
nest:int -> (a, elt, b) Jsont.Repr.array_map -> encoder -> a -> unit
890
+
=
891
+
fun ~nest map e v ->
892
+
let encode_element ~nest map e i v =
893
+
if i <> 0 then write_sep e;
894
+
try encode ~nest map.elt e v; e with
895
+
| Jsont.Error e ->
896
+
Jsont.Repr.error_push_array Jsont.Meta.none map (i, Jsont.Meta.none) e
897
+
in
898
+
match e.format with
899
+
| Jsont.Minify ->
900
+
write_char e '[';
901
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
902
+
write_char e ']'
903
+
| Jsont.Layout ->
904
+
let meta = map.enc_meta v in
905
+
write_ws_before e meta;
906
+
write_char e '[';
907
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
908
+
write_char e ']';
909
+
write_ws_after e meta
910
+
| Jsont.Indent ->
911
+
let encode_element ~nest map e i v =
912
+
if i <> 0 then write_sep e;
913
+
write_char e '\n';
914
+
write_indent e ~nest;
915
+
try encode ~nest map.elt e v; e with
916
+
| Jsont.Error e ->
917
+
Jsont.Repr.error_push_array
918
+
Jsont.Meta.none map (i, Jsont.Meta.none) e
919
+
in
920
+
let array_not_empty e =
921
+
e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[')
922
+
in
923
+
write_char e '[';
924
+
ignore (map.enc (encode_element ~nest:(nest + 1) map) e v);
925
+
if array_not_empty e then (write_char e '\n'; write_indent e ~nest);
926
+
write_char e ']'
927
+
928
+
and encode_object : type o enc.
929
+
nest:int -> (o, o) Jsont.Repr.object_map -> encoder -> o -> unit
930
+
=
931
+
fun ~nest map e o -> match e.format with
932
+
| Jsont.Minify ->
933
+
write_char e '{';
934
+
ignore @@
935
+
encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o;
936
+
write_char e '}';
937
+
| Jsont.Layout ->
938
+
let meta = map.enc_meta o in
939
+
write_ws_before e meta;
940
+
write_char e '{';
941
+
ignore @@
942
+
encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o;
943
+
write_char e '}';
944
+
write_ws_after e meta;
945
+
| Jsont.Indent ->
946
+
write_char e '{';
947
+
let start =
948
+
encode_object_map ~nest:(nest + 1) map ~do_unknown:true e ~start:true o
949
+
in
950
+
if not start then (write_char e '\n'; write_indent e ~nest);
951
+
write_char e '}'
952
+
953
+
and encode_object_map : type o enc.
954
+
nest:int -> (o, o) Jsont.Repr.object_map -> do_unknown:bool -> encoder ->
955
+
start:bool -> o -> bool
956
+
=
957
+
fun ~nest map ~do_unknown e ~start o ->
958
+
let encode_mem ~nest map e o start (Mem_enc mmap) =
959
+
try
960
+
let v = mmap.enc o in
961
+
if mmap.enc_omit v then start else
962
+
begin
963
+
if not start then write_char e ',';
964
+
if e.format = Jsont.Indent then encode_mem_indent ~nest e;
965
+
let meta =
966
+
(* if e.format = Jsont.Layout then mmap.enc_name_meta v else *)
967
+
Jsont.Meta.none
968
+
in
969
+
encode_mem_name e meta mmap.name;
970
+
encode ~nest mmap.type' e v;
971
+
false
972
+
end
973
+
with
974
+
| Jsont.Error e ->
975
+
Jsont.Repr.error_push_object Jsont.Meta.none map
976
+
(mmap.name, Jsont.Meta.none) e
977
+
in
978
+
match map.shape with
979
+
| Object_basic u ->
980
+
let start =
981
+
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
982
+
in
983
+
begin match u with
984
+
| Unknown_keep (umap, enc) when do_unknown ->
985
+
encode_unknown_mems ~nest map umap e ~start (enc o)
986
+
| _ -> start
987
+
end
988
+
| Object_cases (umap, cases) ->
989
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
990
+
let start =
991
+
if cases.tag.enc_omit case.tag
992
+
then start
993
+
else encode_mem ~nest map e case.tag start (Mem_enc cases.tag)
994
+
in
995
+
let start =
996
+
List.fold_left (encode_mem ~nest map e o) start map.mem_encs
997
+
in
998
+
match umap with
999
+
| Some (Unknown_keep (umap, enc)) ->
1000
+
let start =
1001
+
encode_object_map ~nest case.object_map ~do_unknown:false e ~start c
1002
+
in
1003
+
encode_unknown_mems ~nest map umap e ~start (enc o)
1004
+
| _ ->
1005
+
encode_object_map ~nest case.object_map ~do_unknown e ~start c
1006
+
1007
+
and encode_unknown_mems : type o dec mems a builder.
1008
+
nest:int -> (o,o) object_map -> (mems, a, builder) mems_map ->
1009
+
encoder -> start:bool -> mems -> bool
1010
+
=
1011
+
fun ~nest map umap e ~start mems ->
1012
+
let encode_unknown_mem ~nest map umap e meta n v start =
1013
+
try
1014
+
if not start then write_char e ',';
1015
+
if e.format = Jsont.Indent then encode_mem_indent ~nest e;
1016
+
encode_mem_name e meta n;
1017
+
encode ~nest umap.mems_type e v; false
1018
+
with
1019
+
| Jsont.Error e ->
1020
+
Jsont.Repr.error_push_object Jsont.Meta.none map (n, Jsont.Meta.none) e
1021
+
in
1022
+
umap.enc (encode_unknown_mem ~nest map umap e) mems start
1023
+
1024
+
let encode' ?buf ?format ?number_format t v ~eod w =
1025
+
let e = make_encoder ?buf ?format ?number_format w in
1026
+
let t = Jsont.Repr.of_t t in
1027
+
try Ok (encode ~nest:0 t e v; write_eot ~eod e) with
1028
+
| Jsont.Error e -> Error e
1029
+
1030
+
let encode ?buf ?format ?number_format t v ~eod w =
1031
+
Result.map_error Jsont.Error.to_string @@
1032
+
encode' ?buf ?format ?number_format ~eod t v w
1033
+
1034
+
let encode_string' ?buf ?format ?number_format t v =
1035
+
let b = Buffer.create 255 in
1036
+
let w = Bytes.Writer.of_buffer b in
1037
+
match encode' ?buf ?format ?number_format ~eod:true t v w with
1038
+
| Ok () -> Ok (Buffer.contents b) | Error _ as e -> e
1039
+
1040
+
let encode_string ?buf ?format ?number_format t v =
1041
+
Result.map_error Jsont.Error.to_string @@
1042
+
encode_string' ?buf ?format ?number_format t v
1043
+
1044
+
(* Recode *)
1045
+
1046
+
let unsurprising_defaults layout format = match layout, format with
1047
+
| Some true, None -> Some true, Some Jsont.Layout
1048
+
| None, (Some Jsont.Layout as l) -> Some true, l
1049
+
| l, f -> l, f
1050
+
1051
+
let recode' ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1052
+
let layout, format = unsurprising_defaults layout format in
1053
+
match decode' ?layout ?locs ?file t r with
1054
+
| Error _ as e -> e
1055
+
| Ok v -> encode' ?buf ?format ?number_format t v ~eod w
1056
+
1057
+
let recode ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod =
1058
+
Result.map_error Jsont.Error.to_string @@
1059
+
recode' ?layout ?locs ?file ?buf ?format ?number_format t r w ~eod
1060
+
1061
+
let recode_string' ?layout ?locs ?file ?buf ?format ?number_format t s =
1062
+
let layout, format = unsurprising_defaults layout format in
1063
+
match decode_string' ?layout ?locs ?file t s with
1064
+
| Error _ as e -> e
1065
+
| Ok v -> encode_string' ?buf ?format ?number_format t v
1066
+
1067
+
let recode_string ?layout ?locs ?file ?buf ?format ?number_format t s =
1068
+
Result.map_error Jsont.Error.to_string @@
1069
+
recode_string' ?layout ?locs ?file ?buf ?format ?number_format t s
+128
vendor/opam/jsont/src/bytesrw/jsont_bytesrw.mli
+128
vendor/opam/jsont/src/bytesrw/jsont_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
11
+
on {{!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
15
+
some error reports. *)
16
+
17
+
open Bytesrw
18
+
19
+
(** {1:decode Decode} *)
20
+
21
+
val decode :
22
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t ->
23
+
Bytes.Reader.t -> ('a, string) result
24
+
(** [decode t r] decodes a value from [r] according to [t].
25
+
{ul
26
+
{- If [layout] is [true] whitespace is preserved in {!Jsont.Meta.t}
27
+
values. Defaults to [false].}
28
+
{- If [locs] is [true] locations are preserved in {!Jsont.Meta.t}
29
+
values and error messages are precisely located. Defaults to [false].}
30
+
{- [file] is the file path from which [r] is assumed to read.
31
+
Defaults to {!Jsont.Textloc.file_none}}} *)
32
+
33
+
val decode' :
34
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t ->
35
+
Bytes.Reader.t -> ('a, Jsont.Error.t) result
36
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
37
+
38
+
val decode_string :
39
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t ->
40
+
string -> ('a, string) result
41
+
(** [decode_string] is like {!val-decode} but decodes directly from a string. *)
42
+
43
+
val decode_string' :
44
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> 'a Jsont.t ->
45
+
string -> ('a, Jsont.Error.t) result
46
+
(** [decode_string'] is like {!val-decode'} but decodes directly from a
47
+
string. *)
48
+
49
+
(** {1:encode Encode} *)
50
+
51
+
val encode :
52
+
?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format ->
53
+
'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, string) result
54
+
(** [encode t v w] encodes value [v] according to [t] on [w].
55
+
{ul
56
+
{- If [buf] is specified it is used as a buffer for the slices written
57
+
on [w]. Defaults to a buffer of length {!Bytes.Writer.slice_length}[ w].}
58
+
{- [format] specifies how the JSON should be formatted.
59
+
Defaults to {!Jsont.Minify}.}
60
+
{- [number_format] specifies the format string to format numbers. Defaults
61
+
to {!Jsont.default_number_format}.}
62
+
{- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should
63
+
be written on [w].}} *)
64
+
65
+
val encode' :
66
+
?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format ->
67
+
'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, Jsont.Error.t) result
68
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
69
+
70
+
val encode_string :
71
+
?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format ->
72
+
'a Jsont.t -> 'a -> (string, string) result
73
+
(** [encode_string] is like {!val-encode} but writes to a string. *)
74
+
75
+
val encode_string' :
76
+
?buf:Bytes.t -> ?format:Jsont.format -> ?number_format:Jsont.number_format ->
77
+
'a Jsont.t -> 'a -> (string, Jsont.Error.t) result
78
+
(** [encode_string'] is like {!val-encode'} but writes to a string. *)
79
+
80
+
(** {1:recode Recode}
81
+
82
+
The defaults in these functions are those of {!val-decode} and
83
+
{!val-encode}, except if [layout] is [true], [format] defaults to
84
+
[Jsont.Layout] and vice-versa. *)
85
+
86
+
val recode :
87
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t ->
88
+
?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t ->
89
+
Bytes.Reader.t -> Bytes.Writer.t -> eod:bool -> (unit, string) result
90
+
(** [recode] is {!val-decode} followed by {!val-recode}. *)
91
+
92
+
val recode' :
93
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t ->
94
+
?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t ->
95
+
Bytes.Reader.t -> Bytes.Writer.t -> eod:bool -> (unit, Jsont.Error.t) result
96
+
(** [recode'] is like {!val-recode} but preserves the error structure. *)
97
+
98
+
val recode_string :
99
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t ->
100
+
?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t ->
101
+
string -> (string, string) result
102
+
(** [recode] is {!decode_string} followed by {!recode_string}. *)
103
+
104
+
val recode_string' :
105
+
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath -> ?buf:Bytes.t ->
106
+
?format:Jsont.format -> ?number_format:Jsont.number_format -> 'a Jsont.t ->
107
+
string -> (string, Jsont.Error.t) result
108
+
(** [recode_string'] is like {!val-recode_string} but preserves the error
109
+
structure. *)
110
+
111
+
(** {1:layout Layout preservation}
112
+
113
+
In order to simplify the implementation not all layout is preserved.
114
+
In particular:
115
+
{ul
116
+
{- White space in empty arrays and objects is dropped.}
117
+
{- Unicode escapes are replaced by their UTF-8 encoding.}
118
+
{- The format of numbers is not preserved.}} *)
119
+
120
+
(** {1:duplicate Duplicate object members}
121
+
122
+
Duplicate object members are undefined behaviour in JSON. We
123
+
follow the behaviour of
124
+
{{:https://262.ecma-international.org/6.0/#sec-internalizejsonproperty}
125
+
[JSON.parse]} and the last one takes over, however duplicate
126
+
members all have to parse with the specified type as we error as soon
127
+
as possible. Also
128
+
{{!Jsont.Object.case_mem}case members} are not allowed to duplicate. *)
+1
vendor/opam/jsont/src/bytesrw/jsont_bytesrw.mllib
+1
vendor/opam/jsont/src/bytesrw/jsont_bytesrw.mllib
···
1
+
Jsont_bytesrw
+5
vendor/opam/jsont/src/dune
+5
vendor/opam/jsont/src/dune
+2058
vendor/opam/jsont/src/jsont.ml
+2058
vendor/opam/jsont/src/jsont.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Fmt = Jsont_base.Fmt
7
+
type 'a fmt = 'a Fmt.t
8
+
let pp_kind = Fmt.code
9
+
let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind
10
+
let pp_name = Fmt.code
11
+
let pp_int ppf i = Fmt.code ppf (Int.to_string i)
12
+
13
+
module Textloc = Jsont_base.Textloc
14
+
module Meta = Jsont_base.Meta
15
+
type 'a node = 'a * Meta.t
16
+
17
+
module Path = Jsont_base.Path
18
+
module Sort = Jsont_base.Sort
19
+
20
+
type error_kind = string
21
+
type context_index = string node * Path.index
22
+
type context = context_index list
23
+
type error = context * Meta.t * error_kind
24
+
exception Error of error
25
+
26
+
module Error = struct
27
+
28
+
(* Kinds of errors *)
29
+
30
+
type kind = error_kind
31
+
let kind_to_string k = k
32
+
33
+
(* Errors *)
34
+
35
+
module Context = struct
36
+
type index = context_index
37
+
type t = context
38
+
let empty = []
39
+
let is_empty ctx = ctx = []
40
+
let push_array kinded_sort n ctx = (kinded_sort, Path.Nth n) :: ctx
41
+
let push_object kinded_sort n ctx = (kinded_sort, Path.Mem n) :: ctx
42
+
let pp ppf ctx =
43
+
let pp_meta ppf meta =
44
+
if Meta.is_none meta then () else
45
+
Fmt.pf ppf "%a: " Textloc.pp (Meta.textloc meta)
46
+
in
47
+
let pp_el ppf (kind, index) = match index with
48
+
| Path.Nth (n, meta) ->
49
+
Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]"
50
+
pp_meta meta pp_int n
51
+
pp_meta (snd kind) pp_kind (fst kind)
52
+
| Path.Mem (name, meta) ->
53
+
Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]"
54
+
pp_meta meta pp_name name
55
+
pp_meta (snd kind) pp_kind (fst kind)
56
+
in
57
+
if ctx = [] then () else
58
+
Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx)
59
+
end
60
+
61
+
type t = error
62
+
63
+
let make_msg ctx meta msg = ctx, meta, msg
64
+
let raise ctx meta msg = raise_notrace (Error (ctx, meta, msg))
65
+
let msg meta msg = raise_notrace (Error (Context.empty, meta, msg))
66
+
let msgf meta fmt = Format.kasprintf (fun m -> msg meta m) fmt
67
+
let push_array kinded_sort n (ctx, meta, e) =
68
+
raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e))
69
+
70
+
let push_object kinded_sort n (ctx, meta, e) =
71
+
raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e))
72
+
73
+
let adjust_context ~first_byte ~first_line (ctx, meta, e) = match ctx with
74
+
| [] -> raise_notrace (Error (ctx, meta, e))
75
+
| ((sort, smeta), idx) :: is ->
76
+
let textloc = Meta.textloc smeta in
77
+
let textloc =
78
+
if Textloc.is_none textloc then textloc else
79
+
Textloc.set_first textloc ~first_byte ~first_line
80
+
in
81
+
let smeta = Meta.with_textloc smeta textloc in
82
+
let ctx = ((sort, smeta), idx) :: is in
83
+
raise_notrace (Error (ctx, meta, e))
84
+
85
+
let pp ppf (ctx, m, msg) =
86
+
let pp_meta ppf m =
87
+
if not (Meta.is_none m)
88
+
then Fmt.pf ppf "@,%a:" Textloc.pp (Meta.textloc m)
89
+
in
90
+
Fmt.pf ppf "@[<v>%a%a%a@]" Fmt.lines msg pp_meta m Context.pp ctx
91
+
92
+
let to_string e = Format.asprintf "%a" pp e
93
+
94
+
let puterr = Fmt.puterr
95
+
let disable_ansi_styler = Fmt.disable_ansi_styler
96
+
97
+
(* Predefined errors *)
98
+
99
+
let expected meta exp ~fnd =
100
+
msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd
101
+
102
+
let sort meta ~exp ~fnd =
103
+
msgf meta "Expected %a but found %a" Sort.pp exp Sort.pp fnd
104
+
105
+
let kinded_sort meta ~exp ~fnd =
106
+
msgf meta "Expected %a but found %a" Fmt.code exp Sort.pp fnd
107
+
108
+
let missing_mems meta ~kinded_sort ~exp ~fnd =
109
+
let pp_miss ppf m =
110
+
Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd)
111
+
in
112
+
match exp with
113
+
| [n] ->
114
+
msgf meta "@[<v>Missing member %a in %a%a@]"
115
+
Fmt.code n Fmt.code kinded_sort Fmt.similar_mems (n, fnd)
116
+
| exp ->
117
+
msgf meta "@[<v1>Missing members in %a:@,%a@]"
118
+
Fmt.code kinded_sort (Fmt.list pp_miss) exp
119
+
120
+
let unexpected_mems meta ~kinded_sort ~exp ~fnd =
121
+
let pp_unexp ppf m =
122
+
Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp)
123
+
in
124
+
match fnd with
125
+
| [(u, _)] ->
126
+
msgf meta "@[<v>Unexpected member %a for %a%a@]"
127
+
Fmt.code u Fmt.code kinded_sort Fmt.should_it_be_mem (u, exp)
128
+
| us ->
129
+
msgf meta "@[<v1>Unexpected members for %a:@,%a@]"
130
+
Fmt.code kinded_sort (Fmt.list pp_unexp) (List.map fst us)
131
+
132
+
let unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd =
133
+
let pp_kind ppf () =
134
+
Fmt.pf ppf "member %a value in %a" Fmt.code mem_name Fmt.code kinded_sort
135
+
in
136
+
msgf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp)
137
+
138
+
(* Numbers *)
139
+
140
+
let index_out_of_range meta ~n ~len =
141
+
msgf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1)
142
+
143
+
let number_range meta ~kind n =
144
+
msgf meta "Number %a not in %a range"
145
+
Fmt.code (Fmt.str "%a" Fmt.json_number n) Fmt.code kind
146
+
147
+
let parse_string_number meta ~kind s =
148
+
msgf meta "String %a does not parse to %a value"
149
+
Fmt.json_string s pp_kind kind
150
+
151
+
let integer_range meta ~kind n =
152
+
msgf meta "Integer %a not in %a range" pp_int n pp_kind kind
153
+
154
+
(* Maps *)
155
+
156
+
let no_decoder meta ~kind = msgf meta "No decoder for %a" pp_kind kind
157
+
let no_encoder meta ~kind = msgf meta "No encoder for %a" pp_kind kind
158
+
let decode_todo meta ~kind_opt:k = msgf meta "TODO: decode%a" pp_kind_opt k
159
+
let encode_todo meta ~kind_opt:k = msgf meta "TODO: encode%a" pp_kind_opt k
160
+
let for' meta ~kind e = msgf meta "%a: %s" pp_kind kind e
161
+
end
162
+
163
+
(* Types *)
164
+
165
+
module Repr = struct (* See the .mli for documentation *)
166
+
module String_map = Map.Make (String)
167
+
module Type = Jsont_base.Type
168
+
169
+
type ('ret, 'f) dec_fun =
170
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
171
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
172
+
173
+
type ('a, 'b) base_map =
174
+
{ kind : string;
175
+
doc : string;
176
+
dec : Meta.t -> 'a -> 'b;
177
+
enc : 'b -> 'a;
178
+
enc_meta : 'b -> Meta.t; }
179
+
180
+
type 'a t =
181
+
| Null : (unit, 'a) base_map -> 'a t
182
+
| Bool : (bool, 'a) base_map -> 'a t
183
+
| Number : (float, 'a) base_map -> 'a t
184
+
| String : (string, 'a) base_map -> 'a t
185
+
| Array : ('a, 'elt, 'builder) array_map -> 'a t
186
+
| Object : ('o, 'o) object_map -> 'o t
187
+
| Any : 'a any_map -> 'a t
188
+
| Map : ('a, 'b) map -> 'b t
189
+
| Rec : 'a t Lazy.t -> 'a t
190
+
191
+
and ('array, 'elt, 'builder) array_map =
192
+
{ kind : string;
193
+
doc : string;
194
+
elt : 'elt t;
195
+
dec_empty : unit -> 'builder;
196
+
dec_skip : int -> 'builder -> bool;
197
+
dec_add : int -> 'elt -> 'builder -> 'builder;
198
+
dec_finish : Meta.t -> int -> 'builder -> 'array;
199
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
200
+
enc_meta : 'array -> Meta.t; }
201
+
202
+
and ('o, 'dec) object_map =
203
+
{ kind : string;
204
+
doc : string;
205
+
dec : ('o, 'dec) dec_fun;
206
+
mem_decs : mem_dec String_map.t;
207
+
mem_encs : 'o mem_enc list;
208
+
enc_meta : 'o -> Meta.t;
209
+
shape : 'o object_shape; }
210
+
211
+
and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec
212
+
and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
213
+
and ('o, 'a) mem_map =
214
+
{ name : string;
215
+
doc : string;
216
+
type' : 'a t;
217
+
id : 'a Type.Id.t;
218
+
dec_absent : 'a option;
219
+
enc : 'o -> 'a;
220
+
(* enc_name_meta : 'a -> Meta.t; See comment in .mli *)
221
+
enc_omit : 'a -> bool; }
222
+
223
+
and 'o object_shape =
224
+
| Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape
225
+
| Object_cases :
226
+
('o, 'mems, 'builder) unknown_mems option *
227
+
('o, 'cases, 'tag) object_cases -> 'o object_shape
228
+
229
+
and ('o, 'mems, 'builder) unknown_mems =
230
+
| Unknown_skip : ('o, unit, unit) unknown_mems
231
+
| Unknown_error : ('o, unit, unit) unknown_mems
232
+
| Unknown_keep :
233
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems) ->
234
+
('o, 'mems, 'builder) unknown_mems
235
+
236
+
and ('mems, 'a, 'builder) mems_map =
237
+
{ kind : string;
238
+
doc : string;
239
+
mems_type : 'a t;
240
+
id : 'mems Type.Id.t;
241
+
dec_empty : unit -> 'builder;
242
+
dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder;
243
+
dec_finish : Meta.t -> 'builder -> 'mems;
244
+
enc :
245
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc }
246
+
247
+
and ('o, 'cases, 'tag) object_cases =
248
+
{ tag : ('tag, 'tag) mem_map;
249
+
tag_compare : 'tag -> 'tag -> int;
250
+
tag_to_string : ('tag -> string) option;
251
+
id : 'cases Type.Id.t;
252
+
cases : ('cases, 'tag) case list;
253
+
enc : 'o -> 'cases;
254
+
enc_case : 'cases -> ('cases, 'tag) case_value; }
255
+
256
+
and ('cases, 'case, 'tag) case_map =
257
+
{ tag : 'tag;
258
+
object_map : ('case, 'case) object_map;
259
+
dec : 'case -> 'cases; }
260
+
261
+
and ('cases, 'tag) case_value =
262
+
| Case_value :
263
+
('cases, 'case, 'tag) case_map * 'case -> ('cases, 'tag) case_value
264
+
265
+
and ('cases, 'tag) case =
266
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
267
+
268
+
and 'a any_map =
269
+
{ kind : string;
270
+
doc : string;
271
+
dec_null : 'a t option;
272
+
dec_bool : 'a t option;
273
+
dec_number : 'a t option;
274
+
dec_string : 'a t option;
275
+
dec_array : 'a t option;
276
+
dec_object : 'a t option;
277
+
enc : 'a -> 'a t; }
278
+
279
+
and ('a, 'b) map =
280
+
{ kind : string;
281
+
doc : string;
282
+
dom : 'a t;
283
+
dec : 'a -> 'b;
284
+
enc : 'b -> 'a; }
285
+
286
+
(* Convert *)
287
+
288
+
let of_t = Fun.id
289
+
let unsafe_to_t = Fun.id
290
+
291
+
(* Kinds and doc *)
292
+
293
+
let base_map_with_doc ?kind ?doc (map : ('a, 'b) base_map) =
294
+
let kind = Option.value ~default:map.kind doc in
295
+
let doc = Option.value ~default:map.doc doc in
296
+
{ map with kind; doc }
297
+
298
+
let array_map_with_doc ?kind ?doc (map : ('a, 'b, 'c) array_map) =
299
+
let kind = Option.value ~default:map.kind doc in
300
+
let doc = Option.value ~default:map.doc doc in
301
+
{ map with kind; doc }
302
+
303
+
let object_map_with_doc ?kind ?doc (map : ('o, 'o) object_map) =
304
+
let kind = Option.value ~default:map.kind doc in
305
+
let doc = Option.value ~default:map.doc doc in
306
+
{ map with kind; doc }
307
+
308
+
let any_map_with_doc ?kind ?doc (map : 'a any_map) =
309
+
let kind = Option.value ~default:map.kind doc in
310
+
let doc = Option.value ~default:map.doc doc in
311
+
{ map with kind; doc }
312
+
313
+
let map_with_doc ?kind ?doc (map : ('a, 'b) 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 rec with_doc ?kind ?doc = function
319
+
| Null map -> Null (base_map_with_doc ?kind ?doc map)
320
+
| Bool map -> Bool (base_map_with_doc ?kind ?doc map)
321
+
| Number map -> Number (base_map_with_doc ?kind ?doc map)
322
+
| String map -> String (base_map_with_doc ?kind ?doc map)
323
+
| Array map -> Array (array_map_with_doc ?kind ?doc map)
324
+
| Object map -> Object (object_map_with_doc ?kind ?doc map)
325
+
| Any map -> Any (any_map_with_doc ?kind ?doc map)
326
+
| Map map -> Map (map_with_doc ?kind ?doc map)
327
+
| Rec l -> with_doc ?kind ?doc (Lazy.force l)
328
+
329
+
let object_map_kinded_sort (map : ('o, 'dec) object_map) =
330
+
Sort.kinded ~kind:map.kind Object
331
+
332
+
let rec kinded_sort : type a. a t -> string = function
333
+
| Null map -> Sort.kinded ~kind:map.kind Null
334
+
| Bool map -> Sort.kinded ~kind:map.kind Bool
335
+
| Number map -> Sort.kinded ~kind:map.kind Number
336
+
| String map -> Sort.kinded ~kind:map.kind String
337
+
| Array map -> array_map_kinded_sort map
338
+
| Object map -> object_map_kinded_sort map
339
+
| Any map -> if map.kind = "" then any_map_kinded_sort map else map.kind
340
+
| Map map -> if map.kind = "" then kinded_sort map.dom else map.kind
341
+
| Rec l -> kinded_sort (Lazy.force l)
342
+
343
+
and array_map_kinded_sort : type a e b. (a, e, b) array_map -> string =
344
+
fun map ->
345
+
if map.kind <> "" then Sort.kinded ~kind:map.kind Array else
346
+
let elt = kinded_sort map.elt in
347
+
String.concat "" ["array<"; elt; ">"]
348
+
349
+
and any_map_kinded_sort : type a. a any_map -> string = fun map ->
350
+
let add_case ks sort = function
351
+
| None -> ks
352
+
| Some k ->
353
+
(if map.kind <> "" then kinded_sort k else
354
+
Sort.kinded ~kind:map.kind sort)
355
+
:: ks
356
+
in
357
+
let ks = add_case [] Object map.dec_object in
358
+
let ks = add_case ks Array map.dec_array in
359
+
let ks = add_case ks String map.dec_string in
360
+
let ks = add_case ks Number map.dec_number in
361
+
let ks = add_case ks Bool map.dec_bool in
362
+
let ks = add_case ks Null map.dec_null in
363
+
"one of " ^ String.concat ", " ks
364
+
365
+
let rec kind : type a. a t -> string = function
366
+
| Null map -> Sort.or_kind ~kind:map.kind Null
367
+
| Bool map -> Sort.or_kind ~kind:map.kind Bool
368
+
| Number map -> Sort.or_kind ~kind:map.kind Number
369
+
| String map -> Sort.or_kind ~kind:map.kind String
370
+
| Array map -> Sort.or_kind ~kind:map.kind Array
371
+
| Object map -> Sort.or_kind ~kind:map.kind Object
372
+
| Any map -> if map.kind <> "" then map.kind else "any"
373
+
| Map map -> if map.kind <> "" then map.kind else kind map.dom
374
+
| Rec l -> kind (Lazy.force l)
375
+
376
+
let rec doc : type a. a t -> string = function
377
+
| Null map -> map.doc | Bool map -> map.doc | Number map -> map.doc
378
+
| String map -> map.doc | Array map -> map.doc | Object map -> map.doc
379
+
| Any map -> map.doc | Map map -> map.doc | Rec l -> doc (Lazy.force l)
380
+
381
+
(* Errors *)
382
+
383
+
let pp_code = Fmt.code
384
+
let pp_kind = pp_kind
385
+
386
+
let error_push_object meta map name e =
387
+
Error.push_object ((object_map_kinded_sort map), meta) name e
388
+
389
+
let error_push_array meta map i e =
390
+
Error.push_array ((array_map_kinded_sort map), meta) i e
391
+
392
+
let type_error meta t ~fnd =
393
+
Error.kinded_sort meta ~exp:(kinded_sort t) ~fnd
394
+
395
+
let missing_mems_error meta (object_map : ('o, 'o) object_map) ~exp ~fnd =
396
+
let kinded_sort = object_map_kinded_sort object_map in
397
+
let exp =
398
+
let add n (Mem_dec m) acc = match m.dec_absent with
399
+
| None -> n :: acc | Some _ -> acc
400
+
in
401
+
List.rev (String_map.fold add exp [])
402
+
in
403
+
Error.missing_mems meta ~kinded_sort ~exp ~fnd
404
+
405
+
let unexpected_mems_error meta (object_map : ('o, 'o) object_map) ~fnd =
406
+
let kinded_sort = object_map_kinded_sort object_map in
407
+
let exp = List.map (fun (Mem_enc m) -> m.name) object_map.mem_encs in
408
+
Error.unexpected_mems meta ~kinded_sort ~exp ~fnd
409
+
410
+
let unexpected_case_tag_error meta object_map object_cases tag =
411
+
let kinded_sort = object_map_kinded_sort object_map in
412
+
let case_to_string (Case c) = match object_cases.tag_to_string with
413
+
| None -> None | Some str -> Some (str c.tag)
414
+
in
415
+
let exp = List.filter_map case_to_string object_cases.cases in
416
+
let fnd = match object_cases.tag_to_string with
417
+
| None -> "<tag>" (* XXX not good *) | Some str -> str tag
418
+
in
419
+
let mem_name = object_cases.tag.name in
420
+
Error.unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd
421
+
422
+
(* Processor toolbox *)
423
+
424
+
let object_meta_arg : Meta.t Type.Id.t = Type.Id.make ()
425
+
426
+
module Dict = struct
427
+
module M = Map.Make (Int)
428
+
type binding = B : 'a Type.Id.t * 'a -> binding
429
+
type t = binding M.t
430
+
let empty = M.empty
431
+
let mem k m = M.mem (Type.Id.uid k) m
432
+
let add k v m = M.add (Type.Id.uid k) (B (k, v)) m
433
+
let remove k m = M.remove (Type.Id.uid k) m
434
+
let find : type a. a Type.Id.t -> t -> a option =
435
+
fun k m -> match M.find_opt (Type.Id.uid k) m with
436
+
| None -> None
437
+
| Some B (k', v) ->
438
+
match Type.Id.provably_equal k k' with
439
+
| Some Type.Equal -> Some v | None -> assert false
440
+
end
441
+
442
+
let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f =
443
+
fun dec dict -> match dec with
444
+
| Dec_fun f -> f
445
+
| Dec_app (f, arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict))
446
+
447
+
type unknown_mems_option =
448
+
| Unknown_mems :
449
+
('o, 'mems, 'builder) unknown_mems option -> unknown_mems_option
450
+
451
+
let override_unknown_mems ~by umems dict = match by with
452
+
| Unknown_mems None -> umems, dict
453
+
| Unknown_mems _ as by ->
454
+
match umems with
455
+
| Unknown_mems (Some (Unknown_keep (umap, _))) ->
456
+
(* A decoding function still expect [umap.id] argument in
457
+
an Dec_app, we simply stub it with the empty map. *)
458
+
let empty = umap.dec_finish Meta.none (umap.dec_empty ()) in
459
+
let dict = Dict.add umap.id empty dict in
460
+
by, dict
461
+
| _ -> by, dict
462
+
463
+
let finish_object_decode : type o p m mems builder.
464
+
(o, o) object_map -> Meta.t -> (p, mems, builder) unknown_mems -> builder ->
465
+
mem_dec String_map.t -> Dict.t -> Dict.t
466
+
=
467
+
fun map meta umems umap mem_decs dict ->
468
+
let dict = Dict.add object_meta_arg meta dict in
469
+
let dict = match umems with
470
+
| Unknown_skip | Unknown_error -> dict
471
+
| Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish meta umap) dict
472
+
in
473
+
let add_default _ (Mem_dec mem_map) dict = match mem_map.dec_absent with
474
+
| Some v -> Dict.add mem_map.id v dict
475
+
| None -> raise Exit
476
+
in
477
+
(try String_map.fold add_default mem_decs dict with
478
+
| Exit ->
479
+
let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in
480
+
let exp = String_map.filter no_default mem_decs in
481
+
missing_mems_error meta map ~exp ~fnd:[])
482
+
end
483
+
484
+
(* Types *)
485
+
486
+
type 'a t = 'a Repr.t
487
+
let kinded_sort = Repr.kinded_sort
488
+
let kind = Repr.kind
489
+
let doc = Repr.doc
490
+
let with_doc = Repr.with_doc
491
+
492
+
(* Base types *)
493
+
494
+
let enc_meta_none _v = Meta.none
495
+
496
+
module Base = struct
497
+
type ('a, 'b) map = ('a, 'b) Repr.base_map
498
+
499
+
let base_map_sort = "base map"
500
+
501
+
let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () =
502
+
let dec = match dec with
503
+
| Some dec -> dec
504
+
| None ->
505
+
let kind = Sort.kinded' ~kind base_map_sort in
506
+
fun meta _v -> Error.no_decoder meta ~kind
507
+
in
508
+
let enc = match enc with
509
+
| Some enc -> enc
510
+
| None ->
511
+
let kind = Sort.kinded' ~kind base_map_sort in
512
+
fun _v -> Error.no_encoder Meta.none ~kind
513
+
in
514
+
{ Repr.kind; doc; dec; enc; enc_meta }
515
+
516
+
let id =
517
+
let dec _meta v = v and enc = Fun.id in
518
+
{ Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
519
+
520
+
let ignore =
521
+
let kind = "ignore" in
522
+
let dec _meta _v = () in
523
+
let enc _v =
524
+
let kind = Sort.kinded' ~kind base_map_sort in
525
+
Error.no_encoder Meta.none ~kind
526
+
in
527
+
{ Repr.kind; doc = ""; dec; enc; enc_meta = enc_meta_none }
528
+
529
+
let null map = Repr.Null map
530
+
let bool map = Repr.Bool map
531
+
let number map = Repr.Number map
532
+
let string map = Repr.String map
533
+
534
+
let dec dec = fun _meta v -> dec v
535
+
let dec_result ?(kind = "") dec =
536
+
let kind = Sort.kinded' ~kind base_map_sort in
537
+
fun meta v -> match dec v with
538
+
| Ok v -> v | Error e -> Error.for' meta ~kind e
539
+
540
+
let dec_failure ?(kind = "") dec =
541
+
let kind = Sort.kinded' ~kind base_map_sort in
542
+
fun meta v -> try dec v with Failure e -> Error.for' meta ~kind e
543
+
544
+
let enc = Fun.id
545
+
let enc_result ?(kind = "") enc =
546
+
let kind = Sort.kinded' ~kind base_map_sort in
547
+
fun v -> match enc v with
548
+
| Ok v -> v | Error e -> Error.for' Meta.none ~kind e
549
+
550
+
let enc_failure ?(kind = "") enc =
551
+
let kind = Sort.kinded' ~kind base_map_sort in
552
+
fun v -> try enc v with Failure e -> Error.for' Meta.none ~kind e
553
+
end
554
+
555
+
(* Any *)
556
+
557
+
let any
558
+
?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string
559
+
?dec_array ?dec_object ?enc ()
560
+
=
561
+
let enc = match enc with
562
+
| Some enc -> enc
563
+
| None ->
564
+
let kind = Sort.kinded' ~kind "any" in
565
+
fun _v -> Error.no_encoder Meta.none ~kind
566
+
in
567
+
Repr.Any { kind; doc; dec_null; dec_bool; dec_number; dec_string; dec_array;
568
+
dec_object; enc }
569
+
570
+
(* Maps and recursion *)
571
+
572
+
let map ?(kind = "") ?(doc = "") ?dec ?enc dom =
573
+
let map_sort = "map" in
574
+
let dec = match dec with
575
+
| Some dec -> dec
576
+
| None ->
577
+
let kind = Sort.kinded' ~kind map_sort in
578
+
fun _v -> Error.no_decoder Meta.none ~kind
579
+
in
580
+
let enc = match enc with
581
+
| Some enc -> enc
582
+
| None ->
583
+
let kind = Sort.kinded' ~kind map_sort in
584
+
fun _v -> Error.no_encoder Meta.none ~kind
585
+
in
586
+
Repr.Map { kind; doc; dom; dec; enc }
587
+
588
+
let iter ?(kind = "") ?(doc = "") ?dec ?enc dom =
589
+
let dec = match dec with
590
+
| None -> Fun.id | Some dec -> fun v -> dec v; v
591
+
in
592
+
let enc = match enc with
593
+
| None -> Fun.id | Some enc -> fun v -> enc v; v
594
+
in
595
+
Repr.Map { kind; doc; dom; dec; enc }
596
+
597
+
let rec' t = Repr.Rec t
598
+
599
+
(* Nulls and options *)
600
+
601
+
let null ?kind ?doc v =
602
+
let dec _meta () = v and enc _meta = () in
603
+
Repr.Null (Base.map ?doc ?kind ~dec ~enc ())
604
+
605
+
let none =
606
+
let none = (* Can't use [Base.map] because of the value restriction. *)
607
+
let dec _meta _v = None and enc _ = () in
608
+
{ Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none }
609
+
in
610
+
Repr.Null none
611
+
612
+
let some t = map ~dec:Option.some ~enc:Option.get t
613
+
614
+
let option ?kind ?doc t =
615
+
let some = some t in
616
+
let enc = function None -> none | Some _ -> some in
617
+
match t with
618
+
| Null _ -> any ?doc ?kind ~dec_null:none ~enc ()
619
+
| Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc ()
620
+
| Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc ()
621
+
| String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc ()
622
+
| Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc ()
623
+
| Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc ()
624
+
| (Any _ | Map _ | Rec _) ->
625
+
any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some
626
+
~dec_string:some ~dec_array:some ~dec_object:some ~enc ()
627
+
628
+
(* Booleans *)
629
+
630
+
let bool = Repr.Bool Base.id
631
+
632
+
(* Numbers *)
633
+
634
+
let[@inline] check_finite_number meta ~kind v =
635
+
if Float.is_finite v then () else
636
+
Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null
637
+
638
+
let number = Repr.Number Base.id
639
+
640
+
let any_float =
641
+
let kind = "float" in
642
+
let finite = number in
643
+
let non_finite =
644
+
let dec m v = match Float.of_string_opt v with
645
+
| Some v -> v | None -> Error.parse_string_number m ~kind v
646
+
in
647
+
Base.string (Base.map ~kind ~dec ~enc:Float.to_string ())
648
+
in
649
+
let enc v = if Float.is_finite v then finite else non_finite in
650
+
any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc ()
651
+
652
+
let float_as_hex_string =
653
+
let kind = "float" in
654
+
let dec meta v = match Float.of_string_opt v with
655
+
| Some v -> v | None -> Error.parse_string_number meta ~kind v
656
+
in
657
+
let enc v = Printf.sprintf "%h" v in
658
+
Base.string (Base.map ~kind ~dec ~enc ())
659
+
660
+
let uint8 =
661
+
let kind = "uint8" in
662
+
let dec meta v =
663
+
check_finite_number meta ~kind v;
664
+
if Jsont_base.Number.in_exact_uint8_range v then Int.of_float v else
665
+
Error.number_range meta ~kind v
666
+
in
667
+
let enc v =
668
+
if Jsont_base.Number.int_is_uint8 v then Int.to_float v else
669
+
Error.integer_range Meta.none ~kind v
670
+
in
671
+
Base.number (Base.map ~kind ~dec ~enc ())
672
+
673
+
let uint16 =
674
+
let kind = "uint16" in
675
+
let dec meta v =
676
+
check_finite_number meta ~kind v;
677
+
if Jsont_base.Number.in_exact_uint16_range v then Int.of_float v else
678
+
Error.number_range meta ~kind v
679
+
in
680
+
let enc v =
681
+
if Jsont_base.Number.int_is_uint16 v then Int.to_float v else
682
+
Error.integer_range Meta.none ~kind v
683
+
in
684
+
Base.number (Base.map ~kind ~dec ~enc ())
685
+
686
+
let int8 =
687
+
let kind = "int8" in
688
+
let dec meta v =
689
+
check_finite_number meta ~kind v;
690
+
if Jsont_base.Number.in_exact_int8_range v then Int.of_float v else
691
+
Error.number_range meta ~kind v
692
+
in
693
+
let enc v =
694
+
if Jsont_base.Number.int_is_int8 v then Int.to_float v else
695
+
Error.integer_range Meta.none ~kind v
696
+
in
697
+
Base.number (Base.map ~kind ~dec ~enc ())
698
+
699
+
let int16 =
700
+
let kind = "int16" in
701
+
let dec meta v =
702
+
check_finite_number meta ~kind v;
703
+
if Jsont_base.Number.in_exact_int16_range v then Int.of_float v else
704
+
Error.number_range meta ~kind v
705
+
in
706
+
let enc v =
707
+
if Jsont_base.Number.int_is_int16 v then Int.to_float v else
708
+
Error.integer_range Meta.none ~kind v
709
+
in
710
+
Base.number (Base.map ~kind ~dec ~enc ())
711
+
712
+
let int32 =
713
+
let kind = "int32" in
714
+
let dec meta v =
715
+
check_finite_number meta ~kind v;
716
+
if Jsont_base.Number.in_exact_int32_range v then Int32.of_float v else
717
+
Error.number_range meta ~kind v
718
+
in
719
+
let enc = Int32.to_float (* Everything always fits *) in
720
+
Base.number (Base.map ~kind ~dec ~enc ())
721
+
722
+
let int64_as_string =
723
+
let kind = "int64" in
724
+
let dec meta v = match Int64.of_string_opt v with
725
+
| Some v -> v | None -> Error.parse_string_number meta ~kind v
726
+
in
727
+
Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ())
728
+
729
+
let int64_number =
730
+
(* Usage by [int64] entails there's no need to test for nan or check
731
+
range on encoding. *)
732
+
let kind = "int64" in
733
+
let dec meta v =
734
+
if Jsont_base.Number.in_exact_int64_range v then Int64.of_float v else
735
+
Error.number_range meta ~kind v
736
+
in
737
+
Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ())
738
+
739
+
let int64 =
740
+
let dec_number = int64_number and dec_string = int64_as_string in
741
+
let enc v =
742
+
if Jsont_base.Number.can_store_exact_int64 v then int64_number else
743
+
int64_as_string
744
+
in
745
+
any ~kind:"int64" ~dec_number ~dec_string ~enc ()
746
+
747
+
let int_as_string =
748
+
let kind = "OCaml int" in
749
+
let dec meta v = match int_of_string_opt v with
750
+
| Some v -> v | None -> Error.parse_string_number meta ~kind v
751
+
in
752
+
Base.string (Base.map ~kind ~dec ~enc:Int.to_string ())
753
+
754
+
let int_number =
755
+
(* Usage by [int] entails there's no need to test for nan or check range on
756
+
encoding. *)
757
+
let kind = "OCaml int" in
758
+
let dec meta v =
759
+
if Jsont_base.Number.in_exact_int_range v then Int.of_float v else
760
+
Error.number_range meta ~kind v
761
+
in
762
+
Base.number (Base.map ~kind ~dec ~enc:Int.to_float ())
763
+
764
+
let int =
765
+
let enc v =
766
+
if Jsont_base.Number.can_store_exact_int v then int_number else
767
+
int_as_string
768
+
in
769
+
let dec_number = int_number and dec_string = int_as_string in
770
+
any ~kind:"OCaml int" ~dec_number ~dec_string ~enc ()
771
+
772
+
(* String and enums *)
773
+
774
+
let string = Repr.String Base.id
775
+
776
+
let of_of_string ?kind ?doc ?enc of_string =
777
+
let dec = Base.dec_result ?kind of_string in
778
+
let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in
779
+
Base.string (Base.map ?kind ?doc ?enc ~dec ())
780
+
781
+
let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc =
782
+
let kind = Sort.kinded' ~kind "enum" in
783
+
let dec_map =
784
+
let add m (k, v) = Repr.String_map.add k v m in
785
+
let m = List.fold_left add Repr.String_map.empty assoc in
786
+
fun k -> Repr.String_map.find_opt k m
787
+
in
788
+
let enc_map =
789
+
let module M = Map.Make (struct type t = a let compare = cmp end) in
790
+
let add m (k, v) = M.add v k m in
791
+
let m = List.fold_left add M.empty assoc in
792
+
fun v -> M.find_opt v m
793
+
in
794
+
let dec meta s = match dec_map s with
795
+
| Some v -> v
796
+
| None ->
797
+
let kind = Sort.kinded ~kind String in
798
+
let pp_kind ppf () = Fmt.pf ppf "%a value" Repr.pp_kind kind in
799
+
Error.msgf meta "%a" (Fmt.out_of_dom ~pp_kind ()) (s, List.map fst assoc)
800
+
in
801
+
let enc v = match enc_map v with
802
+
| Some s -> s
803
+
| None ->
804
+
Error.msgf Meta.none "Encode %a: unknown enum value" Repr.pp_kind kind
805
+
in
806
+
Base.string (Base.map ~kind ?doc ~dec ~enc ())
807
+
808
+
let binary_string =
809
+
let kind = "hex" in
810
+
let kind' = Sort.kinded ~kind String in
811
+
let dec = Base.dec_result ~kind:kind' Jsont_base.binary_string_of_hex in
812
+
let enc = Base.enc Jsont_base.binary_string_to_hex in
813
+
Base.string (Base.map ~kind ~dec ~enc ())
814
+
815
+
(* Arrays and tuples *)
816
+
817
+
module Array = struct
818
+
type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) Repr.array_map
819
+
type ('array, 'elt) enc =
820
+
{ enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc }
821
+
822
+
let array_kind kind = Sort.kinded ~kind Sort.Array
823
+
let default_skip _i _builder = false
824
+
let map
825
+
?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish
826
+
?enc ?(enc_meta = enc_meta_none) elt
827
+
=
828
+
let dec_empty = match dec_empty with
829
+
| Some dec_empty -> dec_empty
830
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(array_kind kind)
831
+
in
832
+
let dec_skip = Option.value ~default:default_skip dec_skip in
833
+
let dec_add = match dec_add with
834
+
| Some dec_add -> dec_add
835
+
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
836
+
in
837
+
let dec_finish = match dec_finish with
838
+
| Some dec_finish -> dec_finish
839
+
| None -> fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind)
840
+
in
841
+
let enc = match enc with
842
+
| Some { enc } -> enc
843
+
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind)
844
+
in
845
+
{ Repr.kind; doc; elt; dec_empty; dec_add; dec_skip; dec_finish; enc;
846
+
enc_meta; }
847
+
848
+
let list_enc f acc l =
849
+
let rec loop f acc i = function
850
+
| [] -> acc | v :: l -> loop f (f acc i v) (i + 1) l
851
+
in
852
+
loop f acc 0 l
853
+
854
+
let list_map ?kind ?doc ?dec_skip elt =
855
+
let dec_empty () = [] in
856
+
let dec_add _i v l = v :: l in
857
+
let dec_finish _meta _len l = List.rev l in
858
+
let enc = { enc = list_enc } in
859
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
860
+
861
+
type 'a array_builder = 'a Jsont_base.Rarray.t
862
+
863
+
let array_enc f acc a =
864
+
let acc = ref acc in
865
+
for i = 0 to Array.length a - 1
866
+
do acc := f !acc i (Array.unsafe_get a i) done;
867
+
!acc
868
+
869
+
let array_map ?kind ?doc ?dec_skip elt =
870
+
let dec_empty () = Jsont_base.Rarray.empty () in
871
+
let dec_add _i v a = Jsont_base.Rarray.add_last v a in
872
+
let dec_finish _meta _len a = Jsont_base.Rarray.to_array a in
873
+
let enc = { enc = array_enc } in
874
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
875
+
876
+
type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Jsont_base.Rbigarray1.t
877
+
878
+
let bigarray_map ?kind ?doc ?dec_skip k l elt =
879
+
let dec_empty _meta = Jsont_base.Rbigarray1.empty k l in
880
+
let dec_add _i v a = Jsont_base.Rbigarray1.add_last v a in
881
+
let dec_finish _meta _len a = Jsont_base.Rbigarray1.to_bigarray a in
882
+
let enc f acc a =
883
+
let acc = ref acc in
884
+
for i = 0 to Bigarray.Array1.dim a - 1
885
+
do acc := f !acc i (Bigarray.Array1.unsafe_get a i) done;
886
+
!acc
887
+
in
888
+
let enc = { enc } in
889
+
map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt
890
+
891
+
let array map = Repr.Array map
892
+
893
+
let stub_elt =
894
+
Repr.Map { kind = ""; doc = ""; dom = Base.(null id);
895
+
enc = (fun _ -> assert false);
896
+
dec = (fun _ -> assert false); }
897
+
898
+
let ignore =
899
+
let kind = "ignore" in
900
+
let kind' = Sort.kinded ~kind Array in
901
+
let dec_empty () = () and dec_add _i _v () = () in
902
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
903
+
let enc = { enc = fun _ _ () -> Error.no_encoder Meta.none ~kind:kind' } in
904
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
905
+
906
+
let zero =
907
+
let dec_empty () = () and dec_add _i _v () = () in
908
+
let dec_skip _i () = true and dec_finish _meta _len () = () in
909
+
let enc = { enc = fun _ acc () -> acc } in
910
+
let kind = "zero" in
911
+
array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt)
912
+
end
913
+
914
+
let list ?kind ?doc t = Repr.Array (Array.list_map ?kind ?doc t)
915
+
let array ?kind ?doc t = Repr.Array (Array.array_map ?kind ?doc t)
916
+
let array_as_string_map ?kind ?doc ~key t =
917
+
let dec_empty () = Repr.String_map.empty in
918
+
let dec_add _i elt acc = Repr.String_map.add (key elt) elt acc in
919
+
let dec_finish _meta _len acc = acc in
920
+
let enc f acc m =
921
+
let i = ref (-1) in
922
+
Repr.String_map.fold (fun _ elt acc -> incr i; f acc !i elt) m acc
923
+
in
924
+
let enc = Array.{enc} in
925
+
let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in
926
+
Repr.Array map
927
+
928
+
let bigarray ?kind ?doc k t =
929
+
Repr.Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t)
930
+
931
+
let tuple_no_decoder ~kind meta =
932
+
Error.no_decoder meta ~kind:(Sort.kinded' ~kind "tuple")
933
+
934
+
let tuple_no_encoder ~kind =
935
+
Error.no_encoder Meta.none ~kind:(Sort.kinded' ~kind "tuple")
936
+
937
+
let error_tuple_size meta kind ~exp fnd =
938
+
Error.msgf meta "Expected %a elements in %a but found %a"
939
+
pp_int exp pp_kind (Sort.kinded' ~kind "tuple") pp_int fnd
940
+
941
+
let t2 ?(kind = "") ?doc ?dec ?enc t =
942
+
let size = 2 in
943
+
let dec = match dec with
944
+
| None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta
945
+
| Some dec -> fun _meta v0 v1 -> dec v0 v1
946
+
in
947
+
let dec_empty () = [] in
948
+
let dec_add _i v acc = v :: acc in
949
+
let dec_finish meta _len = function
950
+
| [v1; v0] -> dec meta v0 v1
951
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
952
+
in
953
+
let enc = match enc with
954
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
955
+
| Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1)
956
+
in
957
+
let enc = { Array.enc } in
958
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
959
+
960
+
let t3 ?(kind = "") ?doc ?dec ?enc t =
961
+
let size = 3 in
962
+
let dec = match dec with
963
+
| None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta
964
+
| Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2
965
+
in
966
+
let dec_empty () = [] in
967
+
let dec_add _i v acc = v :: acc in
968
+
let dec_finish meta _len = function
969
+
| [v2; v1; v0] -> dec meta v0 v1 v2
970
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
971
+
in
972
+
let enc = match enc with
973
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
974
+
| Some enc ->
975
+
fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)
976
+
in
977
+
let enc = { Array.enc } in
978
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
979
+
980
+
let t4 ?(kind = "") ?doc ?dec ?enc t =
981
+
let size = 4 in
982
+
let dec = match dec with
983
+
| None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta
984
+
| Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3
985
+
in
986
+
let dec_empty () = [] in
987
+
let dec_add _i v acc = v :: acc in
988
+
let dec_finish meta _len = function
989
+
| [v3; v2; v1; v0] -> dec meta v0 v1 v2 v3
990
+
| l -> error_tuple_size meta kind ~exp:size (List.length l)
991
+
in
992
+
let enc = match enc with
993
+
| None -> fun _f _acc _v -> tuple_no_encoder ~kind
994
+
| Some enc ->
995
+
fun f acc v ->
996
+
f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3)
997
+
in
998
+
let enc = { Array.enc } in
999
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t)
1000
+
1001
+
let tn ?(kind = "") ?doc ~n elt =
1002
+
let dec_empty () = Jsont_base.Rarray.empty () in
1003
+
let dec_add _i v a = Jsont_base.Rarray.add_last v a in
1004
+
let dec_finish meta _len a =
1005
+
let len = Jsont_base.Rarray.length a in
1006
+
if len <> n then error_tuple_size meta kind ~exp:n len else
1007
+
Jsont_base.Rarray.to_array a
1008
+
in
1009
+
let enc = { Array.enc = Array.array_enc } in
1010
+
Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt)
1011
+
1012
+
(* Objects *)
1013
+
1014
+
module Object = struct
1015
+
open Repr
1016
+
1017
+
(* Maps *)
1018
+
1019
+
type ('o, 'dec) map = ('o, 'dec) object_map
1020
+
1021
+
let default_shape = Object_basic Unknown_skip
1022
+
1023
+
let _map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec =
1024
+
{ kind; doc; dec; mem_decs = String_map.empty; mem_encs = [];
1025
+
enc_meta; shape = default_shape }
1026
+
1027
+
let map ?kind ?doc dec = _map ?kind ?doc (Dec_fun dec)
1028
+
let map' ?kind ?doc ?enc_meta dec =
1029
+
_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg))
1030
+
1031
+
let enc_only ?(kind = "") ?doc ?enc_meta () =
1032
+
let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in
1033
+
map' ~kind ?doc ?enc_meta dec
1034
+
1035
+
let check_name_unicity m =
1036
+
let add n kind = function
1037
+
| None -> Some kind
1038
+
| Some kind' ->
1039
+
let ks k = Sort.or_kind ~kind Object in
1040
+
let k0 = ks kind and k1 = ks kind' in
1041
+
invalid_arg @@
1042
+
if String.equal k0 k1
1043
+
then Fmt.str "member %s defined twice in %s" n k0
1044
+
else Fmt.str "member %s defined both in %s and %s" n k0 k1
1045
+
in
1046
+
let rec loop :
1047
+
type o dec. string String_map.t -> (o, dec) object_map -> unit
1048
+
=
1049
+
fun names m ->
1050
+
let add_name names n = String_map.update n (add n m.kind) names in
1051
+
let add_mem_enc names (Mem_enc m) = add_name names m.name in
1052
+
let names = List.fold_left add_mem_enc names m.mem_encs in
1053
+
match m.shape with
1054
+
| Object_basic _ -> ()
1055
+
| Object_cases (u, cases) ->
1056
+
let names = add_name names cases.tag.name in
1057
+
let check_case (Case c) = loop names c.object_map in
1058
+
List.iter check_case cases.cases
1059
+
in
1060
+
loop String_map.empty m
1061
+
1062
+
let finish mems =
1063
+
let () = check_name_unicity mems in
1064
+
Object { mems with mem_encs = List.rev mems.mem_encs }
1065
+
1066
+
let get_object_map = function
1067
+
| Object map -> map | _ -> invalid_arg "Not an object"
1068
+
1069
+
(* Members *)
1070
+
1071
+
module Mem = struct
1072
+
type ('o, 'a) map = ('o, 'a) Repr.mem_map
1073
+
1074
+
let no_enc name = fun _v ->
1075
+
Error.msgf Meta.none "No encoder for member %a" pp_code name
1076
+
1077
+
let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' =
1078
+
let id = Type.Id.make () in
1079
+
let enc = match enc with None -> no_enc name | Some enc -> enc in
1080
+
let enc_omit = match enc_omit with
1081
+
| None -> Fun.const false | Some omit -> omit
1082
+
in
1083
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
1084
+
1085
+
let app object_map mm =
1086
+
let mem_decs = String_map.add mm.name (Mem_dec mm) object_map.mem_decs in
1087
+
let mem_encs = Mem_enc mm :: object_map.mem_encs in
1088
+
let dec = Dec_app (object_map.dec, mm.id) in
1089
+
{ object_map with dec; mem_decs; mem_encs }
1090
+
end
1091
+
1092
+
let mem ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map =
1093
+
let mmap = Mem.map ~doc ?dec_absent ?enc ?enc_omit name type' in
1094
+
let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in
1095
+
let mem_encs = Mem_enc mmap :: map.mem_encs in
1096
+
let dec = Dec_app (map.dec, mmap.id) in
1097
+
{ map with dec; mem_decs; mem_encs }
1098
+
1099
+
let opt_mem ?doc ?enc:e name dom map =
1100
+
let dec = Option.some and enc = Option.get in
1101
+
let some = Map { kind = ""; doc = ""; dom; dec; enc} in
1102
+
mem ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map
1103
+
1104
+
(* Case objects *)
1105
+
1106
+
module Case = struct
1107
+
type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map
1108
+
type ('cases, 'tag) t = ('cases, 'tag) case
1109
+
type ('cases, 'tag) value = ('cases, 'tag) case_value
1110
+
1111
+
let no_dec _ = Error.msgf Meta.none "No decoder for case"
1112
+
let map ?(dec = no_dec) tag obj =
1113
+
{ tag; object_map = get_object_map obj; dec; }
1114
+
1115
+
let map_tag c = c.tag
1116
+
let make c = Case c
1117
+
let tag (Case c) = map_tag c
1118
+
let value c v = Case_value (c, v)
1119
+
end
1120
+
1121
+
let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string =
1122
+
match map.shape with
1123
+
| Object_cases _ -> invalid_arg "Multiple calls to Jsont.Object.case_mem"
1124
+
| _ ->
1125
+
match dec_absent with
1126
+
| None -> ()
1127
+
| Some tag ->
1128
+
(* Check that we have a case definition for it *)
1129
+
let equal_t (Case case) = tag_compare case.tag tag = 0 in
1130
+
if not (List.exists equal_t cases) then
1131
+
let tag = match tag_to_string with
1132
+
| None -> "" | Some tag_to_string -> " " ^ tag_to_string tag
1133
+
in
1134
+
invalid_arg ("No case for dec_absent case member value" ^ tag)
1135
+
1136
+
let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit =
1137
+
let id = Type.Id.make () in
1138
+
let enc t = t (* N.B. this fact may be used by encoders. *) in
1139
+
let enc_omit = match enc_omit with
1140
+
| None -> Fun.const false | Some omit -> omit
1141
+
in
1142
+
{ name; doc; type'; id; dec_absent; enc; enc_omit }
1143
+
1144
+
let case_mem
1145
+
?doc ?(tag_compare = Stdlib.compare) ?tag_to_string ?dec_absent
1146
+
?enc ?enc_omit ?enc_case name type' cases map
1147
+
=
1148
+
let () = check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string in
1149
+
let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in
1150
+
let enc = match enc with None -> Mem.no_enc name | Some e -> e in
1151
+
let enc_case = match enc_case with
1152
+
| Some enc_case -> enc_case
1153
+
| None ->
1154
+
fun _case ->
1155
+
Error.msgf Meta.none "No case encoder for member %a" pp_code name
1156
+
in
1157
+
let id = Type.Id.make () in
1158
+
let cases = {tag; tag_compare; tag_to_string; id; cases; enc; enc_case} in
1159
+
let dec = Dec_app (map.dec, id) in
1160
+
{ map with dec; shape = Object_cases (None, cases) }
1161
+
1162
+
(* Unknown members *)
1163
+
1164
+
module Mems = struct
1165
+
type ('mems, 'a) enc =
1166
+
{ enc :
1167
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc ->
1168
+
'acc }
1169
+
1170
+
type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map
1171
+
1172
+
let mems_kind kind = Sort.kinded' ~kind "members map"
1173
+
let map
1174
+
?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish
1175
+
?enc mems_type
1176
+
=
1177
+
let dec_empty = match dec_empty with
1178
+
| Some dec_empty -> dec_empty
1179
+
| None -> fun () -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1180
+
in
1181
+
let dec_add = match dec_add with
1182
+
| Some dec_add -> dec_add
1183
+
| None -> fun _ _ _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1184
+
in
1185
+
let dec_finish = match dec_finish with
1186
+
| Some dec_finish -> dec_finish
1187
+
| None -> fun _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind)
1188
+
in
1189
+
let enc = match enc with
1190
+
| Some { enc } -> enc
1191
+
| None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(mems_kind kind)
1192
+
in
1193
+
let id = Type.Id.make () in
1194
+
{ kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc }
1195
+
1196
+
let string_map ?kind ?doc type' =
1197
+
let dec_empty () = String_map.empty in
1198
+
let dec_add _meta n v mems = String_map.add n v mems in
1199
+
let dec_finish _meta mems = mems in
1200
+
let enc f mems acc =
1201
+
String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc
1202
+
in
1203
+
map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{enc}
1204
+
end
1205
+
1206
+
let set_shape_unknown_mems shape u = match shape with
1207
+
| Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _) ->
1208
+
invalid_arg "Jsont.Object.keep_unknown already called on object"
1209
+
| Object_basic _ -> Object_basic u
1210
+
| Object_cases (_, cases) -> Object_cases (Some u, cases)
1211
+
1212
+
let skip_unknown map =
1213
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_skip }
1214
+
1215
+
let error_unknown map =
1216
+
{ map with shape = set_shape_unknown_mems map.shape Unknown_error }
1217
+
1218
+
let mems_noenc (mems : (_, _, _) mems_map) _o =
1219
+
let kind = Sort.kinded' ~kind:mems.kind "members" in
1220
+
Error.no_encoder Meta.none ~kind
1221
+
1222
+
let keep_unknown ?enc mems (map : ('o, 'dec) object_map) =
1223
+
let enc = match enc with None -> mems_noenc mems | Some enc -> enc in
1224
+
let dec = Dec_app (map.dec, mems.id) in
1225
+
let unknown = Unknown_keep (mems, enc) in
1226
+
{ map with dec; shape = set_shape_unknown_mems map.shape unknown }
1227
+
1228
+
let zero = finish (map ~kind:"zero" ())
1229
+
1230
+
let as_string_map ?kind ?doc t =
1231
+
map ?kind ?doc Fun.id
1232
+
|> keep_unknown (Mems.string_map t) ~enc:Fun.id
1233
+
|> finish
1234
+
end
1235
+
1236
+
(* Ignoring *)
1237
+
1238
+
let ignore =
1239
+
let kind = "ignore" in
1240
+
let dec_null = Repr.Null Base.ignore and dec_bool = Repr.Bool Base.ignore in
1241
+
let dec_number = Repr.Number Base.ignore in
1242
+
let dec_string = Repr.String Base.ignore in
1243
+
let dec_array = Array.ignore and dec_object = Object.zero in
1244
+
let enc _v = Error.no_encoder Meta.none ~kind in
1245
+
any ~kind ~dec_null ~dec_bool ~dec_number ~dec_string ~dec_array ~dec_object
1246
+
~enc ()
1247
+
1248
+
let zero =
1249
+
let kind = "zero" in
1250
+
let null = null () and dec_bool = Repr.Bool Base.ignore in
1251
+
let dec_number = Repr.Number Base.ignore in
1252
+
let dec_string = Repr.String Base.ignore in
1253
+
let dec_array = Array.ignore and dec_object = Object.zero in
1254
+
let enc () = null in
1255
+
any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array
1256
+
~dec_object ~enc ()
1257
+
1258
+
let todo ?(kind = "") ?doc ?dec_stub () =
1259
+
let dec = match dec_stub with
1260
+
| Some v -> Fun.const v
1261
+
| None -> fun _v -> Error.decode_todo Meta.none ~kind_opt:kind
1262
+
in
1263
+
let enc _v = Error.encode_todo Meta.none ~kind_opt:kind in
1264
+
map ~kind ?doc ~dec ~enc ignore
1265
+
1266
+
(* Generic JSON *)
1267
+
1268
+
type name = string node
1269
+
type mem = name * json
1270
+
and object' = mem list
1271
+
and json =
1272
+
| Null of unit node
1273
+
| Bool of bool node
1274
+
| Number of float node
1275
+
| String of string node
1276
+
| Array of json list node
1277
+
| Object of object' node
1278
+
1279
+
let pp_null = Fmt.json_null
1280
+
let pp_bool = Fmt.json_bool
1281
+
let pp_string = Fmt.json_string
1282
+
let pp_number = Fmt.json_number
1283
+
let pp_number' = Fmt.json_number'
1284
+
let pp_json' ?(number_format = Fmt.json_default_number_format) () ppf j =
1285
+
let pp_indent = 2 in
1286
+
let pp_sep ppf () =
1287
+
Format.pp_print_char ppf ',';
1288
+
Format.pp_print_break ppf 1 pp_indent
1289
+
in
1290
+
let rec pp_array ppf a =
1291
+
Format.pp_open_hovbox ppf 0;
1292
+
Format.pp_print_char ppf '[';
1293
+
Format.pp_print_break ppf 0 pp_indent;
1294
+
(Format.pp_print_list ~pp_sep pp_value) ppf a;
1295
+
Format.pp_print_break ppf 0 0;
1296
+
Format.pp_print_char ppf ']';
1297
+
Format.pp_close_box ppf ()
1298
+
and pp_mem ppf ((m, _), v) =
1299
+
Format.pp_open_hvbox ppf 0;
1300
+
pp_string ppf m; Format.pp_print_string ppf ": "; pp_value ppf v;
1301
+
Format.pp_close_box ppf ();
1302
+
and pp_obj ppf o =
1303
+
Format.pp_open_hvbox ppf 0;
1304
+
Format.pp_print_char ppf '{';
1305
+
Format.pp_print_break ppf 0 pp_indent;
1306
+
(Format.pp_print_list ~pp_sep pp_mem) ppf o;
1307
+
Format.pp_print_break ppf 0 0;
1308
+
Format.pp_print_char ppf '}';
1309
+
Format.pp_close_box ppf ();
1310
+
and pp_value ppf = function
1311
+
| Null _ -> pp_null ppf ()
1312
+
| Bool (b,_ ) -> pp_bool ppf b
1313
+
| Number (f, _) -> pp_number' number_format ppf f
1314
+
| String (s, _) -> pp_string ppf s
1315
+
| Array (a, _) -> pp_array ppf a
1316
+
| Object (o, _) -> pp_obj ppf o
1317
+
in
1318
+
pp_value ppf j
1319
+
1320
+
let pp_json ppf j = pp_json' () ppf j
1321
+
1322
+
(* Generic JSON *)
1323
+
1324
+
module Json = struct
1325
+
type 'a cons = ?meta:Meta.t -> 'a -> json
1326
+
type t = json
1327
+
1328
+
let meta = function
1329
+
| Null (_, m) -> m | Bool (_, m) -> m | Number (_, m) -> m
1330
+
| String (_, m) -> m | Array (_, m) -> m | Object (_, m) -> m
1331
+
1332
+
let set_meta m = function
1333
+
| Null (v, _) -> Null (v, m) | Bool (v, _) -> Bool (v, m)
1334
+
| Number (v, _) -> Number (v, m) | String (v, _) -> String (v, m)
1335
+
| Array (v, _) -> Array (v, m) | Object (v, _) -> Object (v, m)
1336
+
1337
+
let get_meta = meta
1338
+
let copy_layout v ~dst =
1339
+
set_meta (Meta.copy_ws (meta v) ~dst:(meta dst)) dst
1340
+
1341
+
let sort = function
1342
+
| Null _ -> Sort.Null | Bool _ -> Sort.Bool | Number _ -> Sort.Number
1343
+
| String _ -> Sort.String | Array _ -> Sort.Array | Object _ -> Sort.Object
1344
+
1345
+
let rec compare (j0 : json) (j1 : json) = match j0, j1 with
1346
+
| Null ((), _), Null ((), _) -> 0
1347
+
| Null _, _ -> -1 | _, Null _ -> 1
1348
+
| Bool (b0, _), Bool (b1, _) -> Bool.compare b0 b1
1349
+
| Bool _, _ -> -1 | _, Bool _ -> 1
1350
+
| Number (f0, _), Number (f1, _) -> Float.compare f0 f1
1351
+
| Number _, _ -> -1 | _, Number _ -> 1
1352
+
| String (s0, _), String (s1, _) -> String.compare s0 s1
1353
+
| String _, _ -> -1 | _, String _ -> 1
1354
+
| Array (a0, _), (Array (a1, _)) -> List.compare compare a0 a1
1355
+
| Array _, _ -> -1 | _, Array _ -> 1
1356
+
| Object (o0, _), Object (o1, _) ->
1357
+
let order_mem ((n0, _), _) ((n1, _), _) = String.compare n0 n1 in
1358
+
let compare_mem ((n0, _), j0) ((n1, _), j1) =
1359
+
let c = String.compare n0 n1 in
1360
+
if c = 0 then compare j0 j1 else c
1361
+
in
1362
+
List.compare compare_mem (List.sort order_mem o0) (List.sort order_mem o1)
1363
+
1364
+
let equal j0 j1 = compare j0 j1 = 0
1365
+
let pp = pp_json
1366
+
1367
+
(* Nulls and options *)
1368
+
1369
+
let null' = Null ((), Meta.none)
1370
+
let null ?(meta = Meta.none) () = Null ((), meta)
1371
+
let option c ?meta = function None -> null ?meta () | Some v -> c ?meta v
1372
+
1373
+
(* Booleans *)
1374
+
1375
+
let bool ?(meta = Meta.none) b = Bool (b, meta)
1376
+
1377
+
(* Numbers *)
1378
+
1379
+
let number ?(meta = Meta.none) n = Number (n, meta)
1380
+
let any_float ?(meta = Meta.none) v =
1381
+
if Float.is_finite v
1382
+
then Number (v, meta)
1383
+
else String (Float.to_string v, meta)
1384
+
1385
+
let int32 ?(meta = Meta.none) v = Number (Int32.to_float v, meta)
1386
+
let int64_as_string ?(meta = Meta.none) v = String (Int64.to_string v, meta)
1387
+
let int64 ?(meta = Meta.none) v =
1388
+
if Jsont_base.Number.can_store_exact_int64 v
1389
+
then Number (Int64.to_float v, meta)
1390
+
else String (Int64.to_string v, meta)
1391
+
1392
+
let int_as_string ?(meta = Meta.none) i = String (Int.to_string i, meta)
1393
+
let int ?(meta = Meta.none) v =
1394
+
if Jsont_base.Number.can_store_exact_int v
1395
+
then Number (Int.to_float v, meta)
1396
+
else String (Int.to_string v, meta)
1397
+
1398
+
(* Strings *)
1399
+
1400
+
let string ?(meta = Meta.none) s = String (s, meta)
1401
+
1402
+
(* Arrays *)
1403
+
1404
+
let list ?(meta = Meta.none) l = Array (l, meta)
1405
+
let array ?(meta = Meta.none) a = Array (Stdlib.Array.to_list a, meta)
1406
+
let empty_array = list []
1407
+
1408
+
(* Objects *)
1409
+
1410
+
let name ?(meta = Meta.none) n = n, meta
1411
+
let mem n v = n, v
1412
+
let object' ?(meta = Meta.none) mems = Object (mems, meta)
1413
+
let empty_object = object' []
1414
+
1415
+
let rec find_mem n = function
1416
+
| [] -> None
1417
+
| ((n', _), _ as m) :: ms ->
1418
+
if String.equal n n' then Some m else find_mem n ms
1419
+
1420
+
let find_mem' (n, _) ms = find_mem n ms
1421
+
let object_names mems = List.map (fun ((n, _), _) -> n) mems
1422
+
let object_names' mems = List.map fst mems
1423
+
1424
+
(* Zero *)
1425
+
1426
+
let zero ?meta j = match sort j with
1427
+
| Null -> null ?meta () | Bool -> bool ?meta false
1428
+
| Number -> number ?meta 0. | String -> string ?meta ""
1429
+
| Array -> list ?meta [] | Object -> object' ?meta []
1430
+
1431
+
(* Converting *)
1432
+
1433
+
open Repr
1434
+
1435
+
let error_sort ~exp j = Error.sort (meta j) ~exp ~fnd:(sort j)
1436
+
let error_type t fnd =
1437
+
Error.kinded_sort (meta fnd) ~exp:(kinded_sort t) ~fnd:(sort fnd)
1438
+
1439
+
let find_all_unexpected ~mem_decs mems =
1440
+
let unexpected ((n, _ as nm), _v) =
1441
+
match Repr.String_map.find_opt n mem_decs with
1442
+
| None -> Some nm | Some _ -> None
1443
+
in
1444
+
List.filter_map unexpected mems
1445
+
1446
+
(* Decoding *)
1447
+
1448
+
let rec decode : type a. a Repr.t -> json -> a =
1449
+
fun t j -> match t with
1450
+
| Null map ->
1451
+
(match j with Null (n, meta) -> map.dec meta n | j -> error_type t j)
1452
+
| Bool map ->
1453
+
(match j with Bool (b, meta) -> map.dec meta b | j -> error_type t j)
1454
+
| Number map ->
1455
+
(match j with
1456
+
| Number (n, meta) -> map.dec meta n
1457
+
| Null (_, meta) -> map.dec meta Float.nan
1458
+
| j -> error_type t j)
1459
+
| String map ->
1460
+
(match j with String (s, meta) -> map.dec meta s | j -> error_type t j)
1461
+
| Array map ->
1462
+
(match j with
1463
+
| Array (vs, meta) -> decode_array map meta vs
1464
+
| j -> error_type t j)
1465
+
| Object map ->
1466
+
(match j with
1467
+
| Object (mems, meta) -> decode_object map meta mems
1468
+
| j -> error_type t j)
1469
+
| Map map -> map.dec (decode map.dom j)
1470
+
| Any map -> decode_any t map j
1471
+
| Rec t -> decode (Lazy.force t) j
1472
+
1473
+
and decode_array :
1474
+
type a elt b. (a, elt, b) array_map -> Meta.t -> json list -> a
1475
+
=
1476
+
fun map meta vs ->
1477
+
let rec next (map : (a, elt, b) array_map) meta b i = function
1478
+
| [] -> map.dec_finish meta i b
1479
+
| v :: vs ->
1480
+
let b =
1481
+
try
1482
+
if map.dec_skip i b then b else
1483
+
map.dec_add i (decode map.elt v) b
1484
+
with Error e -> Repr.error_push_array meta map (i, get_meta v) e
1485
+
in
1486
+
next map meta b (i + 1) vs
1487
+
in
1488
+
next map meta (map.dec_empty ()) 0 vs
1489
+
1490
+
and decode_object : type o. (o, o) Object.map -> Meta.t -> object' -> o =
1491
+
fun map meta mems ->
1492
+
let dict = Dict.empty in
1493
+
let umems = Unknown_mems None in
1494
+
apply_dict map.dec @@
1495
+
decode_object_map map meta umems String_map.empty String_map.empty dict mems
1496
+
1497
+
and decode_object_map : type o.
1498
+
(o, o) Object.map -> Meta.t -> unknown_mems_option ->
1499
+
mem_dec String_map.t -> mem_dec String_map.t -> Dict.t -> object' -> Dict.t
1500
+
=
1501
+
fun map meta umems mem_miss mem_decs dict mems ->
1502
+
let u _ _ _ = assert false in
1503
+
let mem_miss = String_map.union u mem_miss map.mem_decs in
1504
+
let mem_decs = String_map.union u mem_decs map.mem_decs in
1505
+
match map.shape with
1506
+
| Object_cases (umems', cases) ->
1507
+
let umems' = Unknown_mems umems' in
1508
+
let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in
1509
+
decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems
1510
+
| Object_basic umems' ->
1511
+
let umems' = Unknown_mems (Some umems') in
1512
+
let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in
1513
+
match umems with
1514
+
| Unknown_mems (Some Unknown_skip | None) ->
1515
+
let umems = Unknown_skip in
1516
+
decode_object_basic map meta umems () mem_miss mem_decs dict mems
1517
+
| Unknown_mems (Some (Unknown_error as umems)) ->
1518
+
decode_object_basic map meta umems () mem_miss mem_decs dict mems
1519
+
| Unknown_mems (Some (Unknown_keep (umap, _) as umems)) ->
1520
+
let umap = umap.dec_empty () in
1521
+
decode_object_basic map meta umems umap mem_miss mem_decs dict mems
1522
+
1523
+
and decode_object_basic : type o p m b.
1524
+
(o, o) object_map -> Meta.t -> (p, m, b) unknown_mems -> b ->
1525
+
mem_dec String_map.t -> mem_dec String_map.t -> Dict.t -> object' -> Dict.t
1526
+
=
1527
+
fun map meta umems umap mem_miss mem_decs dict -> function
1528
+
| [] -> Repr.finish_object_decode map meta umems umap mem_miss dict
1529
+
| ((n, nmeta as nm), v) :: mems ->
1530
+
match String_map.find_opt n mem_decs with
1531
+
| Some (Mem_dec m) ->
1532
+
let dict = try Dict.add m.id (decode m.type' v) dict with
1533
+
| Error e -> Repr.error_push_object meta map nm e
1534
+
in
1535
+
let mem_miss = String_map.remove n mem_miss in
1536
+
decode_object_basic map meta umems umap mem_miss mem_decs dict mems
1537
+
| None ->
1538
+
match umems with
1539
+
| Unknown_skip ->
1540
+
decode_object_basic
1541
+
map meta umems umap mem_miss mem_decs dict mems
1542
+
| Unknown_error ->
1543
+
let fnd = nm :: find_all_unexpected ~mem_decs mems in
1544
+
Repr.unexpected_mems_error meta map ~fnd
1545
+
| Unknown_keep (umap', _) ->
1546
+
let umap =
1547
+
try umap'.dec_add nmeta n (decode umap'.mems_type v) umap with
1548
+
| Error e -> Repr.error_push_object meta map nm e
1549
+
in
1550
+
decode_object_basic
1551
+
map meta umems umap mem_miss mem_decs dict mems
1552
+
1553
+
and decode_object_cases : type o cs t.
1554
+
(o, o) object_map -> Meta.t -> unknown_mems_option ->
1555
+
(o, cs, t) object_cases -> mem_dec String_map.t -> mem_dec String_map.t ->
1556
+
Dict.t -> object' -> object' -> Dict.t
1557
+
=
1558
+
fun map meta umems cases mem_miss mem_decs dict delay mems ->
1559
+
let decode_case_tag map meta tag delay mems =
1560
+
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
1561
+
match List.find_opt eq_tag cases.cases with
1562
+
| None -> Repr.unexpected_case_tag_error meta map cases tag
1563
+
| Some (Case case) ->
1564
+
let mems = List.rev_append delay mems in
1565
+
let dict =
1566
+
decode_object_map
1567
+
case.object_map meta umems mem_miss mem_decs dict mems
1568
+
in
1569
+
Dict.add
1570
+
cases.id (case.dec (apply_dict case.object_map.dec dict)) dict
1571
+
in
1572
+
match mems with
1573
+
| [] ->
1574
+
(match cases.tag.dec_absent with
1575
+
| Some tag -> decode_case_tag map meta tag delay []
1576
+
| None ->
1577
+
let kinded_sort = Repr.object_map_kinded_sort map in
1578
+
Error.missing_mems meta ~kinded_sort
1579
+
~exp:[cases.tag.name]
1580
+
~fnd:(List.map (fun ((n, _), _) -> n) delay))
1581
+
| ((n, meta as nm), v as mem) :: mems ->
1582
+
if n = cases.tag.name then
1583
+
let tag = try decode cases.tag.type' v with
1584
+
| Error e -> Repr.error_push_object meta map nm e
1585
+
in
1586
+
decode_case_tag map meta tag delay mems
1587
+
else
1588
+
match String_map.find_opt n mem_decs with
1589
+
| None ->
1590
+
let delay = mem :: delay in
1591
+
decode_object_cases
1592
+
map meta umems cases mem_miss mem_decs dict delay mems
1593
+
| Some (Mem_dec m) ->
1594
+
let dict = try Dict.add m.id (decode m.type' v) dict with
1595
+
| Error e -> Repr.error_push_object meta map nm e
1596
+
in
1597
+
let mem_miss = String_map.remove n mem_miss in
1598
+
decode_object_cases
1599
+
map meta umems cases mem_miss mem_decs dict delay mems
1600
+
1601
+
and decode_any : type a. a Repr.t -> a any_map -> json -> a =
1602
+
fun t map j ->
1603
+
let dec t map j = match map with
1604
+
| Some t -> decode t j | None -> error_type t j
1605
+
in
1606
+
match j with
1607
+
| Null _ -> dec t map.dec_null j
1608
+
| Bool _ -> dec t map.dec_bool j
1609
+
| Number _ -> dec t map.dec_number j
1610
+
| String _ -> dec t map.dec_string j
1611
+
| Array _ -> dec t map.dec_array j
1612
+
| Object _ -> dec t map.dec_object j
1613
+
1614
+
let dec = decode
1615
+
let decode' t j = try Ok (decode t j) with Error e -> Result.Error e
1616
+
let decode t j = Result.map_error Error.to_string (decode' t j)
1617
+
1618
+
(* Encode *)
1619
+
1620
+
let rec encode : type a. a Repr.t -> a -> json =
1621
+
fun t v -> match t with
1622
+
| Null map -> null ~meta:(map.enc_meta v) (map.enc v)
1623
+
| Bool map -> bool ~meta:(map.enc_meta v) (map.enc v)
1624
+
| Number map -> number ~meta:(map.enc_meta v) (map.enc v)
1625
+
| String map -> string ~meta:(map.enc_meta v) (map.enc v)
1626
+
| Array map ->
1627
+
let enc map acc i elt =
1628
+
try encode map.elt elt :: acc with
1629
+
| Error e -> Repr.error_push_array Meta.none map (i, Meta.none) e
1630
+
in
1631
+
list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v))
1632
+
| Object map ->
1633
+
let mems = encode_object map ~do_unknown:true v [] in
1634
+
Object (List.rev mems, map.enc_meta v)
1635
+
| Any map -> encode (map.enc v) v
1636
+
| Map map -> encode map.dom (map.enc v)
1637
+
| Rec t -> encode (Lazy.force t) v
1638
+
1639
+
and encode_object : type o dec.
1640
+
(o, o) object_map -> do_unknown:bool -> o -> object' -> object'
1641
+
=
1642
+
fun map ~do_unknown o obj ->
1643
+
let encode_mem map obj (Mem_enc mmap) =
1644
+
try
1645
+
let v = mmap.enc o in
1646
+
if mmap.enc_omit v then obj else
1647
+
((mmap.name, Meta.none), encode mmap.type' v) :: obj
1648
+
with
1649
+
| Error e -> Repr.error_push_object Meta.none map (mmap.name, Meta.none) e
1650
+
in
1651
+
let obj = List.fold_left (encode_mem map) obj map.mem_encs in
1652
+
match map.shape with
1653
+
| Object_basic (Unknown_keep (umap, enc)) when do_unknown ->
1654
+
encode_unknown_mems map umap (enc o) obj
1655
+
| Object_basic _ -> obj
1656
+
| Object_cases (u, cases) ->
1657
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
1658
+
let obj =
1659
+
let n = cases.tag.name, Meta.none in
1660
+
try
1661
+
if cases.tag.enc_omit case.tag then obj else
1662
+
(n, encode cases.tag.type' case.tag) :: obj
1663
+
with
1664
+
| Error e -> Repr.error_push_object Meta.none map n e
1665
+
in
1666
+
match u with
1667
+
| Some (Unknown_keep (umap, enc)) ->
1668
+
(* Less T.R. but feels nicer to encode unknowns at the end *)
1669
+
let obj = encode_object case.object_map ~do_unknown:false c obj in
1670
+
encode_unknown_mems map umap (enc o) obj
1671
+
| _ -> encode_object case.object_map ~do_unknown c obj
1672
+
1673
+
and encode_unknown_mems : type o dec mems a builder.
1674
+
(o, o) object_map -> (mems, a, builder) mems_map -> mems -> object' ->
1675
+
object'
1676
+
=
1677
+
fun map umap mems obj ->
1678
+
let encode_mem map meta name v obj =
1679
+
let n = (name, meta) in
1680
+
let v = try encode umap.mems_type v with
1681
+
| Error e -> Repr.error_push_object Meta.none map n e
1682
+
in
1683
+
(n, v) :: obj
1684
+
in
1685
+
(umap.enc (encode_mem map) mems obj)
1686
+
1687
+
let enc = encode
1688
+
let encode' t v = try Ok (encode t v) with Error e -> Result.Error e
1689
+
let encode t v = Result.map_error Error.to_string (encode' t v)
1690
+
1691
+
(* Recode *)
1692
+
1693
+
let update t v = enc t (dec t v)
1694
+
let recode' t v = try Ok (update t v) with Error e -> Result.Error e
1695
+
let recode t v = Result.map_error Error.to_string (recode' t v)
1696
+
end
1697
+
1698
+
let json_null =
1699
+
let dec meta () = Json.null ~meta () in
1700
+
let enc = function
1701
+
| Null ((), _) -> () | j -> Json.error_sort ~exp:Sort.Null j
1702
+
in
1703
+
Repr.Null (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1704
+
1705
+
let json_bool =
1706
+
let dec meta b = Json.bool ~meta b in
1707
+
let enc = function
1708
+
| Bool (b, _) -> b | j -> Json.error_sort ~exp:Sort.Bool j
1709
+
in
1710
+
Repr.Bool (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1711
+
1712
+
let json_number =
1713
+
let dec meta n = Json.number ~meta n in
1714
+
let enc = function
1715
+
| Number (n, _) -> n | j -> Json.error_sort ~exp:Sort.Number j
1716
+
in
1717
+
Repr.Number (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1718
+
1719
+
let json_string =
1720
+
let dec meta s = Json.string ~meta s in
1721
+
let enc = function
1722
+
| String (s, _) -> s | j -> Json.error_sort ~exp:Sort.String j
1723
+
in
1724
+
Repr.String (Base.map ~dec ~enc ~enc_meta:Json.meta ())
1725
+
1726
+
let json, json_array, mem_list, json_object =
1727
+
let rec elt = Repr.Rec any
1728
+
and array_map = lazy begin
1729
+
let dec_empty () = [] in
1730
+
let dec_add _i v a = v :: a in
1731
+
let dec_finish meta _len a = Json.list ~meta (List.rev a) in
1732
+
let enc f acc = function
1733
+
| Array (a, _) -> Array.list_enc f acc a
1734
+
| j -> Json.error_sort ~exp:Sort.Array j
1735
+
in
1736
+
let enc = { Array.enc = enc } in
1737
+
Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Json.meta elt
1738
+
end
1739
+
1740
+
and array = lazy (Array.array (Lazy.force array_map))
1741
+
and mems = lazy begin
1742
+
let dec_empty () = [] in
1743
+
let dec_add meta n v mems = ((n, meta), v) :: mems in
1744
+
let dec_finish _meta mems = List.rev mems in
1745
+
let enc f l a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
1746
+
let enc = { Object.Mems.enc = enc } in
1747
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc elt
1748
+
end
1749
+
1750
+
and object' = lazy begin
1751
+
let enc_meta = function
1752
+
| Object (_, meta) -> meta | j -> Json.error_sort ~exp:Sort.Object j
1753
+
in
1754
+
let enc = function
1755
+
| Object (mems, _) -> mems | j -> Json.error_sort ~exp:Sort.Object j
1756
+
in
1757
+
let dec meta mems = Object (mems, meta) in
1758
+
Object.map' dec ~enc_meta
1759
+
|> Object.keep_unknown (Lazy.force mems) ~enc
1760
+
|> Object.finish
1761
+
end
1762
+
1763
+
and any = lazy begin
1764
+
let json_array = Lazy.force array in
1765
+
let json_object = Lazy.force object' in
1766
+
let enc = function
1767
+
| Null _ -> json_null | Bool _ -> json_bool
1768
+
| Number _ -> json_number | String _ -> json_string
1769
+
| Array _ -> json_array | Object _ -> json_object
1770
+
in
1771
+
Repr.Any { kind = "json"; doc = "";
1772
+
dec_null = Some json_null; dec_bool = Some json_bool;
1773
+
dec_number = Some json_number; dec_string = Some json_string;
1774
+
dec_array = Some json_array;
1775
+
dec_object = Some json_object; enc }
1776
+
end
1777
+
in
1778
+
Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object'
1779
+
1780
+
let json_mems =
1781
+
let dec_empty () = [] in
1782
+
let dec_add meta name v mems = ((name, meta), v) :: mems in
1783
+
let dec_finish meta mems = Object (List.rev mems, meta) in
1784
+
let enc f j acc = match j with
1785
+
| Object (ms, _) -> List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms
1786
+
| j -> Json.error_sort ~exp:Sort.Object j
1787
+
in
1788
+
let enc = { Object.Mems.enc = enc } in
1789
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
1790
+
1791
+
(* Queries and updates *)
1792
+
1793
+
(* val app : ('a -> 'b) t -> 'a t -> 'b t
1794
+
val product : 'a t -> 'b t -> ('a * 'b) t
1795
+
val bind : 'a t -> ('a -> 'b t) -> 'b t
1796
+
val map : ('a -> 'b) -> 'a t -> 'b t *)
1797
+
1798
+
let const t v =
1799
+
let const _ = v in
1800
+
let dec = map ~dec:const ignore in
1801
+
let enc = map ~enc:const t in
1802
+
let enc _v = enc in
1803
+
any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec ~dec_array:dec
1804
+
~dec_object:dec ~enc ()
1805
+
1806
+
let recode ~dec:dom f ~enc =
1807
+
let m = map ~dec:f dom in
1808
+
let enc _v = enc in
1809
+
any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m
1810
+
~dec_object:m ~enc ()
1811
+
1812
+
let update t =
1813
+
let dec v = Json.update t v in
1814
+
Repr.Map { kind = ""; doc = ""; dom = json; dec; enc = Fun.id }
1815
+
1816
+
(* Array queries *)
1817
+
1818
+
let rec list_repeat n v l = if n <= 0 then l else list_repeat (n - 1) v (v :: l)
1819
+
1820
+
let nth ?absent n t =
1821
+
let dec_empty () = None in
1822
+
let dec_skip i _v = i <> n in
1823
+
let dec_add _i v _acc = Some v in
1824
+
let dec_finish meta len v = match v with
1825
+
| Some v -> v
1826
+
| None ->
1827
+
match absent with
1828
+
| Some v -> v
1829
+
| None -> Error.index_out_of_range meta ~n ~len
1830
+
in
1831
+
let enc f acc v = f acc 0 v in
1832
+
let enc = { Array.enc } in
1833
+
Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t)
1834
+
1835
+
let update_nth ?stub ?absent n t =
1836
+
let update_elt n t v = Json.copy_layout v ~dst:(Json.update t v) in
1837
+
let rec update_array ~seen n t i acc = function
1838
+
| v :: vs when i = n ->
1839
+
let elt = update_elt (i, Json.meta v) t v in
1840
+
update_array ~seen:true n t (i + 1) (elt :: acc) vs
1841
+
| v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs
1842
+
| [] when seen -> Either.Right (List.rev acc)
1843
+
| [] -> Either.Left (acc, i)
1844
+
in
1845
+
let update ?stub ?absent n t j = match j with
1846
+
| Array (vs, meta) ->
1847
+
begin match update_array ~seen:false n t 0 [] vs with
1848
+
| Either.Right elts -> Array (elts, meta)
1849
+
| Either.Left (acc, len) ->
1850
+
match absent with
1851
+
| None -> Error.index_out_of_range meta ~n ~len
1852
+
| Some absent ->
1853
+
let elt = Json.enc t absent in
1854
+
let stub = match stub with
1855
+
| None -> Json.zero elt | Some j -> j
1856
+
in
1857
+
Array (List.rev (elt :: list_repeat (n - len) stub acc), meta)
1858
+
end
1859
+
| j -> Json.error_sort ~exp:Sort.Array j
1860
+
in
1861
+
let dec = update ?stub ?absent n t in
1862
+
let enc j = j in
1863
+
map ~dec ~enc json
1864
+
1865
+
let set_nth ?stub ?(allow_absent = false) t n v =
1866
+
let absent = if allow_absent then Some v else None in
1867
+
update_nth ?stub ?absent n (const t v)
1868
+
1869
+
let delete_nth ?(allow_absent = false) n =
1870
+
let dec_empty () = [] in
1871
+
let dec_add i v a = if i = n then a else (v :: a) in
1872
+
let dec_finish meta len a =
1873
+
if n < len || allow_absent then Json.list ~meta (List.rev a) else
1874
+
Error.index_out_of_range meta ~n ~len
1875
+
in
1876
+
let enc f acc = function
1877
+
| Array (a, _) -> Array.list_enc f acc a
1878
+
| j -> Json.error_sort ~exp:Sort.Array j
1879
+
in
1880
+
let enc_meta j = Json.meta j in
1881
+
let enc = { Array.enc = enc } in
1882
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
1883
+
1884
+
let filter_map_array a b f =
1885
+
let dec_empty () = [] in
1886
+
let dec_add i v acc = match f i (Json.dec a v) with
1887
+
| None -> acc | Some v' -> (Json.enc b v') :: acc
1888
+
in
1889
+
let dec_finish meta _len acc = Json.list ~meta (List.rev acc) in
1890
+
let enc f acc = function
1891
+
| Array (a, _) -> Array.list_enc f acc a
1892
+
| j -> Json.error_sort ~exp:Sort.Array j
1893
+
in
1894
+
let enc = { Array.enc = enc } in
1895
+
let enc_meta j = Json.meta j in
1896
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta json)
1897
+
1898
+
let fold_array t f acc =
1899
+
let dec_empty () = acc in
1900
+
let dec_add = f in
1901
+
let dec_finish _meta _len acc = acc in
1902
+
let enc _f acc _a = acc in
1903
+
let enc = { Array.enc = enc } in
1904
+
Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t)
1905
+
1906
+
(* Object queries *)
1907
+
1908
+
let mem ?absent name t =
1909
+
Object.map Fun.id
1910
+
|> Object.mem name t ~enc:Fun.id ?dec_absent:absent
1911
+
|> Object.finish
1912
+
1913
+
let update_mem ?absent name t =
1914
+
let update_mem n t v = n, Json.copy_layout v ~dst:(Json.update t v) in
1915
+
let rec update_object ~seen name t acc = function
1916
+
| ((name', _ as n), v) :: mems when String.equal name name' ->
1917
+
update_object ~seen:true name t (update_mem n t v :: acc) mems
1918
+
| mem :: mems -> update_object ~seen name t (mem :: acc) mems
1919
+
| [] when seen -> Either.Right (List.rev acc)
1920
+
| [] -> Either.Left acc
1921
+
in
1922
+
let update ?absent name t = function
1923
+
| Object (mems, meta) ->
1924
+
let mems = match update_object ~seen:false name t [] mems with
1925
+
| Either.Right mems -> mems
1926
+
| Either.Left acc ->
1927
+
match absent with
1928
+
| None ->
1929
+
let fnd = Json.object_names mems in
1930
+
Error.missing_mems meta ~kinded_sort:"" ~exp:[name] ~fnd
1931
+
| Some absent ->
1932
+
let m = (name, Meta.none), Json.enc t absent in
1933
+
List.rev (m :: acc)
1934
+
in
1935
+
Object (mems, meta)
1936
+
| j -> Json.error_sort ~exp:Sort.Object j
1937
+
in
1938
+
let update = update ?absent name t in
1939
+
let enc j = j in
1940
+
map ~dec:update ~enc json
1941
+
1942
+
let set_mem ?(allow_absent = false) t name v =
1943
+
let absent = if allow_absent then Some v else None in
1944
+
update_mem ?absent name (const t v)
1945
+
1946
+
let update_json_object ~name ~dec_add ~dec_finish =
1947
+
let mems =
1948
+
let dec_empty () = false, [] in
1949
+
let enc f (_, l) a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in
1950
+
let enc = { Object.Mems.enc = enc } in
1951
+
Object.Mems.map ~dec_empty ~dec_add ~dec_finish ~enc json
1952
+
in
1953
+
let enc_meta = function
1954
+
| Object (_, meta) -> meta | j -> Json.error_sort ~exp:Sort.Object j
1955
+
in
1956
+
let enc = function
1957
+
| Object (mems, _) -> false, mems | j -> Json.error_sort ~exp:Sort.Object j
1958
+
in
1959
+
let dec meta (ok, mems) =
1960
+
let fnd = Json.object_names mems in
1961
+
if not ok
1962
+
then Error.missing_mems meta ~kinded_sort:"" ~exp:[name] ~fnd else
1963
+
Object (List.rev mems, meta)
1964
+
in
1965
+
Object.map' dec ~enc_meta
1966
+
|> Object.keep_unknown mems ~enc
1967
+
|> Object.finish
1968
+
1969
+
let delete_mem ?(allow_absent = false) name =
1970
+
let dec_add meta n v (ok, mems) =
1971
+
if n = name then true, mems else ok, ((n, meta), v) :: mems
1972
+
in
1973
+
let dec_finish _meta (ok, ms as a) = if allow_absent then (true, ms) else a in
1974
+
update_json_object ~name ~dec_add ~dec_finish
1975
+
1976
+
let fold_object t f acc =
1977
+
let mems =
1978
+
let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in
1979
+
let enc f _ acc = acc in
1980
+
Object.Mems.map t ~dec_empty ~dec_add ~dec_finish ~enc:{ Object.Mems.enc }
1981
+
in
1982
+
Object.map Fun.id
1983
+
|> Object.keep_unknown mems ~enc:Fun.id
1984
+
|> Object.finish
1985
+
1986
+
let filter_map_object a b f =
1987
+
let dec_add meta n v (_, mems) =
1988
+
match f meta n (Json.dec a v) with
1989
+
| None -> (true, mems)
1990
+
| Some (n', v') -> (true, (n', (Json.enc b v')) :: mems)
1991
+
in
1992
+
let dec_finish _meta acc = acc in
1993
+
update_json_object ~name:"" (* irrelevant *) ~dec_add ~dec_finish
1994
+
1995
+
(* Index queries *)
1996
+
1997
+
let index ?absent i t = match i with
1998
+
| Path.Nth (n, _) -> nth ?absent n t
1999
+
| Path.Mem (n, _) -> mem ?absent n t
2000
+
2001
+
let set_index ?allow_absent t i v = match i with
2002
+
| Path.Nth (n, _) -> set_nth ?allow_absent t n v
2003
+
| Path.Mem (n, _) -> set_mem ?allow_absent t n v
2004
+
2005
+
let update_index ?stub ?absent i t = match i with
2006
+
| Path.Nth (n, _) -> update_nth ?stub ?absent n t
2007
+
| Path.Mem (n, _) -> update_mem ?absent n t
2008
+
2009
+
let delete_index ?allow_absent = function
2010
+
| Path.Nth (n, _) -> delete_nth ?allow_absent n
2011
+
| Path.Mem (n, _) -> delete_mem ?allow_absent n
2012
+
2013
+
(* Path queries *)
2014
+
2015
+
let path ?absent p q =
2016
+
List.fold_left (fun q i -> index ?absent i q) q (Path.rev_indices p)
2017
+
2018
+
let update_path ?stub ?absent p t = match Path.rev_indices p with
2019
+
| [] -> update t
2020
+
| i :: is ->
2021
+
match absent with
2022
+
| None ->
2023
+
let update t i = update_index i t in
2024
+
List.fold_left update (update_index i t) is
2025
+
| Some absent ->
2026
+
let rec loop absent t = function
2027
+
| Path.Nth (n, _) :: is ->
2028
+
loop Json.empty_array (update_nth ~absent n t) is
2029
+
| Path.Mem (n, _) :: is ->
2030
+
loop Json.empty_object (update_mem ~absent n t) is
2031
+
| [] -> t
2032
+
in
2033
+
match i with
2034
+
| Path.Nth (n, _) ->
2035
+
loop Json.empty_array (update_nth ?stub ~absent n t) is
2036
+
| Path.Mem (n, _) ->
2037
+
loop Json.empty_object (update_mem ~absent n t) is
2038
+
2039
+
let delete_path ?allow_absent p = match Path.rev_indices p with
2040
+
| [] -> recode ~dec:ignore (fun () -> Json.null') ~enc:json
2041
+
| i :: is ->
2042
+
let upd del i = update_index i del in
2043
+
List.fold_left upd (delete_index ?allow_absent i) is
2044
+
2045
+
let set_path ?stub ?(allow_absent = false) t p v = match Path.rev_indices p with
2046
+
| [] -> recode ~dec:ignore (fun () -> Json.enc t v) ~enc:json
2047
+
| i :: is ->
2048
+
let absent = if allow_absent then Some v else None in
2049
+
update_path ?stub ?absent p (const t v)
2050
+
2051
+
(* Formatting *)
2052
+
2053
+
type format = Minify | Indent | Layout
2054
+
type number_format = Fmt.json_number_format
2055
+
let default_number_format = Fmt.json_default_number_format
2056
+
let pp_value ?number_format t () = fun ppf v -> match Json.encode t v with
2057
+
| Ok j -> pp_json' ?number_format () ppf j
2058
+
| Error e -> pp_string ppf e
+2056
vendor/opam/jsont/src/jsont.mli
+2056
vendor/opam/jsont/src/jsont.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
10
+
values {e JSON types}.
11
+
12
+
In these maps the {e decoding} direction maps from JSON values to
13
+
OCaml values and the {e encoding} direction maps from OCaml values
14
+
to JSON values. Depending on your needs, one direction or the
15
+
other can be left unspecified. Some of the decoding maps may be
16
+
lossy or creative which leads to JSON 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
29
+
by an inclusive range of absolute {{!Textloc.type-byte_pos}byte} positions
30
+
and the {{!Textloc.type-line_pos}line positions} on which those occur. *)
31
+
module Textloc : sig
32
+
33
+
(** {1:fpath File paths} *)
34
+
35
+
type fpath = string
36
+
(** The type for file paths. *)
37
+
38
+
val file_none : fpath
39
+
(** [file_none] is ["-"]. A file path to use when there is none. *)
40
+
41
+
(** {1:pos Positions} *)
42
+
43
+
(** {2:byte_pos Byte positions} *)
44
+
45
+
type byte_pos = int
46
+
(** The type for zero-based, absolute, byte positions in text. If
47
+
the text has [n] bytes, [0] is the first position and [n-1] is
48
+
the last position. *)
49
+
50
+
val byte_pos_none : byte_pos
51
+
(** [byte_pos_none] is [-1]. A position to use when there is none. *)
52
+
53
+
(** {2:lines Lines} *)
54
+
55
+
type line_num = int
56
+
(** The type for one-based, line numbers in the text. Lines
57
+
increment after a {e newline} which is either a line feed ['\n']
58
+
(U+000A), a carriage return ['\r'] (U+000D) or a carriage return
59
+
and a line feed ["\r\n"] (<U+000D,U+000A>). *)
60
+
61
+
val line_num_none : line_num
62
+
(** [line_num_none] is [-1]. A line number to use when there is none. *)
63
+
64
+
(** {2:line_pos Line positions} *)
65
+
66
+
type line_pos = line_num * byte_pos
67
+
(** The type for line positions. This identifies a line by its line
68
+
number and the absolute byte position following its newline
69
+
(or the start of text for the first line). That byte position:
70
+
{ul
71
+
{- Indexes the first byte of text of the line if the line is non-empty.}
72
+
{- Indexes the first byte of the next {e newline} sequence if the line
73
+
is empty.}
74
+
{- Is out of bounds and equal to the text's length for a last empty
75
+
line. This is also the case on empty text.}} *)
76
+
77
+
val line_pos_first : line_pos
78
+
(** [line_pos_first] is [1, 0]. Note that this is the only line position
79
+
of the empty text. *)
80
+
81
+
val line_pos_none : line_pos
82
+
(** [line_pos_none] is [(line_pos_none, pos_pos_none)]. *)
83
+
84
+
(** {1:tloc Text locations} *)
85
+
86
+
type t
87
+
(** The type for text locations. A text location identifies a text
88
+
span in an UTF-8 encoded file by an inclusive range of absolute
89
+
{{!type-byte_pos}byte positions} and the {{!type-line_pos}line
90
+
positions} on which they occur.
91
+
92
+
If the first byte equals the last byte the range contains
93
+
exactly that byte. If the first byte is greater than the last
94
+
byte this represents an insertion point before the first
95
+
byte. In this case information about the last position should
96
+
be ignored: it can contain anything. *)
97
+
98
+
val none : t
99
+
(** [none] is a position to use when there is none. *)
100
+
101
+
val make :
102
+
file:fpath -> first_byte:byte_pos -> last_byte:byte_pos ->
103
+
first_line:line_pos -> last_line:line_pos -> t
104
+
(** [v ~file ~first_byte ~last_byte ~first_line ~last_line] is a text
105
+
location with the given arguments, see corresponding accessors for
106
+
the semantics. 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
116
+
[true]. *)
117
+
118
+
val last_byte : t -> byte_pos
119
+
(** [last_byte l] is [l]'s last byte. Irrelevant if {!is_none} or
120
+
{!is_empty} is [true]. *)
121
+
122
+
val first_line : t -> line_pos
123
+
(** [first_line l] is the line position on which [first_byte l] lies.
124
+
Irrelevant if {!is_none} is [true].*)
125
+
126
+
val last_line : t -> line_pos
127
+
(** [last_line l] is the line position on which [last_byte l] lies.
128
+
Irrelevant if {!is_none} or {!is_empty} is [true].*)
129
+
130
+
(** {2:preds Predicates and comparisons} *)
131
+
132
+
val is_none : t -> bool
133
+
(** [is_none t] is [true] iff [first_byte < 0]. *)
134
+
135
+
val is_empty : t -> bool
136
+
(** [is_empty t] is [true] iff [first_byte t > last_byte t]. *)
137
+
138
+
val equal : t -> t -> bool
139
+
(** [equal t0 t1] is [true] iff [t0] and [t1] are equal. This checks
140
+
that {!file}, {!first_byte} and {!last_byte} are equal. Line information
141
+
is ignored. *)
142
+
143
+
val compare : t -> t -> int
144
+
(** [compare t0 t1] orders [t0] and [t1]. The order is compatible
145
+
with {!equal}. Comparison starts with {!file}, follows with
146
+
{!first_byte} and ends, if needed, with {!last_byte}. Line
147
+
information is ignored. *)
148
+
149
+
(** {2:shrink_and_stretch Shrink and stretch} *)
150
+
151
+
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
152
+
(** [set_first l ~first_byte ~first_line] sets the the first position of
153
+
[l] to given values. *)
154
+
155
+
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
156
+
(** [set_last l ~last_byte ~last_line] sets the last position of [l]
157
+
to given values. *)
158
+
159
+
val to_first : t -> t
160
+
(** [to_first l] has both first and last positions set to [l]'s first
161
+
position. The range spans {!first_byte}. See also {!before}. *)
162
+
163
+
val to_last : t -> t
164
+
(** [to_last l] has both first and last positions set to [l]'s last
165
+
position. The range spans {!last_byte}. See also {!after}. *)
166
+
167
+
val before : t -> t
168
+
(** [before t] is the {{!is_empty}empty} text location starting at
169
+
{!first_byte}. *)
170
+
171
+
val after : t -> t
172
+
(** [after t] is the empty {{!is_empty}empty} location starting at
173
+
[last_byte t + 1]; note that at the end of input this may be an
174
+
invalid byte {e index}. The {!first_line} and {!last_line} of the
175
+
result is [last_line t]. *)
176
+
177
+
val span : t -> t -> t
178
+
(** [span l0 l1] is the span from the smallest byte position of [l0] and
179
+
[l1] to the largest byte position of [l0] and [l1]. The file path is
180
+
taken from the greatest byte position. *)
181
+
182
+
val reloc : first:t -> last:t -> t
183
+
(** [reloc ~first ~last] uses the first position of [first], the
184
+
last position of [last] and the file of [last]. *)
185
+
186
+
(** {2:fmt Formatting} *)
187
+
188
+
val pp_ocaml : Format.formatter -> t -> unit
189
+
(** [pp_ocaml] formats text locations like the OCaml compiler. *)
190
+
191
+
val pp_gnu : Format.formatter -> t -> unit
192
+
(** [pp_gnu] formats text locations according to the
193
+
{{:https://www.gnu.org/prep/standards/standards.html#Errors}GNU
194
+
convention}. *)
195
+
196
+
val pp : Format.formatter -> t -> unit
197
+
(** [pp] is {!pp_ocaml}. *)
198
+
199
+
val pp_dump : Format.formatter -> t -> unit
200
+
(** [pp_dump] formats raw data for debugging. *)
201
+
end
202
+
203
+
(** Abstract syntax tree node metadata.
204
+
205
+
This type keeps information about source text locations
206
+
and whitespace. *)
207
+
module Meta : sig
208
+
type t
209
+
(** The type for node metadata. *)
210
+
211
+
val make : ?ws_before:string -> ?ws_after:string -> Textloc.t -> t
212
+
(** [make textloc ~ws_before ~ws_after] is metadata with text location
213
+
[textloc] whitespace [ws_before] before the node and [ws_after] after
214
+
the node. Both default to [""]. *)
215
+
216
+
val none : t
217
+
(** [none] is metadata for when there is none. Its {!textloc}
218
+
is {!Textloc.none} and its whitespace is empty. *)
219
+
220
+
val is_none : t -> bool
221
+
(** [is_none m] is [true] iff [m] is {!none}. *)
222
+
223
+
val textloc : t -> Textloc.t
224
+
(** [textloc m] is the text location of [m]. *)
225
+
226
+
val ws_before : t -> string
227
+
(** [ws_before m] is source whitespace before the node. *)
228
+
229
+
val ws_after : t -> string
230
+
(** [ws_after m] is source whitespace after the node. *)
231
+
232
+
val with_textloc : t -> Textloc.t -> t
233
+
(** [with_textloc m l] is [m] with text location [l] *)
234
+
235
+
val clear_ws : t -> t
236
+
(** [clear_ws m] is [m] with {!ws_before} and {!ws_after} set to [""]. *)
237
+
238
+
val clear_textloc : t -> t
239
+
(** [clear_textloc m] is [m] with {!textloc} set to {!Textloc.none}. *)
240
+
241
+
val copy_ws : t -> dst:t -> t
242
+
(** [copy_ws src ~dst] copies {!ws_before} and {!ws_after} of [src]
243
+
to [dst]. *)
244
+
end
245
+
246
+
type 'a node = 'a * Meta.t
247
+
(** The type for abstract syntax tree nodes.
248
+
The node data of type ['a] and its metadata. *)
249
+
250
+
(** JSON paths.
251
+
252
+
Paths are used for keeping track of erroring
253
+
{{!Error.Context.t}contexts} and for specifying {{!Jsont.queries}
254
+
query and update}
255
+
locations. *)
256
+
module Path : sig
257
+
258
+
(** {1:indices Indices} *)
259
+
260
+
type index =
261
+
| Mem of string node (** Indexes the value of the member [n] of an object. *)
262
+
| Nth of int node (** Indexes the value of the [n]th element of an array. *)
263
+
(** The type for indexing operations on JSON values. *)
264
+
265
+
val pp_index : index fmt
266
+
(** [pp_index] formats indexes. *)
267
+
268
+
val pp_index_trace : index fmt
269
+
(** [pp_index] formats indexes and their location. *)
270
+
271
+
(** {1:path Paths} *)
272
+
273
+
type t
274
+
(** The type for paths, a sequence of indexing operations. *)
275
+
276
+
val root : t
277
+
(** [root] is the root path. *)
278
+
279
+
val is_root : t -> bool
280
+
(** [is_root p] is [true] iff [p] is the root path. *)
281
+
282
+
val nth : ?meta:Meta.t -> int -> t -> t
283
+
(** [nth n p] indexes the array indexed by [p] at index [n]. *)
284
+
285
+
val mem : ?meta:Meta.t -> string -> t -> t
286
+
(** [mem n p] indexes the object indexed by [p] at member [n]. *)
287
+
288
+
val rev_indices : t -> index list
289
+
(** [rev_indices p] are the indices of [p] in reverse order, the last
290
+
indexing operation appears first. *)
291
+
292
+
val of_string : string -> (t, string) result
293
+
(** [of_string s] parses a path according to the
294
+
{{!Path.path_syntax}path syntax}. *)
295
+
296
+
val pp : t fmt
297
+
(** [pp] formats paths. *)
298
+
299
+
val pp_trace : t fmt
300
+
(** [pp_trace] formats paths as a stack trace, if not empty. *)
301
+
302
+
(** {1:path_syntax Path syntax}
303
+
304
+
Path provide a way for end users to address JSON and edit locations.
305
+
306
+
A {e path} is a sequence of member and list indexing
307
+
operations. Applying the path to a JSON value leads to either a
308
+
JSON value, or nothing if one of the indices does not exist, or
309
+
an error if ones tries to index a non-indexable value.
310
+
311
+
Here are a few examples of paths.
312
+
313
+
{@json[
314
+
{
315
+
"ocaml": {
316
+
"libs": ["jsont", "brr", "cmdliner"]
317
+
}
318
+
}
319
+
]}
320
+
321
+
{@shell[
322
+
ocaml.libs # value of member "libs" of member "ocaml"
323
+
ocaml.libs.[0] # first element of member "libs" of member "ocaml"
324
+
]}
325
+
326
+
More formally a {e path} is a [.] seperated list of indices. An
327
+
{e index} is written [[i]]. [i] can a zero-based list index. Or
328
+
[i] can be an object member name [n]. If there is no ambiguity,
329
+
the surrounding brackets can be dropped.
330
+
331
+
{b Notes.}
332
+
{ul
333
+
{- The syntax has no form of quoting at the moment this
334
+
means key names can't contain, [\[], [\]], or start with a number.}
335
+
{- It would be nice to be able to drop the dots in order
336
+
to be compatible with {{:https://www.rfc-editor.org/rfc/rfc9535}
337
+
JSONPath} syntax.}
338
+
{- Reintroduce and implement negative indices (they are parsed).}} *)
339
+
end
340
+
341
+
(** Sorts of JSON values. *)
342
+
module Sort : sig
343
+
type t =
344
+
| Null (** Nulls *)
345
+
| Bool (** Booleans *)
346
+
| Number (** Numbers *)
347
+
| String (** Strings *)
348
+
| Array (** Arrays *)
349
+
| Object (** Objects *)
350
+
(** The type for sorts of JSON values. *)
351
+
352
+
val to_string : t -> string
353
+
(** [to_string sort] is a string for sort [sort]. *)
354
+
355
+
val pp : Format.formatter -> t -> unit
356
+
(** [pp] formats sorts. *)
357
+
358
+
(** {1:kinds Kinds}
359
+
360
+
For formatting error messages. *)
361
+
362
+
val or_kind : kind:string -> t -> string
363
+
(** [or_kind ~kind sort] is [to_string sort] if [kind] is [""] and
364
+
[kind] otherwise. *)
365
+
366
+
val kinded : kind:string -> t -> string
367
+
(** [kinded ~kind sort] is [to_string sort] if [kind] is [""]
368
+
and [String.concat " " [kind; to_string sort]] otherwise. *)
369
+
370
+
val kinded' : kind:string -> string -> string
371
+
(** [kinded' ~kind sort] is [sort] if [kind] is [""]
372
+
and [String.concat " " [kind; sort]] otherwise. *)
373
+
end
374
+
375
+
(** Encoding, decoding and query errors. *)
376
+
module Error : sig
377
+
378
+
(** {1:kinds Kinds of errors} *)
379
+
380
+
type kind
381
+
(** The type for kind of errors. *)
382
+
383
+
val kind_to_string : kind -> string
384
+
(** [kind_to_string kind] is [kind] as a string. *)
385
+
386
+
(** {1:errors Errors} *)
387
+
388
+
(** JSON error contexts. *)
389
+
module Context : sig
390
+
391
+
type index = string node * Path.index
392
+
(** The type for context indices. The {{!Jsont.kinded_sort}kinded sort} of
393
+
an array or object and its index. *)
394
+
395
+
type t = index list
396
+
(** The type for erroring contexts. The first element indexes the
397
+
root JSON value. *)
398
+
399
+
val empty : t
400
+
(** [empty] is the empty context. *)
401
+
402
+
val is_empty : t -> bool
403
+
(** [is_empty ctx] is [true] iff [ctx] is {!empty}. *)
404
+
405
+
val push_array : string node -> int node -> t -> t
406
+
(** [push_array kinded_sort n ctx] wraps [ctx] as the [n]th element of an
407
+
array of {{!Jsont.kinded_sort}kinded sort} [kinded_sort]. *)
408
+
409
+
val push_object : string node -> string node -> t -> t
410
+
(** [push_object kinded_sort n ctx] wraps [ctx] as the member named [n] of
411
+
an object of {{!Jsont.kinded_sort}kinded sort} [kinded_sort]. *)
412
+
end
413
+
414
+
type t = Context.t * Meta.t * kind
415
+
(** The type for errors. The context, the error localisation and the
416
+
kind of error. *)
417
+
418
+
val raise : Context.t -> Meta.t -> kind -> 'a
419
+
(** [raise ctx meta k] raises an error with given paramters. *)
420
+
421
+
val make_msg : Context.t -> Meta.t -> string -> t
422
+
(** [make_msg ctx meta msg] is an error with message [msg] for meta [meta]
423
+
in context [ctx]. *)
424
+
425
+
val msg : Meta.t -> string -> 'a
426
+
(** [msg meta msg] raises an error with message [msg] for meta
427
+
[meta] in an empty context. *)
428
+
429
+
val msgf : Meta.t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a
430
+
(** [msgf meta fmt …] is like {!val-msg} but formats an error message. *)
431
+
432
+
val expected : Meta.t -> string -> fnd:string -> 'a
433
+
(** [expected meta fmt exp ~fnd] is
434
+
[msgf "Expected %s but found %s" exp fnd]. *)
435
+
436
+
val push_array : string node -> int node -> t -> 'a
437
+
(** [push_array kinded_sort n e] contextualises [e] as an error in the
438
+
[n]th element of an array of {{!Jsont.kinded_sort}kinded sort}
439
+
[kinded_sort]. *)
440
+
441
+
val push_object : string node -> string node -> t -> 'a
442
+
(** [push_object kinded_sort n e] contextualises [e] as an error in
443
+
the member [n] of an object of {{!Jsont.kinded_sort}kinded sort}
444
+
[kinded_sort]. *)
445
+
446
+
val adjust_context :
447
+
first_byte:Textloc.byte_pos -> first_line:Textloc.line_pos -> t -> 'a
448
+
(** [adjust_context ~first_byte ~first_line] adjusts the error's
449
+
context's meta to encompass the given positions. *)
450
+
451
+
(** {1:fmt Formatting} *)
452
+
453
+
val to_string : t -> string
454
+
(** [error_to_string e] formats [e] using {!val-pp} to a string. *)
455
+
456
+
val pp : t fmt
457
+
(** [pp_error] formats errors. *)
458
+
459
+
val puterr : unit fmt
460
+
(** [puterr] formats [Error:] in red. *)
461
+
462
+
(**/**)
463
+
val disable_ansi_styler : unit -> unit
464
+
(**/**)
465
+
end
466
+
467
+
exception Error of Error.t
468
+
(** The exception raised on map errors. In general codec and query
469
+
functions turn that for you into a {!result} value. *)
470
+
471
+
(** {1:types Types} *)
472
+
473
+
type 'a t
474
+
(** The type for JSON types.
475
+
476
+
A value of this type represents a subset of JSON values mapped to
477
+
a subset of values of type ['a] and vice versa. *)
478
+
479
+
val kinded_sort : 'a t -> string
480
+
(** [kinded_sort t] is a human readable string describing the JSON
481
+
values typed by [t]. This combines the kind of the map with the
482
+
{{!Sort}sort}(s) of JSON value mapped by [t]. For example if [t]
483
+
is an object map and the kind specified for the
484
+
{{!Object.val-map}map} is ["T"] then this is ["T object"], if the
485
+
kind is empty this is simply ["object"]. See also
486
+
{!Sort.kinded}. *)
487
+
488
+
val kind : 'a t -> string
489
+
(** [kind t] is the [kind] of the underlying map. If the kind is an
490
+
empty string this falls back to mention the {{!Sort}sort}. For
491
+
example if [t] is an object map and the kind specified for the
492
+
{{!Object.val-map}map} is ["T"] then this is ["T"], if the kind is
493
+
empty then this is ["object"]. See also {!Sort.or_kind}. *)
494
+
495
+
val doc : 'a t -> string
496
+
(** [doc t] is a documentation string for the JSON values typed by [t]. *)
497
+
498
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
499
+
(** [with_doc ?kind ?doc t] is [t] with its {!doc} or {!kind}
500
+
updated to the corresponding values if specified. *)
501
+
502
+
(** {1:base Base types}
503
+
504
+
Read the {{!page-cookbook.base_types}cookbook} on base types. *)
505
+
506
+
(** Mapping JSON base types. *)
507
+
module Base : sig
508
+
509
+
(** {1:maps Maps} *)
510
+
511
+
type ('a, 'b) map
512
+
(** The type for mapping JSON values of type ['a] to values of type ['b]. *)
513
+
514
+
val map :
515
+
?kind:string -> ?doc:string -> ?dec:(Meta.t -> 'a -> 'b) ->
516
+
?enc:('b -> 'a) -> ?enc_meta:('b -> Meta.t) ->
517
+
unit -> ('a, 'b) map
518
+
(** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types
519
+
represented by value of type ['a] to values of type ['b] with:
520
+
{ul
521
+
{- [kind] names the entities represented by the map and [doc]
522
+
documents them. Both default to [""].}
523
+
{- [dec] is used to decode values of type ['a] to values of
524
+
type ['b]. Can be omitted if the map is only used for
525
+
encoding, the default unconditionally errors.}
526
+
{- [enc] is used to encode values of type ['b] to values of
527
+
type ['a]. Can be omitted if the map is only used for
528
+
decoding, the default unconditionally errors.}
529
+
{- [enc_meta] is used to recover JSON metadata (source text
530
+
layout information) from a value to encode. The default
531
+
unconditionnaly returns {!Jsont.Meta.none}.}}
532
+
533
+
{{!decenc}These functions} can be used to quickly devise
534
+
[dec] and [enc] functions from standard OCaml conversion
535
+
interfaces. *)
536
+
537
+
val id : ('a, 'a) map
538
+
(** [id] is the identity map. *)
539
+
540
+
val ignore : ('a, unit) map
541
+
(** [ignore] is the ignoring map. It ignores decodes and errors on
542
+
encodes. *)
543
+
544
+
(** {2:types JSON types} *)
545
+
546
+
val null : (unit, 'a) map -> 'a t
547
+
(** [null map] maps with [map] JSON nulls represented by [()] to
548
+
values of type ['a]. See also {!Jsont.null}. *)
549
+
550
+
val bool : (bool, 'a) map -> 'a t
551
+
(** [bool map] maps with [map] JSON booleans represented by [bool]
552
+
values to values of type ['a]. See also {!Jsont.bool}. *)
553
+
554
+
val number : (float, 'a) map -> 'a t
555
+
(** [number map] maps with [map] JSON nulls or numbers represented by
556
+
[float] values to values of type ['a]. The [float]
557
+
representation decodes JSON nulls to {!Float.nan} and lossily
558
+
encodes any {{!Float.is_finite}non-finite} to JSON null
559
+
({{!page-cookbook.non_finite_numbers}explanation}). See also
560
+
{!Jsont.number}. *)
561
+
562
+
val string : (string, 'a) map -> 'a t
563
+
(** [string map] maps with [map] {e unescaped} JSON strings represented
564
+
by UTF-8 encoded [string] values to values of type ['a]. See
565
+
also {!Jsont.string}. *)
566
+
567
+
(** {1:decenc Decoding and encoding functions}
568
+
569
+
These function create suitable [dec] and [enc] functions
570
+
to give to {!val-map} from standard OCaml conversion interfaces.
571
+
See also {!Jsont.of_of_string}. *)
572
+
573
+
val dec : ('a -> 'b) -> (Meta.t -> 'a -> 'b)
574
+
(** [dec f] is a decoding function from [f]. This assumes [f] never fails. *)
575
+
576
+
val dec_result :
577
+
?kind:string -> ('a -> ('b, string) result) -> (Meta.t -> 'a -> 'b)
578
+
(** [dec f] is a decoding function from [f]. [Error _] values are given to
579
+
{!Error.msg}, prefixed by [kind:] (if specified). *)
580
+
581
+
val dec_failure : ?kind:string -> ('a -> 'b) -> (Meta.t -> 'a -> 'b)
582
+
(** [dec f] is a decoding function from [f]. [Failure _] exceptions
583
+
are catched and given to {!Error.msg}, prefixed by [kind:] (if
584
+
specified). *)
585
+
586
+
val enc : ('b -> 'a) -> ('b -> 'a)
587
+
(** [enc f] is an encoding function from [f]. This assumes [f] never fails. *)
588
+
589
+
val enc_result : ?kind:string -> ('b -> ('a, string) result) -> ('b -> 'a)
590
+
(** [enc_result f] is an encoding function from [f]. [Error _] values are
591
+
given to {!Error.msg}, prefixed by [kind:] (if specified). *)
592
+
593
+
val enc_failure : ?kind:string -> ('b -> 'a) -> ('b -> 'a)
594
+
(** [enc_failure f] is an encoding function from [f]. [Failure _]
595
+
exceptions are catched and given to {!Error.msg}, prefixed by [kind:]
596
+
(if specified). *)
597
+
end
598
+
599
+
(** {2:option Nulls and options}
600
+
601
+
Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *)
602
+
603
+
val null : ?kind:string -> ?doc:string -> 'a -> 'a t
604
+
(** [null v] maps JSON nulls to [v]. On encodes any value of type ['a]
605
+
is encoded by null. [doc] and [kind] are given to the underlying
606
+
{!Base.type-map}. See also {!Base.null}. *)
607
+
608
+
val none : 'a option t
609
+
(** [none] maps JSON nulls to [None]. *)
610
+
611
+
val some : 'a t -> 'a option t
612
+
(** [some t] maps JSON like [t] does but wraps results in [Some].
613
+
Encoding fails if the value is [None]. *)
614
+
615
+
val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t
616
+
(** [option t] maps JSON nulls to [None] and other values by [t].
617
+
[doc] and [kind] are given to the underlying {!val-any} map. *)
618
+
619
+
(** {2:booleans Booleans} *)
620
+
621
+
val bool : bool t
622
+
(** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *)
623
+
624
+
(** {2:numbers Numbers}
625
+
626
+
Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON
627
+
numbers and their many pitfalls. *)
628
+
629
+
val number : float t
630
+
(** [number] maps JSON nulls or numbers to [float] values. On decodes
631
+
JSON null is mapped to {!Float.nan}. On encodes any
632
+
{{!Float.is_finite}non-finite} float is lossily mapped to JSON
633
+
null ({{!page-cookbook.non_finite_numbers}explanation}). See also
634
+
{!Base.number}, {!any_float} and the integer combinators below. *)
635
+
636
+
val any_float : float t
637
+
(** [any_float] is a lossless representation for IEEE 754 doubles. It
638
+
maps {{!Float.is_finite}non-finite} floats by the JSON strings
639
+
defined by {!Float.to_string}. This contrasts with {!val-number}
640
+
which maps them to JSON null values
641
+
({{!page-cookbook.non_finite_numbers}explanation}). Note that on
642
+
decodes this still maps JSON nulls to {!Float.nan} and any
643
+
successful string decode of {!Float.of_string_opt} (so numbers can
644
+
also be written as strings). See also {!val-number}.
645
+
646
+
{b Warning.} [any_float] should only be used between parties that
647
+
have agreed on such an encoding. To maximize interoperability you
648
+
should use the lossy {!val-number} map. *)
649
+
650
+
val float_as_hex_string : float t
651
+
(** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex
652
+
notation to float values. On encodes strings this uses the ["%h"]
653
+
format string. On decodes it accepts anything sucessfully decoded
654
+
by {!Float.of_string_opt}. *)
655
+
656
+
val uint8 : int t
657
+
(** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers
658
+
are sucessfully decoded if after truncation they can be represented
659
+
on the \[0;255\] range. Encoding errors if the integer is out of
660
+
range.*)
661
+
662
+
val uint16 : int t
663
+
(** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers
664
+
are sucessfully decoded if after truncation they can be represented
665
+
on the \[0;65535\] range. Encoding errors if the integer is out of
666
+
range.*)
667
+
668
+
val int8 : int t
669
+
(** [int8] maps JSON numbers to 8-bit integers. JSON numbers
670
+
are sucessfully decoded if after truncation they can be represented
671
+
on the \[-128;127\] range. Encoding errors if the integer is out of
672
+
range.*)
673
+
674
+
val int16 : int t
675
+
(** [int16] maps JSON numbers to 16-bit integers. JSON numbers
676
+
are sucessfully decoded if after truncation they can be represented
677
+
on the \[-32768;32767\] range. Encoding errors if the integer is out
678
+
of range. *)
679
+
680
+
val int32 : int32 t
681
+
(** [int32] maps JSON numbers to 32-bit integers. JSON numbers
682
+
are sucessfully decoded if after truncation they can be represented
683
+
on the [int32] range, otherwise the decoder errors. *)
684
+
685
+
val int64 : int64 t
686
+
(** [int] maps truncated JSON numbers or JSON strings to 64-bit
687
+
integers.
688
+
{ul
689
+
{- JSON numbers are sucessfully decoded if after truncation they can
690
+
be represented on the [int64] range, otherwise the decoder
691
+
errors. [int64] values are encoded as JSON numbers if the
692
+
integer is in the \[-2{^53};2{^53}\] range.}
693
+
{- JSON strings are decoded using {!int_of_string_opt}, this
694
+
allows binary, octal, decimal and hex syntaxes and errors on
695
+
overflow and syntax errors. [int] values are encoded as JSON
696
+
strings with {!Int.to_string} when the integer is outside the
697
+
\[-2{^53};2{^53}\] range}} *)
698
+
699
+
val int64_as_string : int64 t
700
+
(** [int64_as_string] maps JSON strings to 64-bit integers. On decodes
701
+
this uses {!Int64.of_string_opt} which allows binary, octal,
702
+
decimal and hex syntaxes and errors on overflow and syntax
703
+
errors. On encodes uses {!Int64.to_string}. *)
704
+
705
+
val int : int t
706
+
(** [int] maps truncated JSON numbers or JSON strings to [int] values.
707
+
{ul
708
+
{- JSON numbers are sucessfully decoded if after truncation they can
709
+
be represented on the [int] range, otherwise the decoder
710
+
errors. [int] values are encoded as JSON numbers if the
711
+
integer is in the \[-2{^53};2{^53}\] range.}
712
+
{- JSON strings are decoded using {!int_of_string_opt}, this
713
+
allows binary, octal, decimal and hex syntaxes and errors on
714
+
overflow and syntax errors. [int] values are encoded as JSON
715
+
strings with {!Int.to_string} when the integer is outside the
716
+
\[-2{^53};2{^53}\] range}}
717
+
718
+
{b Warning.} The behaviour of this function is platform
719
+
dependent, it depends on the value of {!Sys.int_size}. *)
720
+
721
+
val int_as_string : int t
722
+
(** [int_as_string] maps JSON strings to [int] values. On
723
+
decodes this uses {!int_of_string_opt} which allows binary,
724
+
octal, decimal and hex syntaxes and errors on overflow and
725
+
syntax errors. On encodes uses {!Int.to_string}.
726
+
727
+
{b Warning.} The behaviour of this function is platform
728
+
dependent, it depends on the value of {!Sys.int_size}. *)
729
+
730
+
(** {2:enums Strings and enums}
731
+
732
+
Read the {{!page-cookbook.transform_strings}cookbook} on
733
+
transforming strings. *)
734
+
735
+
val string : string t
736
+
(** [string] maps unescaped JSON strings to UTF-8 encoded [string]
737
+
values. See also {!Base.string}.
738
+
739
+
{b Warning.} Encoders assume OCaml [string]s have been checked for
740
+
UTF-8 validity. *)
741
+
742
+
val of_of_string : ?kind:string -> ?doc:string ->
743
+
?enc:('a -> string) -> (string -> ('a, string) result) -> 'a t
744
+
(** [of_of_string of_string] maps JSON string with a
745
+
{{!Base.type-map}base map} using [of_string] for decoding and [enc] for
746
+
encoding. See the {{!page-cookbook.transform_strings}cookbook}. *)
747
+
748
+
val enum :
749
+
?cmp:('a -> 'a -> int) -> ?kind:string -> ?doc:string ->
750
+
(string * 'a) list -> 'a t
751
+
(** [enum assoc] maps JSON strings member of the [assoc] list to the
752
+
corresponding OCaml value and vice versa in log(n).
753
+
[cmp] is used to compare the OCaml values, it defaults to {!Stdlib.compare}.
754
+
Decoding and encoding errors on strings or values not part of
755
+
[assoc] *)
756
+
757
+
val binary_string : string t
758
+
(** [binary_string] maps JSON strings made of an even number of
759
+
hexdecimal US-ASCII upper or lower case digits to the corresponding
760
+
byte sequence. On encoding uses only lower case hexadecimal
761
+
digits to encode the byte sequence. *)
762
+
763
+
(** {1:arrays Arrays and tuples}
764
+
765
+
Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays
766
+
and see also {{!array_queries}array queries and updates}. *)
767
+
768
+
(** Mapping JSON arrays. *)
769
+
module Array : sig
770
+
771
+
(** {1:maps Maps} *)
772
+
773
+
type ('array, 'elt) enc =
774
+
{ enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc }
775
+
(** The type for specifying array encoding functions. A function to fold
776
+
over the elements of type ['elt] of the array of type ['array]. *)
777
+
778
+
type ('array, 'elt, 'builder) map
779
+
(** The type for mapping JSON arrays with elements of type ['elt] to arrays
780
+
of type ['array] using values of type ['builder] to build them. *)
781
+
782
+
val map :
783
+
?kind:string -> ?doc:string ->
784
+
?dec_empty:(unit -> 'builder) ->
785
+
?dec_skip:(int -> 'builder -> bool) ->
786
+
?dec_add:(int -> 'elt -> 'builder -> 'builder) ->
787
+
?dec_finish:(Meta.t -> int -> 'builder -> 'array) ->
788
+
?enc:('array, 'elt) enc ->
789
+
?enc_meta:('array -> Meta.t) -> 'elt t ->
790
+
('array, 'elt, 'builder) map
791
+
(** [map elt] maps JSON arrays of type ['elt] to arrays of
792
+
type ['array] built with type ['builder].
793
+
{ul
794
+
{- [kind] names the entities represented by the map and [doc]
795
+
documents them. Both default to [""].}
796
+
{- [dec_empty ()] is used to create a builder for the empty array.
797
+
Can be omitted if the map is only used for encoding, the default
798
+
unconditionally errors.}
799
+
{- [dec_skip i b] is used to skip the [i]th index of the JSON array.
800
+
If [true], the element is not decoded with [elt] and not added with
801
+
[dec_add] but skipped. The default always returns [false].}
802
+
{- [dec_add i v] is used to add the [i]th JSON element [v] $
803
+
decoded by [elt] to the builder [b]. Can be omitted if the map is
804
+
only used for encoding, the default unconditionally errors.}
805
+
{- [dec_finish b] converts the builder to the final array.
806
+
Can be omitted if the map is only used for encoding, the default
807
+
unconditionally errors.}
808
+
{- [enc.enc f acc a] folds over the elements of array [a] in
809
+
increasing order with [f] and starting with [acc]. This function
810
+
is used to encode [a] to a JSON array. Can be omitted if the
811
+
map is only used for decoding, the default unconditionally errors.}
812
+
{- [enc_meta a] is the metadata to use for encoding [v] to a JSON
813
+
array. Default returns {!Meta.none}.}} *)
814
+
815
+
val list_map :
816
+
?kind:string -> ?doc:string ->
817
+
?dec_skip:(int -> 'a list -> bool) -> 'a t ->
818
+
('a list, 'a, 'a list) map
819
+
(** [list_map elt] maps JSON arrays with elements of type [elt]
820
+
to [list] values. See also {!Jsont.list}. *)
821
+
822
+
type 'a array_builder
823
+
(** The type for array builders. *)
824
+
825
+
val array_map :
826
+
?kind:string -> ?doc:string ->
827
+
?dec_skip:(int -> 'a array_builder -> bool) -> 'a t ->
828
+
('a array, 'a, 'a array_builder) map
829
+
(** [array_map elt] maps JSON arrays with elements of type [elt]
830
+
to [array] values. See also {!Jsont.array}. *)
831
+
832
+
type ('a, 'b, 'c) bigarray_builder
833
+
(** The type for bigarray_builders. *)
834
+
835
+
val bigarray_map :
836
+
?kind:string -> ?doc:string ->
837
+
?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) ->
838
+
('a, 'b) Bigarray.kind -> 'c Bigarray.layout -> 'a t ->
839
+
(('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map
840
+
(** [bigarray k l elt] maps JSON arrays with elements of
841
+
type [elt] to bigarray values of kind [k] and layout [l]. See
842
+
also {!Jsont.bigarray}. *)
843
+
844
+
(** {1:types JSON types} *)
845
+
846
+
val array : ('a, _, _) map -> 'a t
847
+
(** [array map] maps with [map] JSON arrays to values of type ['a].
848
+
See the the {{!section-arrays}array combinators}. *)
849
+
850
+
val ignore : unit t
851
+
(** [ignore] ignores JSON arrays on decoding and errors on encoding. *)
852
+
853
+
val zero : unit t
854
+
(** [zero] ignores JSON arrays on decoding and encodes an empty array. *)
855
+
end
856
+
857
+
val list : ?kind:string -> ?doc:string -> 'a t -> 'a list t
858
+
(** [list t] maps JSON arrays of type [t] to [list] values. See also
859
+
{!Array.list_map}. *)
860
+
861
+
val array : ?kind:string -> ?doc:string -> 'a t -> 'a array t
862
+
(** [array t] maps JSON arrays of type [t] to [array] values. See
863
+
also {!Array.array_map}. *)
864
+
865
+
val array_as_string_map :
866
+
?kind:string -> ?doc:string -> key:('a -> string) -> 'a t ->
867
+
'a Map.Make(String).t t
868
+
(** [array_as_string_map ~key t] maps JSON array elements of type [t] to
869
+
string maps by indexing them with [key]. If two elements have
870
+
the same [key] the element with the greatest index takes over.
871
+
Elements of the map are encoded to a JSON array in (binary) key order. *)
872
+
873
+
val bigarray :
874
+
?kind:string -> ?doc:string -> ('a, 'b) Bigarray.kind -> 'a t ->
875
+
('a, 'b, Bigarray.c_layout) Bigarray.Array1.t t
876
+
(** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t] values.
877
+
See also {!Array.bigarray_map}. *)
878
+
879
+
val t2 :
880
+
?kind:string -> ?doc:string -> ?dec:('a -> 'a -> 't2) ->
881
+
?enc:('t2 -> int -> 'a) -> 'a t -> 't2 t
882
+
(** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type
883
+
[t] to value of type ['t2]. Decodes error if there are more
884
+
elements. [enc v i] must return the zero-based [i]th element. *)
885
+
886
+
val t3 :
887
+
?kind:string -> ?doc:string -> ?dec:('a -> 'a -> 'a -> 't3) ->
888
+
?enc:('t3 -> int -> 'a) -> 'a t -> 't3 t
889
+
(** [t3] is like {!t2} but for 3 elements. *)
890
+
891
+
val t4 :
892
+
?kind:string -> ?doc:string -> ?dec:('a -> 'a -> 'a -> 'a -> 't4) ->
893
+
?enc:('t4 -> int -> 'a) -> 'a t -> 't4 t
894
+
(** [t4] is like {!t2} but for 4 elements. *)
895
+
896
+
val tn : ?kind:string -> ?doc:string -> n:int -> 'a t -> 'a array t
897
+
(** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to
898
+
[array] values. This is {!val-array} limited by [n]. *)
899
+
900
+
(** {1:objects Objects}
901
+
902
+
Read the {{!page-cookbook.dealing_with_objects}cookbook} on
903
+
objects. See a {{!page-cookbook.objects_as_records}simple
904
+
example}. See also {{!object_queries}object queries and
905
+
updates}. *)
906
+
907
+
(** Mapping JSON objects. *)
908
+
module Object : sig
909
+
910
+
(** {1:maps Maps} *)
911
+
912
+
type ('o, 'dec) map
913
+
(** The type for mapping JSON objects to values of type ['o]. The
914
+
['dec] type is used to construct ['o] from members see {!val-mem}. *)
915
+
916
+
val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
917
+
(** [map dec] is an empty JSON object decoded by function [dec].
918
+
{ul
919
+
{- [kind] names the entities represented by the map and [doc]
920
+
documents them. Both default to [""].}
921
+
{- [dec] is a constructor eventually returning a value of
922
+
type ['o] to be saturated with calls to {!val-mem}, {!val-case_mem}
923
+
or {!val-keep_unknown}. This is needed for decoding. Use {!enc_only}
924
+
if the result is only used for encoding.}} *)
925
+
926
+
val map' :
927
+
?kind:string -> ?doc:string -> ?enc_meta:('o -> Meta.t) ->
928
+
(Meta.t -> 'dec) -> ('o, 'dec) map
929
+
(** [map' dec] is like {!val-map} except you get the object's
930
+
decoding metdata in [dec] and [enc_meta] is used to recover it
931
+
on encoding. *)
932
+
933
+
val enc_only :
934
+
?kind:string -> ?doc:string -> ?enc_meta:('o -> Meta.t) -> unit ->
935
+
('o, 'a) map
936
+
(** [enc_only ()] is like {!val-map'} but can only be used for
937
+
encoding. *)
938
+
939
+
val finish : ('o, 'o) map -> 'o t
940
+
(** [finish map] is a JSON type for objects mapped by [map]. Raises
941
+
[Invalid_argument] if [map] describes a member name more than
942
+
once. *)
943
+
944
+
(** {1:mems Members} *)
945
+
946
+
(** Member maps.
947
+
948
+
Usually it's better to use {!Jsont.Object.mem} or {!Jsont.Object.opt_mem}
949
+
directly. But this may be useful in certain abstraction contexts. *)
950
+
module Mem : sig
951
+
952
+
type ('o, 'dec) object_map := ('o, 'dec) map
953
+
954
+
type ('o, 'a) map
955
+
(** The type for mapping a member object to a value ['a] stored
956
+
in an OCaml value of type ['o]. *)
957
+
958
+
val map :
959
+
?doc:string -> ?dec_absent:'a -> ?enc:('o -> 'a) ->
960
+
?enc_omit:('a -> bool) -> string -> 'a t -> ('o, 'a) map
961
+
(** See {!Jsont.Object.mem}. *)
962
+
963
+
val app : ('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map
964
+
(** [app map mmap] applies the member map [mmap] to the contructor of
965
+
the object map [map]. In turn this adds the [mmap] member definition
966
+
to the object described by [map]. *)
967
+
end
968
+
969
+
val mem :
970
+
?doc:string -> ?dec_absent:'a -> ?enc:('o -> 'a) ->
971
+
?enc_omit:('a -> bool) -> string -> 'a t -> ('o, 'a -> 'b) map ->
972
+
('o, 'b) map
973
+
(** [mem name t map] is a member named [name] of type
974
+
[t] for an object of type ['o] being constructed by [map].
975
+
{ul
976
+
{- [doc] is a documentation string for the member. Defaults to [""].}
977
+
{- [dec_absent], if specified, is the value used for the decoding
978
+
direction when the member named [name] is missing. If unspecified
979
+
decoding errors when the member is absent. See also {!opt_mem}
980
+
and {{!page-cookbook.optional_members}this example}.}
981
+
{- [enc] is used to project the member's value from the object
982
+
representation ['o] for encoding to JSON with [t]. It can be omitted
983
+
if the result is only used for decoding.}
984
+
{- [enc_omit] is for the encoding direction. If the member value returned
985
+
by [enc] returns [true] on [enc_omit], the member is omited in the
986
+
encoded JSON object. Defaults to [Fun.const false].
987
+
See also {!opt_mem} and
988
+
{{!page-cookbook.optional_members}this example}.}} *)
989
+
990
+
val opt_mem :
991
+
?doc:string -> ?enc:('o -> 'a option) -> string -> 'a t ->
992
+
('o, 'a option -> 'b) map -> ('o, 'b) map
993
+
(** [opt_mem name t map] is:
994
+
{[
995
+
let dec_absent = None and enc_omit = Option.is_none in
996
+
Jsont.Object.mem name (Jsont.some t) map ~dec_absent ~enc_omit
997
+
]}
998
+
A shortcut to represent optional members of type ['a] with ['a option]
999
+
values. *)
1000
+
1001
+
(** {1:cases Case objects}
1002
+
1003
+
Read the {{!page-cookbook.cases}cookbook} on case objects. *)
1004
+
1005
+
(** Case objects.
1006
+
1007
+
Case objects are used to describe objects whose members depend
1008
+
on the tag value of a distinguished case member. See an
1009
+
{{!page-cookbook.cases}example}. *)
1010
+
module Case : sig
1011
+
1012
+
(** {1:maps Maps} *)
1013
+
1014
+
type 'a jsont := 'a t
1015
+
1016
+
type ('cases, 'case, 'tag) map
1017
+
(** The type for mapping a case object represented by ['case] belonging to
1018
+
a common type represented by ['cases] depending on the value
1019
+
of a case member of type ['tag]. *)
1020
+
1021
+
val map :
1022
+
?dec:('case -> 'cases) -> 'tag -> 'case jsont ->
1023
+
('cases, 'case, 'tag) map
1024
+
(** [map ~dec v obj] defines the object map [obj] as being the
1025
+
case for the tag value [v] of the case member. [dec] indicates how to
1026
+
inject the object case into the type common to all cases.
1027
+
1028
+
Raises [Invalid_argument] if [obj] is not a direct result of
1029
+
{!finish}, that is if [obj] does not describe an object. *)
1030
+
1031
+
val map_tag : ('cases, 'case, 'tag) map -> 'tag
1032
+
(** [map_tag m] is [m]'s tag. *)
1033
+
1034
+
(** {1:cases Cases} *)
1035
+
1036
+
type ('cases, 'tag) t
1037
+
(** The type for a case of the type ['cases]. This is
1038
+
{!type-map} with its ['case] representation hidden. *)
1039
+
1040
+
val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t
1041
+
(** [make map] is [map] as a case. *)
1042
+
1043
+
val tag : ('cases, 'tag) t -> 'tag
1044
+
(** [tag c] is the tag of [c]. *)
1045
+
1046
+
(** {1:case Case values} *)
1047
+
1048
+
type ('cases, 'tag) value
1049
+
(** The type for case values. This holds a case value and
1050
+
its case map {!type-map}. Use {!val-value} to construct them. *)
1051
+
1052
+
val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value
1053
+
(** [value map v] is a case value [v] described by [map]. *)
1054
+
end
1055
+
1056
+
val case_mem :
1057
+
?doc:string -> ?tag_compare:('tag -> 'tag -> int) ->
1058
+
?tag_to_string:('tag -> string) -> ?dec_absent:'tag ->
1059
+
?enc:('o -> 'cases) -> ?enc_omit:('tag -> bool) ->
1060
+
?enc_case:('cases -> ('cases, 'tag) Case.value) -> string -> 'tag t ->
1061
+
('cases, 'tag) Case.t list -> ('o, 'cases -> 'a) map -> ('o, 'a) map
1062
+
(** [case_mem name t cases map] is mostly like {!val-mem} except the member
1063
+
[name] selects an object representation according to the member value of
1064
+
type [t]:
1065
+
{ul
1066
+
{- [doc] is a documentation string for the member. Defaults to [""].}
1067
+
{- [tag_compare] is used to compare tags. Defaults to {!Stdlib.compare}}
1068
+
{- [tag_to_string] is used to stringify tags for improving
1069
+
error reporting.}
1070
+
{- [dec_absent], if specified, is the case value used for the decoding
1071
+
direction when the case member named [name] is missing. If unspecified
1072
+
decoding errors when the member is absent.}
1073
+
{- [enc] is used to project the value in which cases are stored
1074
+
from the object representation ['o] for encoding to JSON. It
1075
+
can be omitted if the result is only used for decoding.}
1076
+
{- [enc_case] determines the actual case value from the value returned
1077
+
by [enc].}
1078
+
{- [enc_omit] is used on the tag of the case returned by [enc_case]
1079
+
to determine if the case member can be ommited in the encoded JSON
1080
+
object}
1081
+
{- [cases] enumerates all the cases, it is needed for decoding.}}
1082
+
1083
+
The names of the members of each case must be disjoint from [name]
1084
+
or those of [map] otherwise [Invalid_argument] is raised on
1085
+
{!finish}. Raises [Invalid_argument] if [case_mem] was already called
1086
+
on map. *)
1087
+
1088
+
(** {1:unknown_members Unknown members}
1089
+
1090
+
Read the {{!page-cookbook.unknown_members}cookbook} on unknown object
1091
+
members.
1092
+
1093
+
On {{!cases}case objects} each individual case has its own
1094
+
behaviour unless the combinators are used on the case object map
1095
+
in which case it overrides the behaviour of cases. For those
1096
+
cases that use {!keep_unknown} they will get the result of an
1097
+
empty builder in their decoding function and the encoder is
1098
+
ignored on encode. *)
1099
+
1100
+
(** Uniform members. *)
1101
+
module Mems : sig
1102
+
1103
+
(** {1:maps Maps} *)
1104
+
1105
+
type 'a jsont := 'a t
1106
+
1107
+
type ('mems, 'a) enc =
1108
+
{ enc :
1109
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) ->
1110
+
'mems -> 'acc -> 'acc }
1111
+
(** The type for specifying unknown members encoding function.
1112
+
A function to fold over unknown members of uniform type ['a]
1113
+
stored in a value of type ['mems]. *)
1114
+
1115
+
type ('mems, 'a, 'builder) map
1116
+
(** The type for mapping members of uniform type ['a] to values of
1117
+
type ['mems] using a builder of type ['builder]. *)
1118
+
1119
+
val map :
1120
+
?kind:string -> ?doc:string ->
1121
+
?dec_empty:(unit -> 'builder) ->
1122
+
?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) ->
1123
+
?dec_finish:(Meta.t -> 'builder -> 'mems) ->
1124
+
?enc:('mems, 'a) enc -> 'a jsont -> ('mems, 'a, 'builder) map
1125
+
(** [map type'] maps unknown members of uniform type ['a]
1126
+
to values of type ['mems] built with type ['builder].
1127
+
{ul
1128
+
{- [kind] names the entities represented by the map and [doc]
1129
+
documents them. Both default to [""].}
1130
+
{- [dec_empty] is used to create a builder for the members.
1131
+
Can be omitted if the map is only used for encoding, the default
1132
+
unconditionally errors.}
1133
+
{- [dec_add meta name v b] is used to add a member named [name]
1134
+
with meta [meta] with member value [v] to builder [b].
1135
+
Can be omitted if the map is only used for encoding, the default
1136
+
unconditionally errors.}
1137
+
{- [dec_finish meta b] converts the builder to the final members
1138
+
value. [meta] is the metadata of the object in which they were
1139
+
found. Can be omitted if the map is only used for encoding, the
1140
+
default unconditionally errors.}
1141
+
{- [enc f mems acc] folds over the elements of [mems] starting
1142
+
with [acc]. This function is used to encode the members.
1143
+
Can be omitted if the map is only used for decoding, the
1144
+
default unconditionally errors.}}
1145
+
See {!keep_unknown}. *)
1146
+
1147
+
val string_map :
1148
+
?kind:string -> ?doc:string -> 'a jsont ->
1149
+
('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map
1150
+
(** [string_map t] collects unknown member by name and types their
1151
+
values with [t]. See {!keep_unknown} and {!as_string_map}. *)
1152
+
end
1153
+
1154
+
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
1155
+
(** [skip_unknown map] makes [map] skip unknown members. This is the
1156
+
default, no need to specify it. Raises [Invalid_argument] if
1157
+
{!keep_unknown} was already specified on [map]. *)
1158
+
1159
+
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
1160
+
(** [error_unknown map] makes [map] error on unknown members. Raises
1161
+
[Invalid_argument] if {!keep_unknown} was already specified on
1162
+
[map]. See {{!page-cookbook.erroring}this example}. *)
1163
+
1164
+
val keep_unknown :
1165
+
?enc:('o -> 'mems) -> ('mems, _, _) Mems.map ->
1166
+
('o, 'mems -> 'a) map -> ('o, 'a) map
1167
+
(** [keep_unknown mems map] makes [map] keep unknown member with [mems].
1168
+
Raises [Invalid_argument] if {!keep_unknown} was already
1169
+
specified on [map]. See this {{!page-cookbook.keeping}this
1170
+
example}, {!Mems.string_map} and {!Jsont.json_mems}. *)
1171
+
1172
+
(** {1:types JSON types } *)
1173
+
1174
+
val as_string_map :
1175
+
?kind:string -> ?doc:string -> 'a t -> 'a Stdlib.Map.Make(String).t t
1176
+
(** [as_string_map t] maps object to key-value maps of type [t].
1177
+
See also {!Mems.string_map} and {!Jsont.json_mems}. *)
1178
+
1179
+
val zero : unit t
1180
+
(** [zero] ignores JSON objects on decoding and encodes an empty object. *)
1181
+
end
1182
+
1183
+
(** {1:any Any} *)
1184
+
1185
+
val any :
1186
+
?kind:string -> ?doc:string -> ?dec_null:'a t -> ?dec_bool:'a t ->
1187
+
?dec_number:'a t -> ?dec_string:'a t -> ?dec_array:'a t ->
1188
+
?dec_object:'a t -> ?enc:('a -> 'a t) -> unit -> 'a t
1189
+
(** [any ()] maps subsets of JSON value of different sorts to values
1190
+
of type ['a]. The unspecified cases are not part of the subset and
1191
+
error on decoding. [enc] selects the type to use on encoding and errors
1192
+
if omitted. [kind] names the entities represented by the type and [doc]
1193
+
documents them, both defaults to [""]. *)
1194
+
1195
+
(** {1:maps Maps & recursion} *)
1196
+
1197
+
val map :
1198
+
?kind:string -> ?doc:string -> ?dec:('a -> 'b) ->
1199
+
?enc:('b -> 'a) -> 'a t -> 'b t
1200
+
(** [map t] changes the type of [t] from ['a] to ['b].
1201
+
{ul
1202
+
{- [kind] names the entities represented by the type and [doc]
1203
+
documents them, both default to [""].}
1204
+
{- [dec] decodes values of type ['a] to values of type ['b].
1205
+
Can be omitted if the result is only used for
1206
+
encoding. The default errors.}
1207
+
{- [enc] encodes values of type ['b] to values of type ['a].
1208
+
Can be omitted if the result is only used for
1209
+
decoding. The default errors.}}
1210
+
1211
+
For mapping base types use {!Jsont.Base.map}. *)
1212
+
1213
+
val iter :
1214
+
?kind:string -> ?doc:string -> ?dec:('a -> unit) -> ?enc:('a -> unit) ->
1215
+
'a t -> 'a t
1216
+
(** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding
1217
+
but otherwise behaves like [t] does. Typically [dec] can be used
1218
+
to further assert the shape of the decoded value and {!Error.msgf}
1219
+
if it hasn't the right shape. [iter] can also be used as a tracing
1220
+
facility for debugging. *)
1221
+
1222
+
val rec' : 'a t Lazy.t -> 'a t
1223
+
(** [rec'] maps recursive JSON values. See the {{!page-cookbook.recursion}
1224
+
cookbook}. *)
1225
+
1226
+
(** {1:ignoring Ignoring} *)
1227
+
1228
+
val ignore : unit t
1229
+
(** [ignore] lossily maps all JSON values to [()] on decoding and
1230
+
errors on encoding. See also {!const}. *)
1231
+
1232
+
val zero : unit t
1233
+
(** [zero] lossily maps all JSON values to [()] on decoding and
1234
+
encodes JSON nulls. *)
1235
+
1236
+
val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a t
1237
+
(** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if
1238
+
specified (errors otherwise) and errors on encoding. *)
1239
+
1240
+
(** {1:generic_json Generic JSON} *)
1241
+
1242
+
type name = string node
1243
+
(** The type for JSON member names. *)
1244
+
1245
+
type mem = name * json
1246
+
(** The type for generic JSON object members. *)
1247
+
1248
+
and object' = mem list
1249
+
(** The type for generic JSON objects. *)
1250
+
1251
+
and json =
1252
+
| Null of unit node
1253
+
| Bool of bool node
1254
+
| Number of float node
1255
+
(** Encoders must use [Null] if float is {{!Float.is_finite}not finite}. *)
1256
+
| String of string node
1257
+
| Array of json list node
1258
+
| Object of object' node (** *)
1259
+
(** The type for generic JSON values. *)
1260
+
1261
+
(** Generic JSON values. *)
1262
+
module Json : sig
1263
+
1264
+
(** {1:json JSON values} *)
1265
+
1266
+
type 'a jsont := 'a t
1267
+
1268
+
type 'a cons = ?meta:Meta.t -> 'a -> json
1269
+
(** The type for constructing JSON values from an OCaml value of type ['a].
1270
+
[meta] defaults to {!Meta.none}. *)
1271
+
1272
+
type t = json
1273
+
(** See {!Jsont.val-json}. *)
1274
+
1275
+
val meta : json -> Meta.t
1276
+
(** [meta v] is the metadata of value [v]. *)
1277
+
1278
+
val set_meta : Meta.t -> json -> json
1279
+
(** [set_meta m v] replaces [v]'s meta with [m]. *)
1280
+
1281
+
val copy_layout : json -> dst:json -> json
1282
+
(** [copy_layout src ~dst] copies the layout of [src] and sets
1283
+
it on [dst] using {!Meta.copy_ws}. *)
1284
+
1285
+
val sort : json -> Sort.t
1286
+
(** [sort v] is the sort of value [v]. *)
1287
+
1288
+
val zero : json cons
1289
+
(** [zero j] is a stub value of the sort value of [j]. The stub
1290
+
value is the “natural” zero: null, false, 0, empty string,
1291
+
empty array, empty object. *)
1292
+
1293
+
val equal : json -> json -> bool
1294
+
(** [equal j0 j1] is {!compare}[ j0 j1 = 0]. *)
1295
+
1296
+
val compare : json -> json -> int
1297
+
(** [compare j0 j1] is a total order on JSON values:
1298
+
{ul
1299
+
{- Floating point values are compared with {!Float.compare},
1300
+
this means NaN values are equal.}
1301
+
{- Strings are compared byte wise.}
1302
+
{- Objects members are sorted before being compared.}
1303
+
{- {!Meta.t} values are ignored.}} *)
1304
+
1305
+
val pp : t fmt
1306
+
(** See {!Jsont.pp_json}. *)
1307
+
1308
+
(** {2:null Nulls and options} *)
1309
+
1310
+
val null : unit cons
1311
+
(** [null] is [Null (unit, meta)]. *)
1312
+
1313
+
val option : 'a cons -> 'a option cons
1314
+
(** [option c] constructs [Some v] values with [c v] and [None] ones
1315
+
with {!val-null}. *)
1316
+
1317
+
(** {2:bool Booleans} *)
1318
+
1319
+
val bool : bool cons
1320
+
(** [bool b] is [Bool (b, meta)]. *)
1321
+
1322
+
(** {2:numbers Numbers} *)
1323
+
1324
+
val number : float cons
1325
+
(** [number n] is [Number (n, meta)]. *)
1326
+
1327
+
val any_float : float cons
1328
+
(** [any_float v] is [number v] if {!Float.is_finite}[ v] is [true]
1329
+
and [string (Float.to_string v)] otherwise. See {!Jsont.any_float}. *)
1330
+
1331
+
val int32 : int32 cons
1332
+
(** [int32] is [i] as a JSON number. *)
1333
+
1334
+
val int64 : int64 cons
1335
+
(** [int64 i] is [i] as a JSON number or a JSON string if
1336
+
not in the range \[-2{^53};2{^53}\]. See also {!int64_as_string}. *)
1337
+
1338
+
val int64_as_string : int64 cons
1339
+
(** [int64_as_string i] is [i] as a JSON string. See also {!int64}. *)
1340
+
1341
+
val int : int cons
1342
+
(** [int] is [i] as a JSON number or a JSON string if not
1343
+
in the range \[-2{^53};2{^53}\]. See also {!int_as_string}. *)
1344
+
1345
+
val int_as_string : int cons
1346
+
(** [int_as_string i] is [i] as a JSON string. See also {!int}. *)
1347
+
1348
+
(** {2:strings Strings} *)
1349
+
1350
+
val string : string cons
1351
+
(** [string s] is [String (s, meta)]. *)
1352
+
1353
+
(** {2:arrays Arrays} *)
1354
+
1355
+
val list : json list cons
1356
+
(** [list l] is [Array (l, meta)]. *)
1357
+
1358
+
val array : json array cons
1359
+
(** [array l] is [Array (Array.to_list a, meta)]. See also {!list}. *)
1360
+
1361
+
(** {2:objects Objects} *)
1362
+
1363
+
val name : ?meta:Meta.t -> string -> name
1364
+
(** [name ?meta n] is [(n, meta)]. [meta] defaults to {!Meta.none}. *)
1365
+
1366
+
val mem : name -> json -> mem
1367
+
(** [mem n v] is [(n, v)]. [meta] defaults to {!Meta.none}. *)
1368
+
1369
+
val object' : object' cons
1370
+
(** [object o] is [Object (o, meta)]. *)
1371
+
1372
+
val find_mem : string -> object' -> mem option
1373
+
(** [find_mem n ms] find the first member whose name matches [n] in [ms]. *)
1374
+
1375
+
val find_mem' : name -> object' -> mem option
1376
+
(** [find_mem n ms] is [find_mem (fst n) ms]. *)
1377
+
1378
+
val object_names : object' -> string list
1379
+
(** [object_names ms] are the names of [ms]. *)
1380
+
1381
+
val object_names' : object' -> name list
1382
+
(** [object_names ms] are the names of [ms]. *)
1383
+
1384
+
(** {1:decode Decode} *)
1385
+
1386
+
val decode : 'a jsont -> json -> ('a, string) result
1387
+
(** [decode t j] decodes a value from the generic JSON [j] according
1388
+
to type [t]. *)
1389
+
1390
+
val decode' : 'a jsont -> json -> ('a, Error.t) result
1391
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
1392
+
1393
+
(** {1:encode Encode} *)
1394
+
1395
+
val encode : 'a jsont -> 'a -> (json, string) result
1396
+
(** [encode t v] encodes a generic JSON value for [v] according
1397
+
to type [t]. *)
1398
+
1399
+
val encode' : 'a jsont -> 'a -> (json, Error.t) result
1400
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
1401
+
1402
+
(** {1:recode Recode} *)
1403
+
1404
+
val recode : 'a jsont -> json -> (json, string) result
1405
+
(** [recode t v] decodes [v] with [t] and encodes it with [t]. *)
1406
+
1407
+
val recode' : 'a jsont -> json -> (json, Error.t) result
1408
+
(** [recode'] is like {!val-recode} but preserves the error structure. *)
1409
+
1410
+
val update : 'a jsont -> json -> json
1411
+
(** [update] is like {!val-recode} but raises {!Jsont.exception-Error}. *)
1412
+
1413
+
(** {1:errors Errors} *)
1414
+
1415
+
val error_sort : exp:Sort.t -> json -> 'a
1416
+
(** [error_sort ~exp fnd] errors when sort [exp] was expected but
1417
+
generic JSON [fnd] was found. *)
1418
+
1419
+
val error_type : 'a jsont -> json -> 'a
1420
+
(** [error_type t fnd] errors when the type expected by [t]
1421
+
does not match [fnd]. *)
1422
+
end
1423
+
1424
+
val json : json t
1425
+
(** [json] maps any JSON value to its generic representation. *)
1426
+
1427
+
val json_null : json t
1428
+
(** [json_null] maps JSON nulls to their generic representation. *)
1429
+
1430
+
val json_bool : json t
1431
+
(** [json_bool] maps JSON booleans to their generic representation. *)
1432
+
1433
+
val json_number : json t
1434
+
(** [json_number] maps JSON nulls or numbers
1435
+
({{!page-cookbook.non_finite_numbers}explanation}) to their generic
1436
+
representation. *)
1437
+
1438
+
val json_string : json t
1439
+
(** [json_string] represents JSON strings by their generic representation. *)
1440
+
1441
+
val json_array : json t
1442
+
(** [json_array] represents JSON arrays by their generic representation. *)
1443
+
1444
+
val json_object : json t
1445
+
(** [json_object] represents JSON objects by their generic representation. *)
1446
+
1447
+
val json_mems : (json, json, mem list) Object.Mems.map
1448
+
(** [json_mems] is a members map collecting unknown members into a
1449
+
generic JSON object. See {{!page-cookbook.keeping}this example}. *)
1450
+
1451
+
(** {1:queries Queries and updates}
1452
+
1453
+
Queries are lossy or aggregating decodes. Updates decode to
1454
+
{!type-json} values but transform the data along the way. They allow to
1455
+
process JSON data without having to fully model it
1456
+
(see the update example in the {{!page-index.quick_start}quick start}). *)
1457
+
1458
+
val const : 'a t -> 'a -> 'a t
1459
+
(** [const t v] maps any JSON value to [v] on decodes and
1460
+
unconditionally encodes [v] with [t]. *)
1461
+
1462
+
val recode : dec:'a t -> ('a -> 'b) -> enc:'b t -> 'b t
1463
+
(** [recode ~dec f ~enc] maps on decodes like [dec] does followed by
1464
+
[f] and on encodes uses [enc]. This can be used to change the JSON
1465
+
sort of value. For example:
1466
+
{[
1467
+
recode ~dec:int (fun _ i -> string_of_int s) ~enc:string
1468
+
]}
1469
+
decodes an integer but encodes the integer as a string. *)
1470
+
1471
+
val update : 'a t -> json t
1472
+
(** [update t] decodes any JSON with [t] and directly encodes it back
1473
+
with [t] to yield the decode result. Encodes any JSON like {!val-json}
1474
+
does. *)
1475
+
1476
+
(** {2:array_queries Arrays} *)
1477
+
1478
+
val nth : ?absent:'a -> int -> 'a t -> 'a t
1479
+
(** [nth n t] decodes the [n]th index of a JSON array with [t]. Other
1480
+
indices are skipped. The decode errors if there is no such index
1481
+
unless [absent] is specified in which case this value is returned.
1482
+
Encodes a singleton array. *)
1483
+
1484
+
val set_nth : ?stub:json -> ?allow_absent:bool -> 'a t -> int -> 'a -> json t
1485
+
(** [set_nth t n v] on decodes sets the [n]th value of a JSON array to
1486
+
[v] encoded by [t]. Other indices are left untouched. Errors if
1487
+
there is no such index unless [~allow_absent:true] is specified in
1488
+
which case the index is created preceeded by as many [stub]
1489
+
indices as needed. [stub] defaults to {!Json.zero} applied to the
1490
+
value [v] encoded by [t] (i.e. the "natural zero" of [v]'s encoding sort).
1491
+
Encodes like {!json_array} does. *)
1492
+
1493
+
val update_nth : ?stub:json -> ?absent:'a -> int -> 'a t -> json t
1494
+
(** [update_nth n t] on decode recodes the [n]th value of a JSON array
1495
+
with [t]. Errors if there is no such index unless [absent] is
1496
+
specified in which case the index is created with [absent],
1497
+
encoded with [t] and preceeded by as many [stub] values as
1498
+
needed. [stub] defaults to {!Json.zero} applied to the recode.
1499
+
Encodes like {!json_array} does. *)
1500
+
1501
+
val delete_nth : ?allow_absent:bool -> int -> json t
1502
+
(** [delete_nth n] drops the [n]th index of a JSON array on both
1503
+
decode and encodes. Other indices are left untouched. Errors if
1504
+
there is no such index unless [~allow_absent:true] is specified in
1505
+
which case the data is left untouched. *)
1506
+
1507
+
val filter_map_array : 'a t -> 'b t -> (int -> 'a -> 'b option) -> json t
1508
+
(** [filter_map_array a b f] maps the [a] elements of a JSON array
1509
+
with [f] to [b] elements or deletes them on [None]. Encodes
1510
+
generic JSON arrays like {!json_array} does. *)
1511
+
1512
+
val fold_array : 'a t -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b t
1513
+
(** [fold_array t f acc] fold [f] over the [t] elements of a JSON
1514
+
array starting with [acc]. Encodes an empty JSON array. *)
1515
+
1516
+
(** {2:object_queries Objects} *)
1517
+
1518
+
val mem : ?absent:'a -> string -> 'a t -> 'a t
1519
+
(** [mem name t] decodes the member named [name] of a JSON object with
1520
+
[t]. Other members are skipped. The decode errors if there is no
1521
+
such member unless [absent] is specified in which case this value
1522
+
is returned. Encodes an object with a single [name] member. *)
1523
+
1524
+
val set_mem : ?allow_absent:bool -> 'a t -> string -> 'a -> json t
1525
+
(** [set_mem t name v] sets the member value of [name] of a [JSON]
1526
+
object to an encoding of [v] with [t]. This happens both on
1527
+
decodes and encodes. Errors if there is no such member unless
1528
+
[allow_absent:true] is specified in which case a member is added
1529
+
to the object. *)
1530
+
1531
+
val update_mem : ?absent:'a -> string -> 'a t -> json t
1532
+
(** [update_mem name t] recodes the member value of [name] of a JSON
1533
+
object with [t]. This happens both on decodes and encodes. Errors
1534
+
if there is no such member unless [absent] is specified in which
1535
+
case a member with this value encoded with [t] is added to the
1536
+
object. *)
1537
+
1538
+
val delete_mem : ?allow_absent:bool -> string -> json t
1539
+
(** [delete_mem name] deletes the member named [name] of a JSON object
1540
+
on decode. Other members are left untouched. The decode errors if
1541
+
there is no such member unless [~allow_absent:true] is specified
1542
+
in which case the data is left untouched. Encodes generic JSON
1543
+
objects like {!json_object} does. *)
1544
+
1545
+
val filter_map_object :
1546
+
'a t -> 'b t -> (Meta.t -> string -> 'a -> (name * 'b) option) -> json t
1547
+
(** [filter_map_object a b f] maps the [a] members of a JSON object
1548
+
with [f] to [(n, b)] members or deletes them on [None]. The meta
1549
+
given to [f] is the meta of the member name. Encodes generic JSON
1550
+
arrays like {!json_object} does. *)
1551
+
1552
+
val fold_object : 'a t -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b t
1553
+
(** [fold_object t f acc] folds [f] over the [t] members of a JSON object
1554
+
starting with [acc]. Encodes an empty JSON object. *)
1555
+
1556
+
(** {2:index_queries Indices} *)
1557
+
1558
+
val index : ?absent:'a -> Path.index -> 'a t -> 'a t
1559
+
(** [index] uses {!val-nth} or {!val-mem} on the given index. *)
1560
+
1561
+
val set_index : ?allow_absent:bool -> 'a t -> Path.index -> 'a -> json t
1562
+
(** [set_index] uses {!set_nth} or {!set_mem} on the given index. *)
1563
+
1564
+
val update_index : ?stub:json -> ?absent:'a -> Path.index -> 'a t -> json t
1565
+
(** [update_index] uses {!update_nth} or {!update_mem} on the given index. *)
1566
+
1567
+
val delete_index : ?allow_absent:bool -> Path.index -> json t
1568
+
(** [delete_index] uses {!delete_nth} or {!delete_mem} on the given index. *)
1569
+
1570
+
(** {2:path_queries Paths} *)
1571
+
1572
+
val path : ?absent:'a -> Path.t -> 'a t -> 'a t
1573
+
(** [path p t] {{!index}decodes} with [t] on the last index of [p]. If
1574
+
[p] is {!Path.root} this is [t]. *)
1575
+
1576
+
val set_path :
1577
+
?stub:json -> ?allow_absent:bool -> 'a t -> Path.t -> 'a -> json t
1578
+
(** [set_path t p v] {{!set_index}sets} the last index of [p]. If [p]
1579
+
is {!Path.root} this encodes [v] with [t]. *)
1580
+
1581
+
val update_path : ?stub:json -> ?absent:'a -> Path.t -> 'a t -> json t
1582
+
(** [update_path p t] {{!update_index}updates} the last index of [p] with
1583
+
[t]. On the root path this is [t]. *)
1584
+
1585
+
val delete_path : ?allow_absent:bool -> Path.t -> json t
1586
+
(** [delete_path p] {{!delete_index}deletes} the last index of [p]. If
1587
+
[p] is {!Path.root} this is {!Json.val-null}. *)
1588
+
1589
+
(** {1:fmt Formatting} *)
1590
+
1591
+
type format =
1592
+
| Minify (** Compact. No whitespace, no newlines. *)
1593
+
| Indent (** Indented output (not necessarily pretty). *)
1594
+
| Layout (** Follow {!Meta} layout information. *)
1595
+
(** The type for specifying JSON encoding formatting. See for example
1596
+
{!Jsont_bytesrw.val-encode}. *)
1597
+
1598
+
type number_format = (float -> unit, Format.formatter, unit) Stdlib.format
1599
+
(** The type for JSON number formatters. *)
1600
+
1601
+
val default_number_format : number_format
1602
+
(** [default_number_format] is ["%.17g"]. This number formats ensures
1603
+
that finite floating point values can be interchanged without loss
1604
+
of precision. *)
1605
+
1606
+
val pp_null : unit fmt
1607
+
(** [pp_null] formats a JSON null. *)
1608
+
1609
+
val pp_bool : bool fmt
1610
+
(** [pp_bool] formats a JSON bool. *)
1611
+
1612
+
val pp_number : float fmt
1613
+
(** [pp_number] formats a JSON number of a JSON null if the float
1614
+
is not finite. Uses the {!default_number_format}. *)
1615
+
1616
+
val pp_number' : number_format -> float fmt
1617
+
(** [pp_number fmt] is like {!pp_number} but uses [fmt] to format the
1618
+
number. *)
1619
+
1620
+
val pp_string : string fmt
1621
+
(** [pp_string] formats a JSON string (quoted and escaped). Assumes
1622
+
the string is valid UTF-8. *)
1623
+
1624
+
val pp_json : json fmt
1625
+
(** [pp_json] formats JSON, see {!pp_json'}. *)
1626
+
1627
+
val pp_json' : ?number_format:number_format -> unit -> json fmt
1628
+
(** [pp' ~format ~number_format () ppf j] formats [j] on [ppf]. The output
1629
+
is indented but may be more compact than an [Indent] JSON encoder may do.
1630
+
For example arrays may be output on one line if they fit etc.
1631
+
{ul
1632
+
{- [number_format] is used to format JSON numbers. Defaults to
1633
+
{!default_number_format}}
1634
+
{- Non-finite numbers are output as JSON nulls
1635
+
({{!page-cookbook.non_finite_numbers}explanation}).}
1636
+
{- Strings are assumed to be valid UTF-8.}} *)
1637
+
1638
+
val pp_value : ?number_format:number_format -> 'a t -> unit -> 'a fmt
1639
+
(** [pp_value t ()] formats the JSON representation of values as
1640
+
described by [t] by encoding it with {!Json.val-encode} and formatting
1641
+
it with {!pp_json'}. If the encoding of the value errors a JSON
1642
+
string with the error message is formatted. This means that {!pp_value}
1643
+
should always format valid JSON text. *)
1644
+
1645
+
(** {1:low Low-level representation} *)
1646
+
1647
+
(** Low level representation (unstable).
1648
+
1649
+
This representation may change even between minor versions of the
1650
+
library. It can be used to devise new processors on JSON types.
1651
+
1652
+
Processors should be ready to catch the {!Jsont.exception-Error} exception
1653
+
when they invoke functional members of the representation.
1654
+
1655
+
Processors should make sure they interpret mappings
1656
+
correctly. In particular:
1657
+
{ul
1658
+
{- The [Number] case represents the sets of JSON numbers and nulls.}}
1659
+
1660
+
See the source of {!Json.decode'} and {!Json.encode'}
1661
+
for a simple example on how to process this representation. The
1662
+
{{:https://erratique.ch/repos/jsont/tree/paper}paper}
1663
+
in the Jsont source repository may also help to understand this menagerie
1664
+
of types. *)
1665
+
module Repr : sig
1666
+
type 'a t' := 'a t
1667
+
1668
+
module String_map : Map.S with type key = string
1669
+
(** A [Map.Make(String)] instance. *)
1670
+
1671
+
(** Type identifiers. Can be removed once we require OCaml 5.1 *)
1672
+
module Type : sig
1673
+
type (_, _) eq = Equal : ('a, 'a) eq
1674
+
module Id : sig
1675
+
type 'a t
1676
+
val make : unit -> 'a t
1677
+
val uid : 'a t -> int
1678
+
val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option
1679
+
end
1680
+
end
1681
+
1682
+
type ('ret, 'f) dec_fun =
1683
+
| Dec_fun : 'f -> ('ret, 'f) dec_fun
1684
+
(** The function and its return type. *)
1685
+
| Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun
1686
+
(** Application of an argument to a function witnessed by a type
1687
+
identifier. The type identifier can be used to lookup a value
1688
+
of the right type in an heterogenous dictionary. *)
1689
+
(** The type for decoding functions. *)
1690
+
1691
+
(** {1:base Base value maps} *)
1692
+
1693
+
type ('a, 'b) base_map =
1694
+
{ kind : string;
1695
+
(** The kind of JSON value that are mapped (documentation) *)
1696
+
doc : string;
1697
+
(** A doc string for the kind of JSON value. *)
1698
+
dec : Meta.t -> 'a -> 'b;
1699
+
(** [dec] decodes a base value represented by its metadata and ['a] to
1700
+
['b]. *)
1701
+
enc : 'b -> 'a;
1702
+
(** [enc] encodes a value of type ['b] to a base JSON value represented
1703
+
by ['a]. *)
1704
+
enc_meta : 'b -> Meta.t;
1705
+
(** [enc_meta] recovers the base JSON value metadata from ['b] (if any). *)
1706
+
}
1707
+
(** The type for mapping JSON base values represented in OCaml by
1708
+
['a] (these values are fixed by the cases in {!t}) to a value of
1709
+
type ['b]. *)
1710
+
1711
+
(** {1:types JSON types} *)
1712
+
1713
+
type 'a t =
1714
+
| Null : (unit, 'a) base_map -> 'a t (** Null maps. *)
1715
+
| Bool : (bool, 'a) base_map -> 'a t (** Boolean maps. *)
1716
+
| Number : (float, 'a) base_map -> 'a t (** Number maps. *)
1717
+
| String : (string, 'a) base_map -> 'a t (** String maps. *)
1718
+
| Array : ('a, 'elt, 'builder) array_map -> 'a t (** Array maps. *)
1719
+
| Object : ('o, 'o) object_map -> 'o t (** Object maps. *)
1720
+
| Any : 'a any_map -> 'a t (** Map for different sorts of JSON values. *)
1721
+
| Map : ('b, 'a) map -> 'a t (** Map from JSON type ['b] to JSON type ['a]. *)
1722
+
| Rec : 'a t Lazy.t -> 'a t (** Recursive definition. *)
1723
+
(** The type for JSON types. *)
1724
+
1725
+
(** {1:array Array maps} *)
1726
+
1727
+
and ('array, 'elt, 'builder) array_map =
1728
+
{ kind : string;
1729
+
(** The kind of JSON array mapped (documentation). *)
1730
+
doc : string;
1731
+
(** Documentation string for the JSON array. *)
1732
+
elt : 'elt t;
1733
+
(** The type for the array elements. *)
1734
+
dec_empty : unit -> 'builder;
1735
+
(** [dec_empty ()] creates a new empty array builder. *)
1736
+
dec_skip : int -> 'builder -> bool;
1737
+
(** [dec_skip i b] determines if the [i]th index of the JSON array can be
1738
+
skipped. *)
1739
+
dec_add : int -> 'elt -> 'builder -> 'builder;
1740
+
(** [dec_add] adds the [i]th index value of the JSON array
1741
+
as decoded by [elt] to the builder. *)
1742
+
dec_finish : Meta.t -> int -> 'builder -> 'array;
1743
+
(** [dec_finish] turns the builder into an array given its
1744
+
metadata and length. *)
1745
+
enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc;
1746
+
(** [enc] folds over the elements of the array for encoding. *)
1747
+
enc_meta : 'array -> Meta.t;
1748
+
(** [enc_meta] recovers the metadata of an array (if any). *) }
1749
+
(** The type for mapping JSON arrays to values of type ['array]
1750
+
with array elements mapped to type ['elt] and using a ['builder]
1751
+
value to construct the array. *)
1752
+
1753
+
(** {1:object_map Object maps} *)
1754
+
1755
+
and ('o, 'dec) object_map =
1756
+
{ kind : string;
1757
+
(** The kind of JSON object (documentation). *)
1758
+
doc : string;
1759
+
(** A doc string for the JSON member. *)
1760
+
dec : ('o, 'dec) dec_fun;
1761
+
(** The object decoding function to construct an ['o] value. *)
1762
+
mem_decs : mem_dec String_map.t;
1763
+
(** [mem_decs] are the member decoders sorted by member name. *)
1764
+
mem_encs : 'o mem_enc list;
1765
+
(** [mem_encs] is the list of member encoders. *)
1766
+
enc_meta : 'o -> Meta.t;
1767
+
(** [enc_meta] recovers the metadata of an object (if any). *)
1768
+
shape : 'o object_shape;
1769
+
(** [shape] is the {{!object_shape}shape} of the object. *) }
1770
+
(** The type for mapping a JSON object to values of type ['o] using
1771
+
a decoding function of type ['dec]. [mem_decs] and [mem_encs]
1772
+
have the same {!mem_map} values they are just sorted
1773
+
differently for decoding and encoding purposes. *)
1774
+
1775
+
and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec
1776
+
(** The type for member maps in decoding position. *)
1777
+
1778
+
and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc
1779
+
(** The type for member maps in encoding position. *)
1780
+
1781
+
and ('o, 'a) mem_map =
1782
+
{ name : string;
1783
+
(** The JSON member name. *)
1784
+
doc : string;
1785
+
(** Documentation for the JSON member. *)
1786
+
type' : 'a t;
1787
+
(** The type for the member value. *)
1788
+
id : 'a Type.Id.t;
1789
+
(** A type identifier for the member. This allows to store
1790
+
the decode in a {!Dict.t} on decode and give it in time
1791
+
to the object decoding function of the object map. *)
1792
+
dec_absent : 'a option;
1793
+
(** The value to use if absent (if any). *)
1794
+
enc : 'o -> 'a;
1795
+
(** [enc] recovers the value to encode from ['o]. *)
1796
+
(* enc_name_meta : 'a -> Meta.t;
1797
+
XXX This should have been the meta found for the name, but
1798
+
that does not fit so well in the member combinators, it's
1799
+
not impossible to fit it in but likely increases the cost
1800
+
for decoding objects. The layout preserving updates occur
1801
+
via generic JSON which uses [mems_map] in which the meta
1802
+
is available in [dec_add]. Let's leave it that way for now. *)
1803
+
enc_omit : 'a -> bool;
1804
+
(** [enc_omit] is [true] if the result of [enc] should
1805
+
not be encoded. *)
1806
+
}
1807
+
(** The type for mapping a JSON member to a value of type ['a] in
1808
+
an object represented by a value of type ['o]. *)
1809
+
1810
+
and 'o object_shape =
1811
+
| Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape
1812
+
(** A basic object, possibly indicating how to handle unknown members *)
1813
+
| Object_cases :
1814
+
('o, 'mems, 'builder) unknown_mems option *
1815
+
('o, 'cases, 'tag) object_cases -> 'o object_shape
1816
+
(** An object with a case member each case further describing
1817
+
an object map. *)
1818
+
(** The type for object shapes. *)
1819
+
1820
+
(** {2:unknown_mems Unknown members} *)
1821
+
1822
+
and ('o, 'mems, 'builder) unknown_mems =
1823
+
| Unknown_skip : ('o, unit, unit) unknown_mems
1824
+
(** Skip unknown members. *)
1825
+
| Unknown_error : ('o, unit, unit) unknown_mems
1826
+
(** Error on unknown members. *)
1827
+
| Unknown_keep :
1828
+
('mems, 'a, 'builder) mems_map * ('o -> 'mems) ->
1829
+
('o, 'mems, 'builder) unknown_mems
1830
+
(** Gather unknown members in a member map. *)
1831
+
(** The type for specifying decoding behaviour on unknown JSON object
1832
+
members. *)
1833
+
1834
+
and ('mems, 'a, 'builder) mems_map =
1835
+
{ kind : string; (** The kind for unknown members (documentation). *)
1836
+
doc : string; (** Documentation string for the unknown members. *)
1837
+
mems_type : 'a t; (** The uniform type according which unknown members
1838
+
are typed. *)
1839
+
id : 'mems Type.Id.t; (** A type identifier for the unknown member
1840
+
map. *)
1841
+
dec_empty : unit -> 'builder;
1842
+
(** [dec_empty] create a new empty member map builder. *)
1843
+
dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder;
1844
+
(** [dec_add] adds a member named [n] with metadata [meta] and
1845
+
value parsed by [mems_type] to the builder. *)
1846
+
dec_finish : Meta.t -> 'builder -> 'mems;
1847
+
(** [dec_finish] turns the builder into an unknown member map.
1848
+
The [meta] is the meta data of the object in which they were found. *)
1849
+
enc :
1850
+
'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc;
1851
+
(** [enc] folds over the member map for encoding. *)
1852
+
}
1853
+
(** The type for gathering unknown JSON members uniformly typed
1854
+
according to ['a] in a map ['mems] constructed with ['builder]. *)
1855
+
1856
+
(** {2:case_objects Case objects} *)
1857
+
1858
+
and ('o, 'cases, 'tag) object_cases =
1859
+
{ tag : ('tag, 'tag) mem_map;
1860
+
(** The JSON member used to decide cases. The [enc] field of
1861
+
this [mem_map] should be the identity, this allows
1862
+
encoders to reuse generic encoding code for members. We
1863
+
don't have [('o, 'tag) mem_map] here because the tag is not
1864
+
stored we recover the case via [enc] and [enc_case] below. *)
1865
+
tag_compare : 'tag -> 'tag -> int;
1866
+
(** The function to compare tags. *)
1867
+
tag_to_string : ('tag -> string) option;
1868
+
(** The function to stringify tags for error reporting. *)
1869
+
id : 'cases Type.Id.t;
1870
+
(** A type identifier for the tag. *)
1871
+
cases : ('cases, 'tag) case list;
1872
+
(** The list of possible cases. *)
1873
+
enc : 'o -> 'cases;
1874
+
(** [enc] is the function to recover case values from the value
1875
+
['o] the object is mapped to. *)
1876
+
enc_case : 'cases -> ('cases, 'tag) case_value;
1877
+
(** [enc_case] retrieves the concrete case from the common
1878
+
[cases] values. You can see it as preforming a match. *)
1879
+
}
1880
+
(** The type for object cases mapped to a common type ['cases] stored
1881
+
in a vlue of type ['o] and identified by tag values of type ['tag]. *)
1882
+
1883
+
and ('cases, 'case, 'tag) case_map =
1884
+
{ tag : 'tag;
1885
+
(** The tag value for the case. *)
1886
+
object_map : ('case, 'case) object_map;
1887
+
(** The object map for the case. *)
1888
+
dec : 'case -> 'cases;
1889
+
(** [dec] is the function used on decoding to inject the case
1890
+
into the common ['cases] type. *)
1891
+
}
1892
+
(** The type for an object case with common type ['cases] specific
1893
+
type ['case] and tag type ['tag]. *)
1894
+
1895
+
and ('cases, 'tag) case_value =
1896
+
| Case_value :
1897
+
('cases, 'case, 'tag) case_map * 'case -> ('cases, 'tag) case_value
1898
+
(** The type for case values. This packs a case value and its
1899
+
description. *)
1900
+
1901
+
and ('cases, 'tag) case =
1902
+
| Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case
1903
+
(** The type for hiding the the concrete type of a case . *)
1904
+
1905
+
(** {1:any Any maps} *)
1906
+
1907
+
and 'a any_map =
1908
+
{ kind : string;
1909
+
(** The kind of JSON values mapped (documentation). *)
1910
+
doc : string;
1911
+
(** Documentation string for the kind of values. *)
1912
+
dec_null : 'a t option;
1913
+
(** [dec_null], if any, is used for decoding JSON nulls. *)
1914
+
dec_bool : 'a t option;
1915
+
(** [dec_bool], if any, is used for decoding JSON bools. *)
1916
+
dec_number : 'a t option;
1917
+
(** [dec_number], if any, is used for decoding JSON numbers. *)
1918
+
dec_string : 'a t option;
1919
+
(** [dec_string], if any, is used for decoding JSON strings. *)
1920
+
dec_array : 'a t option;
1921
+
(** [dec_array], if any, is used for decoding JSON arrays. *)
1922
+
dec_object : 'a t option;
1923
+
(** [dec_object], if any, is used for decoding JSON objects. *)
1924
+
enc : 'a -> 'a t;
1925
+
(** [enc] specifies the encoder to use on a given value. *)
1926
+
}
1927
+
(** The type for mapping JSON values with multiple sorts to a value
1928
+
of type ['a]. If a decoding case is [None], the decoding
1929
+
errors on these JSON values. *)
1930
+
1931
+
(** {1:type_map Type maps} *)
1932
+
1933
+
and ('a, 'b) map =
1934
+
{ kind : string;
1935
+
(** The kind of JSON values mapped (documentation). *)
1936
+
doc : string;
1937
+
(** Documentation string for the kind of values. *)
1938
+
dom : 'a t;
1939
+
(** The domain of the map. *)
1940
+
dec : 'a -> 'b;
1941
+
(** [dec] decodes ['a] to ['b]. *)
1942
+
enc : 'b -> 'a;
1943
+
(** [enc] encodes ['b] to ['a]. *) }
1944
+
(** The type for mapping JSON types of type ['a] to a JSON type of
1945
+
type ['b]. *)
1946
+
1947
+
(** {1:conv Convert} *)
1948
+
1949
+
val of_t : 'a t' -> 'a t
1950
+
(** [of_t] is {!Stdlib.Fun.id}. *)
1951
+
1952
+
val unsafe_to_t : 'a t -> 'a t'
1953
+
(** [unsafe_to_t r] converts the representation to a type [r]. It
1954
+
is unsafe because constructors of the {!Jsont} module do
1955
+
maintain some invariants. *)
1956
+
1957
+
(** {1:kinds Kinds and doc} *)
1958
+
1959
+
val kinded_sort : 'a t -> string
1960
+
(** [kinded_sort t] is kinded sort of [t], see {!Jsont.kinded_sort}. *)
1961
+
1962
+
val array_map_kinded_sort : ('a, 'elt, 'builder) array_map -> string
1963
+
(** [array_map_kinded_sort map] is like {!kinded_sort} but
1964
+
acts directly on the array [map]. *)
1965
+
1966
+
val object_map_kinded_sort : ('o, 'dec) object_map -> string
1967
+
(** [object_map_kind map] is like {!kinded_sort} but acts directly
1968
+
on the object [map]. *)
1969
+
1970
+
val pp_kind : string fmt
1971
+
(** [pp_kind] formats kinds. *)
1972
+
1973
+
val doc : 'a t -> string
1974
+
(** See {!Jsont.doc}. *)
1975
+
1976
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
1977
+
(** See {!Jsont.with_doc}. *)
1978
+
1979
+
(** {1:errors Errors} *)
1980
+
1981
+
val error_push_array :
1982
+
Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a
1983
+
(** [error_push_array] is like {!Error.push_array} but uses the
1984
+
given array [meta] and array map to caracterize the context. *)
1985
+
1986
+
val error_push_object :
1987
+
Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a
1988
+
(** [error_push_object] is like {!Error.push_object} but uses the
1989
+
given object [meta] and object map to caracterize the context. *)
1990
+
1991
+
val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b
1992
+
(** [type_error meta ~exp ~fnd] errors when kind [exp] was expected
1993
+
but sort [fnd] was found. *)
1994
+
1995
+
val missing_mems_error :
1996
+
Meta.t -> ('o, 'o) object_map -> exp:mem_dec String_map.t ->
1997
+
fnd:string list -> 'a
1998
+
(** [missing_mems_error m map exp fnd] errors when [exp] cannot
1999
+
be found, [fnd] can list a few members that were found. *)
2000
+
2001
+
val unexpected_mems_error :
2002
+
Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a
2003
+
(** [unexpected_mems_error meta map ~fnd] errors when [fnd] are
2004
+
unexpected members for object [map]. *)
2005
+
2006
+
val unexpected_case_tag_error :
2007
+
Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases ->
2008
+
'tag -> 'a
2009
+
(** [unexpected_case_tag_error meta map cases tag] is when a [tag]
2010
+
of a case member has no corresponding case. *)
2011
+
2012
+
(** {1:toolbox Processor toolbox} *)
2013
+
2014
+
val object_meta_arg : Meta.t Type.Id.t
2015
+
(** [object_meta_arg] holds the {!Jsont.Object.mem} to *)
2016
+
2017
+
(** Heterogeneous dictionaries. *)
2018
+
module Dict : sig
2019
+
type binding = B : 'a Type.Id.t * 'a -> binding
2020
+
type t
2021
+
val empty : t
2022
+
val mem : 'a Type.Id.t -> t -> bool
2023
+
val add : 'a Type.Id.t -> 'a -> t -> t
2024
+
val remove : 'a Type.Id.t -> t -> t
2025
+
val find : 'a Type.Id.t -> t -> 'a option
2026
+
end
2027
+
2028
+
val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f
2029
+
(** [apply_dict dec dict] applies [dict] to [f] in order to get the
2030
+
value ['f]. Raises [Invalid_argument] if [dict] has not all the
2031
+
type identifiers that [dec] needs. *)
2032
+
2033
+
type unknown_mems_option =
2034
+
| Unknown_mems :
2035
+
('o, 'mems, 'builder) unknown_mems option -> unknown_mems_option
2036
+
(** A type for hiding an optional {!type-unknown_mems} values. *)
2037
+
2038
+
val override_unknown_mems :
2039
+
by:unknown_mems_option -> unknown_mems_option ->
2040
+
Dict.t -> unknown_mems_option * Dict.t
2041
+
(** [override_unknown_mems ~by current dict] preforms the unknown member
2042
+
overriding logic for {!Jsont.Object.Case} objects. In particular if
2043
+
[current] is a {!Jsont.Object.Mems.val-map} it adds an empty one in [dict]
2044
+
so that the associated decoding function does not fail. *)
2045
+
2046
+
val finish_object_decode :
2047
+
('o, 'o) object_map -> Meta.t -> ('p, 'mems, 'builder) unknown_mems ->
2048
+
'builder -> mem_dec String_map.t -> Dict.t -> Dict.t
2049
+
(** [finish_object_decode map meta unknown_mems umap rem_mems dict] finishes
2050
+
an object map [map] decode. It adds the [umap] (if needed) to [dict],
2051
+
it adds [meta] to [dict] under {!object_meta_arg} and tries to find
2052
+
andd default values to [dict] for [rem_mems] (and errors if it can't). *)
2053
+
2054
+
val pp_code : string fmt
2055
+
(** [pp_code] formats strings like code (in bold). *)
2056
+
end
+642
vendor/opam/jsont/src/jsont_base.ml
+642
vendor/opam/jsont/src/jsont_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 = match last with
11
+
| None -> max
12
+
| Some l when l > max -> max
13
+
| Some l -> l
14
+
in
15
+
let first = if first < 0 then 0 else first in
16
+
if first > last then "" else
17
+
String.sub s first (last - first + 1)
18
+
19
+
let edit_distance s0 s1 =
20
+
let min_by f a b = if f a <= f b then a else b in
21
+
let max_by f a b = if f a <= f b then b else a in
22
+
let minimum a b c = min a (min b c) in
23
+
let s0 = min_by String.length s0 s1 (* row *)
24
+
and s1 = max_by String.length s0 s1 in (* column *)
25
+
let m = String.length s0 and n = String.length s1 in
26
+
let rec rows row0 row i =
27
+
if i > n then row0.(m) else begin
28
+
row.(0) <- i;
29
+
for j = 1 to m do
30
+
if s0.[j - 1] = s1.[i - 1] then row.(j) <- row0.(j - 1) 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 in
35
+
rows (Array.init (m + 1) (fun x -> x)) (Array.make (m + 1) 0) 1
36
+
37
+
let suggest ?(dist = 2) candidates s =
38
+
let add (min, acc) name =
39
+
let d = edit_distance s name in
40
+
if d = min then min, (name :: acc) else
41
+
if d < min then d, [name] else
42
+
min, acc
43
+
in
44
+
let d, suggs = List.fold_left add (max_int, []) candidates in
45
+
if d <= dist (* suggest only if not too far *) then List.rev suggs else []
46
+
47
+
(* Hex converters *)
48
+
49
+
let lower_hex_digit n =
50
+
let n = n land 0xF in
51
+
Char.unsafe_chr (if n < 10 then 0x30 + n else 0x57 + n)
52
+
53
+
let binary_string_to_hex s =
54
+
let rec loop max s i h k =
55
+
if i > max then Bytes.unsafe_to_string h else
56
+
let byte = Char.code s.[i] in
57
+
Bytes.set h k (lower_hex_digit (byte lsr 4));
58
+
Bytes.set h (k + 1) (lower_hex_digit byte);
59
+
loop max s (i + 1) h (k + 2)
60
+
in
61
+
let len = String.length s in
62
+
let h = Bytes.create (2 * len) in
63
+
loop (len - 1) s 0 h 0
64
+
65
+
exception Illegal_hex of int
66
+
67
+
let binary_string_of_hex h =
68
+
let hex_value s i = match s.[i] with
69
+
| '0' .. '9' as c -> Char.code c - 0x30
70
+
| 'A' .. 'F' as c -> 10 + (Char.code c - 0x41)
71
+
| 'a' .. 'f' as c -> 10 + (Char.code c - 0x61)
72
+
| _ -> raise_notrace (Illegal_hex i)
73
+
in
74
+
try match String.length h with
75
+
| len when len mod 2 <> 0 -> raise (Illegal_hex len)
76
+
| len ->
77
+
let rec loop max s i h k =
78
+
if i > max then Ok (Bytes.unsafe_to_string s) else
79
+
let hi = hex_value h k and lo = hex_value h (k + 1) in
80
+
Bytes.set s i (Char.chr @@ (hi lsl 4) lor lo);
81
+
loop max s (i + 1) h (k + 2)
82
+
in
83
+
let s_len = len / 2 in
84
+
let s = Bytes.create s_len in
85
+
loop (s_len - 1) s 0 h 0
86
+
with Illegal_hex i ->
87
+
if i = String.length h
88
+
then Error "Missing final hexadecimal digit" else
89
+
let c = String.get_uint8 h i in
90
+
Error (Printf.sprintf "%d: byte x%x not an ASCII hexadecimal digit" i c)
91
+
92
+
(* Type identifiers. *)
93
+
94
+
module Type = struct (* Can be removed once we require OCaml 5.1 *)
95
+
type (_, _) eq = Equal : ('a, 'a) eq
96
+
module Id = struct
97
+
type _ id = ..
98
+
module type ID = sig type t type _ id += Id : t id end
99
+
type 'a t = (module ID with type t = 'a)
100
+
101
+
let make (type a) () : a t =
102
+
(module struct type t = a type _ id += Id : t id end)
103
+
104
+
let provably_equal
105
+
(type a b) ((module A) : a t) ((module B) : b t) : (a, b) eq option
106
+
=
107
+
match A.Id with B.Id -> Some Equal | _ -> None
108
+
109
+
let uid (type a) ((module A) : a t) =
110
+
Obj.Extension_constructor.id (Obj.Extension_constructor.of_val A.Id)
111
+
end
112
+
end
113
+
114
+
(* Resizable arrays *)
115
+
116
+
module Rarray = struct
117
+
type 'a t =
118
+
{ mutable els : 'a array;
119
+
mutable max : int; (* index of last element of [els]. *) }
120
+
121
+
let get a i = a.els.(i)
122
+
let empty () = { els = [||]; max = -1 }
123
+
let grow a v =
124
+
let len = a.max + 1 in
125
+
let els' = Array.make (2 * (if len = 0 then 1 else len)) v in
126
+
Array.blit a.els 0 els' 0 len; a.els <- els'
127
+
128
+
let length a = a.max + 1
129
+
let add_last v a =
130
+
let max = a.max + 1 in
131
+
if max = Array.length a.els then grow a v;
132
+
a.max <- max; a.els.(max) <- v; a
133
+
134
+
let to_array a =
135
+
if a.max + 1 = Array.length a.els then a.els else
136
+
let v = Array.make (a.max + 1) a.els.(0) in
137
+
Array.blit a.els 0 v 0 (a.max + 1);
138
+
v
139
+
end
140
+
141
+
(* Resizable bigarrays *)
142
+
143
+
module Rbigarray1 = struct
144
+
type ('a, 'b, 'c) t =
145
+
{ mutable els : ('a, 'b, 'c) Bigarray.Array1.t;
146
+
mutable max : int; (* index of the last element of [els]. *) }
147
+
148
+
let get a i = Bigarray.Array1.get a.els i
149
+
150
+
let empty kind layout =
151
+
{ els = Bigarray.Array1.create kind layout 0; max = -1 }
152
+
153
+
let grow a v =
154
+
let len = a.max + 1 in
155
+
let len = if len = 0 then 1 else len in
156
+
let init i = Bigarray.Array1.(if i <= a.max then get a.els i else v) in
157
+
let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
158
+
let els' = Bigarray.Array1.init k l (2 * len) init in
159
+
a.els <- els'
160
+
161
+
let length a = a.max + 1
162
+
let add_last v a =
163
+
let max = a.max + 1 in
164
+
if max = Bigarray.Array1.dim a.els then grow a v;
165
+
a.max <- max; Bigarray.Array1.set a.els max v; a
166
+
167
+
let to_bigarray a =
168
+
if a.max + 1 = Bigarray.Array1.dim a.els then a.els else
169
+
let init i = Bigarray.Array1.get a.els i in
170
+
let k, l = Bigarray.Array1.(kind a.els, layout a.els) in
171
+
Bigarray.Array1.init k l (a.max + 1) init
172
+
end
173
+
174
+
(* Mini fmt *)
175
+
176
+
module Fmt = struct
177
+
type 'a t = Format.formatter -> 'a -> unit
178
+
let pf = Format.fprintf
179
+
let str = Format.asprintf
180
+
let nop _ () = ()
181
+
let sp = Format.pp_print_space
182
+
let comma ppf () = Format.pp_print_char ppf ','; sp ppf ()
183
+
let list = Format.pp_print_list
184
+
let char = Format.pp_print_char
185
+
let string = Format.pp_print_string
186
+
let substring first len ppf s =
187
+
if first = 0 && len = String.length s then string ppf s else
188
+
(* One day use https://github.com/ocaml/ocaml/pull/12133 *)
189
+
for i = first to first + len - 1 do char ppf s.[i] done
190
+
191
+
let lines ppf s =
192
+
Format.pp_print_list string ppf (String.split_on_char '\n' s)
193
+
194
+
(* ANSI styling
195
+
196
+
Note this is the scheme we have in More.Fmt but obviously
197
+
we can't depend on it. For now we decided not to surface it
198
+
at the library level. Ideally something should be provided
199
+
upstream. *)
200
+
201
+
type styler = Ansi | Plain
202
+
203
+
let styler' = Atomic.make @@
204
+
match Sys.getenv_opt "NO_COLOR" with
205
+
| Some s when s <> "" -> Plain
206
+
| _ ->
207
+
match Sys.getenv_opt "TERM" with
208
+
| Some "dumb" -> Plain
209
+
| None when Sys.backend_type <> Other "js_of_ocaml" -> Plain
210
+
| _ -> Ansi
211
+
212
+
let set_styler styler = Atomic.set styler' styler
213
+
let styler () = Atomic.get styler'
214
+
215
+
let ansi_reset = "\x1B[0m"
216
+
let bold ppf s =
217
+
if Atomic.get styler' = Plain then string ppf s else
218
+
pf ppf "@<0>%s%s@<0>%s" "\x1B[1m" s ansi_reset
219
+
220
+
let bold_red ppf s =
221
+
if Atomic.get styler' = Plain then string ppf s else
222
+
pf ppf "@<0>%s%s@<0>%s" "\x1B[31;1m" s ansi_reset
223
+
224
+
let code = bold
225
+
let puterr ppf () = bold_red ppf "Error"; char ppf ':'
226
+
227
+
let disable_ansi_styler () = set_styler Plain
228
+
229
+
(* HCI fragments *)
230
+
231
+
let op_enum op ?(empty = nop) pp_v ppf = function
232
+
| [] -> empty ppf ()
233
+
| [v] -> pp_v ppf v
234
+
| _ as vs ->
235
+
let rec loop ppf = function
236
+
| [v0; v1] -> pf ppf "%a@ %s@ %a" pp_v v0 op pp_v v1
237
+
| v :: vs -> pf ppf "%a,@ " pp_v v; loop ppf vs
238
+
| [] -> assert false
239
+
in
240
+
loop ppf vs
241
+
242
+
let or_enum ?empty pp_v ppf vs = op_enum "or" ?empty pp_v ppf vs
243
+
244
+
let should_it_be pp_v ppf = function
245
+
| [] -> () | vs -> pf ppf "Should it be %a ?" (or_enum pp_v) vs
246
+
247
+
let must_be pp_v ppf = function
248
+
| [] -> () | vs -> pf ppf "Must be %a." (or_enum pp_v) vs
249
+
250
+
let unexpected ~kind pp_v ppf v = pf ppf "Unexpected %a: %a." kind () pp_v v
251
+
let unexpected' ~kind pp_v ~hint ppf (v, hints) = match hints with
252
+
| [] -> unexpected ~kind pp_v ppf v
253
+
| hints -> unexpected ~kind pp_v ppf v; sp ppf (); (hint pp_v) ppf hints
254
+
255
+
let out_of_dom ?pp_kind () ppf (s, ss) =
256
+
let kind = match pp_kind with
257
+
| None -> fun ppf () -> string ppf "value" | Some pp_kind -> pp_kind
258
+
in
259
+
let hint, ss = match suggest ss s with
260
+
| [] -> must_be, ss | ss -> should_it_be, ss
261
+
in
262
+
pf ppf "@[%a@]" (unexpected' ~kind code ~hint) (s, ss)
263
+
264
+
let similar_mems ppf (exp, fnd) = match suggest fnd exp with
265
+
| [] -> () | ms ->
266
+
pf ppf "@;@[Similar members in object: %a@]" (list ~pp_sep:comma code) ms
267
+
268
+
let should_it_be_mem ppf (exp, fnd) = match suggest fnd exp with
269
+
| [] -> () | ms -> pf ppf "@;@[%a@]" (should_it_be code) ms
270
+
271
+
(* JSON formatting *)
272
+
273
+
type json_number_format = (float -> unit, Format.formatter, unit) format
274
+
let json_default_number_format : json_number_format = format_of_string "%.17g"
275
+
276
+
let json_null ppf () = string ppf "null"
277
+
let json_bool ppf b = string ppf (if b then "true" else "false")
278
+
let json_number' fmt ppf f = (* cf. ECMAScript's JSON.stringify *)
279
+
if Float.is_finite f then pf ppf fmt f else json_null ppf ()
280
+
281
+
let json_number ppf v = json_number' json_default_number_format ppf v
282
+
let json_string ppf s =
283
+
let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in
284
+
let len = String.length s in
285
+
let max_idx = len - 1 in
286
+
let flush ppf start i =
287
+
if start < len then substring start (i - start) ppf s
288
+
in
289
+
let rec loop start i =
290
+
if i > max_idx then flush ppf start i else
291
+
let next = i + 1 in
292
+
match String.get s i with
293
+
| '"' -> flush ppf start i; string ppf "\\\""; loop next next
294
+
| '\\' -> flush ppf start i; string ppf "\\\\"; loop next next
295
+
| '\n' -> flush ppf start i; string ppf "\\n"; loop next next
296
+
| '\r' -> flush ppf start i; string ppf "\\r"; loop next next
297
+
| '\t' -> flush ppf start i; string ppf "\\t"; loop next next
298
+
| c when is_control c ->
299
+
flush ppf start i;
300
+
string ppf (Printf.sprintf "\\u%04X" (Char.code c));
301
+
loop next next
302
+
| _c -> loop start next
303
+
in
304
+
char ppf '"'; loop 0 0; char ppf '"'
305
+
end
306
+
307
+
(* Text locations *)
308
+
309
+
module Textloc = struct
310
+
311
+
(* File paths *)
312
+
313
+
type fpath = string
314
+
let file_none = "-"
315
+
let pp_path = Format.pp_print_string
316
+
317
+
(* Byte positions *)
318
+
319
+
type byte_pos = int (* zero-based *)
320
+
let byte_pos_none = -1
321
+
322
+
(* Lines *)
323
+
324
+
type line_num = int (* one-based *)
325
+
let line_num_none = -1
326
+
327
+
(* Line positions
328
+
329
+
We keep the byte position of the first element on the line. This
330
+
first element may not exist and be equal to the text length if
331
+
the input ends with a newline. Editors expect tools to compute
332
+
visual columns (not a very good idea). By keeping these byte
333
+
positions we can approximate columns by subtracting the line byte
334
+
position data byte location. This will only be correct on
335
+
US-ASCII data. *)
336
+
337
+
type line_pos = line_num * byte_pos
338
+
let line_pos_first = 1, 0
339
+
let line_pos_none = line_num_none, byte_pos_none
340
+
341
+
(* Text locations *)
342
+
343
+
type t =
344
+
{ file : fpath;
345
+
first_byte : byte_pos; last_byte : byte_pos;
346
+
first_line : line_pos; last_line : line_pos }
347
+
348
+
let make ~file ~first_byte ~last_byte ~first_line ~last_line =
349
+
{ file; first_byte; last_byte; first_line; last_line }
350
+
351
+
let file l = l.file
352
+
let set_file l file = { l with file }
353
+
let first_byte l = l.first_byte
354
+
let last_byte l = l.last_byte
355
+
let first_line l = l.first_line
356
+
let last_line l = l.last_line
357
+
let none =
358
+
let first_byte = byte_pos_none and last_byte = byte_pos_none in
359
+
let first_line = line_pos_none and last_line = line_pos_none in
360
+
make ~file:file_none ~first_byte ~last_byte ~first_line ~last_line
361
+
362
+
(* Predicates and comparisons *)
363
+
364
+
let is_none l = l.first_byte < 0
365
+
let is_empty l = l.first_byte > l.last_byte
366
+
let equal l0 l1 =
367
+
String.equal l0.file l1.file &&
368
+
Int.equal l0.first_byte l1.first_byte &&
369
+
Int.equal l0.last_byte l1.last_byte
370
+
371
+
let compare l0 l1 =
372
+
let c = String.compare l0.file l1.file in
373
+
if c <> 0 then c else
374
+
let c = Int.compare l0.first_byte l1.first_byte in
375
+
if c <> 0 then c else
376
+
Int.compare l0.last_byte l1.last_byte
377
+
378
+
(* Shrink and stretch *)
379
+
380
+
let set_first l ~first_byte ~first_line = { l with first_byte; first_line }
381
+
let set_last l ~last_byte ~last_line = { l with last_byte; last_line }
382
+
383
+
[@@@warning "-6"]
384
+
let to_first l =
385
+
make l.file l.first_byte l.first_byte l.first_line l.first_line
386
+
387
+
let to_last l =
388
+
make l.file l.last_byte l.last_byte l.last_line l.last_line
389
+
390
+
let before l =
391
+
make l.file l.first_byte byte_pos_none l.first_line line_pos_none
392
+
393
+
let after l =
394
+
make l.file (l.first_byte + 1) byte_pos_none l.last_line line_pos_none
395
+
[@@@warning "+6"]
396
+
397
+
let span l0 l1 =
398
+
let first_byte, first_line =
399
+
if l0.first_byte < l1.first_byte
400
+
then l0.first_byte, l0.first_line
401
+
else l1.first_byte, l1.first_line
402
+
in
403
+
let last_byte, last_line, file =
404
+
if l0.last_byte < l1.last_byte
405
+
then l1.last_byte, l1.last_line, l1.file
406
+
else l0.last_byte, l0.last_line, l0.file
407
+
in
408
+
make ~file ~first_byte ~first_line ~last_byte ~last_line
409
+
410
+
[@@@warning "-6"]
411
+
let reloc ~first ~last =
412
+
make last.file first.first_byte last.last_byte first.first_line
413
+
last.last_line
414
+
[@@@warning "+6"]
415
+
416
+
(* Formatters *)
417
+
418
+
let pf = Format.fprintf
419
+
let pp_ocaml ppf l = match is_none l with
420
+
| true -> pf ppf "File \"%a\"" pp_path l.file
421
+
| false ->
422
+
let pp_lines ppf l = match fst l.first_line = fst l.last_line with
423
+
| true -> pf ppf "line %d" (fst l.first_line)
424
+
| false -> pf ppf "lines %d-%d" (fst l.first_line) (fst l.last_line)
425
+
in
426
+
(* "characters" represent positions (insertion points) not columns *)
427
+
let pos_s = l.first_byte - snd l.first_line in
428
+
let pos_e = l.last_byte - snd l.last_line + 1 in
429
+
if pos_s = 0 && pos_e = 0
430
+
then pf ppf "File \"%a\", %a" pp_path l.file pp_lines l
431
+
else pf ppf "File \"%a\", %a, characters %d-%d"
432
+
pp_path l.file pp_lines l pos_s pos_e
433
+
434
+
let pp_gnu ppf l = match is_none l with
435
+
| true -> pf ppf "%a:" pp_path l.file
436
+
| false ->
437
+
let pp_lines ppf l =
438
+
let col_s = l.first_byte - snd l.first_line + 1 in
439
+
let col_e = l.last_byte - snd l.last_line + 1 in
440
+
match fst l.first_line = fst l.last_line with
441
+
| true -> pf ppf "%d.%d-%d" (fst l.first_line) col_s col_e
442
+
| false ->
443
+
pf ppf "%d.%d-%d.%d"
444
+
(fst l.first_line) col_s (fst l.last_line) col_e
445
+
in
446
+
pf ppf "%a:%a" pp_path l.file pp_lines l
447
+
448
+
let pp = pp_ocaml
449
+
450
+
let pp_dump ppf l =
451
+
pf ppf "file:%s bytes:%d-%d lines:(%d,%d)-(%d,%d)"
452
+
l.file l.first_byte l.last_byte (fst l.first_line)
453
+
(snd l.first_line) (fst l.last_line) (snd l.last_line)
454
+
end
455
+
456
+
type 'a fmt = Stdlib.Format.formatter -> 'a -> unit
457
+
458
+
(* Node meta data *)
459
+
460
+
module Meta = struct
461
+
type t =
462
+
{ textloc : Textloc.t;
463
+
ws_before : string;
464
+
ws_after : string; }
465
+
466
+
let make ?(ws_before = "") ?(ws_after = "") textloc =
467
+
{ textloc; ws_before; ws_after }
468
+
469
+
let none = { textloc = Textloc.none; ws_before = ""; ws_after = "" }
470
+
let is_none m = none == m
471
+
let textloc m = m.textloc
472
+
let ws_before m = m.ws_before
473
+
let ws_after m = m.ws_after
474
+
let with_textloc m textloc = { m with textloc }
475
+
let clear_ws m = { m with ws_before = ""; ws_after = "" }
476
+
let clear_textloc m = { m with textloc = Textloc.none }
477
+
let copy_ws src ~dst =
478
+
{ dst with ws_before = src.ws_before; ws_after = src.ws_after }
479
+
end
480
+
481
+
type 'a node = 'a * Meta.t
482
+
483
+
(* JSON numbers *)
484
+
485
+
module Number = struct
486
+
let number_contains_int = Sys.int_size <= 53
487
+
let min_exact_int = if number_contains_int then Int.min_int else -(1 lsl 53)
488
+
let max_exact_int = if number_contains_int then Int.max_int else 1 lsl 53
489
+
let min_exact_uint8 = 0 let max_exact_uint8 = 255
490
+
let min_exact_uint16 = 0 let max_exact_uint16 = 65535
491
+
let min_exact_int8 = -128 let max_exact_int8 = 127
492
+
let min_exact_int16 = -32768 let max_exact_int16 = 32767
493
+
let min_exact_int32 = Int32.min_int let max_exact_int32 = Int32.max_int
494
+
let max_exact_int64 = Int64.shift_left 1L 53
495
+
let min_exact_int64 = Int64.neg max_exact_int64
496
+
497
+
let[@inline] int_is_uint8 v = v land (lnot 0xFF) = 0
498
+
let[@inline] int_is_uint16 v = v land (lnot 0xFFFF) = 0
499
+
let[@inline] int_is_int8 v = min_exact_int8 <= v && v <= max_exact_int8
500
+
let[@inline] int_is_int16 v = min_exact_int16 <= v && v <= max_exact_int16
501
+
502
+
let[@inline] can_store_exact_int v =
503
+
min_exact_int <= v && v <= max_exact_int
504
+
505
+
let[@inline] can_store_exact_int64 v =
506
+
Int64.(compare min_exact_int64 v <= 0 && compare v max_exact_int64 <= 0)
507
+
508
+
let max_exact_int_float = Int.to_float max_exact_int
509
+
let min_exact_int_float = Int.to_float min_exact_int
510
+
let max_exact_uint8_float = Int.to_float max_exact_uint8
511
+
let min_exact_uint8_float = Int.to_float min_exact_uint8
512
+
let max_exact_uint16_float = Int.to_float max_exact_uint16
513
+
let min_exact_uint16_float = Int.to_float min_exact_uint16
514
+
let max_exact_int8_float = Int.to_float max_exact_int8
515
+
let min_exact_int8_float = Int.to_float min_exact_int8
516
+
let min_exact_int16_float = Int.to_float min_exact_int16
517
+
let max_exact_int16_float = Int.to_float max_exact_int16
518
+
let max_exact_int32_float = Int32.to_float max_exact_int32
519
+
let min_exact_int32_float = Int32.to_float min_exact_int32
520
+
let max_exact_int64_float = Int64.to_float max_exact_int64
521
+
let min_exact_int64_float = Int64.to_float min_exact_int64
522
+
523
+
let[@inline] in_exact_int_range v =
524
+
min_exact_int_float <= v && v <= max_exact_int_float
525
+
526
+
let[@inline] in_exact_uint8_range v =
527
+
min_exact_uint8_float <= v && v <= max_exact_uint8_float
528
+
529
+
let[@inline] in_exact_uint16_range v =
530
+
min_exact_uint16_float <= v && v <= max_exact_uint16_float
531
+
532
+
let[@inline] in_exact_int8_range v =
533
+
min_exact_int8_float <= v && v <= max_exact_int8_float
534
+
535
+
let[@inline] in_exact_int16_range v =
536
+
min_exact_int16_float <= v && v <= max_exact_int16_float
537
+
538
+
let[@inline] in_exact_int32_range v =
539
+
min_exact_int32_float <= v && v <= max_exact_int32_float
540
+
541
+
let[@inline] in_exact_int64_range v =
542
+
min_exact_int64_float <= v && v <= max_exact_int64_float
543
+
end
544
+
545
+
(* JSON Paths *)
546
+
547
+
module Path = struct
548
+
549
+
(* Indices *)
550
+
551
+
type index = Mem of string node | Nth of int node
552
+
553
+
let pp_name ppf n = Fmt.code ppf n
554
+
let pp_index_num ppf n = Fmt.code ppf (Int.to_string n)
555
+
556
+
let pp_index ppf = function
557
+
| Mem (n, _) -> pp_name ppf n
558
+
| Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n
559
+
560
+
let pp_index_trace ppf = function
561
+
| Mem (n, meta) ->
562
+
Fmt.pf ppf "%a: in member %a" Textloc.pp (Meta.textloc meta) pp_name n
563
+
| Nth (n, meta) ->
564
+
Fmt.pf ppf "%a: at index %a" Textloc.pp (Meta.textloc meta) pp_index_num n
565
+
566
+
let pp_bracketed_index ppf = function
567
+
| Mem (n, _) -> Fmt.pf ppf "[%a]" pp_name n
568
+
| Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n
569
+
570
+
(* Paths *)
571
+
572
+
type t = index list
573
+
let root = []
574
+
let is_root = function [] -> true | _ -> false
575
+
let nth ?(meta = Meta.none) n p = Nth (n, meta) :: p
576
+
let mem ?(meta = Meta.none) n p = Mem (n, meta) :: p
577
+
let rev_indices p = p
578
+
let pp ppf is =
579
+
let pp_sep ppf () = Fmt.char ppf '.' in
580
+
Fmt.list ~pp_sep pp_index ppf (List.rev is)
581
+
582
+
let pp_trace ppf is =
583
+
if is <> [] then Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_index_trace) is
584
+
585
+
let none = []
586
+
let err i fmt = Format.kasprintf failwith ("%d: " ^^ fmt) i
587
+
let err_unexp_eoi i = err i "Unexpected end of input"
588
+
let err_unexp_char i s = err i "Unexpected character: %C" s.[i]
589
+
let err_illegal_char i s = err i "Illegal character here: %C" s.[i]
590
+
let err_unexp i s = err i "Unexpected input: %S" (string_subrange ~first:i s)
591
+
592
+
(* Parsing *)
593
+
594
+
let parse_eoi s i max = if i > max then () else err_unexp i s
595
+
let parse_index p s i max =
596
+
let first, stop = match s.[i] with '[' -> i + 1, ']' | _ -> i, '.' in
597
+
let last, next =
598
+
let rec loop stop s i max = match i > max with
599
+
| true -> if stop = ']' then err_unexp_eoi i else (i - 1), i
600
+
| false ->
601
+
let illegal = s.[i] = '[' || (s.[i] = ']' && stop = '.') in
602
+
if illegal then err_illegal_char i s else
603
+
if s.[i] <> stop then loop stop s (i + 1) max else
604
+
(i - 1), if stop = ']' then i + 1 else i
605
+
in
606
+
loop stop s first max
607
+
in
608
+
let idx = string_subrange ~first ~last s in
609
+
if idx = "" then err first "illegal empty index" else
610
+
match int_of_string idx with
611
+
| exception Failure _ -> next, (Mem (idx, Meta.none)) :: p
612
+
| idx -> next, (Nth (idx, Meta.none)) :: p
613
+
614
+
let of_string s =
615
+
let rec loop p s i max =
616
+
if i > max then p else
617
+
let next, p = parse_index p s i max in
618
+
if next > max then p else
619
+
if s.[next] <> '.' then err_unexp_char next s else
620
+
if next + 1 <= max then loop p s (next + 1) max else
621
+
err_unexp_eoi next
622
+
in
623
+
try
624
+
if s = "" then Ok [] else
625
+
let start = if s.[0] = '.' then 1 else 0 in
626
+
Ok (loop [] s start (String.length s - 1))
627
+
with Failure e -> Error e
628
+
end
629
+
630
+
(* JSON sorts *)
631
+
632
+
module Sort = struct
633
+
type t = Null | Bool | Number | String | Array | Object
634
+
let to_string = function
635
+
| Null -> "null" | Bool -> "bool" | Number -> "number"
636
+
| String -> "string" | Array -> "array" | Object -> "object"
637
+
638
+
let kinded' ~kind:k s = if k = "" then s else String.concat " " [k; s]
639
+
let kinded ~kind sort = kinded' ~kind (to_string sort)
640
+
let or_kind ~kind sort = if kind <> "" then kind else (to_string sort)
641
+
let pp ppf s = Fmt.code ppf (to_string s)
642
+
end
+188
vendor/opam/jsont/src/jsont_base.mli
+188
vendor/opam/jsont/src/jsont_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 {!Jsont}. *)
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
+
module Id : sig
16
+
type 'a t
17
+
val make : unit -> 'a t
18
+
val uid : 'a t -> int
19
+
val provably_equal : 'a t -> 'b t -> ('a, 'b) eq option
20
+
end
21
+
end
22
+
23
+
(** Resizable arrays. *)
24
+
module Rarray : sig
25
+
type 'a t
26
+
val get : 'a t -> int -> 'a
27
+
val empty : unit -> 'a t
28
+
val grow : 'a t -> 'a -> unit
29
+
val length : 'a t -> int
30
+
val add_last : 'a -> 'a t -> 'a t
31
+
val to_array : 'a t -> 'a array
32
+
end
33
+
34
+
(** Resizable bigarrays. *)
35
+
module Rbigarray1 : sig
36
+
type ('a, 'b, 'c) t
37
+
val get : ('a, 'b, 'c) t -> int -> 'a
38
+
val empty : ('a, 'b) Bigarray.kind -> 'c Bigarray.layout -> ('a, 'b, 'c) t
39
+
val grow : ('a, 'b, 'c) t -> 'a -> unit
40
+
val length : ('a, 'b, 'c) t -> int
41
+
val add_last : 'a -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
42
+
val to_bigarray : ('a, 'b, 'c) t -> ('a, 'b, 'c) Bigarray.Array1.t
43
+
end
44
+
45
+
(** Mini fmt *)
46
+
module Fmt : sig
47
+
type 'a t = Format.formatter -> 'a -> unit
48
+
val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
49
+
val str : ('a, Format.formatter, unit, string) format4 -> 'a
50
+
val disable_ansi_styler : unit -> unit
51
+
52
+
val nop : unit t
53
+
val sp : unit t
54
+
val list : ?pp_sep:unit t -> 'a t -> 'a list t
55
+
val char : char t
56
+
val string : string t
57
+
val substring : int -> int -> string t
58
+
val lines : string t
59
+
val bold : string t
60
+
val bold_red : string t
61
+
val code : string t
62
+
val puterr : unit t
63
+
val out_of_dom : ?pp_kind:unit t -> unit -> (string * string list) t
64
+
val should_it_be_mem : (string * string list) t
65
+
val similar_mems : (string * string list) t
66
+
67
+
68
+
type json_number_format = (float -> unit, Format.formatter, unit) format
69
+
val json_null : unit t
70
+
val json_bool : bool t
71
+
val json_default_number_format : json_number_format
72
+
val json_number' : json_number_format-> float t
73
+
val json_number : float t
74
+
val json_string : string t
75
+
end
76
+
77
+
(** See {!Jsont.Textloc} *)
78
+
module Textloc : sig
79
+
type fpath = string
80
+
val file_none : fpath
81
+
82
+
type byte_pos = int
83
+
val byte_pos_none : byte_pos
84
+
85
+
type line_num = int
86
+
val line_num_none : line_num
87
+
88
+
type line_pos = line_num * byte_pos
89
+
val line_pos_first : line_pos
90
+
val line_pos_none : line_pos
91
+
92
+
type t
93
+
val none : t
94
+
val make :
95
+
file:fpath -> first_byte:byte_pos -> last_byte:byte_pos ->
96
+
first_line:line_pos -> last_line:line_pos -> t
97
+
98
+
val file : t -> fpath
99
+
val set_file : t -> fpath -> t
100
+
val first_byte : t -> byte_pos
101
+
val last_byte : t -> byte_pos
102
+
val first_line : t -> line_pos
103
+
val last_line : t -> line_pos
104
+
val is_none : t -> bool
105
+
val is_empty : t -> bool
106
+
val equal : t -> t -> bool
107
+
val compare : t -> t -> int
108
+
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
109
+
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
110
+
val to_first : t -> t
111
+
val to_last : t -> t
112
+
val before : t -> t
113
+
val after : t -> t
114
+
val span : t -> t -> t
115
+
val reloc : first:t -> last:t -> t
116
+
val pp_ocaml : Format.formatter -> t -> unit
117
+
val pp_gnu : Format.formatter -> t -> unit
118
+
val pp : Format.formatter -> t -> unit
119
+
val pp_dump : Format.formatter -> t -> unit
120
+
end
121
+
122
+
type 'a fmt = Stdlib.Format.formatter -> 'a -> unit
123
+
124
+
(** See {!Jsont.Meta} *)
125
+
module Meta : sig
126
+
type t
127
+
val make : ?ws_before:string -> ?ws_after:string -> Textloc.t -> t
128
+
val none : t
129
+
val is_none : t -> bool
130
+
val textloc : t -> Textloc.t
131
+
val ws_before : t -> string
132
+
val ws_after : t -> string
133
+
val with_textloc : t -> Textloc.t -> t
134
+
val clear_ws : t -> t
135
+
val clear_textloc : t -> t
136
+
val copy_ws : t -> dst:t -> t
137
+
end
138
+
139
+
type 'a node = 'a * Meta.t
140
+
141
+
(** JSON number tools. *)
142
+
module Number : sig
143
+
val number_contains_int : bool
144
+
val int_is_uint8 : int -> bool
145
+
val int_is_uint16 : int -> bool
146
+
val int_is_int8 : int -> bool
147
+
val int_is_int16 : int -> bool
148
+
val can_store_exact_int : int -> bool
149
+
val can_store_exact_int64 : Int64.t -> bool
150
+
val in_exact_int_range : float -> bool
151
+
val in_exact_uint8_range : float -> bool
152
+
val in_exact_uint16_range : float -> bool
153
+
val in_exact_int8_range : float -> bool
154
+
val in_exact_int16_range : float -> bool
155
+
val in_exact_int32_range : float -> bool
156
+
val in_exact_int64_range : float -> bool
157
+
end
158
+
159
+
(** See {!Jsont.Path} *)
160
+
module Path : sig
161
+
type index =
162
+
| Mem of string node
163
+
| Nth of int node
164
+
165
+
val pp_index : index fmt
166
+
val pp_index_trace : index fmt
167
+
168
+
type t
169
+
val root : t
170
+
val is_root : t -> bool
171
+
val nth : ?meta:Meta.t -> int -> t -> t
172
+
val mem : ?meta:Meta.t -> string -> t -> t
173
+
val rev_indices : t -> index list
174
+
val of_string : string -> (t, string) result
175
+
val pp : t fmt
176
+
val pp_trace : t fmt
177
+
end
178
+
179
+
(** See {!Jsont.Sort} *)
180
+
module Sort : sig
181
+
type t = Null | Bool | Number | String | Array | Object
182
+
val to_string : t -> string
183
+
184
+
val kinded' : kind:string -> string -> string
185
+
val kinded : kind:string -> t -> string
186
+
val or_kind : kind:string -> t -> string
187
+
val pp : Format.formatter -> t -> unit
188
+
end
+260
vendor/opam/jsont/test/cookbook.ml
+260
vendor/opam/jsont/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
+
14
+
(* Base maps *)
15
+
16
+
module M = struct
17
+
type t = unit
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
+
let make name age = { name; age }
41
+
let name p = p.name
42
+
let age p = p.age
43
+
let jsont =
44
+
Jsont.Object.map ~kind:"Person" make
45
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
46
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
47
+
|> Jsont.Object.finish
48
+
end
49
+
50
+
(* Objects as key-value maps *)
51
+
52
+
module String_map = Map.Make (String)
53
+
54
+
let map : ?kind:string -> 'a Jsont.t -> 'a String_map.t Jsont.t =
55
+
fun ?kind t ->
56
+
Jsont.Object.map ?kind Fun.id
57
+
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map t) ~enc:Fun.id
58
+
|> Jsont.Object.finish
59
+
60
+
(* Optional members *)
61
+
62
+
module Person_opt_age = struct
63
+
type t = { name : string; age : int option }
64
+
let make name age = { name; age }
65
+
let name p = p.name
66
+
let age p = p.age
67
+
let jsont =
68
+
Jsont.Object.map ~kind:"Person" make
69
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
70
+
|> Jsont.Object.mem "age" Jsont.(some int)
71
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:age
72
+
|> Jsont.Object.finish
73
+
end
74
+
75
+
(* Unknown object members *)
76
+
77
+
module Person_strict = struct
78
+
type t = { name : string; age : int; }
79
+
let make name age = { name; age }
80
+
let name p = p.name
81
+
let age p = p.age
82
+
let jsont =
83
+
Jsont.Object.map ~kind:"Person" make
84
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
85
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
86
+
|> Jsont.Object.error_unknown
87
+
|> Jsont.Object.finish
88
+
end
89
+
90
+
module Person_keep = struct
91
+
type t = { name : string; age : int; unknown : Jsont.json ; }
92
+
let make name age unknown = { name; age; unknown }
93
+
let name p = p.name
94
+
let age p = p.age
95
+
let unknown v = v.unknown
96
+
let jsont =
97
+
Jsont.Object.map ~kind:"Person" make
98
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
99
+
|> Jsont.Object.mem "age" Jsont.int ~enc:age
100
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
101
+
|> Jsont.Object.finish
102
+
end
103
+
104
+
(* Dealing with recursive JSON *)
105
+
106
+
module Tree = struct
107
+
type 'a t = Node of 'a * 'a t list
108
+
let make v children = Node (v, children)
109
+
let value (Node (v, _)) = v
110
+
let children (Node (_, children)) = children
111
+
let jsont value_type =
112
+
let rec t = lazy
113
+
(Jsont.Object.map ~kind:"Tree" make
114
+
|> Jsont.Object.mem "value" value_type ~enc:value
115
+
|> Jsont.Object.mem "children" (Jsont.list (Jsont.rec' t)) ~enc:children
116
+
|> Jsont.Object.finish)
117
+
in
118
+
Lazy.force t
119
+
end
120
+
121
+
(* Dealing with object types or classes *)
122
+
123
+
module Geometry_variant = struct
124
+
module Circle = struct
125
+
type t = { name : string; radius : float; }
126
+
let make name radius = { name; radius }
127
+
let name c = c.name
128
+
let radius c = c.radius
129
+
let jsont =
130
+
Jsont.Object.map ~kind:"Circle" make
131
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
132
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
133
+
|> Jsont.Object.finish
134
+
end
135
+
136
+
module Rect = struct
137
+
type t = { name : string; width : float; height : float }
138
+
let make name width height = { name; width; height }
139
+
let name r = r.name
140
+
let width r = r.width
141
+
let height r = r.height
142
+
let jsont =
143
+
Jsont.Object.map ~kind:"Rect" make
144
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
145
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
146
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
147
+
|> Jsont.Object.finish
148
+
end
149
+
150
+
type t = Circle of Circle.t | Rect of Rect.t
151
+
let circle c = Circle c
152
+
let rect r = Rect r
153
+
let jsont =
154
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
155
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
156
+
let enc_case = function
157
+
| Circle c -> Jsont.Object.Case.value circle c
158
+
| Rect r -> Jsont.Object.Case.value rect r
159
+
in
160
+
let cases = Jsont.Object.Case.[make circle; make rect] in
161
+
Jsont.Object.map ~kind:"Geometry" Fun.id
162
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
163
+
|> Jsont.Object.finish
164
+
end
165
+
166
+
module Geometry_record = struct
167
+
module Circle = struct
168
+
type t = { radius : float; }
169
+
let make radius = { radius }
170
+
let radius c = c.radius
171
+
let jsont =
172
+
Jsont.Object.map ~kind:"Circle" make
173
+
|> Jsont.Object.mem "radius" Jsont.number ~enc:radius
174
+
|> Jsont.Object.finish
175
+
end
176
+
177
+
module Rect = struct
178
+
type t = { width : float; height : float }
179
+
let make width height = { width; height }
180
+
let width r = r.width
181
+
let height r = r.height
182
+
let jsont =
183
+
Jsont.Object.map ~kind:"Rect" make
184
+
|> Jsont.Object.mem "width" Jsont.number ~enc:width
185
+
|> Jsont.Object.mem "height" Jsont.number ~enc:height
186
+
|> Jsont.Object.finish
187
+
end
188
+
189
+
type type' = Circle of Circle.t | Rect of Rect.t
190
+
let circle c = Circle c
191
+
let rect r = Rect r
192
+
193
+
type t = { name : string; type' : type' }
194
+
let make name type' = { name; type' }
195
+
let name g = g.name
196
+
let type' g = g.type'
197
+
198
+
let jsont =
199
+
let circle = Jsont.Object.Case.map "Circle" Circle.jsont ~dec:circle in
200
+
let rect = Jsont.Object.Case.map "Rect" Rect.jsont ~dec:rect in
201
+
let enc_case = function
202
+
| Circle c -> Jsont.Object.Case.value circle c
203
+
| Rect r -> Jsont.Object.Case.value rect r
204
+
in
205
+
let cases = Jsont.Object.Case.[make circle; make rect] in
206
+
Jsont.Object.map ~kind:"Geometry" make
207
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
208
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
209
+
|> Jsont.Object.finish
210
+
end
211
+
212
+
213
+
(* Untagged object types *)
214
+
215
+
module Response = struct
216
+
type t =
217
+
{ id : int;
218
+
value : (Jsont.json, string) result }
219
+
220
+
let make id result error =
221
+
let pp_mem = Jsont.Repr.pp_code in
222
+
match result, error with
223
+
| Some result, None -> { id; value = Ok result }
224
+
| None, Some error -> { id; value = Error error }
225
+
| Some _ , Some _ ->
226
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
227
+
pp_mem "result" pp_mem "error"
228
+
| None, None ->
229
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
230
+
pp_mem "result" pp_mem "error"
231
+
232
+
let result r = match r.value with Ok v -> Some v | Error _ -> None
233
+
let error r = match r.value with Ok _ -> None | Error e -> Some e
234
+
235
+
let jsont =
236
+
Jsont.Object.map make
237
+
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun r -> r.id)
238
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:result
239
+
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:error
240
+
|> Jsont.Object.finish
241
+
end
242
+
243
+
(* Flattening objects on queries *)
244
+
245
+
module Group = struct
246
+
type t = { id : int; name : string; persons : Person.t list }
247
+
let make id name persons = { id; name; persons }
248
+
249
+
let info_jsont =
250
+
Jsont.Object.map make
251
+
|> Jsont.Object.mem "id" Jsont.int
252
+
|> Jsont.Object.mem "name" Jsont.string
253
+
|> Jsont.Object.finish
254
+
255
+
let jsont =
256
+
Jsont.Object.map (fun k persons -> k persons)
257
+
|> Jsont.Object.mem "info" info_jsont
258
+
|> Jsont.Object.mem "persons" (Jsont.list Person.jsont)
259
+
|> Jsont.Object.finish
260
+
end
+30
vendor/opam/jsont/test/expect/array.indent.json
+30
vendor/opam/jsont/test/expect/array.indent.json
+7
vendor/opam/jsont/test/expect/array.json
+7
vendor/opam/jsont/test/expect/array.json
+7
vendor/opam/jsont/test/expect/array.layout.json
+7
vendor/opam/jsont/test/expect/array.layout.json
+82
vendor/opam/jsont/test/expect/array.locs
+82
vendor/opam/jsont/test/expect/array.locs
···
1
+
Array:
2
+
File "array.json", lines 1-7, characters 0-14
3
+
Array:
4
+
File "array.json", line 1, characters 2-4
5
+
6
+
Array:
7
+
File "array.json", line 1, characters 6-19
8
+
String [1m"hey"[0m:
9
+
File "array.json", line 1, characters 7-12
10
+
11
+
Bool [1mtrue[0m:
12
+
File "array.json", line 1, characters 14-18
13
+
14
+
String [1m"something"[0m:
15
+
File "array.json", line 3, characters 11-22
16
+
17
+
Number [1m100[0m:
18
+
File "array.json", line 4, characters 2-5
19
+
20
+
Object:
21
+
File "array.json", lines 5-6, characters 2-54
22
+
Member [1m"has"[0m:
23
+
File "array.json", line 5, characters 5-10
24
+
Bool [1mtrue[0m:
25
+
File "array.json", line 5, characters 12-16
26
+
27
+
Member [1m"to"[0m:
28
+
File "array.json", line 5, characters 18-22
29
+
[1mnull[0m:
30
+
File "array.json", line 6, characters 5-9
31
+
32
+
Member [1m"be"[0m:
33
+
File "array.json", line 6, characters 11-15
34
+
Array:
35
+
File "array.json", line 6, characters 17-41
36
+
Number [1m0[0m:
37
+
File "array.json", line 6, characters 18-19
38
+
39
+
Number [1m1[0m:
40
+
File "array.json", line 6, characters 20-21
41
+
42
+
Number [1m2[0m:
43
+
File "array.json", line 6, characters 22-23
44
+
45
+
Number [1m3[0m:
46
+
File "array.json", line 6, characters 24-25
47
+
48
+
Number [1m4[0m:
49
+
File "array.json", line 6, characters 26-27
50
+
51
+
Number [1m5[0m:
52
+
File "array.json", line 6, characters 28-29
53
+
54
+
Number [1m6[0m:
55
+
File "array.json", line 6, characters 30-31
56
+
57
+
Number [1m7[0m:
58
+
File "array.json", line 6, characters 32-33
59
+
60
+
Number [1m8[0m:
61
+
File "array.json", line 6, characters 34-35
62
+
63
+
Number [1m9[0m:
64
+
File "array.json", line 6, characters 36-37
65
+
66
+
Number [1m10[0m:
67
+
File "array.json", line 6, characters 38-40
68
+
69
+
Member [1m"said"[0m:
70
+
File "array.json", line 6, characters 43-49
71
+
Object:
72
+
File "array.json", line 6, characters 51-53
73
+
74
+
Number [1m45[0m:
75
+
File "array.json", line 7, characters 2-4
76
+
77
+
Number [1m45[0m:
78
+
File "array.json", line 7, characters 6-8
79
+
80
+
Number [1m48[0m:
81
+
File "array.json", line 7, characters 10-12
82
+
+1
vendor/opam/jsont/test/expect/array.minify.json
+1
vendor/opam/jsont/test/expect/array.minify.json
···
1
+
[[],["hey",true],"something",100,{"has":true,"to":null,"be":[0,1,2,3,4,5,6,7,8,9,10],"said":{}},45,45,48]
+7
vendor/opam/jsont/test/expect/array.pretty.json
+7
vendor/opam/jsont/test/expect/array.pretty.json
+1
vendor/opam/jsont/test/expect/bool.indent.json
+1
vendor/opam/jsont/test/expect/bool.indent.json
···
1
+
true
+2
vendor/opam/jsont/test/expect/bool.locs
+2
vendor/opam/jsont/test/expect/bool.locs
+1
vendor/opam/jsont/test/expect/bool.minify.json
+1
vendor/opam/jsont/test/expect/bool.minify.json
···
1
+
true
+1
vendor/opam/jsont/test/expect/bool.pretty.json
+1
vendor/opam/jsont/test/expect/bool.pretty.json
···
1
+
true
+39
vendor/opam/jsont/test/expect/doc.indent.json
+39
vendor/opam/jsont/test/expect/doc.indent.json
···
1
+
{
2
+
"name": "hey",
3
+
"version": 1.45,
4
+
"deprecated": false,
5
+
"ignore": [
6
+
"README.md",
7
+
"LICENSE.md"
8
+
],
9
+
"other": [
10
+
{
11
+
"a": 1
12
+
},
13
+
{
14
+
"a": 2
15
+
},
16
+
{
17
+
"a": 3
18
+
},
19
+
{
20
+
"a": 4
21
+
},
22
+
{
23
+
"a": 5
24
+
},
25
+
{
26
+
"a": 6
27
+
},
28
+
{
29
+
"a": 7
30
+
},
31
+
{
32
+
"hu": null
33
+
}
34
+
],
35
+
"metameta": true,
36
+
"obj": {
37
+
"magic": null
38
+
}
39
+
}
+10
vendor/opam/jsont/test/expect/doc.json
+10
vendor/opam/jsont/test/expect/doc.json
+10
vendor/opam/jsont/test/expect/doc.layout.json
+10
vendor/opam/jsont/test/expect/doc.layout.json
+101
vendor/opam/jsont/test/expect/doc.locs
+101
vendor/opam/jsont/test/expect/doc.locs
···
1
+
Object:
2
+
File "doc.json", lines 1-10, characters 0-1
3
+
Member [1m"name"[0m:
4
+
File "doc.json", line 1, characters 2-8
5
+
String [1m"hey"[0m:
6
+
File "doc.json", line 1, characters 10-15
7
+
8
+
Member [1m"version"[0m:
9
+
File "doc.json", line 2, characters 2-11
10
+
Number [1m1.45[0m:
11
+
File "doc.json", line 2, characters 13-17
12
+
13
+
Member [1m"deprecated"[0m:
14
+
File "doc.json", line 3, characters 2-14
15
+
Bool [1mfalse[0m:
16
+
File "doc.json", line 3, characters 16-21
17
+
18
+
Member [1m"ignore"[0m:
19
+
File "doc.json", line 4, characters 2-10
20
+
Array:
21
+
File "doc.json", lines 4-5, characters 12-30
22
+
String [1m"README.md"[0m:
23
+
File "doc.json", line 4, characters 13-24
24
+
25
+
String [1m"LICENSE.md"[0m:
26
+
File "doc.json", line 5, characters 17-29
27
+
28
+
Member [1m"other"[0m:
29
+
File "doc.json", line 6, characters 2-9
30
+
Array:
31
+
File "doc.json", line 6, characters 11-105
32
+
Object:
33
+
File "doc.json", line 6, characters 12-22
34
+
Member [1m"a"[0m:
35
+
File "doc.json", line 6, characters 14-17
36
+
Number [1m1[0m:
37
+
File "doc.json", line 6, characters 19-20
38
+
39
+
Object:
40
+
File "doc.json", line 6, characters 25-34
41
+
Member [1m"a"[0m:
42
+
File "doc.json", line 6, characters 26-29
43
+
Number [1m2[0m:
44
+
File "doc.json", line 6, characters 31-32
45
+
46
+
Object:
47
+
File "doc.json", line 6, characters 38-47
48
+
Member [1m"a"[0m:
49
+
File "doc.json", line 6, characters 39-42
50
+
Number [1m3[0m:
51
+
File "doc.json", line 6, characters 44-45
52
+
53
+
Object:
54
+
File "doc.json", line 6, characters 49-58
55
+
Member [1m"a"[0m:
56
+
File "doc.json", line 6, characters 50-53
57
+
Number [1m4[0m:
58
+
File "doc.json", line 6, characters 55-56
59
+
60
+
Object:
61
+
File "doc.json", line 6, characters 60-69
62
+
Member [1m"a"[0m:
63
+
File "doc.json", line 6, characters 61-64
64
+
Number [1m5[0m:
65
+
File "doc.json", line 6, characters 66-67
66
+
67
+
Object:
68
+
File "doc.json", line 6, characters 71-80
69
+
Member [1m"a"[0m:
70
+
File "doc.json", line 6, characters 72-75
71
+
Number [1m6[0m:
72
+
File "doc.json", line 6, characters 77-78
73
+
74
+
Object:
75
+
File "doc.json", line 6, characters 82-89
76
+
Member [1m"a"[0m:
77
+
File "doc.json", line 6, characters 83-86
78
+
Number [1m7[0m:
79
+
File "doc.json", line 6, characters 87-88
80
+
81
+
Object:
82
+
File "doc.json", line 6, characters 91-104
83
+
Member [1m"hu"[0m:
84
+
File "doc.json", line 6, characters 92-96
85
+
[1mnull[0m:
86
+
File "doc.json", line 6, characters 97-101
87
+
88
+
Member [1m"metameta"[0m:
89
+
File "doc.json", line 7, characters 2-12
90
+
Bool [1mtrue[0m:
91
+
File "doc.json", line 7, characters 14-18
92
+
93
+
Member [1m"obj"[0m:
94
+
File "doc.json", line 8, characters 2-7
95
+
Object:
96
+
File "doc.json", line 9, characters 2-19
97
+
Member [1m"magic"[0m:
98
+
File "doc.json", line 9, characters 4-11
99
+
[1mnull[0m:
100
+
File "doc.json", line 9, characters 13-17
101
+
+1
vendor/opam/jsont/test/expect/doc.minify.json
+1
vendor/opam/jsont/test/expect/doc.minify.json
···
1
+
{"name":"hey","version":1.45,"deprecated":false,"ignore":["README.md","LICENSE.md"],"other":[{"a":1},{"a":2},{"a":3},{"a":4},{"a":5},{"a":6},{"a":7},{"hu":null}],"metameta":true,"obj":{"magic":null}}
+10
vendor/opam/jsont/test/expect/doc.pretty.json
+10
vendor/opam/jsont/test/expect/doc.pretty.json
+1
vendor/opam/jsont/test/expect/invalid-array0.json
+1
vendor/opam/jsont/test/expect/invalid-array0.json
···
1
+
[1,2,,3]
+4
vendor/opam/jsont/test/expect/invalid-array0.stderr
+4
vendor/opam/jsont/test/expect/invalid-array0.stderr
+1
vendor/opam/jsont/test/expect/invalid-array1.json
+1
vendor/opam/jsont/test/expect/invalid-array1.json
···
1
+
[1, 2, 3 4,5]
+2
vendor/opam/jsont/test/expect/invalid-array1.stderr
+2
vendor/opam/jsont/test/expect/invalid-array1.stderr
+1
vendor/opam/jsont/test/expect/invalid-array2.json
+1
vendor/opam/jsont/test/expect/invalid-array2.json
···
1
+
[1,2,3,]
+4
vendor/opam/jsont/test/expect/invalid-array2.stderr
+4
vendor/opam/jsont/test/expect/invalid-array2.stderr
+1
vendor/opam/jsont/test/expect/invalid-array3.json
+1
vendor/opam/jsont/test/expect/invalid-array3.json
···
1
+
[1,2,3,
+4
vendor/opam/jsont/test/expect/invalid-array3.stderr
+4
vendor/opam/jsont/test/expect/invalid-array3.stderr
+2
vendor/opam/jsont/test/expect/invalid-bool0.stderr
+2
vendor/opam/jsont/test/expect/invalid-bool0.stderr
+1
vendor/opam/jsont/test/expect/invalid-obj0.json
+1
vendor/opam/jsont/test/expect/invalid-obj0.json
···
1
+
{ "bla": }
+4
vendor/opam/jsont/test/expect/invalid-obj0.stderr
+4
vendor/opam/jsont/test/expect/invalid-obj0.stderr
+1
vendor/opam/jsont/test/expect/invalid-obj1.json
+1
vendor/opam/jsont/test/expect/invalid-obj1.json
···
1
+
{ "bla": 1, 2 }
+2
vendor/opam/jsont/test/expect/invalid-obj1.stderr
+2
vendor/opam/jsont/test/expect/invalid-obj1.stderr
+1
vendor/opam/jsont/test/expect/invalid-obj2.json
+1
vendor/opam/jsont/test/expect/invalid-obj2.json
···
1
+
{ "bla": 1, }
+2
vendor/opam/jsont/test/expect/invalid-obj2.stderr
+2
vendor/opam/jsont/test/expect/invalid-obj2.stderr
+1
vendor/opam/jsont/test/expect/invalid-obj3.json
+1
vendor/opam/jsont/test/expect/invalid-obj3.json
···
1
+
{ "bla": 1, "hey": "ho"
+2
vendor/opam/jsont/test/expect/invalid-obj3.stderr
+2
vendor/opam/jsont/test/expect/invalid-obj3.stderr
+324
vendor/opam/jsont/test/geojson.ml
+324
vendor/opam/jsont/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
+
let float_array_jsont ~kind = Jsont.array ~kind Jsont.number
21
+
22
+
type 'a garray = 'a array
23
+
let garray = Jsont.array
24
+
25
+
module Bbox = struct
26
+
type t = float_array
27
+
let jsont = float_array_jsont ~kind:"Bbox"
28
+
end
29
+
30
+
module Position = struct
31
+
type t = float_array
32
+
let jsont = float_array_jsont ~kind:"Position"
33
+
end
34
+
35
+
module Geojson_object = struct
36
+
type 'a t =
37
+
{ type' : 'a;
38
+
bbox : Bbox.t option;
39
+
unknown : Jsont.json }
40
+
41
+
let make type' bbox unknown = { type'; bbox; unknown }
42
+
let type' o = o.type'
43
+
let bbox o = o.bbox
44
+
let unknown o = o.unknown
45
+
46
+
let finish_jsont map =
47
+
map
48
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
49
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
50
+
|> Jsont.Object.finish
51
+
52
+
let geometry ~kind coordinates =
53
+
Jsont.Object.map ~kind make
54
+
|> Jsont.Object.mem "coordinates" coordinates ~enc:type'
55
+
|> finish_jsont
56
+
end
57
+
58
+
module Point = struct
59
+
type t = Position.t
60
+
let jsont = Geojson_object.geometry ~kind:"Point" Position.jsont
61
+
end
62
+
63
+
module Multi_point = struct
64
+
type t = Position.t garray
65
+
let jsont =
66
+
Geojson_object.geometry ~kind:"MultiPoint" (garray Position.jsont)
67
+
end
68
+
69
+
module Line_string = struct
70
+
type t = Position.t garray
71
+
let jsont =
72
+
Geojson_object.geometry ~kind:"LineString" (garray Position.jsont)
73
+
end
74
+
75
+
module Multi_line_string = struct
76
+
type t = Line_string.t garray
77
+
let jsont =
78
+
Geojson_object.geometry ~kind:"LineString" (garray (garray Position.jsont))
79
+
end
80
+
81
+
module Polygon = struct
82
+
type t = Line_string.t garray
83
+
let jsont =
84
+
Geojson_object.geometry ~kind:"Polygon" (garray (garray Position.jsont))
85
+
end
86
+
87
+
module Multi_polygon = struct
88
+
type t = Polygon.t garray
89
+
let jsont =
90
+
Geojson_object.geometry ~kind:"MultiPolygon"
91
+
(garray (garray (garray Position.jsont)))
92
+
end
93
+
94
+
module Geojson = struct
95
+
type 'a object' = 'a Geojson_object.t
96
+
type geometry =
97
+
[ `Point of Point.t object'
98
+
| `Multi_point of Multi_point.t object'
99
+
| `Line_string of Line_string.t object'
100
+
| `Multi_line_string of Multi_line_string.t object'
101
+
| `Polygon of Polygon.t object'
102
+
| `Multi_polygon of Multi_polygon.t object'
103
+
| `Geometry_collection of geometry_collection object' ]
104
+
and geometry_collection = geometry list
105
+
106
+
module Feature = struct
107
+
type id = [ `Number of float | `String of string ]
108
+
type t =
109
+
{ id : id option;
110
+
geometry : geometry option;
111
+
properties : Jsont.json option; }
112
+
113
+
let make id geometry properties = { id; geometry; properties }
114
+
let make_geojson_object id geometry properties =
115
+
Geojson_object.make (make id geometry properties)
116
+
117
+
let id f = f.id
118
+
let geometry f = f.geometry
119
+
let properties f = f.properties
120
+
121
+
type collection = t object' list
122
+
end
123
+
124
+
type t =
125
+
[ `Feature of Feature.t object'
126
+
| `Feature_collection of Feature.collection object'
127
+
| geometry ]
128
+
129
+
let point v = `Point v
130
+
let multi_point v = `Multi_point v
131
+
let line_string v = `Line_string v
132
+
let multi_line_string v = `Multi_line_string v
133
+
let polygon v = `Polygon v
134
+
let multi_polygon v = `Multi_polygon v
135
+
let geometry_collection vs = `Geometry_collection vs
136
+
let feature v = `Feature v
137
+
let feature_collection vs = `Feature_collection vs
138
+
139
+
let feature_id_jsont =
140
+
let number =
141
+
let dec = Jsont.Base.dec (fun n -> `Number n) in
142
+
let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) in
143
+
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
144
+
in
145
+
let string =
146
+
let dec = Jsont.Base.dec (fun n -> `String n) in
147
+
let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in
148
+
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
149
+
in
150
+
let enc = function `Number _ -> number | `String _ -> string in
151
+
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
152
+
153
+
(* The first two Json types below handle subtyping by redoing
154
+
cases for subsets of types. *)
155
+
156
+
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec
157
+
158
+
let rec geometry_jsont = lazy begin
159
+
let case_point = case_map Point.jsont point in
160
+
let case_multi_point = case_map Multi_point.jsont multi_point in
161
+
let case_line_string = case_map Line_string.jsont line_string in
162
+
let case_multi_line_string =
163
+
case_map Multi_line_string.jsont multi_line_string
164
+
in
165
+
let case_polygon = case_map Polygon.jsont polygon in
166
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
167
+
let case_geometry_collection =
168
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
169
+
in
170
+
let enc_case = function
171
+
| `Point v -> Jsont.Object.Case.value case_point v
172
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
173
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
174
+
| `Multi_line_string v -> Jsont.Object.Case.value case_multi_line_string v
175
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
176
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
177
+
| `Geometry_collection v ->
178
+
Jsont.Object.Case.value case_geometry_collection v
179
+
in
180
+
let cases = Jsont.Object.Case.[
181
+
make case_point; make case_multi_point; make case_line_string;
182
+
make case_multi_line_string; make case_polygon; make case_multi_polygon;
183
+
make case_geometry_collection ]
184
+
in
185
+
Jsont.Object.map ~kind:"Geometry object" Fun.id
186
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
187
+
~tag_to_string:Fun.id ~tag_compare:String.compare
188
+
|> Jsont.Object.finish
189
+
end
190
+
191
+
and feature_jsont : Feature.t object' Jsont.t Lazy.t = lazy begin
192
+
let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in
193
+
let enc_case v = Jsont.Object.Case.value case_feature v in
194
+
let cases = Jsont.Object.Case.[ make case_feature ] in
195
+
Jsont.Object.map ~kind:"Feature" Fun.id
196
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
197
+
~tag_to_string:Fun.id ~tag_compare:String.compare
198
+
|> Jsont.Object.finish
199
+
end
200
+
201
+
and case_feature_jsont : Feature.t object' Jsont.t Lazy.t = lazy begin
202
+
Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object
203
+
|> Jsont.Object.opt_mem "id" feature_id_jsont
204
+
~enc:(fun o -> Feature.id (Geojson_object.type' o))
205
+
|> Jsont.Object.mem "geometry" (Jsont.option (Jsont.rec' geometry_jsont))
206
+
~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
207
+
|> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object)
208
+
~enc:(fun o -> Feature.properties (Geojson_object.type' o))
209
+
|> Geojson_object.finish_jsont
210
+
end
211
+
212
+
and geometry_collection_jsont = lazy begin
213
+
Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make
214
+
|> Jsont.Object.mem "geometries" (Jsont.list (Jsont.rec' geometry_jsont))
215
+
~enc:Geojson_object.type'
216
+
|> Geojson_object.finish_jsont
217
+
end
218
+
219
+
and feature_collection_json = lazy begin
220
+
Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make
221
+
|> Jsont.Object.mem "features" Jsont.(list (Jsont.rec' feature_jsont))
222
+
~enc:Geojson_object.type'
223
+
|> Geojson_object.finish_jsont
224
+
end
225
+
226
+
and jsont : t Jsont.t Lazy.t = lazy begin
227
+
let case_point = case_map Point.jsont point in
228
+
let case_multi_point = case_map Multi_point.jsont multi_point in
229
+
let case_line_string = case_map Line_string.jsont line_string in
230
+
let case_multi_line_string =
231
+
case_map Multi_line_string.jsont multi_line_string
232
+
in
233
+
let case_polygon = case_map Polygon.jsont polygon in
234
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
235
+
let case_geometry_collection =
236
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
237
+
in
238
+
let case_feature = case_map (Lazy.force case_feature_jsont) feature in
239
+
let case_feature_collection =
240
+
case_map (Lazy.force feature_collection_json) feature_collection
241
+
in
242
+
let enc_case = function
243
+
| `Point v -> Jsont.Object.Case.value case_point v
244
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
245
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
246
+
| `Multi_line_string v -> Jsont.Object.Case.value case_multi_line_string v
247
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
248
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
249
+
| `Geometry_collection v ->
250
+
Jsont.Object.Case.value case_geometry_collection v
251
+
| `Feature v -> Jsont.Object.Case.value case_feature v
252
+
| `Feature_collection v -> Jsont.Object.Case.value case_feature_collection v
253
+
in
254
+
let cases = Jsont.Object.Case.[
255
+
make case_point; make case_multi_point; make case_line_string;
256
+
make case_multi_line_string; make case_polygon; make case_multi_polygon;
257
+
make case_geometry_collection; make case_feature;
258
+
make case_feature_collection ]
259
+
in
260
+
Jsont.Object.map ~kind:"GeoJSON" Fun.id
261
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
262
+
~tag_to_string:Fun.id ~tag_compare:String.compare
263
+
|> Jsont.Object.finish
264
+
end
265
+
266
+
let jsont = Lazy.force jsont
267
+
end
268
+
269
+
(* Command line interface *)
270
+
271
+
let ( let* ) = Result.bind
272
+
let strf = Printf.sprintf
273
+
274
+
let log_if_error ~use = function
275
+
| Ok v -> v
276
+
| Error e ->
277
+
let lines = String.split_on_char '\n' e in
278
+
Format.eprintf "@[%a @[<v>%a@]@]"
279
+
Jsont.Error.puterr () (Format.pp_print_list Format.pp_print_string) lines;
280
+
use
281
+
282
+
let with_infile file f = (* XXX add something to bytesrw. *)
283
+
let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with
284
+
| Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
285
+
in
286
+
try match file with
287
+
| "-" -> process file In_channel.stdin
288
+
| file -> In_channel.with_open_bin file (process file)
289
+
with Sys_error e -> Error e
290
+
291
+
let trip ~file ~format ~locs ~dec_only =
292
+
log_if_error ~use:1 @@
293
+
with_infile file @@ fun r ->
294
+
log_if_error ~use:1 @@
295
+
let* t = Jsont_bytesrw.decode ~file ~locs Geojson.jsont r in
296
+
if dec_only then Ok 0 else
297
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
298
+
let* () = Jsont_bytesrw.encode ~format ~eod:true Geojson.jsont t w in
299
+
Ok 0
300
+
301
+
open Cmdliner
302
+
open Cmdliner.Term.Syntax
303
+
304
+
let geojson =
305
+
Cmd.v (Cmd.info "geojson" ~doc:"round trip GeoJSON") @@
306
+
let+ file =
307
+
let doc = "$(docv) is the GeoJSON file. Use $(b,-) for stdin." in
308
+
Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
309
+
and+ locs =
310
+
let doc = "Preserve locations (better errors)." in
311
+
Arg.(value & flag & info ["l"; "locs"] ~doc)
312
+
and+ format =
313
+
let fmt = [ "indent", Jsont.Indent; "minify", Jsont.Minify ] in
314
+
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt)in
315
+
Arg.(value & opt (enum fmt) Jsont.Minify &
316
+
info ["f"; "format"] ~doc ~docv:"FMT")
317
+
and+ dec_only =
318
+
let doc = "Decode only." in
319
+
Arg.(value & flag & info ["d"] ~doc)
320
+
in
321
+
trip ~file ~format ~locs ~dec_only
322
+
323
+
let main () = Cmd.eval' geojson
324
+
let () = if !Sys.interactive then () else exit (main ())
+108
vendor/opam/jsont/test/json_rpc.ml
+108
vendor/opam/jsont/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
+
let jsonrpc_jsont = Jsont.enum ["2.0", `V2]
12
+
13
+
(* JSON-RPC identifiers *)
14
+
15
+
type id = [ `String of string | `Number of float | `Null ]
16
+
let id_jsont : id Jsont.t =
17
+
let null = Jsont.null `Null in
18
+
let string =
19
+
let dec s = `String s in
20
+
let enc = function `String s -> s | _ -> assert false in
21
+
Jsont.map ~dec ~enc Jsont.string
22
+
in
23
+
let number =
24
+
let dec n = `Number n in
25
+
let enc = function `Number n -> n | _ -> assert false in
26
+
Jsont.map ~dec ~enc Jsont.number
27
+
in
28
+
let enc = function
29
+
| `Null -> null | `String _ -> string | `Number _ -> number
30
+
in
31
+
Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
32
+
33
+
(* JSON-RPC request object *)
34
+
35
+
type params = Jsont.json (* An array or object *)
36
+
let params_jsont =
37
+
let enc = function
38
+
| Jsont.Object _ | Jsont.Array _ -> Jsont.json
39
+
| j ->
40
+
let meta = Jsont.Meta.none in
41
+
let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in
42
+
Jsont.Error.expected meta "object or array" ~fnd
43
+
in
44
+
let kind = "JSON-RPC params" in
45
+
Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc ()
46
+
47
+
type request =
48
+
{ jsonrpc : jsonrpc;
49
+
method' : string;
50
+
params : params option;
51
+
id : id option; }
52
+
53
+
let request jsonrpc method' params id = { jsonrpc; method'; params; id }
54
+
let request_jsont : request Jsont.t =
55
+
Jsont.Object.map request
56
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
57
+
|> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method')
58
+
|> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
59
+
|> Jsont.Object.opt_mem "id" id_jsont ~enc:(fun r -> r.id)
60
+
|> Jsont.Object.finish
61
+
62
+
(* JSON-RPC error objects *)
63
+
64
+
type error =
65
+
{ code : int;
66
+
message : string;
67
+
data : Jsont.json option; }
68
+
69
+
let error code message data = { code; message; data }
70
+
let error_jsont =
71
+
Jsont.Object.map error
72
+
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
73
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
74
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
75
+
|> Jsont.Object.finish
76
+
77
+
(* JSON-RPC response object *)
78
+
79
+
type response =
80
+
{ jsonrpc : jsonrpc;
81
+
value : (Jsont.json, error) result;
82
+
id : id; }
83
+
84
+
let response jsonrpc result error id : response =
85
+
let err_both () =
86
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
87
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
88
+
in
89
+
let err_none () =
90
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
91
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
92
+
in
93
+
match result, error with
94
+
| Some result, None -> { jsonrpc; value = Ok result; id }
95
+
| None, Some error -> { jsonrpc; value = Error error; id }
96
+
| Some _ , Some _ -> err_both ()
97
+
| None, None -> err_none ()
98
+
99
+
let response_result r = match r.value with Ok v -> Some v | Error _ -> None
100
+
let response_error r = match r.value with Ok _ -> None | Error e -> Some e
101
+
102
+
let response_jsont : response Jsont.t =
103
+
Jsont.Object.map response
104
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
105
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result
106
+
|> Jsont.Object.opt_mem "error" error_jsont ~enc:response_error
107
+
|> Jsont.Object.mem "id" id_jsont ~enc:(fun r -> r.id)
108
+
|> Jsont.Object.finish
+429
vendor/opam/jsont/test/jsont_tool.ml
+429
vendor/opam/jsont/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
+
8
+
let strf = Format.asprintf
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@]@."
15
+
exec Jsont.Error.puterr () Format.(pp_print_list pp_print_string) lines;
16
+
use
17
+
18
+
let exit_err_file = 1
19
+
let exit_err_json = 2
20
+
let exit_err_diff = 3
21
+
22
+
module Os = struct
23
+
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
33
+
| Sys_error err -> Error err
34
+
35
+
let write_file file s =
36
+
try
37
+
let oc = if file = "-" then stdout else open_out_bin file in
38
+
let finally () = if file = "-" then () else close_out_noerr oc in
39
+
Fun.protect ~finally @@ fun () -> Ok (Out_channel.output_string oc s)
40
+
with
41
+
| Sys_error err -> Error err
42
+
43
+
let with_tmp_dir f =
44
+
try
45
+
let tmpdir =
46
+
let file = Filename.temp_file "cmarkit" "dir" in
47
+
(Sys.remove file; Sys.mkdir file 0o700; file)
48
+
in
49
+
let finally () = try Sys.rmdir tmpdir with Sys_error _ -> () in
50
+
Fun.protect ~finally @@ fun () -> Ok (f tmpdir)
51
+
with
52
+
| Sys_error err -> Error ("Making temporary dir: " ^ err)
53
+
54
+
let with_cwd cwd f =
55
+
try
56
+
let curr = Sys.getcwd () in
57
+
let () = Sys.chdir cwd in
58
+
let finally () = try Sys.chdir curr with Sys_error _ -> () in
59
+
Fun.protect ~finally @@ fun () -> Ok (f ())
60
+
with
61
+
| Sys_error err -> Error ("With cwd: " ^ err)
62
+
end
63
+
64
+
let diff src fmted =
65
+
let env = ["GIT_CONFIG_SYSTEM=/dev/null"; "GIT_CONFIG_GLOBAL=/dev/null"; ] in
66
+
let set_env = match Sys.win32 with
67
+
| true -> String.concat "" (List.map (fun e -> "set " ^ e ^ " && ") env)
68
+
| false -> String.concat " " env
69
+
in
70
+
let diff = "git diff --ws-error-highlight=all --no-index --patience " in
71
+
let src_file = "src" and fmted_file = "fmt" in
72
+
let cmd = String.concat " " [set_env; diff; src_file; fmted_file] in
73
+
Result.join @@ Result.join @@ Os.with_tmp_dir @@ 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 = (* XXX add something to bytesrw. *)
80
+
let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with
81
+
| Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
82
+
in
83
+
try match file with
84
+
| "-" -> process file In_channel.stdin
85
+
| file -> In_channel.with_open_bin file (process file)
86
+
with Sys_error e -> Error e
87
+
88
+
let output ~format ~number_format j = match format with
89
+
| `Pretty -> Ok (Format.printf "@[%a@]@." (Jsont.pp_json' ~number_format ()) j)
90
+
| `Format format ->
91
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
92
+
Jsont_bytesrw.encode ~format ~number_format ~eod:true Jsont.json j w
93
+
94
+
let output_string ~format ~number_format j = match format with
95
+
| `Pretty -> Ok (Format.asprintf "@[%a@]" (Jsont.pp_json' ~number_format ()) j)
96
+
| `Format format ->
97
+
Jsont_bytesrw.encode_string ~format ~number_format Jsont.json j
98
+
99
+
let trip_type
100
+
?(dec_only = false) ~file ~format ~number_format ~diff:do_diff ~locs t
101
+
=
102
+
log_if_error ~use:exit_err_file @@
103
+
with_infile file @@ fun r ->
104
+
log_if_error ~use:exit_err_json @@
105
+
let layout = format = `Format Jsont.Layout in
106
+
match do_diff with
107
+
| false ->
108
+
let* j = Jsont_bytesrw.decode ~file ~layout ~locs t r in
109
+
if dec_only then Ok 0 else
110
+
let* () = output ~format ~number_format j in
111
+
Ok 0
112
+
| true ->
113
+
let src = Bytesrw.Bytes.Reader.to_string r in
114
+
let* j = Jsont_bytesrw.decode_string ~file ~layout ~locs t src in
115
+
let* fmted = output_string ~format ~number_format j in
116
+
(match diff src fmted with
117
+
| Ok exit -> if exit = 0 then Ok 0 else Ok exit_err_diff
118
+
| Error e -> Format.eprintf "%s" e; Ok Cmdliner.Cmd.Exit.some_error)
119
+
120
+
let delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs =
121
+
let del = Jsont.delete_path ~allow_absent path in
122
+
trip_type ~file ~format ~number_format ~diff ~locs del
123
+
124
+
let fmt ~file ~format ~number_format ~diff ~locs ~dec_only =
125
+
trip_type ~file ~format ~number_format ~diff ~locs ~dec_only Jsont.json
126
+
127
+
let get ~file ~path ~format ~number_format ~diff ~absent ~locs =
128
+
let get = Jsont.path ?absent path Jsont.json in
129
+
trip_type ~file ~format ~number_format ~diff ~locs get
130
+
131
+
let locs' ~file =
132
+
let pf = Format.fprintf in
133
+
let pp_code = Jsont.Repr.pp_code in
134
+
let pp_locs_outline ppf v =
135
+
let indent = 2 in
136
+
let loc label ppf m =
137
+
pf ppf "@[<v>%s:@,%a@]@,"
138
+
label Jsont.Textloc.pp_ocaml (Jsont.Meta.textloc m)
139
+
in
140
+
let rec value ppf = function
141
+
| Jsont.Null ((), m) ->
142
+
loc (strf "%a" pp_code (strf "%a" Jsont.pp_null ())) ppf m
143
+
| Jsont.Bool (b, m) ->
144
+
loc (strf "Bool %a" pp_code (strf "%a" Jsont.pp_bool b)) ppf m
145
+
| Jsont.Number (n, m) ->
146
+
loc (strf "Number %a" pp_code (strf "%a" Jsont.pp_number n)) ppf m
147
+
| Jsont.String (s, m) ->
148
+
loc (strf "String %a" pp_code (strf "%a" Jsont.pp_string s)) ppf m
149
+
| Jsont.Array (l, m) ->
150
+
Format.pp_open_vbox ppf indent;
151
+
loc "Array" ppf m; (Format.pp_print_list value) ppf l;
152
+
Format.pp_close_box ppf ()
153
+
| Jsont.Object (o, m) ->
154
+
let mem ppf ((name, m), v) =
155
+
let l = strf "Member %a" pp_code (strf "%a" Jsont.pp_string name) in
156
+
loc l ppf m; value ppf v;
157
+
in
158
+
Format.pp_open_vbox ppf indent;
159
+
loc "Object" ppf m; (Format.pp_print_list mem) ppf o;
160
+
Format.pp_close_box ppf ()
161
+
in
162
+
value ppf v
163
+
in
164
+
log_if_error ~use:exit_err_file @@
165
+
with_infile file @@ fun reader ->
166
+
log_if_error ~use:exit_err_json @@
167
+
let* j = Jsont_bytesrw.decode ~file ~locs:true Jsont.json reader in
168
+
pp_locs_outline Format.std_formatter j;
169
+
Ok 0
170
+
171
+
let set
172
+
~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json:j ~locs
173
+
=
174
+
let set = Jsont.set_path ?stub ~allow_absent Jsont.json path j in
175
+
trip_type ~file ~format ~number_format ~diff ~locs set
176
+
177
+
(* Command line interface *)
178
+
179
+
open Cmdliner
180
+
open Cmdliner.Term.Syntax
181
+
182
+
let exits =
183
+
Cmd.Exit.info exit_err_file ~doc:"on file read errors." ::
184
+
Cmd.Exit.info exit_err_json ~doc:"on JSON parse or path errors." ::
185
+
Cmd.Exit.info exit_err_diff ~doc:"on JSON output differences." ::
186
+
Cmd.Exit.defaults
187
+
188
+
let path_arg = Arg.conv' ~docv:"JSON_PATH" Jsont.Path.(of_string, pp)
189
+
let json_arg =
190
+
let of_string s =
191
+
Jsont_bytesrw.decode_string ~locs:true ~layout:true Jsont.json s
192
+
in
193
+
let pp = Jsont.pp_json in
194
+
Arg.conv' ~docv:"JSON" (of_string, pp)
195
+
196
+
let format_opt ~default =
197
+
let fmt =
198
+
[ "indent", `Format Jsont.Indent;
199
+
"minify", `Format Jsont.Minify;
200
+
"preserve", `Format Jsont.Layout;
201
+
"pretty", `Pretty ]
202
+
in
203
+
let doc =
204
+
strf "Output style. Must be %s. $(b,minify) guarantess there is \
205
+
no CR (U+000D) or LF (U+000A) in the output. $(b,pretty) is \
206
+
similar to $(b,indent) but may yield more compact outputs."
207
+
(Arg.doc_alts_enum fmt)
208
+
in
209
+
Arg.(value & opt (enum fmt) default & info ["f"; "format"] ~doc ~docv:"FMT")
210
+
211
+
let format_opt_default_pretty = format_opt ~default:`Pretty
212
+
let format_opt_default_preserve = format_opt ~default:(`Format Jsont.Layout)
213
+
214
+
let allow_absent_opt =
215
+
let doc = "Do not error if $(i,JSON_PATH) does not exist." in
216
+
Arg.(value & flag & info ["a"; "allow-absent"] ~doc)
217
+
218
+
let locs_default_false =
219
+
let doc = "Keep track of source locations (improves error messages)." in
220
+
Arg.(value & flag & info ["locs"] ~doc)
221
+
222
+
let locs_default_true =
223
+
let doc = "Do not keep track of source locations." in
224
+
Term.(const ( not ) $ Arg.(value & flag & info ["no-locs"] ~doc))
225
+
226
+
let number_format_opt =
227
+
let doc = "Use C float format string $(docv) to format JSON numbers." in
228
+
let number_format : Jsont.number_format Arg.conv =
229
+
let parse s =
230
+
try Ok (Scanf.format_from_string s Jsont.default_number_format) with
231
+
| Scanf.Scan_failure _ ->
232
+
Error (strf "Cannot format a float with %S" s)
233
+
in
234
+
let pp ppf fmt = Format.pp_print_string ppf (string_of_format fmt) in
235
+
Arg.conv' (parse, pp)
236
+
in
237
+
Arg.(value & opt number_format Jsont.default_number_format &
238
+
info ["n"; "number-format"] ~doc ~docv:"FMT")
239
+
240
+
let diff_flag =
241
+
let doc =
242
+
"Output diff between input and output (needs $(b,git) in \
243
+
your $(b,PATH)). Exits with 0 only there are no differences."
244
+
in
245
+
Arg.(value & flag & info ["diff"] ~doc)
246
+
247
+
let dec_only =
248
+
let doc = "Decode only, no output." in
249
+
Arg.(value & flag & info ["d"; "decode-only"] ~doc)
250
+
251
+
let file_pos ~pos:p =
252
+
let doc = "$(docv) is the JSON file. Use $(b,-) for stdin." in
253
+
Arg.(value & pos p string "-" & info [] ~doc ~docv:"FILE")
254
+
255
+
let file_pos0 = file_pos ~pos:0
256
+
let file_pos1 = file_pos ~pos:1
257
+
let file_pos2 = file_pos ~pos:2
258
+
259
+
let common_man =
260
+
[ `S Manpage.s_bugs;
261
+
`P "This program is distributed with the jsont OCaml library. \
262
+
See $(i,https://erratique.ch/software/jsont) for contact \
263
+
information."; ]
264
+
265
+
let delete_cmd =
266
+
let doc = "Delete the value indexed by a JSON path" in
267
+
let sdocs = Manpage.s_common_options in
268
+
let man = [
269
+
`S Manpage.s_description;
270
+
`P "$(iname) deletes the value indexed by a JSON path. Outputs $(b,null) \
271
+
on the root path $(b,'.'). Examples:";
272
+
`Pre "$(iname) $(b,keywords.[0] package.json)"; `Noblank;
273
+
`Pre "$(iname) $(b,-a keywords.[0] package.json)";
274
+
`Blocks common_man; ]
275
+
in
276
+
let path_opt =
277
+
let doc = "Delete JSON path $(docv)." and docv = "JSON_PATH" in
278
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv)
279
+
in
280
+
Cmd.v (Cmd.info "delete" ~doc ~sdocs ~exits ~man) @@
281
+
let+ file = file_pos1
282
+
and+ path = path_opt
283
+
and+ format = format_opt_default_preserve
284
+
and+ number_format = number_format_opt
285
+
and+ diff = diff_flag
286
+
and+ allow_absent = allow_absent_opt
287
+
and+ locs = locs_default_true in
288
+
delete ~file ~path ~format ~number_format ~diff ~allow_absent ~locs
289
+
290
+
let fmt_cmd =
291
+
let doc = "Format JSON" in
292
+
let sdocs = Manpage.s_common_options in
293
+
let man = [
294
+
`S Manpage.s_description;
295
+
`P "$(iname) formats JSON. Examples:";
296
+
`Pre "$(iname) $(b,package.json)"; `Noblank;
297
+
`Pre "$(iname) $(b,-f minify package.json)";
298
+
`Blocks common_man; ]
299
+
in
300
+
Cmd.v (Cmd.info "fmt" ~doc ~sdocs ~exits ~man) @@
301
+
let+ file = file_pos0
302
+
and+ format = format_opt_default_pretty
303
+
and+ number_format = number_format_opt
304
+
and+ diff = diff_flag
305
+
and+ locs = locs_default_false
306
+
and+ dec_only = dec_only in
307
+
fmt ~file ~format ~number_format ~diff ~locs ~dec_only
308
+
309
+
let get_cmd =
310
+
let doc = "Extract the value indexed by a JSON path" in
311
+
let sdocs = Manpage.s_common_options in
312
+
let man = [
313
+
`S Manpage.s_description;
314
+
`P "$(iname) outputs the value indexed by a JSON path. Examples:";
315
+
`Pre "$(iname) $(b,'keywords.[0]' package.json)"; `Noblank;
316
+
`Pre "$(iname) $(b,-a 'null' 'keywords.[0]' package.json)"; `Noblank;
317
+
`Pre "$(iname) $(b,-a '[]' 'keywords' package.json)"; `Noblank;
318
+
`Pre "$(iname) $(b,'.' package.json)";
319
+
`Blocks common_man; ]
320
+
in
321
+
let path_pos =
322
+
let doc = "Extract the value indexed by JSON path $(docv)." in
323
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH")
324
+
in
325
+
let absent_opt =
326
+
let doc = "Do not error if $(i,JSON_PATH) does not exist, output $(docv) \
327
+
instead."
328
+
in
329
+
Arg.(value & opt (some json_arg) None &
330
+
info ["a"; "absent"] ~doc ~docv:"JSON")
331
+
in
332
+
Cmd.v (Cmd.info "get" ~doc ~sdocs ~exits ~man) @@
333
+
let+ file = file_pos1
334
+
and+ path = path_pos
335
+
and+ format = format_opt_default_pretty
336
+
and+ number_format = number_format_opt
337
+
and+ diff = diff_flag
338
+
and+ absent = absent_opt
339
+
and+ locs = locs_default_true in
340
+
get ~file ~path ~format ~number_format ~diff ~absent ~locs
341
+
342
+
let set_cmd =
343
+
let doc = "Set the value indexed by a JSON path" in
344
+
let sdocs = Manpage.s_common_options in
345
+
let man = [
346
+
`S Manpage.s_description;
347
+
`P "$(iname) sets the value indexed by a JSON path. Examples:";
348
+
`Pre "$(iname) $(b,keywords '[\"codec\"]' package.json)"; `Noblank;
349
+
`Pre "$(iname) $(b,keywords.[0] '\"codec\"' package.json)"; `Noblank;
350
+
`Pre "$(iname) $(b,-a keywords.[4] '\"codec\"' package.json)"; `Noblank;
351
+
`Pre "$(iname) $(b,-s null -a keywords.[4] '\"codec\"' package.json)";
352
+
`Blocks common_man; ]
353
+
in
354
+
let path_pos =
355
+
let doc = "Set the value indexed by JSON path $(docv)." in
356
+
Arg.(required & pos 0 (some path_arg) None & info [] ~doc ~docv:"JSON_PATH")
357
+
in
358
+
let json_pos =
359
+
let doc = "Set value to $(docv)." in
360
+
Arg.(required & pos 1 (some json_arg) None & info [] ~doc ~docv:"JSON")
361
+
in
362
+
let stub =
363
+
let doc =
364
+
"Use $(b,docv) as a stub value to use if an array needs to be extended \
365
+
when $(b,-a) is used. By default uses the natural zero of the \
366
+
set data: null for null, false for booleans, 0 for numbers, empty
367
+
string for strings, empty array for array, empty object for object."
368
+
in
369
+
Arg.(value & opt (some json_arg) None & info ["s"; "stub"] ~doc
370
+
~docv:"JSON")
371
+
in
372
+
Cmd.v (Cmd.info "set" ~doc ~sdocs ~exits ~man) @@
373
+
let+ file = file_pos2
374
+
and+ path = path_pos
375
+
and+ json = json_pos
376
+
and+ stub = stub
377
+
and+ format = format_opt_default_preserve
378
+
and+ number_format = number_format_opt
379
+
and+ diff = diff_flag
380
+
and+ allow_absent = allow_absent_opt
381
+
and+ locs = locs_default_true in
382
+
set ~file ~path ~format ~number_format ~diff ~allow_absent ~stub ~json ~locs
383
+
384
+
let locs_cmd =
385
+
let doc = "Show JSON parse locations" in
386
+
let sdocs = Manpage.s_common_options in
387
+
let man = [
388
+
`S Manpage.s_description;
389
+
`P "$(tname) outputs JSON parse locations. Example:";
390
+
`Pre "$(iname) $(b,package.json)";
391
+
`Blocks common_man; ]
392
+
in
393
+
Cmd.v (Cmd.info "locs" ~doc ~sdocs ~exits ~man) @@
394
+
let+ file = file_pos0 in
395
+
locs' ~file
396
+
397
+
let jsont =
398
+
let doc = "Process JSON data" in
399
+
let sdocs = Manpage.s_common_options in
400
+
let man = [
401
+
`S Manpage.s_description;
402
+
`P "$(mname) processes JSON data in various ways.";
403
+
`Pre "$(b,curl -L URL) | $(mname) $(b,fmt)"; `Noblank;
404
+
`Pre "$(mname) $(b,fmt package.json)"; `Noblank;
405
+
`Pre "$(mname) $(b,get 'keywords.[0]' package.json)"; `Noblank;
406
+
`Pre "$(mname) $(b,set 'keywords.[0]' '\"codec\"' package.json)"; `Noblank;
407
+
`Pre "$(mname) $(b,delete 'keywords.[0]' package.json)";
408
+
`P "More information about $(b,jsont)'s JSON paths is in the section \
409
+
JSON PATHS below.";
410
+
`S Manpage.s_commands;
411
+
`S Manpage.s_common_options;
412
+
`S "JSON PATHS";
413
+
`P "For $(mname) a JSON path is a dot separated sequence of \
414
+
indexing operations. For example $(b,books.[1].authors.[0]) indexes \
415
+
an object on the $(b,books) member, then on the second element of \
416
+
an array, then the $(b,authors) member of an object and finally \
417
+
the first element of that array. The root path is $(b,.), it can
418
+
be omitted if there are indexing operations.";
419
+
`P "In general because of your shell's special characters it's better \
420
+
to single quote your JSON paths.";
421
+
`P "Note that $(mname)'s JSON PATH are unrelated to the JSONPath \
422
+
query language (RFC 9535).";
423
+
`Blocks common_man; ]
424
+
in
425
+
Cmd.group (Cmd.info "jsont" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man) @@
426
+
[get_cmd; delete_cmd; fmt_cmd; locs_cmd; set_cmd;]
427
+
428
+
let main () = Cmd.eval' jsont
429
+
let () = if !Sys.interactive then () else exit (main ())
+42
vendor/opam/jsont/test/quickstart.ml
+42
vendor/opam/jsont/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
+
let assoc = ["todo", Todo; "done", Done; "cancelled", Cancelled ]
22
+
let jsont = Jsont.enum ~kind:"Status" assoc
23
+
end
24
+
25
+
module Item = struct
26
+
type t = { task : string; status : Status.t; tags : string list; }
27
+
let make task status tags = { task; status; tags }
28
+
let task i = i.task
29
+
let status i = i.status
30
+
let tags i = i.tags
31
+
let jsont =
32
+
Jsont.Object.map ~kind:"Item" make
33
+
|> Jsont.Object.mem "task" Jsont.string ~enc:task
34
+
|> Jsont.Object.mem "status" Status.jsont ~enc:status
35
+
|> Jsont.Object.mem "tags" Jsont.(list string) ~enc:tags
36
+
~dec_absent:[] ~enc_omit:(( = ) [])
37
+
|> Jsont.Object.finish
38
+
end
39
+
40
+
let items = Jsont.list Item.jsont
41
+
let items_of_json s = Jsont_bytesrw.decode_string items s
42
+
let items_to_json ?format is = Jsont_bytesrw.encode_string ?format items is
+34
vendor/opam/jsont/test/test_brr.ml
+34
vendor/opam/jsont/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 = match Jsont_brr.encode ?format t v with
17
+
| Ok v -> Ok (Jstr.to_string v) | Error e -> Error (error_to_string e)
18
+
19
+
let test_funs = { Test_common.supports_layout = false; decode; encode }
20
+
21
+
let main () =
22
+
let exit = Test.main @@ fun () ->
23
+
Test_common.test_funs := test_funs;
24
+
Test_common.tests ();
25
+
in
26
+
let result = if exit = 0 then "All tests passed!" else "Some tests FAILED!" in
27
+
let children =
28
+
[ El.h1 [ El.txt' "Jsont_brr tests" ];
29
+
El.p [ El.txt' result];
30
+
El.p [ El.txt' "Open the browser console for details."] ]
31
+
in
32
+
El.set_children (Document.body G.document) children
33
+
34
+
let () = if !Sys.interactive then () else main ()
+37
vendor/opam/jsont/test/test_bytesrw.ml
+37
vendor/opam/jsont/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 ())
+665
vendor/opam/jsont/test/test_common.ml
+665
vendor/opam/jsont/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
+
let test_funs : test_funs ref =
21
+
ref { supports_layout = false;
22
+
decode = (fun ?layout _ _ -> assert false);
23
+
encode = (fun ?format _ _ -> assert false); }
24
+
25
+
let supports_layout () = !test_funs.supports_layout
26
+
let decode ?layout t json = !test_funs.decode ?layout t json
27
+
let encode ?format t v = !test_funs.encode ?format t v
28
+
29
+
(* Test combinators
30
+
31
+
Note that the part of the test combinators rely on the library to
32
+
be correct. If something really feels fishy you may have to
33
+
investigate here too. *)
34
+
35
+
let decode_ok ?__POS__:pos ?value ?(eq = Test.T.any) t json =
36
+
Test.block ?__POS__:pos @@ fun () ->
37
+
match decode t json with
38
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
39
+
| Ok v' ->
40
+
match value with
41
+
| None -> ()
42
+
| Some value -> Test.eq eq v' value ~__POS__
43
+
44
+
let encode_ok ?__POS__:pos ?format t ~value json =
45
+
Test.block ?__POS__:pos @@ fun () ->
46
+
match encode ?format t value with
47
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
48
+
| Ok json' -> Test.string json' json ~__POS__
49
+
50
+
let decode_error ?__POS__:pos ?layout ?msg t json =
51
+
Test.block ?__POS__:pos @@ fun () ->
52
+
match decode ?layout t json with
53
+
| Ok _ -> Test.fail "Decode did not error" ~__POS__
54
+
| Error e ->
55
+
match msg with None -> () | Some msg -> Test.styled_string msg e ~__POS__
56
+
57
+
let encode_error ?__POS__:pos ?msg t v =
58
+
Test.block ?__POS__:pos @@ fun () ->
59
+
match encode t v with
60
+
| Ok _ -> Test.fail "Encode did not error" ~__POS__
61
+
| Error e ->
62
+
match msg with None -> () | Some msg -> Test.styled_string msg e ~__POS__
63
+
64
+
let update ?__POS__:pos ?(format = Jsont.Minify) q j j' =
65
+
let layout = format = Jsont.Layout in
66
+
Test.block ?__POS__:pos @@ fun () ->
67
+
match decode ~layout q j with
68
+
| Error e -> Test.fail "%a" Fmt.lines e ~__POS__
69
+
| Ok v when supports_layout () || not (format = Jsont.Layout) ->
70
+
encode_ok ~format Jsont.json ~value:v j' ~__POS__
71
+
| Ok v ->
72
+
let j' =
73
+
encode ~format:Jsont.Indent Jsont.json
74
+
(decode Jsont.json j' |> Result.get_ok)
75
+
|> Result.get_ok
76
+
in
77
+
encode_ok ~format:Jsont.Indent Jsont.json ~value:v j' ~__POS__
78
+
79
+
(* [trip t src] is the über testing combinator.
80
+
81
+
It rounds trips a decode of [src] according to [t] and verifies
82
+
that the generated JSON [trip] has the same data unless [lossy] is
83
+
specified. If [value] is provided both decodes of [src] and [trip]
84
+
are tested against [value]. If [format] is specified with
85
+
[Jsont.Indent] or [Jsont.Layout] it assumes that [src] and [trip]
86
+
must be equal *)
87
+
88
+
let trip
89
+
?(format = Jsont.Minify) ?(lossy = false) ?value ?(eq = Test.T.any)
90
+
?__POS__:pos t src
91
+
=
92
+
Test.block ?__POS__:pos @@ fun () ->
93
+
let layout = format = Jsont.Layout in
94
+
let v =
95
+
Test.noraise ~__POS__ @@ fun () ->
96
+
Result.get_ok' (decode ~layout t src)
97
+
in
98
+
let trip =
99
+
Test.noraise ~__POS__ @@ fun () ->
100
+
Result.get_ok' (encode ~format t v)
101
+
in
102
+
let v' =
103
+
Test.noraise ~__POS__ @@ fun () ->
104
+
Result.get_ok' (decode t trip)
105
+
in
106
+
begin match value with
107
+
| None -> Test.eq eq v v' ~__POS__;
108
+
| Some value ->
109
+
Test.eq eq v value ~__POS__;
110
+
Test.eq eq v' value ~__POS__;
111
+
end;
112
+
if not lossy then begin
113
+
let json =
114
+
Test.noraise ~__POS__ @@ fun () ->
115
+
Result.get_ok' (decode Jsont.json src)
116
+
in
117
+
let trip =
118
+
Test.noraise ~__POS__ @@ fun () ->
119
+
Result.get_ok' (decode Jsont.json trip)
120
+
in
121
+
Test.eq (module Jsont.Json) json trip ~__POS__
122
+
end;
123
+
if format <> Jsont.Minify then begin
124
+
if format = Jsont.Layout && not (supports_layout ()) then () else
125
+
(* Test that src is a representation of the requested encoding format *)
126
+
Test.string src trip ~__POS__
127
+
end
128
+
129
+
let eq : (module Test.T with type t = 'a) = (module Jsont.Json)
130
+
131
+
(* Tests *)
132
+
133
+
let test_basic_invalid =
134
+
Test.test "basic invalid JSON" @@ fun () ->
135
+
decode_error Jsont.json "" ~__POS__;
136
+
decode_error (Jsont.null ()) "" ~__POS__;
137
+
decode_error Jsont.bool "" ~__POS__;
138
+
decode_error Jsont.json "ha" ~__POS__;
139
+
decode_error (Jsont.null ()) "ha" ~__POS__;
140
+
decode_error Jsont.bool "ha" ~__POS__;
141
+
decode_error Jsont.json " ha" ~__POS__;
142
+
decode_error Jsont.json " r6 " ~__POS__;
143
+
decode_error Jsont.json " { " ~__POS__;
144
+
decode_error Jsont.json " [ " ~__POS__;
145
+
decode_error Jsont.json " ][ " ~__POS__;
146
+
()
147
+
148
+
let test_indent =
149
+
Test.test "Encode with indentation" @@ fun () ->
150
+
()
151
+
152
+
let test_null =
153
+
Test.test "Jsont.null" @@ fun () ->
154
+
trip ~eq ~format:Layout Jsont.json " null \r\n" ~__POS__;
155
+
trip ~eq ~format:Layout Jsont.json "\n null " ~__POS__;
156
+
trip ~eq ~format:Layout Jsont.json "null" ~__POS__;
157
+
trip ~eq ~format:Indent Jsont.json "null" ~__POS__;
158
+
decode_error Jsont.json " nu " ~__POS__;
159
+
decode_error Jsont.json " nul " ~__POS__;
160
+
decode_error Jsont.json " n " ~__POS__;
161
+
trip (Jsont.null ()) " \n null \n " ~value:() ~__POS__;
162
+
trip (Jsont.null ()) " null " ~value:() ~__POS__;
163
+
decode_error (Jsont.null ()) " true " ~__POS__;
164
+
()
165
+
166
+
let test_bool =
167
+
Test.test "Jsont.bool" @@ fun () ->
168
+
trip ~eq ~format:Layout Jsont.json " true \r\n" ~__POS__;
169
+
trip ~eq ~format:Layout Jsont.json "\n false " ~__POS__;
170
+
trip ~eq ~format:Layout Jsont.json "false" ~__POS__;
171
+
trip ~eq ~format:Indent Jsont.json "true" ~__POS__;
172
+
trip ~eq ~format:Indent Jsont.json "false" ~__POS__;
173
+
decode_error Jsont.json " fals " ~__POS__;
174
+
decode_error Jsont.json " falsee " ~__POS__;
175
+
decode_error Jsont.json " f " ~__POS__;
176
+
trip ~eq:Test.T.bool Jsont.bool " true \n " ~value:true ~__POS__;
177
+
trip ~eq:Test.T.bool Jsont.bool " false " ~value:false ~__POS__;
178
+
decode_error Jsont.bool " fals " ~__POS__;
179
+
()
180
+
181
+
let test_numbers =
182
+
Test.test "Jsont.number" @@ fun () ->
183
+
trip ~eq ~format:Layout Jsont.json " 1 " ~__POS__;
184
+
trip ~eq ~format:Layout Jsont.json " 0 \n " ~__POS__;
185
+
trip ~eq ~format:Layout Jsont.json "\n 2.5 " ~__POS__;
186
+
trip ~eq ~format:Indent Jsont.json "0";
187
+
trip ~eq ~format:Indent Jsont.json "0.5";
188
+
decode_error Jsont.json " 01 " ~__POS__;
189
+
decode_error Jsont.json " -a " ~__POS__;
190
+
decode_error Jsont.json " 1. " ~__POS__;
191
+
decode_error Jsont.json " 1.0e+ " ~__POS__;
192
+
decode_error Jsont.json " inf " ~__POS__;
193
+
decode_error Jsont.json " infinity " ~__POS__;
194
+
decode_error Jsont.json " nan " ~__POS__;
195
+
let eq = Test.T.float in
196
+
trip ~eq Jsont.number " -0 " ~value:(-0.) ~__POS__;
197
+
trip ~eq Jsont.number " 0 " ~value:(0.) ~__POS__;
198
+
trip ~eq Jsont.number " 0E1 " ~value:0. ~__POS__;
199
+
trip ~eq Jsont.number " 0e+1 " ~value:0. ~__POS__;
200
+
trip ~eq Jsont.number " null " ~value:Float.nan ~__POS__;
201
+
encode_ok Jsont.number "null" ~value:Float.infinity ~__POS__;
202
+
encode_ok Jsont.number "null" ~value:Float.neg_infinity ~__POS__;
203
+
trip ~eq Jsont.number " 1e300 " ~value:1.e300 ~__POS__;
204
+
decode_error Jsont.number " fals " ~__POS__;
205
+
decode_error Jsont.number " 1. " ~__POS__;
206
+
decode_error Jsont.number " 1.0e+ " ~__POS__;
207
+
decode_error Jsont.number " 0E " ~__POS__;
208
+
decode_error Jsont.number " 1eE2 " ~__POS__;
209
+
()
210
+
211
+
let test_strings =
212
+
Test.test "Jsont.string" @@ fun () ->
213
+
trip ~eq ~format:Layout Jsont.json {| "" |} ~__POS__;
214
+
trip ~eq ~format:Layout Jsont.json " \"\\\"\" " ~__POS__;
215
+
trip ~eq ~format:Layout Jsont.json " \"\\\\\" " ~__POS__;
216
+
trip ~eq ~format:Layout Jsont.json " \"hihi\" \n " ~__POS__;
217
+
trip ~eq ~format:Layout Jsont.json " \"hi\\nhi\" \n " ~__POS__;
218
+
if Sys.backend_type <> Sys.Other "js_of_ocaml" then begin
219
+
decode_error Jsont.json "\"\\uDC01\"" ~__POS__;
220
+
decode_error Jsont.json "\"\\uDBFF\"" ~__POS__;
221
+
decode_error Jsont.json "\"\\uDBFF\\uDBFF\"" ~__POS__;
222
+
end;
223
+
trip ~format:Indent Jsont.json {|""|};
224
+
trip ~format:Indent Jsont.json {|"blablabla"|};
225
+
decode_error Jsont.json "\"hi\nhi\"" ~__POS__;
226
+
decode_error Jsont.json "\n \"abla\" hi " ~__POS__;
227
+
decode_error Jsont.json "\n \"unclosed hi " ~__POS__;
228
+
trip ~eq:Test.T.string
229
+
Jsont.string "\"\\ud83D\\uDc2B\"" ~value:"🐫" ~__POS__;
230
+
trip ~eq:Test.T.string Jsont.string "\"🐫 a\"" ~value:"🐫 a" ~__POS__;
231
+
decode_error Jsont.string " false " ~__POS__;
232
+
decode_error Jsont.string "1.0" ~__POS__;
233
+
()
234
+
235
+
let test_option =
236
+
Test.test "Jsont.{none,some,option}" @@ fun () ->
237
+
(* none *)
238
+
decode_error Jsont.none "2" ~__POS__;
239
+
decode_error Jsont.none "true" ~__POS__;
240
+
trip Jsont.none "null" ~value:None ~__POS__;
241
+
(* some *)
242
+
decode_error Jsont.(some bool) "null" ~__POS__;
243
+
decode_error Jsont.(some bool) "1.0" ~__POS__;
244
+
trip Jsont.(some bool) "true" ~value:(Some true) ~__POS__;
245
+
(* option *)
246
+
decode_error Jsont.(option bool) "1.0" ~__POS__;
247
+
decode_error Jsont.(option bool) "{}" ~__POS__;
248
+
trip Jsont.(option bool) "true" ~value:(Some true) ~__POS__;
249
+
trip Jsont.(option bool) "false" ~value:(Some false) ~__POS__;
250
+
trip Jsont.(option bool) "null" ~value:None ~__POS__;
251
+
()
252
+
253
+
let test_ints =
254
+
Test.test "Jsont.{int…,uint…}" @@ fun () ->
255
+
(* uint8 *)
256
+
decode_error Jsont.uint8 "null" ~__POS__;
257
+
decode_error Jsont.uint8 "true" ~__POS__;
258
+
decode_error Jsont.uint8 "-1" ~__POS__;
259
+
decode_error Jsont.uint8 "256" ~__POS__;
260
+
trip Jsont.uint8 "0" ~value:0 ~__POS__;
261
+
trip Jsont.uint8 "255" ~value:255 ~__POS__;
262
+
(* uint16 *)
263
+
decode_error Jsont.uint16 "null" ~__POS__;
264
+
decode_error Jsont.uint16 "true" ~__POS__;
265
+
decode_error Jsont.uint16 "-1" ~__POS__;
266
+
decode_error Jsont.uint16 "65536" ~__POS__;
267
+
trip Jsont.uint16 "0" ~value:0 ~__POS__;
268
+
trip Jsont.uint16 "65535" ~value:65535 ~__POS__;
269
+
(* int8 *)
270
+
decode_error Jsont.int8 "null" ~__POS__;
271
+
decode_error Jsont.int8 "true" ~__POS__;
272
+
decode_error Jsont.int8 "-129" ~__POS__;
273
+
decode_error Jsont.int8 "128" ~__POS__;
274
+
trip Jsont.int8 "-128" ~value:(-128) ~__POS__;
275
+
trip Jsont.int8 "127" ~value:127 ~__POS__;
276
+
(* int32 *)
277
+
decode_error Jsont.int32 "null" ~__POS__;
278
+
decode_error Jsont.int32 "true" ~__POS__;
279
+
decode_error Jsont.int32 "-2147483649" ~__POS__;
280
+
decode_error Jsont.int32 "2147483648" ~__POS__;
281
+
trip Jsont.int32 "-2147483648" ~value:Int32.min_int ~__POS__;
282
+
trip Jsont.int32 "2147483647" ~value:Int32.max_int ~__POS__;
283
+
(* int64 *)
284
+
let max_exact = Int64.shift_left 1L 53 in
285
+
let max_exact_next = Int64.(add max_exact 1L) in
286
+
let min_exact = Int64.shift_left 1L 53 in
287
+
let min_exact_prev = Int64.(add max_exact 1L) in
288
+
decode_error Jsont.int64 "null" ~__POS__;
289
+
decode_error Jsont.int64 "true" ~__POS__;
290
+
trip Jsont.int64 (Fmt.str "%Ld" max_exact) ~value:max_exact ~__POS__;
291
+
trip Jsont.int64 (Fmt.str "%Ld" min_exact) ~value:min_exact ~__POS__;
292
+
trip Jsont.int64
293
+
(Fmt.str {|"%Ld"|} max_exact_next) ~value:max_exact_next ~__POS__;
294
+
trip Jsont.int64
295
+
(Fmt.str {|"%Ld"|} min_exact_prev) ~value:min_exact_prev ~__POS__;
296
+
(* int_as_string *)
297
+
trip Jsont.int_as_string {|"2"|} ~value:2 ~__POS__;
298
+
trip Jsont.int_as_string
299
+
(Fmt.str {|"%d"|} Int.max_int) ~value:Int.max_int ~__POS__;
300
+
trip Jsont.int_as_string
301
+
(Fmt.str {|"%d"|} Int.min_int) ~value:Int.min_int ~__POS__;
302
+
(* int64_as_string *)
303
+
trip Jsont.int64_as_string
304
+
(Fmt.str {|"%Ld"|} Int64.max_int) ~value:Int64.max_int ~__POS__;
305
+
trip Jsont.int64_as_string
306
+
(Fmt.str {|"%Ld"|} Int64.min_int) ~value:Int64.min_int ~__POS__;
307
+
()
308
+
309
+
let test_floats =
310
+
Test.test "Jsont.{any_float,float_as_hex_string}" @@ fun () ->
311
+
(* any_float *)
312
+
let jsonstr f = Fmt.str {|"%s"|} (Float.to_string f) in
313
+
let eq = Test.T.float in
314
+
decode_ok ~eq Jsont.any_float "null" ~value:Float.nan ~__POS__;
315
+
trip ~eq Jsont.any_float " -0 " ~value:(-0.) ~__POS__;
316
+
trip ~eq Jsont.any_float " 0 " ~value:(0.) ~__POS__;
317
+
trip ~eq Jsont.any_float " 0.5 " ~value:0.5 ~__POS__;
318
+
decode_ok ~eq Jsont.any_float (jsonstr 0.5) ~value:0.5 ~__POS__;
319
+
trip ~eq Jsont.any_float
320
+
(jsonstr Float.nan) ~value:Float.nan ~__POS__;
321
+
trip ~eq Jsont.any_float
322
+
(jsonstr Float.infinity) ~value:Float.infinity ~__POS__;
323
+
trip ~eq Jsont.any_float
324
+
(jsonstr Float.neg_infinity) ~value:Float.neg_infinity ~__POS__;
325
+
326
+
(* float_as_hex_string *)
327
+
let jsonstr f = Fmt.str {|"%h"|} f in
328
+
let t = Jsont.float_as_hex_string in
329
+
decode_error t "null" ~__POS__;
330
+
decode_error t "1.0" ~__POS__;
331
+
trip ~eq t (jsonstr 0.5) ~value:0.5 ~__POS__;
332
+
trip ~eq t (jsonstr Float.nan) ~value:Float.nan ~__POS__;
333
+
trip ~eq t (jsonstr Float.infinity) ~value:Float.infinity ~__POS__;
334
+
trip ~eq t (jsonstr Float.neg_infinity) ~value:Float.neg_infinity ~__POS__;
335
+
()
336
+
337
+
let test_enum_and_binary_string =
338
+
Test.test "Jsont.{of_of_string,enum,binary_string}" @@ fun () ->
339
+
(* of_string *)
340
+
let int_of_string s = match int_of_string_opt s with
341
+
| None -> Error "Not an integer" | Some i -> Ok i
342
+
in
343
+
let t = Jsont.of_of_string ~kind:"int" int_of_string ~enc:Int.to_string in
344
+
trip ~eq:(Test.T.int) t {|"1"|} ~value:1 ~__POS__;
345
+
decode_error t {|"bla"|} ~__POS__;
346
+
(* enum *)
347
+
let enum = Jsont.enum ~kind:"heyho" ["hey", `Hey; "ho", `Ho ] in
348
+
decode_error enum {|null|} ~__POS__;
349
+
decode_error enum {|"ha"|} ~__POS__;
350
+
decode_error enum {|"farfarfar"|} ~__POS__;
351
+
trip enum {|"hey"|} ~value:`Hey ~__POS__;
352
+
trip enum {|"ho"|} ~value:`Ho ~__POS__;
353
+
(* binary_string *)
354
+
decode_error Jsont.binary_string {|null|};
355
+
decode_error Jsont.binary_string {|"00gabb"|} ~__POS__;
356
+
decode_error Jsont.binary_string {|"00aab"|} ~__POS__;
357
+
trip Jsont.binary_string {|"00a1bb"|} ~__POS__;
358
+
trip Jsont.binary_string {|"00a1ff"|} ~value:"\x00\xa1\xff" ~__POS__;
359
+
()
360
+
361
+
let test_arrays =
362
+
Test.test "Jsont.{list,array,bigarray,t2,t3,t4,tn}" @@ fun () ->
363
+
let barr arr = Bigarray.Array1.of_array Int C_layout arr in
364
+
trip ~eq ~format:Layout Jsont.json " [] \n" ~__POS__;
365
+
trip ~eq ~format:Layout Jsont.json " [1, 3] \n\n" ~__POS__;
366
+
trip ~eq ~format:Layout Jsont.json " [1\n,3] \n\n" ~__POS__;
367
+
trip ~eq ~format:Layout Jsont.json " [1\n, \"a\",\n3 ] \n\n" ~__POS__;
368
+
trip ~eq ~format:Indent Jsont.json "[]" ~__POS__;
369
+
trip ~eq ~format:Indent Jsont.json "[\n 1\n]" ~__POS__;
370
+
trip ~eq ~format:Indent Jsont.json "[\n 1,\n \"bla\",\n 2\n]" ~__POS__;
371
+
decode_error Jsont.json "[1 ~__POS__;3]" ~__POS__;
372
+
decode_error Jsont.json " [1,3 " ~__POS__;
373
+
decode_error (Jsont.(list number)) "[1,true,3]" ~__POS__;
374
+
trip Jsont.(list int) " [ ] \n" ~value:[] ~__POS__;
375
+
trip Jsont.(list int) "[1,2,3]" ~value:[1;2;3] ~__POS__;
376
+
trip Jsont.(array int) " [ ] \n" ~value:[||] ~__POS__;
377
+
trip Jsont.(array int) "[1,2,3]" ~value:[|1;2;3|] ~__POS__;
378
+
trip Jsont.(bigarray Int int) " [ ] \n" ~value:(barr [||]) ~__POS__;
379
+
trip Jsont.(bigarray Int int) " [1,2,3] \n" ~value:(barr [|1;2;3;|]) ~__POS__;
380
+
let enc = Array.get in
381
+
let t2_int = Jsont.t2 ~dec:(fun x y -> [|x;y|]) ~enc Jsont.int in
382
+
decode_error t2_int "[]" ~__POS__;
383
+
decode_error t2_int "[1]" ~__POS__;
384
+
trip t2_int "[1,2]" ~value:[|1;2|] ~__POS__;
385
+
decode_error t2_int "[1,2,3]" ~__POS__;
386
+
let t3_int = Jsont.t3 ~dec:(fun x y z -> [|x;y;z|]) ~enc Jsont.int in
387
+
decode_error t3_int "[]" ~__POS__;
388
+
decode_error t3_int "[1]" ~__POS__;
389
+
decode_error t3_int "[1,2]" ~__POS__;
390
+
trip t3_int "[1,2,3]" ~value:[|1;2;3|] ~__POS__;
391
+
decode_error t3_int "[1,2,3,4]" ~__POS__;
392
+
let t4_int = Jsont.t4 ~dec:(fun x y z w -> [|x;y;z;w|]) ~enc Jsont.int in
393
+
decode_error t4_int "[]" ~__POS__;
394
+
decode_error t4_int "[1]" ~__POS__;
395
+
decode_error t4_int "[1,2]" ~__POS__;
396
+
decode_error t4_int "[1,2,3]" ~__POS__;
397
+
trip t4_int "[1,2,3,4]" ~value:[|1;2;3;4|] ~__POS__;
398
+
decode_error t4_int "[1,2,3,4,5]" ~__POS__;
399
+
let t0_int = Jsont.(tn ~n:0 int) in
400
+
let t2_int = Jsont.(tn ~n:2 int) in
401
+
trip t0_int "[]" ~value:[||] ~__POS__;
402
+
decode_error t0_int "[1]" ~__POS__;
403
+
decode_error t0_int "[1;2]" ~__POS__;
404
+
decode_error t2_int "[]" ~__POS__;
405
+
decode_error t2_int "[1]" ~__POS__;
406
+
trip t2_int "[1,2]" ~value:[|1;2|] ~__POS__;
407
+
decode_error t2_int "[1,2,3]" ~__POS__;
408
+
()
409
+
410
+
let test_objects =
411
+
Test.test "Jsont.Object.map" @@ fun () ->
412
+
trip ~eq ~format:Layout Jsont.json " {} \n" ~__POS__;
413
+
trip ~eq ~format:Layout Jsont.json {| {"a": 1} |} ~__POS__;
414
+
trip ~eq ~format:Layout Jsont.json {| {"a": 1, "b":2} |} ~__POS__;
415
+
trip ~eq ~format:Indent Jsont.json "{}" ~__POS__;
416
+
trip ~eq ~format:Indent Jsont.json "{\n \"bla\": 1\n}";
417
+
trip ~format:Indent Item.jsont Item_data.i0_json ~value:Item_data.i0 ~__POS__;
418
+
trip ~format:Indent Item.jsont Item_data.i1_json ~value:Item_data.i1 ~__POS__;
419
+
()
420
+
421
+
let test_unknown_mems =
422
+
Test.test "Jsont.Object.*_unknown" @@ fun () ->
423
+
(* Skip unknowns *)
424
+
trip Unknown.skip_jsont Unknown_data.u0 ~__POS__;
425
+
trip ~lossy:true Unknown.skip_jsont Unknown_data.u1 ~__POS__;
426
+
trip ~lossy:true Unknown.skip_jsont Unknown_data.u2 ~__POS__;
427
+
(* Error on unknown *)
428
+
trip Unknown.error_jsont Unknown_data.u0 ~__POS__;
429
+
decode_error Unknown.error_jsont Unknown_data.u1 ~__POS__;
430
+
decode_error Unknown.error_jsont Unknown_data.u2 ~__POS__;
431
+
(* Keep unknowns *)
432
+
trip Unknown.keep_jsont Unknown_data.u0 ~__POS__;
433
+
trip Unknown.keep_jsont Unknown_data.u1 ~__POS__;
434
+
trip Unknown.keep_jsont Unknown_data.u2 ~__POS__;
435
+
()
436
+
437
+
let test_cases =
438
+
Test.test "Jsont.Object.Case" @@ fun () ->
439
+
decode_error Cases.Person_top.jsont Cases_data.invalid_miss ~__POS__;
440
+
decode_error Cases.Person_top.jsont Cases_data.invalid_case ~__POS__;
441
+
decode_error Cases.Person_field.jsont Cases_data.invalid_miss ~__POS__;
442
+
decode_error Cases.Person_field.jsont Cases_data.invalid_case ~__POS__;
443
+
trip Cases.Person_top.jsont Cases_data.author0
444
+
~value:Cases_data.author0_top ~__POS__;
445
+
trip Cases.Person_top.jsont Cases_data.author0'
446
+
~value:Cases_data.author0_top ~__POS__;
447
+
trip Cases.Person_top.jsont Cases_data.editor0
448
+
~value:Cases_data.editor0_top ~__POS__;
449
+
trip Cases.Person_top.jsont Cases_data.editor0'
450
+
~value:Cases_data.editor0_top ~__POS__;
451
+
trip Cases.Person_field.jsont Cases_data.author0
452
+
~value:Cases_data.author0_field ~__POS__;
453
+
trip Cases.Person_field.jsont Cases_data.author0'
454
+
~value:Cases_data.author0_field ~__POS__;
455
+
trip Cases.Person_field.jsont Cases_data.editor0
456
+
~value:Cases_data.editor0_field ~__POS__;
457
+
trip Cases.Person_field.jsont Cases_data.editor0'
458
+
~value:Cases_data.editor0_field ~__POS__;
459
+
(* Unknown value override *)
460
+
trip Cases.Keep_unknown.jsont ~eq:(module Cases.Keep_unknown)
461
+
Cases_data.unknown_a ~value:Cases_data.unknown_a_value ~__POS__;
462
+
trip Cases.Keep_unknown.jsont ~eq:(module Cases.Keep_unknown)
463
+
Cases_data.unknown_b ~value:Cases_data.unknown_b_value ~__POS__;
464
+
let module M = struct
465
+
type t = string String_map.t
466
+
let equal = String_map.equal String.equal
467
+
let pp ppf v = Fmt.string ppf "<value>"
468
+
end
469
+
in
470
+
trip Cases.Keep_unknown.a_jsont ~eq:(module M)
471
+
Cases_data.unknown_a ~value:Cases_data.unknown_a_a_value ~__POS__;
472
+
encode_ok Cases.Keep_unknown.jsont
473
+
~format:Indent ~value:Cases_data.unknown_a_no_a_unknown_value
474
+
Cases_data.unknown_a_no_a_unknown;
475
+
()
476
+
477
+
let test_rec =
478
+
Test.test "Jsont.rec" @@ fun () ->
479
+
let tree_null = Tree.jsont_with_null Jsont.int in
480
+
trip tree_null Tree_data.empty_null ~value:Tree_data.empty ~__POS__;
481
+
trip tree_null Tree_data.tree0_null ~value:Tree_data.tree0 ~__POS__;
482
+
let tree_cases = Tree.jsont_with_cases Jsont.int in
483
+
trip tree_cases Tree_data.empty_cases ~value:Tree_data.empty ~__POS__;
484
+
trip tree_cases Tree_data.tree0_cases ~value:Tree_data.tree0 ~__POS__;
485
+
()
486
+
487
+
let test_zero =
488
+
Test.test "Jsont.zero" @@ fun () ->
489
+
let decode_ok = decode_ok ~eq:Test.T.unit in
490
+
decode_ok Jsont.zero "null" ~value:() ~__POS__;
491
+
decode_ok Jsont.zero "2" ~value:() ~__POS__;
492
+
decode_ok Jsont.zero {|"a"|} ~value:() ~__POS__;
493
+
decode_ok Jsont.zero {|[1]|} ~value:() ~__POS__;
494
+
decode_ok Jsont.zero {|{"bli":"bla"}|} ~value:() ~__POS__;
495
+
encode_ok Jsont.zero ~value:() "null" ~__POS__;
496
+
()
497
+
498
+
let test_const =
499
+
Test.test "Jsont.const" @@ fun () ->
500
+
trip ~lossy:true Jsont.(const int 4) " {} " ~value:4 ~__POS__;
501
+
trip ~lossy:true Jsont.(const bool true) ~value:true "false" ~__POS__;
502
+
()
503
+
504
+
let recode_int_to_string = Jsont.(recode ~dec:int string_of_int ~enc:string)
505
+
506
+
let test_array_queries =
507
+
let a = "[1,[ 1, 2], 3] " in
508
+
Test.test "Jsont.{nth,*_nth,filter_map_array,fold_array}" @@
509
+
fun () ->
510
+
(* Jsont.nth *)
511
+
decode_ok Jsont.(nth 0 @@ int) a ~value:1 ~__POS__;
512
+
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
513
+
decode_ok Jsont.(nth 1 @@ list int) a ~value:[1;2] ~__POS__;
514
+
decode_error Jsont.(nth 3 @@ int) a ~__POS__;
515
+
decode_ok Jsont.(nth ~absent:3 3 @@ int) ~value:3 a ~__POS__;
516
+
decode_ok Jsont.(nth 0 @@ int) ~value:1 a ~__POS__;
517
+
decode_ok Jsont.(nth 1 @@ nth 1 int) a ~value:2 ~__POS__;
518
+
decode_ok Jsont.(nth 1 @@ list int) a ~value:[1;2] ~__POS__;
519
+
(* Jsont.{set,update}_nth} *)
520
+
update ~format:Jsont.Layout
521
+
Jsont.(update_nth 1 @@ update_nth 1 Jsont.(const int 4))
522
+
a "[1,[ 1, 4], 3] " ~__POS__;
523
+
update ~format:Jsont.Layout Jsont.(update_nth 1 @@ set_nth int 0 2) a
524
+
"[1,[ 2, 2], 3] " ~__POS__;
525
+
decode_error Jsont.(update_nth 1 @@ set_nth int 2 3) a;
526
+
decode_error Jsont.(update_nth 3 int) a;
527
+
update ~format:Jsont.Layout Jsont.(update_nth 3 ~absent:5 int) a
528
+
"[1,[ 1, 2], 3,5] ";
529
+
update ~format:Jsont.Layout
530
+
Jsont.(update_nth 1 @@ set_nth ~allow_absent:true int 3 3) a
531
+
"[1,[ 1, 2,0,3], 3] " ~__POS__;
532
+
update ~format:Jsont.Layout
533
+
Jsont.(update_nth 1 @@ set_nth
534
+
~stub:(Jsont.Json.null ()) ~allow_absent:true int 3 3) a
535
+
"[1,[ 1, 2,null,3], 3] " ~__POS__;
536
+
update ~format:Jsont.Layout
537
+
Jsont.(update_nth 1 @@ update_nth 1 recode_int_to_string) a
538
+
"[1,[ 1, \"2\"], 3] " ~__POS__;
539
+
update Jsont.(update_nth 1 @@ delete_nth 0) a "[1,[2],3]" ~__POS__;
540
+
decode_ok
541
+
Jsont.(nth 1 @@ fold_array int (fun i v acc -> (i, v) :: acc) [])
542
+
a ~value:[(1,2); (0,1)] ~__POS__;
543
+
update Jsont.(update_nth 1 @@ filter_map_array int int
544
+
(fun _ v -> if v mod 2 = 0 then None else Some (v - 1)))
545
+
a "[1,[0],3]" ~__POS__;
546
+
(* Jsont.delete_nth *)
547
+
update ~format:Jsont.Layout Jsont.(delete_nth 1) a "[1, 3] " ~__POS__;
548
+
decode_error Jsont.(delete_nth 3) a ~__POS__;
549
+
update ~format:Jsont.Layout Jsont.(delete_nth ~allow_absent:true 3) a a
550
+
~__POS__;
551
+
(* Jsont.filter_map_array *)
552
+
update ~format:Jsont.Layout
553
+
Jsont.(filter_map_array Jsont.json Jsont.json
554
+
(fun i v -> if i = 1 then None else Some v)) a
555
+
"[1, 3] " ~__POS__;
556
+
(* Jsont.fold_array *)
557
+
decode_ok Jsont.(nth 1 @@ fold_array int (fun i v acc -> i + v + acc) 0) a
558
+
~value:4 ~__POS__;
559
+
()
560
+
561
+
let test_object_queries =
562
+
Test.test "Jsont.{mem,*_mem,fold_object,filter_map_object}" @@ fun () ->
563
+
let o = {| { "a" : { "b" : 1 }, "c": 2 } |} in
564
+
(* Jsont.mem *)
565
+
decode_ok Jsont.(mem "a" @@ mem "b" int) o ~value:1 ~__POS__;
566
+
decode_error Jsont.(mem "a" @@ mem "c" int) o ~__POS__;
567
+
decode_ok Jsont.(mem "a" @@ mem ~absent:3 "c" int) o ~value:3 ~__POS__;
568
+
(* Jsont.{update,set}_mem *)
569
+
update ~format:Jsont.Layout
570
+
Jsont.(update_mem "a" @@ update_mem "b" (const int 3))
571
+
o {| { "a" : { "b" : 3 }, "c": 2 } |} ~__POS__;
572
+
update ~format:Jsont.Layout
573
+
Jsont.(update_mem "a" @@ update_mem "b" recode_int_to_string)
574
+
o {| { "a" : { "b" : "1" }, "c": 2 } |} ~__POS__;
575
+
decode_error
576
+
Jsont.(update_mem "a" @@ update_mem "c" (const int 4)) o ~__POS__;
577
+
update ~format:Jsont.Layout
578
+
Jsont.(update_mem "a" @@ update_mem "c" ~absent:4 (const int 5)) o
579
+
{| { "a" : { "b" : 1 ,"c":5}, "c": 2 } |} ~__POS__;
580
+
update ~format:Jsont.Layout
581
+
Jsont.(set_mem int "a" 2) o
582
+
{| { "a" : 2, "c": 2 } |} ~__POS__;
583
+
decode_error Jsont.(set_mem int "d" 2) o ~__POS__;
584
+
update ~format:Jsont.Layout Jsont.(set_mem ~allow_absent:true int "d" 3) o
585
+
{| { "a" : { "b" : 1 }, "c": 2 ,"d":3} |} ~__POS__;
586
+
(* Jsont.delete_mem *)
587
+
decode_error Jsont.(update_mem "a" @@ delete_mem "c") o ~__POS__;
588
+
update ~format:Jsont.Layout
589
+
Jsont.(update_mem "a" @@ delete_mem ~allow_absent:true "c")
590
+
o o ~__POS__;
591
+
update ~format:Jsont.Layout Jsont.(update_mem "a" @@ delete_mem "b")
592
+
o {| { "a" : {}, "c": 2 } |} ~__POS__;
593
+
update ~format:Jsont.Layout Jsont.(delete_mem "a")
594
+
o {| { "c": 2 } |} ~__POS__;
595
+
(* Jsont.filter_map_object *)
596
+
update ~format:Jsont.Layout
597
+
Jsont.(filter_map_object Jsont.json Jsont.json
598
+
(fun m n v -> if n = "a" then None else Some ((n, m), v)))
599
+
o {| { "c": 2 } |} ~__POS__;
600
+
(* Jsont.fold *)
601
+
decode_ok Jsont.(mem "a" @@
602
+
fold_object int (fun _ n i acc -> i + acc) 2)
603
+
o ~value:3 ~__POS__;
604
+
()
605
+
606
+
let test_path_queries =
607
+
Test.test "Jsont.{path,*_path}" @@ fun () ->
608
+
let v = {| [ 0, { "a": 1}, 2 ] |} in
609
+
(* Jsont.path *)
610
+
decode_error Jsont.(path Path.root int) v ~__POS__;
611
+
update ~format:Jsont.Layout Jsont.(path Path.root Jsont.json) v v ~__POS__;
612
+
decode_ok Jsont.(path Path.(root |> nth 1 |> mem "a") int) v ~value:1;
613
+
decode_ok Jsont.(path Path.(root |> nth 1 |> mem "b") ~absent:2 int) v
614
+
~value:2 ~__POS__;
615
+
(* Jsont.{set,update}_path} *)
616
+
update ~format:Jsont.Layout Jsont.(set_path int Path.root 2)
617
+
v {|2|} ~__POS__;
618
+
update ~format:Jsont.Layout
619
+
Jsont.(set_path string Path.(root |> nth 1 |> mem "a") "hey")
620
+
v {| [ 0, { "a": "hey"}, 2 ] |} ~__POS__;
621
+
update ~format:Jsont.Layout
622
+
Jsont.(set_path ~allow_absent:true
623
+
string Path.(root |> nth 1 |> mem "b") "hey")
624
+
v {| [ 0, { "a": 1,"b":"hey"}, 2 ] |} ~__POS__;
625
+
update ~format:Jsont.Layout
626
+
Jsont.(update_path Path.(root |> nth 1 |> mem "a")
627
+
(map int ~dec:succ ~enc:Fun.id))
628
+
v {| [ 0, { "a": 2}, 2 ] |} ~__POS__;
629
+
(* Jsont.delete_path *)
630
+
update ~format:Jsont.Layout
631
+
Jsont.(delete_path Path.(root |> nth 1 |> mem "a")) v
632
+
{| [ 0, {}, 2 ] |} ~__POS__;
633
+
update ~format:Jsont.Layout
634
+
Jsont.(delete_path Path.(root |> nth 1)) v
635
+
{| [ 0, 2 ] |} ~__POS__;
636
+
update ~format:Jsont.Layout
637
+
Jsont.(delete_path Path.root) v
638
+
{|null|} ~__POS__;
639
+
decode_error Jsont.(delete_path Path.(root |> nth 1 |> mem "b")) v ~__POS__;
640
+
update ~format:Jsont.Layout
641
+
Jsont.(delete_path ~allow_absent:true Path.(root |> nth 1 |> mem "b"))
642
+
v v ~__POS__;
643
+
()
644
+
645
+
let tests () =
646
+
test_basic_invalid ();
647
+
test_null ();
648
+
test_bool ();
649
+
test_numbers ();
650
+
test_strings ();
651
+
test_option ();
652
+
test_ints ();
653
+
test_floats ();
654
+
test_enum_and_binary_string ();
655
+
test_arrays ();
656
+
test_objects ();
657
+
test_unknown_mems ();
658
+
test_cases ();
659
+
test_rec ();
660
+
test_zero ();
661
+
test_const ();
662
+
test_array_queries ();
663
+
test_object_queries ();
664
+
test_path_queries ();
665
+
()
+414
vendor/opam/jsont/test/test_common_samples.ml
+414
vendor/opam/jsont/test/test_common_samples.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
7
+
module String_map = Map.Make (String)
8
+
9
+
(* Items to do. *)
10
+
11
+
module Status = struct
12
+
type t = Todo | Done | Cancelled
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
+
let make task status tags = { task; status; tags }
20
+
let task i = i.task
21
+
let status i = i.status
22
+
let tags i = i.tags
23
+
let jsont =
24
+
Jsont.Object.map ~kind:"Item" make
25
+
|> Jsont.Object.mem "task" Jsont.string ~enc:task
26
+
|> Jsont.Object.mem "status" Status.jsont ~enc:status
27
+
|> Jsont.Object.mem "tags"
28
+
Jsont.(list string) ~dec_absent:[] ~enc:tags ~enc_omit:(( = ) [])
29
+
|> Jsont.Object.finish
30
+
31
+
end
32
+
33
+
module Item_data = struct
34
+
let i0 = Item.{ task = "Hey"; status = Todo; tags = ["huhu";"haha"] }
35
+
let i0_json = (* in Jsont.Indent format *)
36
+
"{\n\
37
+
\ \"task\": \"Hey\",\n\
38
+
\ \"status\": \"todo\",\n\
39
+
\ \"tags\": [\n\
40
+
\ \"huhu\",\n\
41
+
\ \"haha\"\n\
42
+
\ ]\n\
43
+
}"
44
+
45
+
let i1 = Item.{ task = "Ho"; status = Done; tags = [] }
46
+
let i1_json = (* in Jsont.Indent format *)
47
+
"{\n\
48
+
\ \"task\": \"Ho\",\n\
49
+
\ \"status\": \"done\"\n\
50
+
}"
51
+
end
52
+
53
+
(* JSON types to excerice the different unknown member behaviours. *)
54
+
55
+
module Unknown = struct
56
+
type t = { m : bool }
57
+
let make m = { m }
58
+
let m v = v.m
59
+
60
+
let skip_jsont =
61
+
Jsont.Object.map ~kind:"unknown-skip" make
62
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
63
+
|> Jsont.Object.skip_unknown
64
+
|> Jsont.Object.finish
65
+
66
+
let error_jsont =
67
+
Jsont.Object.map ~kind:"unknown-skip" make
68
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:m
69
+
|> Jsont.Object.error_unknown
70
+
|> Jsont.Object.finish
71
+
72
+
let keep_jsont : (t * int String_map.t) Jsont.t =
73
+
let unknown = Jsont.Object.Mems.string_map Jsont.int in
74
+
Jsont.Object.map ~kind:"unknown-keep" (fun m imap -> make m, imap)
75
+
|> Jsont.Object.mem "m" Jsont.bool ~enc:(fun (v, _) -> m v)
76
+
|> Jsont.Object.keep_unknown unknown ~enc:snd
77
+
|> Jsont.Object.finish
78
+
end
79
+
80
+
module Unknown_data = struct
81
+
let u0 = {| { "m": true } |}
82
+
let u1 = {| { "m": true, "u0": 0, "u1": 1 } |}
83
+
let u2 = {| { "u": 0, "m": true } |}
84
+
end
85
+
86
+
(* Object cases *)
87
+
88
+
module Cases = struct
89
+
(* There are two ways to encode object cases in OCaml, either as a toplevel
90
+
variant or as a record with a field that is a variant. With the design
91
+
we have the encoding is mostly the same. This is the JSON we deal with:
92
+
93
+
{ "type": "author",
94
+
"name": "…",
95
+
"pseudo": "…",
96
+
"book_count": 1 }
97
+
98
+
{ "type": "editor",
99
+
"name": "…",
100
+
"publisher": "…" } *)
101
+
102
+
module Person_top = struct (* Toplevel variant *)
103
+
module Author = struct
104
+
type t = { name : string; pseudo : string; book_count : int; }
105
+
let make name book_count pseudo = { name; pseudo; book_count }
106
+
let name a = a.name
107
+
let book_count a = a.book_count
108
+
let pseudo a = a.pseudo
109
+
let jsont =
110
+
Jsont.Object.map ~kind:"Author" make
111
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
112
+
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
113
+
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
114
+
|> Jsont.Object.finish
115
+
end
116
+
117
+
module Editor = struct
118
+
type t = { name : string; publisher : string }
119
+
let make name publisher = { name; publisher}
120
+
let name e = e.name
121
+
let publisher e = e.publisher
122
+
let jsont =
123
+
Jsont.Object.map ~kind:"Editor" make
124
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
125
+
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
126
+
|> Jsont.Object.finish
127
+
end
128
+
129
+
type t = Author of Author.t | Editor of Editor.t
130
+
131
+
let author a = Author a
132
+
let editor e = Editor e
133
+
134
+
let jsont =
135
+
let case_a = Jsont.Object.Case.map "author" Author.jsont ~dec:author in
136
+
let case_e = Jsont.Object.Case.map "editor" Editor.jsont ~dec:editor in
137
+
let cases = Jsont.Object.Case.[make case_a; make case_e] in
138
+
let enc_case = function
139
+
| Author a -> Jsont.Object.Case.value case_a a
140
+
| Editor e -> Jsont.Object.Case.value case_e e
141
+
in
142
+
Jsont.Object.map ~kind:"Person" Fun.id
143
+
|> Jsont.Object.case_mem "type"
144
+
Jsont.string ~tag_to_string:Fun.id ~enc:Fun.id ~enc_case cases
145
+
|> Jsont.Object.finish
146
+
end
147
+
148
+
module Person_field = struct (* Variant in a field *)
149
+
type author = { pseudo : string; book_count : int }
150
+
let make_author pseudo book_count = { pseudo; book_count }
151
+
let pseudo a = a.pseudo
152
+
let book_count a = a.book_count
153
+
let author_jsont =
154
+
Jsont.Object.map ~kind:"Author" make_author
155
+
|> Jsont.Object.mem "pseudo" Jsont.string ~enc:pseudo
156
+
|> Jsont.Object.mem "book_count" Jsont.int ~enc:book_count
157
+
|> Jsont.Object.finish
158
+
159
+
type editor = { publisher : string; }
160
+
let make_editor publisher = { publisher }
161
+
let publisher e = e.publisher
162
+
let editor_jsont =
163
+
Jsont.Object.map ~kind:"Editor" make_editor
164
+
|> Jsont.Object.mem "publisher" Jsont.string ~enc:publisher
165
+
|> Jsont.Object.finish
166
+
167
+
type type' = Author of author | Editor of editor
168
+
let author a = Author a
169
+
let editor e = Editor e
170
+
171
+
type t = { type' : type'; name : string }
172
+
let make type' name = { type'; name }
173
+
let type' v = v.type'
174
+
let name v = v.name
175
+
176
+
let jsont =
177
+
let case_a = Jsont.Object.Case.map "author" author_jsont ~dec:author in
178
+
let case_e = Jsont.Object.Case.map "editor" editor_jsont ~dec:editor in
179
+
let cases = Jsont.Object.Case.[make case_a; make case_e] in
180
+
let enc_case = function
181
+
| Author a -> Jsont.Object.Case.value case_a a
182
+
| Editor e -> Jsont.Object.Case.value case_e e
183
+
in
184
+
Jsont.Object.map ~kind:"Person" make
185
+
|> Jsont.Object.case_mem "type"
186
+
~tag_to_string:Fun.id Jsont.string ~enc:type' ~enc_case cases
187
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
188
+
|> Jsont.Object.finish
189
+
end
190
+
191
+
module Keep_unknown = struct
192
+
type a = string String_map.t
193
+
let a_jsont =
194
+
let unknown = Jsont.Object.Mems.string_map Jsont.string in
195
+
Jsont.Object.map ~kind:"A" Fun.id
196
+
|> Jsont.Object.keep_unknown unknown ~enc:Fun.id
197
+
|> Jsont.Object.finish
198
+
199
+
type b = { name : string }
200
+
let name b = b.name
201
+
let b_jsont =
202
+
Jsont.Object.map ~kind:"B" (fun name -> { name })
203
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
204
+
|> Jsont.Object.error_unknown
205
+
|> Jsont.Object.finish
206
+
207
+
type type' = A of a | B of b
208
+
let a a = A a
209
+
let b b = B b
210
+
type t = { type' : type'; unknown : Jsont.json }
211
+
let make type' unknown = { type'; unknown }
212
+
let type' v = v.type'
213
+
let unknown v = v.unknown
214
+
let equal v0 v1 = match v0.type', v1.type' with
215
+
| A a0, A a1 ->
216
+
String_map.equal String.equal a0 a1 &&
217
+
Jsont.Json.equal v0.unknown v1.unknown
218
+
| B b0, B b1 ->
219
+
String.equal b0.name b1.name &&
220
+
Jsont.Json.equal v0.unknown v1.unknown
221
+
| _, _ -> false
222
+
223
+
let pp ppf v = B0_std.Fmt.string ppf "<value>"
224
+
225
+
let jsont =
226
+
let case_a = Jsont.Object.Case.map "A" a_jsont ~dec:a in
227
+
let case_b = Jsont.Object.Case.map "B" b_jsont ~dec:b in
228
+
let cases = Jsont.Object.Case.[make case_a; make case_b] in
229
+
let enc_case = function
230
+
| A a -> Jsont.Object.Case.value case_a a
231
+
| B b -> Jsont.Object.Case.value case_b b
232
+
in
233
+
Jsont.Object.map ~kind:"Keep_unknown" make
234
+
|> Jsont.Object.case_mem "type"
235
+
~tag_to_string:Fun.id Jsont.string ~enc:type' ~enc_case cases
236
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
237
+
|> Jsont.Object.finish
238
+
end
239
+
240
+
end
241
+
242
+
module Cases_data = struct
243
+
let author0_top, author0_field =
244
+
let name = "Jane" and book_count = 2 and pseudo = "Jude" in
245
+
Cases.Person_top.Author { name; book_count; pseudo },
246
+
{ Cases.Person_field.type' = Author { book_count; pseudo }; name }
247
+
248
+
let invalid_miss = (* Missing type field. *)
249
+
{| { "name": "Jane", "tope": "ha", "tape": "ha",
250
+
"book_count": 2, "pseudo": "Jude" }|}
251
+
252
+
let invalid_case =
253
+
{| { "type": "reader", "name": "Jane" }|}
254
+
255
+
let author0 =
256
+
{| { "type": "author", "name": "Jane", "book_count": 2, "pseudo": "Jude" }|}
257
+
258
+
let author0' = (* out of order case field in the middle *)
259
+
{| { "name": "Jane", "book_count": 2, "type": "author", "pseudo": "Jude" }|}
260
+
261
+
let editor0_top, editor0_field =
262
+
let name = "Joe" and publisher = "Red books" in
263
+
Cases.Person_top.Editor { name; publisher },
264
+
{ Cases.Person_field.type' = Editor { publisher }; name }
265
+
266
+
let editor0 =
267
+
{| { "type": "editor", "name": "Joe", "publisher": "Red books" } |}
268
+
269
+
let editor0' = (* out of order case field at the end *)
270
+
{| { "name": "Joe", "publisher": "Red books", "type": "editor" } |}
271
+
272
+
let unknown_a =
273
+
{| { "m1": "n", "type": "A", "m0": "o" } |}
274
+
275
+
let unknown_b =
276
+
{| { "type": "B", "m1": "v1", "name": "ha", "m2": 0 } |}
277
+
278
+
let unknown_a_value =
279
+
let unknown =
280
+
Jsont.Json.(object' [mem (name "m0") (string "o");
281
+
mem (name "m1") (string "n")])
282
+
in
283
+
Cases.Keep_unknown.make (A String_map.empty) unknown
284
+
285
+
let unknown_a_a_value =
286
+
String_map.empty
287
+
|> String_map.add "m0" "o"
288
+
|> String_map.add "m1" "n"
289
+
|> String_map.add "type" "A"
290
+
291
+
let unknown_a_no_a_unknown = "{\n \"type\": \"A\"\n}"
292
+
let unknown_a_no_a_unknown_value =
293
+
(* Since the map should be ignored since the case object overides it *)
294
+
let unknown = Jsont.Json.object' [] in
295
+
Cases.Keep_unknown.make (A String_map.(empty |> add "bli" "bla")) unknown
296
+
297
+
let unknown_b_value =
298
+
let unknown =
299
+
Jsont.Json.(object' [mem (name "m1") (string "v1");
300
+
mem (name "m2") (number 0.0)])
301
+
in
302
+
Cases.Keep_unknown.make (B { name = "ha" }) unknown
303
+
end
304
+
305
+
(* Type recursion *)
306
+
307
+
module Tree = struct
308
+
type 'a tree = Empty | Node of 'a tree * 'a * 'a tree
309
+
310
+
let rec pp pp_v ppf = function
311
+
| Empty -> Format.fprintf ppf "Empty"
312
+
| Node (l, v, r) ->
313
+
Format.fprintf ppf "@[Node @[<1>(%a,@ %a,@ %a)@]@]"
314
+
(pp pp_v) l pp_v v (pp pp_v) r
315
+
316
+
(* Encoded with null for Empty and nodes with:
317
+
318
+
{ "left": …,
319
+
"value": …,
320
+
"right": … }
321
+
322
+
and null is used for empty. *)
323
+
let jsont_with_null t =
324
+
let rec tree = lazy begin
325
+
let empty = Jsont.null Empty in
326
+
let node =
327
+
let not_a_node () = failwith "not a node" in
328
+
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
329
+
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
330
+
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
331
+
Jsont.Object.map ~kind:"node" (fun l v r -> Node (l, v, r))
332
+
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
333
+
|> Jsont.Object.mem ~enc:value "value" t
334
+
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
335
+
|> Jsont.Object.finish
336
+
in
337
+
let enc = function Empty -> empty | Node _ -> node in
338
+
Jsont.any ~kind:"tree" ~dec_null:empty ~dec_object:node ~enc ()
339
+
end
340
+
in
341
+
Lazy.force tree
342
+
343
+
(* Encoded as two cases :
344
+
345
+
{ "type": "empty" }
346
+
347
+
{ "type": "node",
348
+
"left": …,
349
+
"value": …,
350
+
"right": … } *)
351
+
352
+
let jsont_with_cases t =
353
+
let rec tree = lazy begin
354
+
let leaf_jsont = Jsont.Object.map Empty |> Jsont.Object.finish in
355
+
let node_jsont =
356
+
let not_a_node () = failwith "not a node" in
357
+
let value = function Node (_, v, _) -> v | _ -> not_a_node () in
358
+
let left = function Node (l, _, _) -> l | _ -> not_a_node () in
359
+
let right = function Node (_, _, r) -> r | _ -> not_a_node () in
360
+
Jsont.Object.map (fun l v r -> Node (l, v, r))
361
+
|> Jsont.Object.mem ~enc:left "left" (Jsont.rec' tree)
362
+
|> Jsont.Object.mem ~enc:value "value" t
363
+
|> Jsont.Object.mem ~enc:right "right" (Jsont.rec' tree)
364
+
|> Jsont.Object.finish
365
+
in
366
+
let case_leaf = Jsont.Object.Case.map "empty" leaf_jsont ~dec:Fun.id in
367
+
let case_node = Jsont.Object.Case.map "node" node_jsont ~dec:Fun.id in
368
+
let enc_case = function
369
+
| Empty as v -> Jsont.Object.Case.value case_leaf v
370
+
| Node _ as v -> Jsont.Object.Case.value case_node v
371
+
in
372
+
let cases = Jsont.Object.Case.[ make case_leaf; make case_node ] in
373
+
Jsont.Object.map ~kind:"tree" Fun.id
374
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
375
+
|> Jsont.Object.finish
376
+
end
377
+
in
378
+
Lazy.force tree
379
+
380
+
end
381
+
382
+
module Tree_data = struct
383
+
let empty = Tree.Empty
384
+
let empty_null = {| null |}
385
+
let empty_cases = {| { "type": "empty" } |}
386
+
387
+
let tree0 = Tree.Node (Node (Node (Empty, 1, Empty),
388
+
2,
389
+
Empty),
390
+
3,
391
+
Node (Empty, 4, Empty))
392
+
393
+
let tree0_null =
394
+
{| { "left": { "left": { "left": null, "value": 1, "right": null },
395
+
"value": 2,
396
+
"right": null },
397
+
"value": 3,
398
+
"right": { "left": null, "value": 4, "right": null } } |}
399
+
400
+
let tree0_cases = (* Case member not in order to check decode delays. *)
401
+
{| { "left": { "type": "node",
402
+
"left": { "type": "node",
403
+
"left": { "type": "empty" },
404
+
"right": { "type": "empty" },
405
+
"value": 1 },
406
+
"value": 2,
407
+
"right": { "type" : "empty" }},
408
+
"value": 3,
409
+
"type": "node",
410
+
"right": { "type": "node",
411
+
"left": { "type" : "empty" },
412
+
"value": 4,
413
+
"right": { "type" : "empty" }}} |}
414
+
end
+34
vendor/opam/jsont/test/test_json.ml
+34
vendor/opam/jsont/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 ())
+69
vendor/opam/jsont/test/test_seriot_suite.ml
+69
vendor/opam/jsont/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 else
14
+
if String.starts_with ~prefix:"n_" name then `Reject else
15
+
if String.starts_with ~prefix:"i_" name then `Indeterminate else
16
+
Test.failstop "Unknown kind of test: %s" name
17
+
18
+
let test ~show_errors file =
19
+
let name = Fpath.basename file in
20
+
Test.test name @@ fun () ->
21
+
Test.noraise ~__POS__ @@ fun () ->
22
+
Result.get_ok' @@
23
+
let* json = Os.File.read file in
24
+
let status = status_of_filename name in
25
+
let file = Fpath.to_string file in
26
+
match Jsont_bytesrw.decode_string ~file ~locs:true Jsont.json json with
27
+
| Ok _ ->
28
+
if status = `Accept || status = `Indeterminate
29
+
then Ok ()
30
+
else (Test.failstop " @[<v>Should have been rejected:@,%s@]" json)
31
+
| Error e ->
32
+
if show_errors then Log.err (fun m -> m "%s" e);
33
+
if status = `Reject || status = `Indeterminate
34
+
then Ok ()
35
+
else (Test.failstop " @[<v>Should have been accepted:@,%s@]" json)
36
+
37
+
let run ~dir ~show_errors =
38
+
let dir = Fpath.v dir in
39
+
Log.if_error ~use:1 @@
40
+
let* exists = Os.Dir.exists dir in
41
+
if not exists
42
+
then begin
43
+
Fmt.pr "@[%a @[<v>JSONTestSuite not found@,\
44
+
Use %a to download it@]@]" Test.Fmt.skip ()
45
+
Fmt.code "b0 -- download-seriot-suite";
46
+
Ok 0
47
+
end else
48
+
let dir = Fpath.(dir / "test_parsing") in
49
+
let* files = Os.Dir.fold_files ~recurse:false Os.Dir.path_list dir [] in
50
+
Result.ok @@ Test.main @@ fun () ->
51
+
List.iter (fun file -> test ~show_errors file ()) files
52
+
53
+
open Cmdliner
54
+
open Cmdliner.Term.Syntax
55
+
56
+
let cmd =
57
+
let doc = "Run Nicolas Seriot's JSON test suite" in
58
+
Cmd.v (Cmd.info "test_seriot_suite" ~doc) @@
59
+
let+ show_errors =
60
+
let doc = "Show errors" in
61
+
Arg.(value & flag & info ["e"; "show-errors"] ~doc)
62
+
and+ dir =
63
+
let doc = "Repository directory of the test suite." in
64
+
Arg.(value & pos 0 dir "tmp/JSONTestSuite" & info [] ~doc ~docv:"REPO")
65
+
in
66
+
run ~dir ~show_errors
67
+
68
+
let main () = Cmd.eval' cmd
69
+
let () = if !Sys.interactive then () else exit (main ())
+283
vendor/opam/jsont/test/topojson.ml
+283
vendor/opam/jsont/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
+
let jsont = Jsont.(array ~kind:"Position" number)
13
+
end
14
+
15
+
module Bbox = struct
16
+
type t = float array
17
+
let jsont = Jsont.(array ~kind:"Bbox" number)
18
+
end
19
+
20
+
module Arcs = struct
21
+
type t = Position.t array array
22
+
let jsont = Jsont.(array ~kind:"Arcs" (array Position.jsont))
23
+
end
24
+
25
+
module Transform = struct
26
+
type v2 = float * float
27
+
type t = { scale : v2; translate : v2 }
28
+
29
+
let make scale translate = { scale; translate }
30
+
let scale t = t.scale
31
+
let translate t = t.translate
32
+
33
+
let v2_jsont =
34
+
let dec x y = x, y in
35
+
let enc (x, y) i = if i = 0 then x else y in
36
+
Jsont.t2 ~dec ~enc Jsont.number
37
+
38
+
let jsont =
39
+
Jsont.Object.map ~kind:"Transform" make
40
+
|> Jsont.Object.mem "scale" v2_jsont ~enc:scale
41
+
|> Jsont.Object.mem "translate" v2_jsont ~enc:translate
42
+
|> Jsont.Object.finish
43
+
end
44
+
45
+
module Point = struct
46
+
type t = { coordinates : Position.t }
47
+
let make coordinates = { coordinates }
48
+
let coordinates v = v.coordinates
49
+
let jsont =
50
+
Jsont.Object.map ~kind:"Point" make
51
+
|> Jsont.Object.mem "coordinates" Position.jsont ~enc:coordinates
52
+
|> Jsont.Object.finish
53
+
end
54
+
55
+
module Multi_point = struct
56
+
type t = { coordinates : Position.t list }
57
+
let make coordinates = { coordinates }
58
+
let coordinates v = v.coordinates
59
+
let jsont =
60
+
Jsont.Object.map ~kind:"MultiPoint" make
61
+
|> Jsont.Object.mem "coordinates" (Jsont.list Position.jsont)
62
+
~enc:coordinates
63
+
|> Jsont.Object.finish
64
+
end
65
+
66
+
module Line_string = struct
67
+
type t = { arcs : int32 list }
68
+
let make arcs = { arcs }
69
+
let arcs v = v.arcs
70
+
let jsont =
71
+
Jsont.Object.map ~kind:"LineString" make
72
+
|> Jsont.Object.mem "arcs" Jsont.(list int32) ~enc:arcs
73
+
|> Jsont.Object.finish
74
+
end
75
+
76
+
module Multi_line_string = struct
77
+
type t = { arcs : int32 list list }
78
+
let make arcs = { arcs }
79
+
let arcs v = v.arcs
80
+
let jsont =
81
+
Jsont.Object.map ~kind:"MultiLineString" make
82
+
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
83
+
|> Jsont.Object.finish
84
+
end
85
+
86
+
module Polygon = struct
87
+
type t = { arcs : int32 list list }
88
+
let make arcs = { arcs }
89
+
let arcs v = v.arcs
90
+
let jsont =
91
+
Jsont.Object.map ~kind:"Polygon" make
92
+
|> Jsont.Object.mem "arcs" Jsont.(list (list int32)) ~enc:arcs
93
+
|> Jsont.Object.finish
94
+
end
95
+
96
+
module Multi_polygon = struct
97
+
type t = { arcs : int32 list list list }
98
+
let make arcs = { arcs }
99
+
let arcs v = v.arcs
100
+
let jsont =
101
+
Jsont.Object.map ~kind:"MultiPolygon" make
102
+
|> Jsont.Object.mem "arcs" Jsont.(list (list (list int32))) ~enc:arcs
103
+
|> Jsont.Object.finish
104
+
end
105
+
106
+
module Geometry = struct
107
+
type id = [ `Number of float | `String of string ]
108
+
let id_jsont =
109
+
let number =
110
+
let dec = Jsont.Base.dec (fun n -> `Number n) in
111
+
let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) in
112
+
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
113
+
in
114
+
let string =
115
+
let dec = Jsont.Base.dec (fun n -> `String n) in
116
+
let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in
117
+
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
118
+
in
119
+
let enc = function `Number _ -> number | `String _ -> string in
120
+
Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc ()
121
+
122
+
type t =
123
+
{ type' : type';
124
+
id : id option;
125
+
properties : Jsont.json String_map.t option;
126
+
bbox : Bbox.t option;
127
+
unknown : Jsont.json }
128
+
129
+
and type' =
130
+
| Point of Point.t
131
+
| Multi_point of Multi_point.t
132
+
| Line_string of Line_string.t
133
+
| Multi_line_string of Multi_line_string.t
134
+
| Polygon of Polygon.t
135
+
| Multi_polygon of Multi_polygon.t
136
+
| Geometry_collection of t list
137
+
138
+
let make type' id properties bbox unknown =
139
+
{ type'; id; properties; bbox; unknown }
140
+
141
+
let type' g = g.type'
142
+
let id g = g.id
143
+
let properties g = g.properties
144
+
let bbox g = g.bbox
145
+
let unknown g = g.unknown
146
+
147
+
let point v = Point v
148
+
let multi_point v = Multi_point v
149
+
let line_string v = Line_string v
150
+
let multi_linestr v = Multi_line_string v
151
+
let polygon v = Polygon v
152
+
let multi_polygon v = Multi_polygon v
153
+
let collection vs = Geometry_collection vs
154
+
155
+
let properties_type = Jsont.Object.as_string_map ~kind:"properties" Jsont.json
156
+
157
+
let rec collection_jsont = lazy begin
158
+
Jsont.Object.map ~kind:"GeometryCollection" Fun.id
159
+
|> Jsont.Object.mem "geometries" (Jsont.list (Jsont.rec' jsont)) ~enc:Fun.id
160
+
|> Jsont.Object.finish
161
+
end
162
+
163
+
and jsont = lazy begin
164
+
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec in
165
+
let case_point = case_map Point.jsont point in
166
+
let case_multi_point = case_map Multi_point.jsont multi_point in
167
+
let case_line_string = case_map Line_string.jsont line_string in
168
+
let case_multi_linestr = case_map Multi_line_string.jsont multi_linestr in
169
+
let case_polygon = case_map Polygon.jsont polygon in
170
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
171
+
let case_coll = case_map (Lazy.force collection_jsont) collection in
172
+
let enc_case = function
173
+
| Point p -> Jsont.Object.Case.value case_point p
174
+
| Multi_point m -> Jsont.Object.Case.value case_multi_point m
175
+
| Line_string l -> Jsont.Object.Case.value case_line_string l
176
+
| Multi_line_string m -> Jsont.Object.Case.value case_multi_linestr m
177
+
| Polygon p -> Jsont.Object.Case.value case_polygon p
178
+
| Multi_polygon m -> Jsont.Object.Case.value case_multi_polygon m
179
+
| Geometry_collection gs -> Jsont.Object.Case.value case_coll gs
180
+
and cases = Jsont.Object.Case.[
181
+
make case_point; make case_multi_point; make case_line_string;
182
+
make case_multi_linestr; make case_polygon; make case_multi_polygon;
183
+
make case_coll ]
184
+
in
185
+
Jsont.Object.map ~kind:"Geometry" make
186
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:type' ~enc_case cases
187
+
~tag_to_string:Fun.id ~tag_compare:String.compare
188
+
|> Jsont.Object.opt_mem "id" id_jsont ~enc:id
189
+
|> Jsont.Object.opt_mem "properties" properties_type ~enc:properties
190
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
191
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
192
+
|> Jsont.Object.finish
193
+
end
194
+
195
+
let jsont = Lazy.force jsont
196
+
type objects = t String_map.t
197
+
let objects_jsont = Jsont.Object.as_string_map ~kind:"objects map" jsont
198
+
end
199
+
200
+
module Topology = struct
201
+
type t =
202
+
{ objects : Geometry.objects;
203
+
arcs : Arcs.t;
204
+
transform : Transform.t option;
205
+
bbox : Bbox.t option;
206
+
unknown : Jsont.json }
207
+
208
+
let make objects arcs transform bbox unknown =
209
+
{ objects; arcs; transform; bbox; unknown }
210
+
211
+
let objects t = t.objects
212
+
let arcs t = t.arcs
213
+
let transform t = t.transform
214
+
let bbox t = t.bbox
215
+
let unknown t = t.unknown
216
+
let jsont =
217
+
let kind = "Topology" in
218
+
Jsont.Object.map ~kind (fun () -> make)
219
+
|> Jsont.Object.mem "type" (Jsont.enum [kind, ()]) ~enc:(Fun.const ())
220
+
|> Jsont.Object.mem "objects" Geometry.objects_jsont ~enc:objects
221
+
|> Jsont.Object.mem "arcs" Arcs.jsont ~enc:arcs
222
+
|> Jsont.Object.opt_mem "transform" Transform.jsont ~enc:transform
223
+
|> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox
224
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
225
+
|> Jsont.Object.finish
226
+
end
227
+
228
+
(* Command line interface *)
229
+
230
+
let ( let* ) = Result.bind
231
+
let strf = Printf.sprintf
232
+
233
+
let log_if_error ~use = function
234
+
| Ok v -> v
235
+
| Error e ->
236
+
let lines = String.split_on_char '\n' e in
237
+
Format.eprintf "@[%a @[<v>%a@]@]@."
238
+
Jsont.Error.puterr () (Format.pp_print_list Format.pp_print_string) lines;
239
+
use
240
+
241
+
let with_infile file f = (* XXX add something to bytesrw. *)
242
+
let process file ic = try Ok (f (Bytesrw.Bytes.Reader.of_in_channel ic)) with
243
+
| Sys_error e -> Error (Format.sprintf "@[<v>%s:@,%s@]" file e)
244
+
in
245
+
try match file with
246
+
| "-" -> process file In_channel.stdin
247
+
| file -> In_channel.with_open_bin file (process file)
248
+
with Sys_error e -> Error e
249
+
250
+
let trip ~file ~format ~locs ~dec_only =
251
+
log_if_error ~use:1 @@
252
+
with_infile file @@ fun r ->
253
+
log_if_error ~use:1 @@
254
+
let* t = Jsont_bytesrw.decode ~file ~locs Topology.jsont r in
255
+
if dec_only then Ok 0 else
256
+
let w = Bytesrw.Bytes.Writer.of_out_channel stdout in
257
+
let* () = Jsont_bytesrw.encode ~format ~eod:true Topology.jsont t w in
258
+
Ok 0
259
+
260
+
open Cmdliner
261
+
open Cmdliner.Term.Syntax
262
+
263
+
let topojson =
264
+
Cmd.v (Cmd.info "topojson" ~doc:"round trip TopoJSON") @@
265
+
let+ file =
266
+
let doc = "$(docv) is the TopoJSON file. Use $(b,-) for stdin." in
267
+
Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
268
+
and+ locs =
269
+
let doc = "Preserve locations (better errors)." in
270
+
Arg.(value & flag & info ["l"; "locs"] ~doc)
271
+
and+ format =
272
+
let fmt = [ "indent", Jsont.Indent; "minify", Jsont.Minify ] in
273
+
let doc = strf "Output style. Must be %s." (Arg.doc_alts_enum fmt)in
274
+
Arg.(value & opt (enum fmt) Jsont.Minify &
275
+
info ["f"; "format"] ~doc ~docv:"FMT")
276
+
and+ dec_only =
277
+
let doc = "Decode only." in
278
+
Arg.(value & flag & info ["d"] ~doc)
279
+
in
280
+
trip ~file ~format ~locs ~dec_only
281
+
282
+
let main () = Cmd.eval' topojson
283
+
let () = if !Sys.interactive then () else exit (main ())
+38
vendor/opam/jsont/test/trials.ml
+38
vendor/opam/jsont/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
+
let make content public = { content; public }
9
+
let content msg = msg.content
10
+
let public msg = msg.public
11
+
let jsont : t Jsont.t =
12
+
Jsont.Object.map make
13
+
|> Jsont.Object.mem "content" Jsont.string ~enc:content
14
+
|> Jsont.Object.mem "public" Jsont.bool ~enc:public
15
+
|> Jsont.Object.finish
16
+
end
17
+
18
+
type ('ret, 'f) app =
19
+
| Fun : 'f -> ('ret, 'f) app
20
+
| App : ('ret, 'a -> 'b) app * 'a -> ('ret, 'b) app
21
+
22
+
let ret : 'f -> ('ret, 'f) app = fun f -> Fun f
23
+
let app : ('ret, 'a -> 'b) app -> 'a -> ('ret, 'b) app = fun f a -> App (f, a)
24
+
25
+
let g ~i ~s = string_of_int i ^ s
26
+
27
+
let t0 : (string, string) app =
28
+
app (app (ret (fun i s -> g ~i ~s)) 2) "bla"
29
+
30
+
(* That works but it's not the tructure that we want. *)
31
+
32
+
let ( let+ ) : 'a -> ('a -> 'b) -> ('ret, 'b) app = fun v f -> App (Fun f, v)
33
+
let ( and+ ) : 'a -> 'b -> 'a * 'b = fun x y -> (x, y)
34
+
35
+
let t1 : (string, string) app =
36
+
let+ i = 2
37
+
and+ s = "bla" in
38
+
g ~i ~s