anil.recoil.org
Yaml encoder/decoder for OCaml jsont codecs
fmt
+1440
-1098
+19
-1
.gitignore
+19
-1
.gitignore
···
1
-
_build
1
+
# OCaml build artifacts
2
+
_build/
3
+
*.install
4
+
*.merlin
5
+
6
+
# Third-party sources (fetch locally with opam source)
7
+
third_party/
8
+
9
+
# Symlinked dependencies
2
10
ocaml-yamlrw
11
+
12
+
# Editor and OS files
13
+
.DS_Store
14
+
*.swp
15
+
*~
16
+
.vscode/
17
+
.idea/
18
+
19
+
# Opam local switch
20
+
_opam/
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.28.1
+52
.tangled/workflows/build.yml
+52
.tangled/workflows/build.yml
···
1
+
when:
2
+
- event: ["push", "pull_request"]
3
+
branch: ["main"]
4
+
5
+
engine: nixery
6
+
7
+
dependencies:
8
+
nixpkgs:
9
+
- shell
10
+
- stdenv
11
+
- findutils
12
+
- binutils
13
+
- libunwind
14
+
- ncurses
15
+
- opam
16
+
- git
17
+
- gawk
18
+
- gnupatch
19
+
- gnum4
20
+
- gnumake
21
+
- gnutar
22
+
- gnused
23
+
- gnugrep
24
+
- diffutils
25
+
- gzip
26
+
- bzip2
27
+
- gcc
28
+
- ocaml
29
+
30
+
steps:
31
+
- name: opam
32
+
command: |
33
+
opam init --disable-sandboxing -a -y
34
+
- name: repo
35
+
command: |
36
+
opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git
37
+
- name: switch
38
+
command: |
39
+
opam install . --confirm-level=unsafe-yes --deps-only
40
+
- name: build
41
+
command: |
42
+
opam exec -- dune build
43
+
- name: switch-test
44
+
command: |
45
+
opam install . --confirm-level=unsafe-yes --deps-only --with-test
46
+
- name: test
47
+
command: |
48
+
opam exec -- dune runtest --verbose
49
+
- name: doc
50
+
command: |
51
+
opam install -y odoc
52
+
opam exec -- dune build @doc
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and 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
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+62
README.md
+62
README.md
···
1
+
# yamlt - YAML codec using Jsont type descriptions
2
+
3
+
Yamlt provides YAML streaming encode/decode that interprets Jsont.t type descriptions, allowing the same codec definitions to work for both JSON and YAML.
4
+
5
+
## Key Features
6
+
7
+
- Use the same Jsont.t codec for both JSON and YAML formats
8
+
- Streaming encode/decode with configurable depth and node limits
9
+
- Support for YAML-specific features (scalars, sequences, mappings)
10
+
- Billion laughs protection with configurable limits
11
+
- Multiple output formats (block, flow, layout preservation)
12
+
13
+
## Usage
14
+
15
+
```ocaml
16
+
(* Define a codec once using Jsont *)
17
+
module Config = struct
18
+
type t = { name: string; port: int }
19
+
let make name port = { name; port }
20
+
let jsont =
21
+
Jsont.Object.map ~kind:"Config" make
22
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun c -> c.name)
23
+
|> Jsont.Object.mem "port" Jsont.int ~enc:(fun c -> c.port)
24
+
|> Jsont.Object.finish
25
+
end
26
+
27
+
(* Use the same codec for both JSON and YAML *)
28
+
let from_json = Jsont_bytesrw.decode_string Config.jsont json_str
29
+
let from_yaml = Yamlt.decode_string Config.jsont yaml_str
30
+
```
31
+
32
+
For encoding:
33
+
34
+
```ocaml
35
+
(* Encode to YAML with different formats *)
36
+
let config = Config.make "server" 8080
37
+
38
+
(* Block style (default) *)
39
+
let yaml_block = Yamlt.encode_string Config.jsont config
40
+
41
+
(* Flow style (JSON-like) *)
42
+
let yaml_flow = Yamlt.encode_string ~format:Flow Config.jsont config
43
+
```
44
+
45
+
## Installation
46
+
47
+
```
48
+
opam install yamlt
49
+
```
50
+
51
+
## Documentation
52
+
53
+
API documentation is available at https://tangled.org/@anil.recoil.org/ocaml-yamlt or via:
54
+
55
+
```
56
+
opam install yamlt
57
+
odig doc yamlt
58
+
```
59
+
60
+
## License
61
+
62
+
ISC
+5
dune
+5
dune
+10
-1
dune-project
+10
-1
dune-project
···
1
1
(lang dune 3.18)
2
+
2
3
(name yamlt)
3
4
4
5
(generate_opam_files true)
5
6
7
+
(license ISC)
8
+
(authors "Anil Madhavapeddy")
9
+
(homepage "https://tangled.org/@anil.recoil.org/ocaml-yamlt")
10
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
11
+
(bug_reports "https://tangled.org/@anil.recoil.org/ocaml-yamlt/issues")
12
+
(maintenance_intent "(latest)")
13
+
6
14
(package
7
15
(name yamlt)
8
16
(synopsis "YAML codec using Jsont type descriptions")
···
11
19
(ocaml (>= 4.14.0))
12
20
yamlrw
13
21
jsont
14
-
bytesrw))
22
+
bytesrw
23
+
(odoc :with-doc)))
+469
-389
lib/yamlt.ml
+469
-389
lib/yamlt.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
open Bytesrw
7
7
open Jsont.Repr
···
26
26
meta_none : Jsont.Meta.t;
27
27
}
28
28
29
-
let make_decoder
30
-
?(locs = false) ?(layout = false) ?(file = "-")
29
+
let make_decoder ?(locs = false) ?(layout = false) ?(file = "-")
31
30
?(max_depth = 100) ?(max_nodes = 10_000_000) parser =
32
31
let meta_none = Jsont.Meta.make (Jsont.Textloc.(set_file none) file) in
33
-
{ parser; file; locs; _layout = layout; max_depth; max_nodes;
34
-
node_count = 0; current = None;
35
-
_anchors = Hashtbl.create 16; meta_none }
32
+
{
33
+
parser;
34
+
file;
35
+
locs;
36
+
_layout = layout;
37
+
max_depth;
38
+
max_nodes;
39
+
node_count = 0;
40
+
current = None;
41
+
_anchors = Hashtbl.create 16;
42
+
meta_none;
43
+
}
36
44
37
45
(* Decoder helpers *)
38
46
39
47
let check_depth d ~nest =
40
48
if nest > d.max_depth then
41
-
Jsont.Error.msgf Jsont.Meta.none "Maximum nesting depth %d exceeded" d.max_depth
49
+
Jsont.Error.msgf Jsont.Meta.none "Maximum nesting depth %d exceeded"
50
+
d.max_depth
42
51
43
52
let check_nodes d =
44
53
d.node_count <- d.node_count + 1;
45
54
if d.node_count > d.max_nodes then
46
-
Jsont.Error.msgf Jsont.Meta.none "Maximum node count %d exceeded" d.max_nodes
55
+
Jsont.Error.msgf Jsont.Meta.none "Maximum node count %d exceeded"
56
+
d.max_nodes
47
57
48
58
let meta_of_span d span =
49
-
if not d.locs then d.meta_none else
50
-
let start = span.Span.start and stop = span.Span.stop in
51
-
let first_byte = start.Position.index in
52
-
let last_byte = max first_byte (stop.Position.index - 1) in
53
-
(* line_pos is (line_number, byte_position_of_line_start) *)
54
-
let first_line = (start.Position.line, start.Position.index - start.Position.column + 1) in
55
-
let last_line = (stop.Position.line, stop.Position.index - stop.Position.column + 1) in
56
-
let textloc = Jsont.Textloc.make ~file:d.file
57
-
~first_byte ~last_byte ~first_line ~last_line in
58
-
Jsont.Meta.make textloc
59
+
if not d.locs then d.meta_none
60
+
else
61
+
let start = span.Span.start and stop = span.Span.stop in
62
+
let first_byte = start.Position.index in
63
+
let last_byte = max first_byte (stop.Position.index - 1) in
64
+
(* line_pos is (line_number, byte_position_of_line_start) *)
65
+
let first_line =
66
+
(start.Position.line, start.Position.index - start.Position.column + 1)
67
+
in
68
+
let last_line =
69
+
(stop.Position.line, stop.Position.index - stop.Position.column + 1)
70
+
in
71
+
let textloc =
72
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
73
+
~last_line
74
+
in
75
+
Jsont.Meta.make textloc
59
76
60
77
let next_event d =
61
78
d.current <- Parser.next d.parser;
62
79
d.current
63
80
64
81
let peek_event d =
65
-
match d.current with
66
-
| Some _ -> d.current
67
-
| None -> next_event d
82
+
match d.current with Some _ -> d.current | None -> next_event d
68
83
69
-
let skip_event d =
70
-
d.current <- None
84
+
let skip_event d = d.current <- None
71
85
72
86
let _expect_event d pred name =
73
87
match peek_event d with
74
-
| Some ev when pred ev.Event.event -> skip_event d; ev
88
+
| Some ev when pred ev.Event.event ->
89
+
skip_event d;
90
+
ev
75
91
| Some ev ->
76
92
let span = ev.Event.span in
77
93
let meta = meta_of_span d span in
78
-
Jsont.Error.msgf meta "Expected %s but found %a" name Event.pp ev.Event.event
94
+
Jsont.Error.msgf meta "Expected %s but found %a" name Event.pp
95
+
ev.Event.event
79
96
| None ->
80
-
Jsont.Error.msgf Jsont.Meta.none "Expected %s but reached end of stream" name
97
+
Jsont.Error.msgf Jsont.Meta.none "Expected %s but reached end of stream"
98
+
name
81
99
82
100
(* Error helpers *)
83
101
···
87
105
88
106
let err_type_mismatch d span t ~fnd =
89
107
let meta = meta_of_span d span in
90
-
Jsont.Error.msgf meta "Expected %s but found %s"
91
-
(Jsont.Repr.kinded_sort t) fnd
108
+
Jsont.Error.msgf meta "Expected %s but found %s" (Jsont.Repr.kinded_sort t)
109
+
fnd
92
110
93
111
(* YAML scalar resolution *)
94
112
95
113
let is_null_scalar s =
96
-
s = "" || s = "~" ||
97
-
s = "null" || s = "Null" || s = "NULL"
114
+
s = "" || s = "~" || s = "null" || s = "Null" || s = "NULL"
98
115
99
116
let bool_of_scalar_opt s =
100
117
match s with
101
-
| "true" | "True" | "TRUE"
102
-
| "yes" | "Yes" | "YES"
103
-
| "on" | "On" | "ON" -> Some true
104
-
| "false" | "False" | "FALSE"
105
-
| "no" | "No" | "NO"
106
-
| "off" | "Off" | "OFF" -> Some false
118
+
| "true" | "True" | "TRUE" | "yes" | "Yes" | "YES" | "on" | "On" | "ON" ->
119
+
Some true
120
+
| "false" | "False" | "FALSE" | "no" | "No" | "NO" | "off" | "Off" | "OFF" ->
121
+
Some false
107
122
| _ -> None
108
123
109
124
let float_of_scalar_opt s =
···
113
128
| "+.inf" | "+.Inf" | "+.INF" -> Some Float.infinity
114
129
| "-.inf" | "-.Inf" | "-.INF" -> Some Float.neg_infinity
115
130
| ".nan" | ".NaN" | ".NAN" -> Some Float.nan
116
-
| _ ->
131
+
| _ -> (
117
132
(* Try parsing as number, allowing underscores *)
118
133
let s' = String.concat "" (String.split_on_char '_' s) in
119
134
(* Try int first (supports 0o, 0x, 0b) then float *)
120
135
match int_of_string_opt s' with
121
136
| Some i -> Some (float_of_int i)
122
-
| None -> float_of_string_opt s'
137
+
| None -> float_of_string_opt s')
123
138
124
139
let _int_of_scalar_opt s =
125
140
(* Handle hex, octal, and regular integers with underscores *)
···
127
142
int_of_string_opt s'
128
143
129
144
(* Decode a scalar value according to expected type *)
130
-
let rec decode_scalar_as :
131
-
type a. decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
132
-
fun d ev value style t ->
145
+
let rec decode_scalar_as : type a.
146
+
decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
147
+
fun d ev value style t ->
133
148
check_nodes d;
134
149
let meta = meta_of_span d ev.Event.span in
135
150
match t with
136
151
| Null map ->
137
152
if is_null_scalar value then map.dec meta ()
138
153
else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value)
139
-
| Bool map ->
140
-
(match bool_of_scalar_opt value with
141
-
| Some b -> map.dec meta b
142
-
| None ->
143
-
(* For explicitly quoted strings, fail *)
144
-
if style <> `Plain then
145
-
err_type_mismatch d ev.span t ~fnd:("string " ^ value)
146
-
else
147
-
err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
148
-
| Number map ->
149
-
(* Handle null -> nan mapping like jsont *)
150
-
if is_null_scalar value then map.dec meta Float.nan
154
+
| Bool map -> (
155
+
match bool_of_scalar_opt value with
156
+
| Some b -> map.dec meta b
157
+
| None ->
158
+
(* For explicitly quoted strings, fail *)
159
+
if style <> `Plain then
160
+
err_type_mismatch d ev.span t ~fnd:("string " ^ value)
161
+
else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
162
+
| Number map -> (
163
+
if
164
+
(* Handle null -> nan mapping like jsont *)
165
+
is_null_scalar value
166
+
then map.dec meta Float.nan
151
167
else
152
-
(match float_of_scalar_opt value with
153
-
| Some f -> map.dec meta f
154
-
| None -> err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
168
+
match float_of_scalar_opt value with
169
+
| Some f -> map.dec meta f
170
+
| None -> err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
155
171
| String map ->
156
172
(* Don't decode null values as strings - they should fail so outer combinators
157
173
like 'option' or 'any' can handle them properly.
···
168
184
| Rec lazy_t ->
169
185
(* Handle recursive types *)
170
186
decode_scalar_as d ev value style (Lazy.force lazy_t)
171
-
| _ ->
172
-
err_type_mismatch d ev.span t ~fnd:"scalar"
187
+
| _ -> err_type_mismatch d ev.span t ~fnd:"scalar"
173
188
174
189
(* Forward declaration for mutual recursion *)
175
190
let rec decode : type a. decoder -> nest:int -> a t -> a =
176
-
fun d ~nest t ->
191
+
fun d ~nest t ->
177
192
check_depth d ~nest;
178
193
match peek_event d with
179
194
| None -> Jsont.Error.msgf Jsont.Meta.none "Unexpected end of YAML stream"
180
-
| Some ev ->
181
-
match ev.Event.event, t with
195
+
| Some ev -> (
196
+
match (ev.Event.event, t) with
182
197
(* Scalar events *)
183
198
| Event.Scalar { value; style; anchor; _ }, _ ->
184
199
skip_event d;
185
200
let result = decode_scalar d ~nest ev value style t in
186
201
(* Store anchor if present - TODO: implement anchor storage *)
187
202
(match anchor with
188
-
| Some _name ->
189
-
(* We need generic JSON for anchors - decode as json and convert back *)
190
-
()
191
-
| None -> ());
203
+
| Some _name ->
204
+
(* We need generic JSON for anchors - decode as json and convert back *)
205
+
()
206
+
| None -> ());
192
207
result
193
-
194
208
(* Alias *)
195
209
| Event.Alias { anchor }, _ ->
196
210
skip_event d;
197
211
decode_alias d ev anchor t
198
-
199
212
(* Map combinator - must come before specific event matches *)
200
-
| _, Map m ->
201
-
m.dec (decode d ~nest m.dom)
202
-
213
+
| _, Map m -> m.dec (decode d ~nest m.dom)
203
214
(* Recursive types - must come before specific event matches *)
204
-
| _, Rec lazy_t ->
205
-
decode d ~nest (Lazy.force lazy_t)
206
-
215
+
| _, Rec lazy_t -> decode d ~nest (Lazy.force lazy_t)
207
216
(* Sequence -> Array *)
208
-
| Event.Sequence_start _, Array map ->
209
-
decode_array d ~nest ev map
210
-
211
-
| Event.Sequence_start _, Any map ->
212
-
decode_any_sequence d ~nest ev t map
213
-
217
+
| Event.Sequence_start _, Array map -> decode_array d ~nest ev map
218
+
| Event.Sequence_start _, Any map -> decode_any_sequence d ~nest ev t map
214
219
| Event.Sequence_start _, _ ->
215
220
err_type_mismatch d ev.span t ~fnd:"sequence"
216
-
217
221
(* Mapping -> Object *)
218
-
| Event.Mapping_start _, Object map ->
219
-
decode_object d ~nest ev map
220
-
221
-
| Event.Mapping_start _, Any map ->
222
-
decode_any_mapping d ~nest ev t map
223
-
224
-
| Event.Mapping_start _, _ ->
225
-
err_type_mismatch d ev.span t ~fnd:"mapping"
226
-
222
+
| Event.Mapping_start _, Object map -> decode_object d ~nest ev map
223
+
| Event.Mapping_start _, Any map -> decode_any_mapping d ~nest ev t map
224
+
| Event.Mapping_start _, _ -> err_type_mismatch d ev.span t ~fnd:"mapping"
227
225
(* Unexpected events *)
228
226
| Event.Sequence_end, _ ->
229
227
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected sequence end"
···
236
234
| Event.Stream_start _, _ ->
237
235
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream start"
238
236
| Event.Stream_end, _ ->
239
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream end"
237
+
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream end")
240
238
241
-
and decode_scalar : type a. decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
242
-
fun d ~nest ev value style t ->
239
+
and decode_scalar : type a.
240
+
decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a
241
+
=
242
+
fun d ~nest ev value style t ->
243
243
match t with
244
244
| Any map -> decode_any_scalar d ev value style t map
245
245
| Map m -> m.dec (decode_scalar d ~nest ev value style m.dom)
246
246
| Rec lazy_t -> decode_scalar d ~nest ev value style (Lazy.force lazy_t)
247
247
| _ -> decode_scalar_as d ev value style t
248
248
249
-
and decode_any_scalar : type a. decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a any_map -> a =
250
-
fun d ev value style t map ->
249
+
and decode_any_scalar : type a.
250
+
decoder ->
251
+
Event.spanned ->
252
+
string ->
253
+
Scalar_style.t ->
254
+
a t ->
255
+
a any_map ->
256
+
a =
257
+
fun d ev value style t map ->
251
258
check_nodes d;
252
259
(* Determine which decoder to use based on scalar content *)
253
260
if is_null_scalar value then
254
261
match map.dec_null with
255
262
| Some t' -> decode_scalar_as d ev value style t'
256
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Null
263
+
| None ->
264
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Null
257
265
else if style = `Plain then
258
266
(* Try bool, then number, then string *)
259
267
match bool_of_scalar_opt value with
260
-
| Some _ ->
261
-
(match map.dec_bool with
262
-
| Some t' -> decode_scalar_as d ev value style t'
263
-
| None ->
264
-
match map.dec_string with
265
-
| Some t' -> decode_scalar_as d ev value style t'
266
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Bool)
267
-
| None ->
268
+
| Some _ -> (
269
+
match map.dec_bool with
270
+
| Some t' -> decode_scalar_as d ev value style t'
271
+
| None -> (
272
+
match map.dec_string with
273
+
| Some t' -> decode_scalar_as d ev value style t'
274
+
| None ->
275
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
276
+
~fnd:Jsont.Sort.Bool))
277
+
| None -> (
268
278
match float_of_scalar_opt value with
269
-
| Some _ ->
270
-
(match map.dec_number with
271
-
| Some t' -> decode_scalar_as d ev value style t'
272
-
| None ->
273
-
match map.dec_string with
274
-
| Some t' -> decode_scalar_as d ev value style t'
275
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Number)
276
-
| None ->
279
+
| Some _ -> (
280
+
match map.dec_number with
281
+
| Some t' -> decode_scalar_as d ev value style t'
282
+
| None -> (
283
+
match map.dec_string with
284
+
| Some t' -> decode_scalar_as d ev value style t'
285
+
| None ->
286
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
287
+
~fnd:Jsont.Sort.Number))
288
+
| None -> (
277
289
(* Plain scalar that's not bool/number -> string *)
278
290
match map.dec_string with
279
291
| Some t' -> decode_scalar_as d ev value style t'
280
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.String
292
+
| None ->
293
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
294
+
~fnd:Jsont.Sort.String))
281
295
else
282
296
(* Quoted scalars are strings *)
283
297
match map.dec_string with
284
298
| Some t' -> decode_scalar_as d ev value style t'
285
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.String
299
+
| None ->
300
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.String
286
301
287
302
and decode_alias : type a. decoder -> Event.spanned -> string -> a t -> a =
288
-
fun d ev anchor t ->
303
+
fun d ev anchor t ->
289
304
check_nodes d;
290
305
match Hashtbl.find_opt d._anchors anchor with
291
306
| None ->
292
307
let meta = meta_of_span d ev.span in
293
308
Jsont.Error.msgf meta "Unknown anchor: %s" anchor
294
-
| Some json ->
309
+
| Some json -> (
295
310
(* Decode the stored JSON value through the type *)
296
311
let t' = Jsont.Repr.unsafe_to_t t in
297
312
match Jsont.Json.decode' t' json with
298
313
| Ok v -> v
299
-
| Error e -> raise (Jsont.Error e)
314
+
| Error e -> raise (Jsont.Error e))
300
315
301
-
and decode_array : type a elt b. decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
302
-
fun d ~nest start_ev map ->
303
-
skip_event d; (* consume Sequence_start *)
316
+
and decode_array : type a elt b.
317
+
decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
318
+
fun d ~nest start_ev map ->
319
+
skip_event d;
320
+
(* consume Sequence_start *)
304
321
check_nodes d;
305
322
let meta = meta_of_span d start_ev.span in
306
323
let builder = ref (map.dec_empty ()) in
···
316
333
(try
317
334
if map.dec_skip i !builder then begin
318
335
(* Skip this element by decoding as ignore *)
319
-
let _ : unit = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore) in
336
+
let _ : unit =
337
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
338
+
in
320
339
()
321
-
end else begin
340
+
end
341
+
else begin
322
342
let elt = decode d ~nest:(nest + 1) map.elt in
323
343
builder := map.dec_add i elt !builder
324
344
end
···
327
347
Jsont.Repr.error_push_array meta map (i, imeta) e);
328
348
incr idx;
329
349
loop ()
330
-
| None ->
331
-
Jsont.Error.msgf meta "Unclosed sequence"
350
+
| None -> Jsont.Error.msgf meta "Unclosed sequence"
332
351
in
333
352
loop ()
334
353
335
-
and decode_any_sequence : type a. decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
336
-
fun d ~nest ev t map ->
354
+
and decode_any_sequence : type a.
355
+
decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
356
+
fun d ~nest ev t map ->
337
357
match map.dec_array with
338
-
| Some t' ->
358
+
| Some t' -> (
339
359
(* The t' decoder might be wrapped (e.g., Map for option types)
340
360
Directly decode the array and let the wrapper handle it *)
341
-
(match t' with
342
-
| Array array_map ->
343
-
decode_array d ~nest ev array_map
344
-
| _ ->
345
-
(* For wrapped types like Map (Array ...), use full decode *)
346
-
decode d ~nest t')
347
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
361
+
match t' with
362
+
| Array array_map -> decode_array d ~nest ev array_map
363
+
| _ ->
364
+
(* For wrapped types like Map (Array ...), use full decode *)
365
+
decode d ~nest t')
366
+
| None ->
367
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
348
368
349
-
and decode_object : type o. decoder -> nest:int -> Event.spanned -> (o, o) object_map -> o =
350
-
fun d ~nest start_ev map ->
351
-
skip_event d; (* consume Mapping_start *)
369
+
and decode_object : type o.
370
+
decoder -> nest:int -> Event.spanned -> (o, o) object_map -> o =
371
+
fun d ~nest start_ev map ->
372
+
skip_event d;
373
+
(* consume Mapping_start *)
352
374
check_nodes d;
353
375
let meta = meta_of_span d start_ev.span in
354
-
let dict = decode_object_members d ~nest meta map String_map.empty Dict.empty in
376
+
let dict =
377
+
decode_object_members d ~nest meta map String_map.empty Dict.empty
378
+
in
355
379
let dict = Dict.add object_meta_arg meta dict in
356
380
apply_dict map.dec dict
357
381
358
382
and decode_object_members : type o.
359
-
decoder -> nest:int -> Jsont.Meta.t -> (o, o) object_map ->
360
-
mem_dec String_map.t -> Dict.t -> Dict.t =
361
-
fun d ~nest obj_meta map mem_miss dict ->
383
+
decoder ->
384
+
nest:int ->
385
+
Jsont.Meta.t ->
386
+
(o, o) object_map ->
387
+
mem_dec String_map.t ->
388
+
Dict.t ->
389
+
Dict.t =
390
+
fun d ~nest obj_meta map mem_miss dict ->
362
391
(* Merge expected member decoders *)
363
392
let u _ _ _ = assert false in
364
393
let mem_miss = String_map.union u mem_miss map.mem_decs in
···
371
400
decode_object_cases d ~nest obj_meta map umems cases mem_miss [] dict
372
401
373
402
and decode_object_basic : type o mems builder.
374
-
decoder -> nest:int -> Jsont.Meta.t -> (o, o) object_map ->
375
-
(o, mems, builder) unknown_mems ->
376
-
mem_dec String_map.t -> Dict.t -> Dict.t =
377
-
fun d ~nest obj_meta map umems mem_miss dict ->
378
-
let ubuilder = ref (match umems with
379
-
| Unknown_skip | Unknown_error -> Obj.magic ()
380
-
| Unknown_keep (mmap, _) -> mmap.dec_empty ()) in
403
+
decoder ->
404
+
nest:int ->
405
+
Jsont.Meta.t ->
406
+
(o, o) object_map ->
407
+
(o, mems, builder) unknown_mems ->
408
+
mem_dec String_map.t ->
409
+
Dict.t ->
410
+
Dict.t =
411
+
fun d ~nest obj_meta map umems mem_miss dict ->
412
+
let ubuilder =
413
+
ref
414
+
(match umems with
415
+
| Unknown_skip | Unknown_error -> Obj.magic ()
416
+
| Unknown_keep (mmap, _) -> mmap.dec_empty ())
417
+
in
381
418
let mem_miss = ref mem_miss in
382
419
let dict = ref dict in
383
420
let rec loop () =
···
391
428
let name, name_meta = decode_mapping_key d ev in
392
429
(* Look up member decoder *)
393
430
(match String_map.find_opt name map.mem_decs with
394
-
| Some (Mem_dec mem) ->
395
-
mem_miss := String_map.remove name !mem_miss;
396
-
(try
397
-
let v = decode d ~nest:(nest + 1) mem.type' in
398
-
dict := Dict.add mem.id v !dict
399
-
with Jsont.Error e ->
400
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
401
-
| None ->
402
-
(* Unknown member *)
403
-
match umems with
404
-
| Unknown_skip ->
405
-
let _ : unit = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore) in
406
-
()
407
-
| Unknown_error ->
408
-
Jsont.Repr.unexpected_mems_error obj_meta map ~fnd:[(name, name_meta)]
409
-
| Unknown_keep (mmap, _) ->
410
-
(try
411
-
let v = decode d ~nest:(nest + 1) mmap.mems_type in
412
-
ubuilder := mmap.dec_add name_meta name v !ubuilder
413
-
with Jsont.Error e ->
414
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e));
431
+
| Some (Mem_dec mem) -> (
432
+
mem_miss := String_map.remove name !mem_miss;
433
+
try
434
+
let v = decode d ~nest:(nest + 1) mem.type' in
435
+
dict := Dict.add mem.id v !dict
436
+
with Jsont.Error e ->
437
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
438
+
| None -> (
439
+
(* Unknown member *)
440
+
match umems with
441
+
| Unknown_skip ->
442
+
let _ : unit =
443
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
444
+
in
445
+
()
446
+
| Unknown_error ->
447
+
Jsont.Repr.unexpected_mems_error obj_meta map
448
+
~fnd:[ (name, name_meta) ]
449
+
| Unknown_keep (mmap, _) -> (
450
+
try
451
+
let v = decode d ~nest:(nest + 1) mmap.mems_type in
452
+
ubuilder := mmap.dec_add name_meta name v !ubuilder
453
+
with Jsont.Error e ->
454
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
455
+
));
415
456
loop ()
416
-
| None ->
417
-
Jsont.Error.msgf obj_meta "Unclosed mapping"
457
+
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
418
458
in
419
459
loop ()
420
460
421
461
and finish_object : type o mems builder.
422
-
Jsont.Meta.t -> (o, o) object_map -> (o, mems, builder) unknown_mems ->
423
-
builder -> mem_dec String_map.t -> Dict.t -> Dict.t =
424
-
fun meta map umems ubuilder mem_miss dict ->
462
+
Jsont.Meta.t ->
463
+
(o, o) object_map ->
464
+
(o, mems, builder) unknown_mems ->
465
+
builder ->
466
+
mem_dec String_map.t ->
467
+
Dict.t ->
468
+
Dict.t =
469
+
fun meta map umems ubuilder mem_miss dict ->
425
470
let dict = Dict.add object_meta_arg meta dict in
426
-
let dict = match umems with
471
+
let dict =
472
+
match umems with
427
473
| Unknown_skip | Unknown_error -> dict
428
-
| Unknown_keep (mmap, _) -> Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
474
+
| Unknown_keep (mmap, _) ->
475
+
Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
429
476
in
430
477
(* Check for missing required members *)
431
478
let add_default _ (Mem_dec mem_map) dict =
···
440
487
Jsont.Repr.missing_mems_error meta map ~exp ~fnd:[]
441
488
442
489
and decode_object_cases : type o cases tag.
443
-
decoder -> nest:int -> Jsont.Meta.t -> (o, o) object_map ->
444
-
unknown_mems_option ->
445
-
(o, cases, tag) object_cases ->
446
-
mem_dec String_map.t -> (Jsont.name * Jsont.json) list -> Dict.t -> Dict.t =
447
-
fun d ~nest obj_meta map umems cases mem_miss delayed dict ->
490
+
decoder ->
491
+
nest:int ->
492
+
Jsont.Meta.t ->
493
+
(o, o) object_map ->
494
+
unknown_mems_option ->
495
+
(o, cases, tag) object_cases ->
496
+
mem_dec String_map.t ->
497
+
(Jsont.name * Jsont.json) list ->
498
+
Dict.t ->
499
+
Dict.t =
500
+
fun d ~nest obj_meta map umems cases mem_miss delayed dict ->
448
501
match peek_event d with
449
-
| Some { Event.event = Event.Mapping_end; _ } ->
502
+
| Some { Event.event = Event.Mapping_end; _ } -> (
450
503
skip_event d;
451
504
(* No tag found - use dec_absent if available *)
452
-
(match cases.tag.dec_absent with
453
-
| Some tag ->
454
-
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss delayed dict
455
-
| None ->
456
-
(* Missing required case tag *)
457
-
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
458
-
let fnd = List.map (fun ((n, _), _) -> n) delayed in
459
-
Jsont.Repr.missing_mems_error obj_meta map ~exp ~fnd)
505
+
match cases.tag.dec_absent with
506
+
| Some tag ->
507
+
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
508
+
delayed dict
509
+
| None ->
510
+
(* Missing required case tag *)
511
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
512
+
let fnd = List.map (fun ((n, _), _) -> n) delayed in
513
+
Jsont.Repr.missing_mems_error obj_meta map ~exp ~fnd)
460
514
| Some ev ->
461
515
let name, name_meta = decode_mapping_key d ev in
462
516
if String.equal name cases.tag.name then begin
463
517
(* Found the case tag *)
464
518
let tag = decode d ~nest:(nest + 1) cases.tag.type' in
465
-
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss delayed dict
466
-
end else begin
519
+
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
520
+
delayed dict
521
+
end
522
+
else begin
467
523
(* Not the case tag - check if known member or delay *)
468
524
match String_map.find_opt name map.mem_decs with
469
-
| Some (Mem_dec mem) ->
525
+
| Some (Mem_dec mem) -> (
470
526
let mem_miss = String_map.remove name mem_miss in
471
-
(try
472
-
let v = decode d ~nest:(nest + 1) mem.type' in
473
-
let dict = Dict.add mem.id v dict in
474
-
decode_object_cases d ~nest obj_meta map umems cases mem_miss delayed dict
475
-
with Jsont.Error e ->
476
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
527
+
try
528
+
let v = decode d ~nest:(nest + 1) mem.type' in
529
+
let dict = Dict.add mem.id v dict in
530
+
decode_object_cases d ~nest obj_meta map umems cases mem_miss
531
+
delayed dict
532
+
with Jsont.Error e ->
533
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
477
534
| None ->
478
535
(* Unknown member - decode as generic JSON and delay *)
479
536
let v = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json) in
480
537
let delayed = ((name, name_meta), v) :: delayed in
481
-
decode_object_cases d ~nest obj_meta map umems cases mem_miss delayed dict
538
+
decode_object_cases d ~nest obj_meta map umems cases mem_miss
539
+
delayed dict
482
540
end
483
-
| None ->
484
-
Jsont.Error.msgf obj_meta "Unclosed mapping"
541
+
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
485
542
486
543
and decode_with_case_tag : type o cases tag.
487
-
decoder -> nest:int -> Jsont.Meta.t -> (o, o) object_map ->
488
-
unknown_mems_option ->
489
-
(o, cases, tag) object_cases -> tag ->
490
-
mem_dec String_map.t -> (Jsont.name * Jsont.json) list -> Dict.t -> Dict.t =
491
-
fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
544
+
decoder ->
545
+
nest:int ->
546
+
Jsont.Meta.t ->
547
+
(o, o) object_map ->
548
+
unknown_mems_option ->
549
+
(o, cases, tag) object_cases ->
550
+
tag ->
551
+
mem_dec String_map.t ->
552
+
(Jsont.name * Jsont.json) list ->
553
+
Dict.t ->
554
+
Dict.t =
555
+
fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
492
556
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
493
557
match List.find_opt eq_tag cases.cases with
494
-
| None ->
495
-
Jsont.Repr.unexpected_case_tag_error obj_meta map cases tag
558
+
| None -> Jsont.Repr.unexpected_case_tag_error obj_meta map cases tag
496
559
| Some (Case case) ->
497
560
(* Continue decoding with the case's object map *)
498
-
let case_dict = decode_case_remaining d ~nest obj_meta case.object_map
499
-
umems mem_miss delayed dict in
561
+
let case_dict =
562
+
decode_case_remaining d ~nest obj_meta case.object_map umems mem_miss
563
+
delayed dict
564
+
in
500
565
let case_value = apply_dict case.object_map.dec case_dict in
501
566
Dict.add cases.id (case.dec case_value) dict
502
567
503
568
and decode_case_remaining : type o.
504
-
decoder -> nest:int -> Jsont.Meta.t -> (o, o) object_map ->
505
-
unknown_mems_option ->
506
-
mem_dec String_map.t -> (Jsont.name * Jsont.json) list -> Dict.t -> Dict.t =
507
-
fun d ~nest obj_meta case_map _umems mem_miss delayed dict ->
569
+
decoder ->
570
+
nest:int ->
571
+
Jsont.Meta.t ->
572
+
(o, o) object_map ->
573
+
unknown_mems_option ->
574
+
mem_dec String_map.t ->
575
+
(Jsont.name * Jsont.json) list ->
576
+
Dict.t ->
577
+
Dict.t =
578
+
fun d ~nest obj_meta case_map _umems mem_miss delayed dict ->
508
579
(* First, process delayed members against the case map *)
509
580
let u _ _ _ = assert false in
510
581
let mem_miss = String_map.union u mem_miss case_map.mem_decs in
511
-
let dict, mem_miss = List.fold_left (fun (dict, mem_miss) ((name, meta), json) ->
512
-
match String_map.find_opt name case_map.mem_decs with
513
-
| Some (Mem_dec mem) ->
514
-
let t' = Jsont.Repr.unsafe_to_t mem.type' in
515
-
(match Jsont.Json.decode' t' json with
516
-
| Ok v ->
517
-
let dict = Dict.add mem.id v dict in
518
-
let mem_miss = String_map.remove name mem_miss in
519
-
(dict, mem_miss)
520
-
| Error e ->
521
-
Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
522
-
| None ->
523
-
(* Unknown for case too - skip them *)
524
-
(dict, mem_miss)
525
-
) (dict, mem_miss) delayed in
582
+
let dict, mem_miss =
583
+
List.fold_left
584
+
(fun (dict, mem_miss) ((name, meta), json) ->
585
+
match String_map.find_opt name case_map.mem_decs with
586
+
| Some (Mem_dec mem) -> (
587
+
let t' = Jsont.Repr.unsafe_to_t mem.type' in
588
+
match Jsont.Json.decode' t' json with
589
+
| Ok v ->
590
+
let dict = Dict.add mem.id v dict in
591
+
let mem_miss = String_map.remove name mem_miss in
592
+
(dict, mem_miss)
593
+
| Error e ->
594
+
Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
595
+
| None ->
596
+
(* Unknown for case too - skip them *)
597
+
(dict, mem_miss))
598
+
(dict, mem_miss) delayed
599
+
in
526
600
(* Then continue reading remaining members using case's own unknown handling *)
527
601
match case_map.shape with
528
602
| Object_basic case_umems ->
···
531
605
(* Nested cases shouldn't happen - use skip for safety *)
532
606
decode_object_basic d ~nest obj_meta case_map Unknown_skip mem_miss dict
533
607
534
-
and decode_any_mapping : type a. decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
535
-
fun d ~nest ev t map ->
608
+
and decode_any_mapping : type a.
609
+
decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
610
+
fun d ~nest ev t map ->
536
611
match map.dec_object with
537
612
| Some t' -> decode d ~nest t'
538
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
613
+
| None ->
614
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
539
615
540
616
and decode_mapping_key : decoder -> Event.spanned -> string * Jsont.Meta.t =
541
-
fun d ev ->
617
+
fun d ev ->
542
618
match ev.Event.event with
543
619
| Event.Scalar { value; _ } ->
544
620
skip_event d;
···
553
629
let skip_to_content d =
554
630
let rec loop () =
555
631
match peek_event d with
556
-
| Some { Event.event = Event.Stream_start _; _ } -> skip_event d; loop ()
557
-
| Some { Event.event = Event.Document_start _; _ } -> skip_event d; loop ()
632
+
| Some { Event.event = Event.Stream_start _; _ } ->
633
+
skip_event d;
634
+
loop ()
635
+
| Some { Event.event = Event.Document_start _; _ } ->
636
+
skip_event d;
637
+
loop ()
558
638
| _ -> ()
559
639
in
560
640
loop ()
···
562
642
let skip_end_wrappers d =
563
643
let rec loop () =
564
644
match peek_event d with
565
-
| Some { Event.event = Event.Document_end _; _ } -> skip_event d; loop ()
566
-
| Some { Event.event = Event.Stream_end; _ } -> skip_event d; loop ()
645
+
| Some { Event.event = Event.Document_end _; _ } ->
646
+
skip_event d;
647
+
loop ()
648
+
| Some { Event.event = Event.Stream_end; _ } ->
649
+
skip_event d;
650
+
loop ()
567
651
| None -> ()
568
652
| Some ev ->
569
653
let meta = meta_of_span d ev.span in
570
-
Jsont.Error.msgf meta "Expected end of document but found %a" Event.pp ev.event
654
+
Jsont.Error.msgf meta "Expected end of document but found %a" Event.pp
655
+
ev.event
571
656
in
572
657
loop ()
573
658
···
608
693
scalar_style : Scalar_style.t;
609
694
}
610
695
611
-
let make_encoder
612
-
?(format = Block) ?(indent = 2) ?(explicit_doc = false)
696
+
let make_encoder ?(format = Block) ?(indent = 2) ?(explicit_doc = false)
613
697
?(scalar_style = `Any) emitter =
614
698
{ emitter; format; _indent = indent; explicit_doc; scalar_style }
615
699
···
627
711
628
712
(* Encode null *)
629
713
let encode_null e _meta =
630
-
Emitter.emit e.emitter (Event.Scalar {
631
-
anchor = None;
632
-
tag = None;
633
-
value = "null";
634
-
plain_implicit = true;
635
-
quoted_implicit = true;
636
-
style = `Plain;
637
-
})
714
+
Emitter.emit e.emitter
715
+
(Event.Scalar
716
+
{
717
+
anchor = None;
718
+
tag = None;
719
+
value = "null";
720
+
plain_implicit = true;
721
+
quoted_implicit = true;
722
+
style = `Plain;
723
+
})
638
724
639
725
(* Encode boolean *)
640
726
let encode_bool e _meta b =
641
-
Emitter.emit e.emitter (Event.Scalar {
642
-
anchor = None;
643
-
tag = None;
644
-
value = if b then "true" else "false";
645
-
plain_implicit = true;
646
-
quoted_implicit = true;
647
-
style = `Plain;
648
-
})
727
+
Emitter.emit e.emitter
728
+
(Event.Scalar
729
+
{
730
+
anchor = None;
731
+
tag = None;
732
+
value = (if b then "true" else "false");
733
+
plain_implicit = true;
734
+
quoted_implicit = true;
735
+
style = `Plain;
736
+
})
649
737
650
738
(* Encode number *)
651
739
let encode_number e _meta f =
···
654
742
| FP_nan -> ".nan"
655
743
| FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
656
744
| _ ->
657
-
if Float.is_integer f && Float.abs f < 1e15 then
658
-
Printf.sprintf "%.0f" f
659
-
else
660
-
Printf.sprintf "%g" f
745
+
if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f
746
+
else Printf.sprintf "%g" f
661
747
in
662
-
Emitter.emit e.emitter (Event.Scalar {
663
-
anchor = None;
664
-
tag = None;
665
-
value;
666
-
plain_implicit = true;
667
-
quoted_implicit = true;
668
-
style = `Plain;
669
-
})
748
+
Emitter.emit e.emitter
749
+
(Event.Scalar
750
+
{
751
+
anchor = None;
752
+
tag = None;
753
+
value;
754
+
plain_implicit = true;
755
+
quoted_implicit = true;
756
+
style = `Plain;
757
+
})
670
758
671
759
(* Encode string *)
672
760
let encode_string e _meta s =
673
761
let style = choose_scalar_style ~preferred:e.scalar_style s in
674
-
Emitter.emit e.emitter (Event.Scalar {
675
-
anchor = None;
676
-
tag = None;
677
-
value = s;
678
-
plain_implicit = true;
679
-
quoted_implicit = true;
680
-
style;
681
-
})
762
+
Emitter.emit e.emitter
763
+
(Event.Scalar
764
+
{
765
+
anchor = None;
766
+
tag = None;
767
+
value = s;
768
+
plain_implicit = true;
769
+
quoted_implicit = true;
770
+
style;
771
+
})
682
772
683
773
let rec encode : type a. encoder -> a t -> a -> unit =
684
-
fun e t v ->
774
+
fun e t v ->
685
775
match t with
686
776
| Null map ->
687
777
let meta = map.enc_meta v in
688
778
let () = map.enc v in
689
779
encode_null e meta
690
-
691
780
| Bool map ->
692
781
let meta = map.enc_meta v in
693
782
let b = map.enc v in
694
783
encode_bool e meta b
695
-
696
784
| Number map ->
697
785
let meta = map.enc_meta v in
698
786
let f = map.enc v in
699
787
encode_number e meta f
700
-
701
788
| String map ->
702
789
let meta = map.enc_meta v in
703
790
let s = map.enc v in
704
791
encode_string e meta s
705
-
706
-
| Array map ->
707
-
encode_array e map v
708
-
709
-
| Object map ->
710
-
encode_object e map v
711
-
792
+
| Array map -> encode_array e map v
793
+
| Object map -> encode_object e map v
712
794
| Any map ->
713
795
let t' = map.enc v in
714
796
encode e t' v
715
-
716
-
| Map m ->
717
-
encode e m.dom (m.enc v)
718
-
719
-
| Rec lazy_t ->
720
-
encode e (Lazy.force lazy_t) v
797
+
| Map m -> encode e m.dom (m.enc v)
798
+
| Rec lazy_t -> encode e (Lazy.force lazy_t) v
721
799
722
800
and encode_array : type a elt b. encoder -> (a, elt, b) array_map -> a -> unit =
723
-
fun e map v ->
801
+
fun e map v ->
724
802
let style = layout_style_of_format e.format in
725
-
Emitter.emit e.emitter (Event.Sequence_start {
726
-
anchor = None;
727
-
tag = None;
728
-
implicit = true;
729
-
style;
730
-
});
731
-
let _ = map.enc (fun () _idx elt ->
732
-
encode e map.elt elt;
733
-
()
734
-
) () v in
803
+
Emitter.emit e.emitter
804
+
(Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
805
+
let _ =
806
+
map.enc
807
+
(fun () _idx elt ->
808
+
encode e map.elt elt;
809
+
())
810
+
() v
811
+
in
735
812
Emitter.emit e.emitter Event.Sequence_end
736
813
737
814
and encode_object : type o. encoder -> (o, o) object_map -> o -> unit =
738
-
fun e map v ->
815
+
fun e map v ->
739
816
let style = layout_style_of_format e.format in
740
-
Emitter.emit e.emitter (Event.Mapping_start {
741
-
anchor = None;
742
-
tag = None;
743
-
implicit = true;
744
-
style;
745
-
});
817
+
Emitter.emit e.emitter
818
+
(Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
746
819
(* Encode each member *)
747
-
List.iter (fun (Mem_enc mem) ->
748
-
let mem_v = mem.enc v in
749
-
if not (mem.enc_omit mem_v) then begin
750
-
(* Emit key *)
751
-
Emitter.emit e.emitter (Event.Scalar {
752
-
anchor = None;
753
-
tag = None;
754
-
value = mem.name;
755
-
plain_implicit = true;
756
-
quoted_implicit = true;
757
-
style = `Plain;
758
-
});
759
-
(* Emit value *)
760
-
encode e mem.type' mem_v
761
-
end
762
-
) map.mem_encs;
820
+
List.iter
821
+
(fun (Mem_enc mem) ->
822
+
let mem_v = mem.enc v in
823
+
if not (mem.enc_omit mem_v) then begin
824
+
(* Emit key *)
825
+
Emitter.emit e.emitter
826
+
(Event.Scalar
827
+
{
828
+
anchor = None;
829
+
tag = None;
830
+
value = mem.name;
831
+
plain_implicit = true;
832
+
quoted_implicit = true;
833
+
style = `Plain;
834
+
});
835
+
(* Emit value *)
836
+
encode e mem.type' mem_v
837
+
end)
838
+
map.mem_encs;
763
839
(* Handle case objects *)
764
840
(match map.shape with
765
-
| Object_basic _ -> ()
766
-
| Object_cases (_, cases) ->
767
-
let Case_value (case_map, case_v) = cases.enc_case (cases.enc v) in
768
-
(* Emit case tag *)
769
-
if not (cases.tag.enc_omit (case_map.tag)) then begin
770
-
Emitter.emit e.emitter (Event.Scalar {
771
-
anchor = None;
772
-
tag = None;
773
-
value = cases.tag.name;
774
-
plain_implicit = true;
775
-
quoted_implicit = true;
776
-
style = `Plain;
777
-
});
778
-
encode e cases.tag.type' case_map.tag
779
-
end;
780
-
(* Emit case members *)
781
-
List.iter (fun (Mem_enc mem) ->
782
-
let mem_v = mem.enc case_v in
783
-
if not (mem.enc_omit mem_v) then begin
784
-
Emitter.emit e.emitter (Event.Scalar {
785
-
anchor = None;
786
-
tag = None;
787
-
value = mem.name;
788
-
plain_implicit = true;
789
-
quoted_implicit = true;
790
-
style = `Plain;
791
-
});
792
-
encode e mem.type' mem_v
793
-
end
794
-
) case_map.object_map.mem_encs);
841
+
| Object_basic _ -> ()
842
+
| Object_cases (_, cases) ->
843
+
let (Case_value (case_map, case_v)) = cases.enc_case (cases.enc v) in
844
+
(* Emit case tag *)
845
+
if not (cases.tag.enc_omit case_map.tag) then begin
846
+
Emitter.emit e.emitter
847
+
(Event.Scalar
848
+
{
849
+
anchor = None;
850
+
tag = None;
851
+
value = cases.tag.name;
852
+
plain_implicit = true;
853
+
quoted_implicit = true;
854
+
style = `Plain;
855
+
});
856
+
encode e cases.tag.type' case_map.tag
857
+
end;
858
+
(* Emit case members *)
859
+
List.iter
860
+
(fun (Mem_enc mem) ->
861
+
let mem_v = mem.enc case_v in
862
+
if not (mem.enc_omit mem_v) then begin
863
+
Emitter.emit e.emitter
864
+
(Event.Scalar
865
+
{
866
+
anchor = None;
867
+
tag = None;
868
+
value = mem.name;
869
+
plain_implicit = true;
870
+
quoted_implicit = true;
871
+
style = `Plain;
872
+
});
873
+
encode e mem.type' mem_v
874
+
end)
875
+
case_map.object_map.mem_encs);
795
876
Emitter.emit e.emitter Event.Mapping_end
796
877
797
878
(* Public encode API *)
798
879
799
880
let encode' ?buf:_ ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
800
-
let config = {
801
-
Emitter.default_config with
802
-
indent = Option.value ~default:2 indent;
803
-
layout_style = (match format with
804
-
| Some Flow -> `Flow
805
-
| _ -> `Block);
806
-
} in
881
+
let config =
882
+
{
883
+
Emitter.default_config with
884
+
indent = Option.value ~default:2 indent;
885
+
layout_style = (match format with Some Flow -> `Flow | _ -> `Block);
886
+
}
887
+
in
807
888
let emitter = Emitter.of_writer ~config writer in
808
889
let e = make_encoder ?format ?indent ?explicit_doc ?scalar_style emitter in
809
890
try
810
891
Emitter.emit e.emitter (Event.Stream_start { encoding = `Utf8 });
811
-
Emitter.emit e.emitter (Event.Document_start {
812
-
version = None;
813
-
implicit = not e.explicit_doc;
814
-
});
892
+
Emitter.emit e.emitter
893
+
(Event.Document_start { version = None; implicit = not e.explicit_doc });
815
894
let t' = Jsont.Repr.of_t t in
816
895
encode e t' v;
817
-
Emitter.emit e.emitter (Event.Document_end { implicit = not e.explicit_doc });
896
+
Emitter.emit e.emitter
897
+
(Event.Document_end { implicit = not e.explicit_doc });
818
898
Emitter.emit e.emitter Event.Stream_end;
819
899
if eod then Emitter.flush e.emitter;
820
900
Ok ()
···
831
911
let encode_string' ?buf ?format ?indent ?explicit_doc ?scalar_style t v =
832
912
let b = Buffer.create 256 in
833
913
let writer = Bytes.Writer.of_buffer b in
834
-
match encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod:true writer with
914
+
match
915
+
encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod:true
916
+
writer
917
+
with
835
918
| Ok () -> Ok (Buffer.contents b)
836
919
| Error e -> Error e
837
920
···
841
924
842
925
(* Recode *)
843
926
844
-
let recode ?layout ?locs ?file ?max_depth ?max_nodes
845
-
?buf ?format ?indent ?explicit_doc ?scalar_style t reader writer ~eod =
846
-
let format = match layout, format with
847
-
| Some true, None -> Some Layout
848
-
| _, f -> f
927
+
let recode ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
928
+
?explicit_doc ?scalar_style t reader writer ~eod =
929
+
let format =
930
+
match (layout, format) with Some true, None -> Some Layout | _, f -> f
849
931
in
850
-
let layout = match layout, format with
851
-
| None, Some Layout -> Some true
852
-
| l, _ -> l
932
+
let layout =
933
+
match (layout, format) with None, Some Layout -> Some true | l, _ -> l
853
934
in
854
935
match decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader with
855
-
| Ok v -> encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer
936
+
| Ok v ->
937
+
encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer
856
938
| Error e -> Error (Jsont.Error.to_string e)
857
939
858
-
let recode_string ?layout ?locs ?file ?max_depth ?max_nodes
859
-
?buf ?format ?indent ?explicit_doc ?scalar_style t s =
860
-
let format = match layout, format with
861
-
| Some true, None -> Some Layout
862
-
| _, f -> f
940
+
let recode_string ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
941
+
?explicit_doc ?scalar_style t s =
942
+
let format =
943
+
match (layout, format) with Some true, None -> Some Layout | _, f -> f
863
944
in
864
-
let layout = match layout, format with
865
-
| None, Some Layout -> Some true
866
-
| l, _ -> l
945
+
let layout =
946
+
match (layout, format) with None, Some Layout -> Some true | l, _ -> l
867
947
in
868
948
match decode_string' ?layout ?locs ?file ?max_depth ?max_nodes t s with
869
949
| Ok v -> encode_string ?buf ?format ?indent ?explicit_doc ?scalar_style t v
+149
-91
lib/yamlt.mli
+149
-91
lib/yamlt.mli
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** YAML codec using Jsont type descriptions.
7
7
8
-
This module provides YAML streaming encode/decode that interprets
9
-
{!Jsont.t} type descriptions, allowing the same codec definitions
10
-
to work for both JSON and YAML.
8
+
This module provides YAML streaming encode/decode that interprets {!Jsont.t}
9
+
type descriptions, allowing the same codec definitions to work for both JSON
10
+
and YAML.
11
11
12
12
{b Example:}
13
13
{[
14
14
(* Define a codec once using Jsont *)
15
15
module Config = struct
16
-
type t = { name: string; port: int }
16
+
type t = { name : string; port : int }
17
+
17
18
let make name port = { name; port }
19
+
18
20
let jsont =
19
21
Jsont.Object.map ~kind:"Config" make
20
22
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun c -> c.name)
···
28
30
]}
29
31
30
32
See notes about {{!yaml_mapping}YAML to JSON mapping} and
31
-
{{!yaml_scalars}YAML scalar resolution}.
32
-
*)
33
+
{{!yaml_scalars}YAML scalar resolution}. *)
33
34
34
35
open Bytesrw
35
36
36
37
(** {1:decode Decode} *)
37
38
38
39
val decode :
39
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
40
-
?max_depth:int -> ?max_nodes:int ->
41
-
'a Jsont.t -> Bytes.Reader.t -> ('a, string) result
40
+
?layout:bool ->
41
+
?locs:bool ->
42
+
?file:Jsont.Textloc.fpath ->
43
+
?max_depth:int ->
44
+
?max_nodes:int ->
45
+
'a Jsont.t ->
46
+
Bytes.Reader.t ->
47
+
('a, string) result
42
48
(** [decode t r] decodes a value from YAML reader [r] according to type [t].
43
-
{ul
44
-
{- If [layout] is [true], style information is preserved in {!Jsont.Meta.t}
45
-
values (for potential round-tripping). Defaults to [false].}
46
-
{- If [locs] is [true], source locations are preserved in {!Jsont.Meta.t}
47
-
values and error messages are precisely located. Defaults to [false].}
48
-
{- [file] is the file path for error messages.
49
-
Defaults to {!Jsont.Textloc.file_none}.}
50
-
{- [max_depth] limits nesting depth to prevent stack overflow
51
-
(billion laughs protection). Defaults to [100].}
52
-
{- [max_nodes] limits total decoded nodes
53
-
(billion laughs protection). Defaults to [10_000_000].}}
49
+
- If [layout] is [true], style information is preserved in {!Jsont.Meta.t}
50
+
values (for potential round-tripping). Defaults to [false].
51
+
- If [locs] is [true], source locations are preserved in {!Jsont.Meta.t}
52
+
values and error messages are precisely located. Defaults to [false].
53
+
- [file] is the file path for error messages. Defaults to
54
+
{!Jsont.Textloc.file_none}.
55
+
- [max_depth] limits nesting depth to prevent stack overflow (billion laughs
56
+
protection). Defaults to [100].
57
+
- [max_nodes] limits total decoded nodes (billion laughs protection).
58
+
Defaults to [10_000_000].
54
59
55
-
The YAML input must contain exactly one document. Multi-document
56
-
streams are not supported; use {!decode_all} for those. *)
60
+
The YAML input must contain exactly one document. Multi-document streams are
61
+
not supported; use {!decode_all} for those. *)
57
62
58
63
val decode' :
59
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
60
-
?max_depth:int -> ?max_nodes:int ->
61
-
'a Jsont.t -> Bytes.Reader.t -> ('a, Jsont.Error.t) result
64
+
?layout:bool ->
65
+
?locs:bool ->
66
+
?file:Jsont.Textloc.fpath ->
67
+
?max_depth:int ->
68
+
?max_nodes:int ->
69
+
'a Jsont.t ->
70
+
Bytes.Reader.t ->
71
+
('a, Jsont.Error.t) result
62
72
(** [decode'] is like {!val-decode} but preserves the error structure. *)
63
73
64
74
val decode_string :
65
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
66
-
?max_depth:int -> ?max_nodes:int ->
67
-
'a Jsont.t -> string -> ('a, string) result
75
+
?layout:bool ->
76
+
?locs:bool ->
77
+
?file:Jsont.Textloc.fpath ->
78
+
?max_depth:int ->
79
+
?max_nodes:int ->
80
+
'a Jsont.t ->
81
+
string ->
82
+
('a, string) result
68
83
(** [decode_string] is like {!val-decode} but decodes directly from a string. *)
69
84
70
85
val decode_string' :
71
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
72
-
?max_depth:int -> ?max_nodes:int ->
73
-
'a Jsont.t -> string -> ('a, Jsont.Error.t) result
74
-
(** [decode_string'] is like {!val-decode'} but decodes directly from a string. *)
86
+
?layout:bool ->
87
+
?locs:bool ->
88
+
?file:Jsont.Textloc.fpath ->
89
+
?max_depth:int ->
90
+
?max_nodes:int ->
91
+
'a Jsont.t ->
92
+
string ->
93
+
('a, Jsont.Error.t) result
94
+
(** [decode_string'] is like {!val-decode'} but decodes directly from a string.
95
+
*)
75
96
76
97
(** {1:encode Encode} *)
77
98
78
99
(** YAML output format. *)
79
100
type yaml_format =
80
-
| Block (** Block style (indented) - default. Clean, readable YAML. *)
81
-
| Flow (** Flow style (JSON-like). Compact, single-line collections. *)
101
+
| Block (** Block style (indented) - default. Clean, readable YAML. *)
102
+
| Flow (** Flow style (JSON-like). Compact, single-line collections. *)
82
103
| Layout (** Preserve layout from {!Jsont.Meta.t} when available. *)
83
104
84
105
val encode :
85
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
86
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
87
-
'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, string) result
106
+
?buf:Stdlib.Bytes.t ->
107
+
?format:yaml_format ->
108
+
?indent:int ->
109
+
?explicit_doc:bool ->
110
+
?scalar_style:Yamlrw.Scalar_style.t ->
111
+
'a Jsont.t ->
112
+
'a ->
113
+
eod:bool ->
114
+
Bytes.Writer.t ->
115
+
(unit, string) result
88
116
(** [encode t v w] encodes value [v] according to type [t] to YAML on [w].
89
-
{ul
90
-
{- If [buf] is specified, it is used as a buffer for output slices.
91
-
Defaults to a buffer of length {!Bytesrw.Bytes.Writer.slice_length}[ w].}
92
-
{- [format] controls the output style. Defaults to {!Block}.}
93
-
{- [indent] is the indentation width in spaces. Defaults to [2].}
94
-
{- [explicit_doc] if [true], emits explicit document markers
95
-
([---] and [...]). Defaults to [false].}
96
-
{- [scalar_style] is the preferred style for string scalars.
97
-
Defaults to [`Any] (auto-detect based on content).}
98
-
{- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be
99
-
written on [w] after encoding.}} *)
117
+
- If [buf] is specified, it is used as a buffer for output slices. Defaults
118
+
to a buffer of length {!Bytesrw.Bytes.Writer.slice_length}[ w].
119
+
- [format] controls the output style. Defaults to {!Block}.
120
+
- [indent] is the indentation width in spaces. Defaults to [2].
121
+
- [explicit_doc] if [true], emits explicit document markers ([---] and
122
+
[...]). Defaults to [false].
123
+
- [scalar_style] is the preferred style for string scalars. Defaults to
124
+
[`Any] (auto-detect based on content).
125
+
- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be written on
126
+
[w] after encoding. *)
100
127
101
128
val encode' :
102
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
103
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
104
-
'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t -> (unit, Jsont.Error.t) result
129
+
?buf:Stdlib.Bytes.t ->
130
+
?format:yaml_format ->
131
+
?indent:int ->
132
+
?explicit_doc:bool ->
133
+
?scalar_style:Yamlrw.Scalar_style.t ->
134
+
'a Jsont.t ->
135
+
'a ->
136
+
eod:bool ->
137
+
Bytes.Writer.t ->
138
+
(unit, Jsont.Error.t) result
105
139
(** [encode'] is like {!val-encode} but preserves the error structure. *)
106
140
107
141
val encode_string :
108
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
109
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
110
-
'a Jsont.t -> 'a -> (string, string) result
142
+
?buf:Stdlib.Bytes.t ->
143
+
?format:yaml_format ->
144
+
?indent:int ->
145
+
?explicit_doc:bool ->
146
+
?scalar_style:Yamlrw.Scalar_style.t ->
147
+
'a Jsont.t ->
148
+
'a ->
149
+
(string, string) result
111
150
(** [encode_string] is like {!val-encode} but writes to a string. *)
112
151
113
152
val encode_string' :
114
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
115
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
116
-
'a Jsont.t -> 'a -> (string, Jsont.Error.t) result
153
+
?buf:Stdlib.Bytes.t ->
154
+
?format:yaml_format ->
155
+
?indent:int ->
156
+
?explicit_doc:bool ->
157
+
?scalar_style:Yamlrw.Scalar_style.t ->
158
+
'a Jsont.t ->
159
+
'a ->
160
+
(string, Jsont.Error.t) result
117
161
(** [encode_string'] is like {!val-encode'} but writes to a string. *)
118
162
119
163
(** {1:recode Recode}
120
164
121
165
The defaults in these functions are those of {!val-decode} and
122
-
{!val-encode}, except if [layout] is [true], [format] defaults to
123
-
{!Layout} and vice-versa. *)
166
+
{!val-encode}, except if [layout] is [true], [format] defaults to {!Layout}
167
+
and vice-versa. *)
124
168
125
169
val recode :
126
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
127
-
?max_depth:int -> ?max_nodes:int ->
128
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
129
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
130
-
'a Jsont.t -> Bytes.Reader.t -> Bytes.Writer.t -> eod:bool ->
170
+
?layout:bool ->
171
+
?locs:bool ->
172
+
?file:Jsont.Textloc.fpath ->
173
+
?max_depth:int ->
174
+
?max_nodes:int ->
175
+
?buf:Stdlib.Bytes.t ->
176
+
?format:yaml_format ->
177
+
?indent:int ->
178
+
?explicit_doc:bool ->
179
+
?scalar_style:Yamlrw.Scalar_style.t ->
180
+
'a Jsont.t ->
181
+
Bytes.Reader.t ->
182
+
Bytes.Writer.t ->
183
+
eod:bool ->
131
184
(unit, string) result
132
185
(** [recode t r w] is {!val-decode} followed by {!val-encode}. *)
133
186
134
187
val recode_string :
135
-
?layout:bool -> ?locs:bool -> ?file:Jsont.Textloc.fpath ->
136
-
?max_depth:int -> ?max_nodes:int ->
137
-
?buf:Stdlib.Bytes.t -> ?format:yaml_format -> ?indent:int ->
138
-
?explicit_doc:bool -> ?scalar_style:Yamlrw.Scalar_style.t ->
139
-
'a Jsont.t -> string -> (string, string) result
188
+
?layout:bool ->
189
+
?locs:bool ->
190
+
?file:Jsont.Textloc.fpath ->
191
+
?max_depth:int ->
192
+
?max_nodes:int ->
193
+
?buf:Stdlib.Bytes.t ->
194
+
?format:yaml_format ->
195
+
?indent:int ->
196
+
?explicit_doc:bool ->
197
+
?scalar_style:Yamlrw.Scalar_style.t ->
198
+
'a Jsont.t ->
199
+
string ->
200
+
(string, string) result
140
201
(** [recode_string] is like {!val-recode} but operates on strings. *)
141
202
142
203
(** {1:yaml_mapping YAML to JSON Mapping}
143
204
144
-
YAML is a superset of JSON. This module maps YAML structures to
145
-
the JSON data model that {!Jsont.t} describes:
205
+
YAML is a superset of JSON. This module maps YAML structures to the JSON
206
+
data model that {!Jsont.t} describes:
146
207
147
-
{ul
148
-
{- YAML scalars map to JSON null, boolean, number, or string
149
-
depending on content and the expected type}
150
-
{- YAML sequences map to JSON arrays}
151
-
{- YAML mappings map to JSON objects (keys must be strings)}
152
-
{- YAML aliases are resolved during decoding}
153
-
{- YAML tags are used to guide type resolution when present}}
208
+
- YAML scalars map to JSON null, boolean, number, or string depending on
209
+
content and the expected type
210
+
- YAML sequences map to JSON arrays
211
+
- YAML mappings map to JSON objects (keys must be strings)
212
+
- YAML aliases are resolved during decoding
213
+
- YAML tags are used to guide type resolution when present
154
214
155
215
{b Limitations:}
156
-
{ul
157
-
{- Only string keys are supported in mappings (JSON object compatibility)}
158
-
{- Anchors and aliases are resolved; the alias structure is not preserved}
159
-
{- Multi-document streams require {!decode_all}}} *)
216
+
- Only string keys are supported in mappings (JSON object compatibility)
217
+
- Anchors and aliases are resolved; the alias structure is not preserved
218
+
- Multi-document streams require {!decode_all} *)
160
219
161
220
(** {1:yaml_scalars YAML Scalar Resolution}
162
221
···
164
223
165
224
{b Null:} [null], [Null], [NULL], [~], or empty string
166
225
167
-
{b Boolean:} [true], [True], [TRUE], [false], [False], [FALSE],
168
-
[yes], [Yes], [YES], [no], [No], [NO], [on], [On], [ON],
169
-
[off], [Off], [OFF]
226
+
{b Boolean:} [true], [True], [TRUE], [false], [False], [FALSE], [yes],
227
+
[Yes], [YES], [no], [No], [NO], [on], [On], [ON], [off], [Off], [OFF]
170
228
171
229
{b Number:} Decimal integers, floats, hex ([0x...]), octal ([0o...]),
172
230
infinity ([.inf], [-.inf]), NaN ([.nan])
173
231
174
232
{b String:} Anything else, or explicitly quoted scalars
175
233
176
-
When decoding against a specific {!Jsont.t} type, the expected type
177
-
takes precedence over automatic resolution. For example, decoding
178
-
["yes"] against {!Jsont.string} yields the string ["yes"], not [true]. *)
234
+
When decoding against a specific {!Jsont.t} type, the expected type takes
235
+
precedence over automatic resolution. For example, decoding ["yes"] against
236
+
{!Jsont.string} yields the string ["yes"], not [true]. *)
+4
-1
tests/bin/dune
+4
-1
tests/bin/dune
···
32
32
(name test_edge)
33
33
(public_name test_edge)
34
34
(libraries yamlt jsont jsont.bytesrw bytesrw))
35
-
(executable (name test_null_fix) (libraries yamlt jsont jsont.bytesrw bytesrw))
35
+
36
+
(executable
37
+
(name test_null_fix)
38
+
(libraries yamlt jsont jsont.bytesrw bytesrw))
36
39
37
40
(executable
38
41
(name test_null_complete)
+13
-10
tests/bin/test_array_variants.ml
+13
-10
tests/bin/test_array_variants.ml
···
1
1
let () =
2
2
let codec1 =
3
3
Jsont.Object.map ~kind:"Test" (fun arr -> arr)
4
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.string) ~enc:(fun arr -> arr)
4
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.string) ~enc:(fun arr ->
5
+
arr)
5
6
|> Jsont.Object.finish
6
7
in
7
8
···
9
10
10
11
Printf.printf "Test 1: Non-optional array:\n";
11
12
(match Yamlt.decode_string codec1 yaml1 with
12
-
| Ok arr -> Printf.printf "Result: [%d items]\n" (Array.length arr)
13
-
| Error e -> Printf.printf "Error: %s\n" e);
13
+
| Ok arr -> Printf.printf "Result: [%d items]\n" (Array.length arr)
14
+
| Error e -> Printf.printf "Error: %s\n" e);
14
15
15
16
let codec2 =
16
17
Jsont.Object.map ~kind:"Test" (fun arr -> arr)
17
-
|> Jsont.Object.mem "values" (Jsont.option (Jsont.array Jsont.string)) ~enc:(fun arr -> arr)
18
+
|> Jsont.Object.mem "values"
19
+
(Jsont.option (Jsont.array Jsont.string))
20
+
~enc:(fun arr -> arr)
18
21
|> Jsont.Object.finish
19
22
in
20
23
21
24
Printf.printf "\nTest 2: Jsont.option (Jsont.array):\n";
22
-
(match Yamlt.decode_string codec2 yaml1 with
23
-
| Ok arr ->
24
-
(match arr with
25
-
| None -> Printf.printf "Result: None\n"
26
-
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
27
-
| Error e -> Printf.printf "Error: %s\n" e)
25
+
match Yamlt.decode_string codec2 yaml1 with
26
+
| Ok arr -> (
27
+
match arr with
28
+
| None -> Printf.printf "Result: None\n"
29
+
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
30
+
| Error e -> Printf.printf "Error: %s\n" e
+74
-84
tests/bin/test_arrays.ml
+74
-84
tests/bin/test_arrays.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test array codec functionality with Yamlt *)
7
-
8
7
9
8
(* Helper to read file *)
10
9
let read_file path =
···
28
27
(* Test: Simple int array *)
29
28
let test_int_array file =
30
29
let module M = struct
31
-
type numbers = { values: int array }
30
+
type numbers = { values : int array }
32
31
33
32
let numbers_codec =
34
33
Jsont.Object.map ~kind:"Numbers" (fun values -> { values })
35
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun n -> n.values)
34
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun n ->
35
+
n.values)
36
36
|> Jsont.Object.finish
37
37
38
38
let show n =
39
-
Printf.sprintf "[%s]" (String.concat "; " (Array.to_list (Array.map string_of_int n.values)))
39
+
Printf.sprintf "[%s]"
40
+
(String.concat "; " (Array.to_list (Array.map string_of_int n.values)))
40
41
end in
41
-
42
42
let yaml = read_file file in
43
43
let json = read_file (file ^ ".json") in
44
44
let json_result = Jsont_bytesrw.decode_string M.numbers_codec json in
···
51
51
(* Test: String array *)
52
52
let test_string_array file =
53
53
let module M = struct
54
-
type tags = { items: string array }
54
+
type tags = { items : string array }
55
55
56
56
let tags_codec =
57
57
Jsont.Object.map ~kind:"Tags" (fun items -> { items })
58
-
|> Jsont.Object.mem "items" (Jsont.array Jsont.string) ~enc:(fun t -> t.items)
58
+
|> Jsont.Object.mem "items" (Jsont.array Jsont.string) ~enc:(fun t ->
59
+
t.items)
59
60
|> Jsont.Object.finish
60
61
61
62
let show t =
62
-
Printf.sprintf "[%s]" (String.concat "; " (Array.to_list (Array.map (Printf.sprintf "%S") t.items)))
63
+
Printf.sprintf "[%s]"
64
+
(String.concat "; "
65
+
(Array.to_list (Array.map (Printf.sprintf "%S") t.items)))
63
66
end in
64
-
65
67
let yaml = read_file file in
66
68
let json = read_file (file ^ ".json") in
67
69
let json_result = Jsont_bytesrw.decode_string M.tags_codec json in
···
74
76
(* Test: Float/number array *)
75
77
let test_float_array file =
76
78
let module M = struct
77
-
type measurements = { values: float array }
79
+
type measurements = { values : float array }
78
80
79
81
let measurements_codec =
80
82
Jsont.Object.map ~kind:"Measurements" (fun values -> { values })
81
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.number) ~enc:(fun m -> m.values)
83
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.number) ~enc:(fun m ->
84
+
m.values)
82
85
|> Jsont.Object.finish
83
86
84
87
let show m =
85
88
Printf.sprintf "[%s]"
86
-
(String.concat "; " (Array.to_list (Array.map (Printf.sprintf "%.2f") m.values)))
89
+
(String.concat "; "
90
+
(Array.to_list (Array.map (Printf.sprintf "%.2f") m.values)))
87
91
end in
88
-
89
92
let yaml = read_file file in
90
93
let json = read_file (file ^ ".json") in
91
94
let json_result = Jsont_bytesrw.decode_string M.measurements_codec json in
···
98
101
(* Test: Empty array *)
99
102
let test_empty_array file =
100
103
let module M = struct
101
-
type empty = { items: int array }
104
+
type empty = { items : int array }
102
105
103
106
let empty_codec =
104
107
Jsont.Object.map ~kind:"Empty" (fun items -> { items })
105
-
|> Jsont.Object.mem "items" (Jsont.array Jsont.int) ~enc:(fun e -> e.items)
108
+
|> Jsont.Object.mem "items" (Jsont.array Jsont.int) ~enc:(fun e ->
109
+
e.items)
106
110
|> Jsont.Object.finish
107
111
108
-
let show e =
109
-
Printf.sprintf "length=%d" (Stdlib.Array.length e.items)
112
+
let show e = Printf.sprintf "length=%d" (Stdlib.Array.length e.items)
110
113
end in
111
-
112
114
let yaml = read_file file in
113
115
let json = read_file (file ^ ".json") in
114
116
let json_result = Jsont_bytesrw.decode_string M.empty_codec json in
···
121
123
(* Test: Array of objects *)
122
124
let test_object_array file =
123
125
let module M = struct
124
-
type person = { name: string; age: int }
125
-
type people = { persons: person array }
126
+
type person = { name : string; age : int }
127
+
type people = { persons : person array }
126
128
127
129
let person_codec =
128
130
Jsont.Object.map ~kind:"Person" (fun name age -> { name; age })
···
132
134
133
135
let people_codec =
134
136
Jsont.Object.map ~kind:"People" (fun persons -> { persons })
135
-
|> Jsont.Object.mem "persons" (Jsont.array person_codec) ~enc:(fun p -> p.persons)
137
+
|> Jsont.Object.mem "persons" (Jsont.array person_codec) ~enc:(fun p ->
138
+
p.persons)
136
139
|> Jsont.Object.finish
137
140
138
141
let show_person p = Printf.sprintf "{%s,%d}" p.name p.age
142
+
139
143
let show ps =
140
144
Printf.sprintf "[%s]"
141
145
(String.concat "; " (Array.to_list (Array.map show_person ps.persons)))
142
146
end in
143
-
144
147
let yaml = read_file file in
145
148
let json = read_file (file ^ ".json") in
146
149
let json_result = Jsont_bytesrw.decode_string M.people_codec json in
···
153
156
(* Test: Nested arrays *)
154
157
let test_nested_arrays file =
155
158
let module M = struct
156
-
type matrix = { data: int array array }
159
+
type matrix = { data : int array array }
157
160
158
161
let matrix_codec =
159
162
Jsont.Object.map ~kind:"Matrix" (fun data -> { data })
160
-
|> Jsont.Object.mem "data" (Jsont.array (Jsont.array Jsont.int))
161
-
~enc:(fun m -> m.data)
163
+
|> Jsont.Object.mem "data"
164
+
(Jsont.array (Jsont.array Jsont.int))
165
+
~enc:(fun m -> m.data)
162
166
|> Jsont.Object.finish
163
167
164
168
let show_row row =
165
-
Printf.sprintf "[%s]" (String.concat "; " (Array.to_list (Array.map string_of_int row)))
169
+
Printf.sprintf "[%s]"
170
+
(String.concat "; " (Array.to_list (Array.map string_of_int row)))
166
171
167
172
let show m =
168
-
Printf.sprintf "[%s]" (String.concat "; " (Array.to_list (Array.map show_row m.data)))
173
+
Printf.sprintf "[%s]"
174
+
(String.concat "; " (Array.to_list (Array.map show_row m.data)))
169
175
end in
170
-
171
176
let yaml = read_file file in
172
177
let json = read_file (file ^ ".json") in
173
178
let json_result = Jsont_bytesrw.decode_string M.matrix_codec json in
···
180
185
(* Test: Mixed types in array (should fail with homogeneous codec) *)
181
186
let test_type_mismatch file =
182
187
let module M = struct
183
-
type numbers = { values: int array }
188
+
type numbers = { values : int array }
184
189
185
190
let numbers_codec =
186
191
Jsont.Object.map ~kind:"Numbers" (fun values -> { values })
187
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun n -> n.values)
192
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun n ->
193
+
n.values)
188
194
|> Jsont.Object.finish
189
195
end in
190
-
191
196
let yaml = read_file file in
192
197
let result = Yamlt.decode_string M.numbers_codec yaml in
193
198
match result with
···
197
202
(* Test: Bool array *)
198
203
let test_bool_array file =
199
204
let module M = struct
200
-
type flags = { values: bool array }
205
+
type flags = { values : bool array }
201
206
202
207
let flags_codec =
203
208
Jsont.Object.map ~kind:"Flags" (fun values -> { values })
204
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.bool) ~enc:(fun f -> f.values)
209
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.bool) ~enc:(fun f ->
210
+
f.values)
205
211
|> Jsont.Object.finish
206
212
207
213
let show f =
208
214
Printf.sprintf "[%s]"
209
215
(String.concat "; " (Array.to_list (Array.map string_of_bool f.values)))
210
216
end in
211
-
212
217
let yaml = read_file file in
213
218
let json = read_file (file ^ ".json") in
214
219
let json_result = Jsont_bytesrw.decode_string M.flags_codec json in
···
221
226
(* Test: Array with nulls *)
222
227
let test_nullable_array file =
223
228
let module M = struct
224
-
type nullable = { values: string option array }
229
+
type nullable = { values : string option array }
225
230
226
231
let nullable_codec =
227
232
Jsont.Object.map ~kind:"Nullable" (fun values -> { values })
228
-
|> Jsont.Object.mem "values" (Jsont.array (Jsont.some Jsont.string))
229
-
~enc:(fun n -> n.values)
233
+
|> Jsont.Object.mem "values"
234
+
(Jsont.array (Jsont.some Jsont.string))
235
+
~enc:(fun n -> n.values)
230
236
|> Jsont.Object.finish
231
237
232
-
let show_opt = function
233
-
| None -> "null"
234
-
| Some s -> Printf.sprintf "%S" s
238
+
let show_opt = function None -> "null" | Some s -> Printf.sprintf "%S" s
235
239
236
240
let show n =
237
-
Printf.sprintf "[%s]" (String.concat "; " (Array.to_list (Array.map show_opt n.values)))
241
+
Printf.sprintf "[%s]"
242
+
(String.concat "; " (Array.to_list (Array.map show_opt n.values)))
238
243
end in
239
-
240
244
let yaml = read_file file in
241
245
let json = read_file (file ^ ".json") in
242
246
let json_result = Jsont_bytesrw.decode_string M.nullable_codec json in
···
249
253
(* Test: Encoding arrays to different formats *)
250
254
let test_encode_arrays () =
251
255
let module M = struct
252
-
type data = { numbers: int array; strings: string array }
256
+
type data = { numbers : int array; strings : string array }
253
257
254
258
let data_codec =
255
-
Jsont.Object.map ~kind:"Data" (fun numbers strings -> { numbers; strings })
256
-
|> Jsont.Object.mem "numbers" (Jsont.array Jsont.int) ~enc:(fun d -> d.numbers)
257
-
|> Jsont.Object.mem "strings" (Jsont.array Jsont.string) ~enc:(fun d -> d.strings)
259
+
Jsont.Object.map ~kind:"Data" (fun numbers strings ->
260
+
{ numbers; strings })
261
+
|> Jsont.Object.mem "numbers" (Jsont.array Jsont.int) ~enc:(fun d ->
262
+
d.numbers)
263
+
|> Jsont.Object.mem "strings" (Jsont.array Jsont.string) ~enc:(fun d ->
264
+
d.strings)
258
265
|> Jsont.Object.finish
259
266
end in
260
-
261
-
let data = { M.numbers = [|1; 2; 3; 4; 5|]; strings = [|"hello"; "world"|] } in
267
+
let data =
268
+
{ M.numbers = [| 1; 2; 3; 4; 5 |]; strings = [| "hello"; "world" |] }
269
+
in
262
270
263
271
(* Encode to JSON *)
264
272
(match Jsont_bytesrw.encode_string M.data_codec data with
265
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
266
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
273
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
274
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
267
275
268
276
(* Encode to YAML Block *)
269
277
(match Yamlt.encode_string ~format:Yamlt.Block M.data_codec data with
270
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
271
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
278
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
279
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
272
280
273
281
(* Encode to YAML Flow *)
274
-
(match Yamlt.encode_string ~format:Yamlt.Flow M.data_codec data with
275
-
| Ok s -> Printf.printf "YAML Flow: %s" s
276
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
282
+
match Yamlt.encode_string ~format:Yamlt.Flow M.data_codec data with
283
+
| Ok s -> Printf.printf "YAML Flow: %s" s
284
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e
277
285
278
286
let () =
279
287
let usage = "Usage: test_arrays <command> [args...]" in
···
284
292
end;
285
293
286
294
match Sys.argv.(1) with
287
-
| "int" when Array.length Sys.argv = 3 ->
288
-
test_int_array Sys.argv.(2)
289
-
290
-
| "string" when Array.length Sys.argv = 3 ->
291
-
test_string_array Sys.argv.(2)
292
-
293
-
| "float" when Array.length Sys.argv = 3 ->
294
-
test_float_array Sys.argv.(2)
295
-
296
-
| "empty" when Array.length Sys.argv = 3 ->
297
-
test_empty_array Sys.argv.(2)
298
-
299
-
| "objects" when Array.length Sys.argv = 3 ->
300
-
test_object_array Sys.argv.(2)
301
-
302
-
| "nested" when Array.length Sys.argv = 3 ->
303
-
test_nested_arrays Sys.argv.(2)
304
-
295
+
| "int" when Array.length Sys.argv = 3 -> test_int_array Sys.argv.(2)
296
+
| "string" when Array.length Sys.argv = 3 -> test_string_array Sys.argv.(2)
297
+
| "float" when Array.length Sys.argv = 3 -> test_float_array Sys.argv.(2)
298
+
| "empty" when Array.length Sys.argv = 3 -> test_empty_array Sys.argv.(2)
299
+
| "objects" when Array.length Sys.argv = 3 -> test_object_array Sys.argv.(2)
300
+
| "nested" when Array.length Sys.argv = 3 -> test_nested_arrays Sys.argv.(2)
305
301
| "type-mismatch" when Array.length Sys.argv = 3 ->
306
302
test_type_mismatch Sys.argv.(2)
307
-
308
-
| "bool" when Array.length Sys.argv = 3 ->
309
-
test_bool_array Sys.argv.(2)
310
-
303
+
| "bool" when Array.length Sys.argv = 3 -> test_bool_array Sys.argv.(2)
311
304
| "nullable" when Array.length Sys.argv = 3 ->
312
305
test_nullable_array Sys.argv.(2)
313
-
314
-
| "encode" when Array.length Sys.argv = 2 ->
315
-
test_encode_arrays ()
316
-
306
+
| "encode" when Array.length Sys.argv = 2 -> test_encode_arrays ()
317
307
| _ ->
318
308
prerr_endline usage;
319
309
prerr_endline "Commands:";
+52
-41
tests/bin/test_complex.ml
+52
-41
tests/bin/test_complex.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test complex nested types with Yamlt *)
7
7
···
27
27
(* Test: Deeply nested objects *)
28
28
let test_deep_nesting file =
29
29
let module M = struct
30
-
type level3 = { value: int }
31
-
type level2 = { data: level3 }
32
-
type level1 = { nested: level2 }
33
-
type root = { top: level1 }
30
+
type level3 = { value : int }
31
+
type level2 = { data : level3 }
32
+
type level1 = { nested : level2 }
33
+
type root = { top : level1 }
34
34
35
35
let level3_codec =
36
36
Jsont.Object.map ~kind:"Level3" (fun value -> { value })
···
54
54
55
55
let show r = Printf.sprintf "depth=4, value=%d" r.top.nested.data.value
56
56
end in
57
-
58
57
let yaml = read_file file in
59
58
let json = read_file (file ^ ".json") in
60
59
let json_result = Jsont_bytesrw.decode_string M.root_codec json in
···
67
66
(* Test: Array of objects with nested arrays *)
68
67
let test_mixed_structure file =
69
68
let module M = struct
70
-
type item = { id: int; tags: string array }
71
-
type collection = { name: string; items: item array }
69
+
type item = { id : int; tags : string array }
70
+
type collection = { name : string; items : item array }
72
71
73
72
let item_codec =
74
73
Jsont.Object.map ~kind:"Item" (fun id tags -> { id; tags })
75
74
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun i -> i.id)
76
-
|> Jsont.Object.mem "tags" (Jsont.array Jsont.string) ~enc:(fun i -> i.tags)
75
+
|> Jsont.Object.mem "tags" (Jsont.array Jsont.string) ~enc:(fun i ->
76
+
i.tags)
77
77
|> Jsont.Object.finish
78
78
79
79
let collection_codec =
80
80
Jsont.Object.map ~kind:"Collection" (fun name items -> { name; items })
81
81
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun c -> c.name)
82
-
|> Jsont.Object.mem "items" (Jsont.array item_codec) ~enc:(fun c -> c.items)
82
+
|> Jsont.Object.mem "items" (Jsont.array item_codec) ~enc:(fun c ->
83
+
c.items)
83
84
|> Jsont.Object.finish
84
85
85
86
let show c =
86
-
let total_tags = Stdlib.Array.fold_left (fun acc item ->
87
-
acc + Stdlib.Array.length item.tags) 0 c.items in
88
-
Printf.sprintf "name=%S, items=%d, total_tags=%d"
89
-
c.name (Stdlib.Array.length c.items) total_tags
87
+
let total_tags =
88
+
Stdlib.Array.fold_left
89
+
(fun acc item -> acc + Stdlib.Array.length item.tags)
90
+
0 c.items
91
+
in
92
+
Printf.sprintf "name=%S, items=%d, total_tags=%d" c.name
93
+
(Stdlib.Array.length c.items)
94
+
total_tags
90
95
end in
91
-
92
96
let yaml = read_file file in
93
97
let json = read_file (file ^ ".json") in
94
98
let json_result = Jsont_bytesrw.decode_string M.collection_codec json in
···
102
106
let test_complex_optional file =
103
107
let module M = struct
104
108
type config = {
105
-
host: string;
106
-
port: int option;
107
-
ssl: bool option;
108
-
cert_path: string option;
109
-
fallback_hosts: string array option;
109
+
host : string;
110
+
port : int option;
111
+
ssl : bool option;
112
+
cert_path : string option;
113
+
fallback_hosts : string array option;
110
114
}
111
115
112
116
let config_codec =
···
116
120
|> Jsont.Object.mem "host" Jsont.string ~enc:(fun c -> c.host)
117
121
|> Jsont.Object.opt_mem "port" Jsont.int ~enc:(fun c -> c.port)
118
122
|> Jsont.Object.opt_mem "ssl" Jsont.bool ~enc:(fun c -> c.ssl)
119
-
|> Jsont.Object.opt_mem "cert_path" Jsont.string ~enc:(fun c -> c.cert_path)
123
+
|> Jsont.Object.opt_mem "cert_path" Jsont.string ~enc:(fun c ->
124
+
c.cert_path)
120
125
|> Jsont.Object.opt_mem "fallback_hosts" (Jsont.array Jsont.string)
121
-
~enc:(fun c -> c.fallback_hosts)
126
+
~enc:(fun c -> c.fallback_hosts)
122
127
|> Jsont.Object.finish
123
128
124
129
let show c =
125
-
let port_str = match c.port with None -> "None" | Some p -> string_of_int p in
126
-
let ssl_str = match c.ssl with None -> "None" | Some b -> string_of_bool b in
127
-
let fallbacks = match c.fallback_hosts with
130
+
let port_str =
131
+
match c.port with None -> "None" | Some p -> string_of_int p
132
+
in
133
+
let ssl_str =
134
+
match c.ssl with None -> "None" | Some b -> string_of_bool b
135
+
in
136
+
let fallbacks =
137
+
match c.fallback_hosts with
128
138
| None -> 0
129
-
| Some arr -> Stdlib.Array.length arr in
130
-
Printf.sprintf "host=%S, port=%s, ssl=%s, fallbacks=%d"
131
-
c.host port_str ssl_str fallbacks
139
+
| Some arr -> Stdlib.Array.length arr
140
+
in
141
+
Printf.sprintf "host=%S, port=%s, ssl=%s, fallbacks=%d" c.host port_str
142
+
ssl_str fallbacks
132
143
end in
133
-
134
144
let yaml = read_file file in
135
145
let json = read_file (file ^ ".json") in
136
146
let json_result = Jsont_bytesrw.decode_string M.config_codec json in
···
143
153
(* Test: Heterogeneous data via any type *)
144
154
let test_heterogeneous file =
145
155
let module M = struct
146
-
type data = { mixed: Jsont.json array }
156
+
type data = { mixed : Jsont.json array }
147
157
148
158
let data_codec =
149
159
Jsont.Object.map ~kind:"Data" (fun mixed -> { mixed })
150
-
|> Jsont.Object.mem "mixed" (Jsont.array (Jsont.any ())) ~enc:(fun d -> d.mixed)
160
+
|> Jsont.Object.mem "mixed"
161
+
(Jsont.array (Jsont.any ()))
162
+
~enc:(fun d -> d.mixed)
151
163
|> Jsont.Object.finish
152
164
153
165
let show d = Printf.sprintf "items=%d" (Stdlib.Array.length d.mixed)
154
166
end in
155
-
156
167
let yaml = read_file file in
157
168
let json = read_file (file ^ ".json") in
158
169
let json_result = Jsont_bytesrw.decode_string M.data_codec json in
···
173
184
match Sys.argv.(1) with
174
185
| "deep-nesting" when Stdlib.Array.length Sys.argv = 3 ->
175
186
test_deep_nesting Sys.argv.(2)
176
-
177
187
| "mixed-structure" when Stdlib.Array.length Sys.argv = 3 ->
178
188
test_mixed_structure Sys.argv.(2)
179
-
180
189
| "complex-optional" when Stdlib.Array.length Sys.argv = 3 ->
181
190
test_complex_optional Sys.argv.(2)
182
-
183
191
| "heterogeneous" when Stdlib.Array.length Sys.argv = 3 ->
184
192
test_heterogeneous Sys.argv.(2)
185
-
186
193
| _ ->
187
194
prerr_endline usage;
188
195
prerr_endline "Commands:";
189
196
prerr_endline " deep-nesting <file> - Test deeply nested objects";
190
-
prerr_endline " mixed-structure <file> - Test arrays of objects with nested arrays";
191
-
prerr_endline " complex-optional <file> - Test complex optional/nullable combinations";
192
-
prerr_endline " heterogeneous <file> - Test heterogeneous data via any type";
197
+
prerr_endline
198
+
" mixed-structure <file> - Test arrays of objects with nested arrays";
199
+
prerr_endline
200
+
" complex-optional <file> - Test complex optional/nullable \
201
+
combinations";
202
+
prerr_endline
203
+
" heterogeneous <file> - Test heterogeneous data via any type";
193
204
exit 1
+48
-44
tests/bin/test_comprehensive.ml
+48
-44
tests/bin/test_comprehensive.ml
···
6
6
|> Jsont.Object.mem "value" (Jsont.option Jsont.string) ~enc:(fun v -> v)
7
7
|> Jsont.Object.finish
8
8
in
9
-
9
+
10
10
(match Yamlt.decode_string opt_codec "value: null" with
11
-
| Ok None -> Printf.printf "✓ Plain 'null' with option codec: None\n"
12
-
| _ -> Printf.printf "✗ FAIL\n");
13
-
11
+
| Ok None -> Printf.printf "✓ Plain 'null' with option codec: None\n"
12
+
| _ -> Printf.printf "✗ FAIL\n");
13
+
14
14
(match Yamlt.decode_string opt_codec "value: hello" with
15
-
| Ok (Some "hello") -> Printf.printf "✓ Plain 'hello' with option codec: Some(hello)\n"
16
-
| _ -> Printf.printf "✗ FAIL\n");
17
-
15
+
| Ok (Some "hello") ->
16
+
Printf.printf "✓ Plain 'hello' with option codec: Some(hello)\n"
17
+
| _ -> Printf.printf "✗ FAIL\n");
18
+
18
19
let string_codec =
19
20
Jsont.Object.map ~kind:"Test" (fun v -> v)
20
21
|> Jsont.Object.mem "value" Jsont.string ~enc:(fun v -> v)
21
22
|> Jsont.Object.finish
22
23
in
23
-
24
+
24
25
(match Yamlt.decode_string string_codec "value: null" with
25
-
| Error _ -> Printf.printf "✓ Plain 'null' with string codec: ERROR (expected)\n"
26
-
| _ -> Printf.printf "✗ FAIL\n");
27
-
26
+
| Error _ ->
27
+
Printf.printf "✓ Plain 'null' with string codec: ERROR (expected)\n"
28
+
| _ -> Printf.printf "✗ FAIL\n");
29
+
28
30
(match Yamlt.decode_string string_codec "value: \"\"" with
29
-
| Ok "" -> Printf.printf "✓ Quoted empty string: \"\"\n"
30
-
| _ -> Printf.printf "✗ FAIL\n");
31
-
31
+
| Ok "" -> Printf.printf "✓ Quoted empty string: \"\"\n"
32
+
| _ -> Printf.printf "✗ FAIL\n");
33
+
32
34
(match Yamlt.decode_string string_codec "value: \"null\"" with
33
-
| Ok "null" -> Printf.printf "✓ Quoted 'null': \"null\"\n"
34
-
| _ -> Printf.printf "✗ FAIL\n");
35
-
35
+
| Ok "null" -> Printf.printf "✓ Quoted 'null': \"null\"\n"
36
+
| _ -> Printf.printf "✗ FAIL\n");
37
+
36
38
(* Test 2: Number formats *)
37
39
Printf.printf "\n=== NUMBER FORMATS ===\n";
38
40
let num_codec =
···
40
42
|> Jsont.Object.mem "value" Jsont.number ~enc:(fun v -> v)
41
43
|> Jsont.Object.finish
42
44
in
43
-
45
+
44
46
(match Yamlt.decode_string num_codec "value: 0xFF" with
45
-
| Ok 255. -> Printf.printf "✓ Hex 0xFF: 255\n"
46
-
| _ -> Printf.printf "✗ FAIL\n");
47
-
47
+
| Ok 255. -> Printf.printf "✓ Hex 0xFF: 255\n"
48
+
| _ -> Printf.printf "✗ FAIL\n");
49
+
48
50
(match Yamlt.decode_string num_codec "value: 0o77" with
49
-
| Ok 63. -> Printf.printf "✓ Octal 0o77: 63\n"
50
-
| _ -> Printf.printf "✗ FAIL\n");
51
-
51
+
| Ok 63. -> Printf.printf "✓ Octal 0o77: 63\n"
52
+
| _ -> Printf.printf "✗ FAIL\n");
53
+
52
54
(match Yamlt.decode_string num_codec "value: 0b1010" with
53
-
| Ok 10. -> Printf.printf "✓ Binary 0b1010: 10\n"
54
-
| _ -> Printf.printf "✗ FAIL\n");
55
-
55
+
| Ok 10. -> Printf.printf "✓ Binary 0b1010: 10\n"
56
+
| _ -> Printf.printf "✗ FAIL\n");
57
+
56
58
(* Test 3: Optional arrays *)
57
59
Printf.printf "\n=== OPTIONAL ARRAYS ===\n";
58
60
let opt_array_codec =
59
61
Jsont.Object.map ~kind:"Test" (fun v -> v)
60
-
|> Jsont.Object.opt_mem "values" (Jsont.array Jsont.string) ~enc:(fun v -> v)
62
+
|> Jsont.Object.opt_mem "values" (Jsont.array Jsont.string) ~enc:(fun v ->
63
+
v)
61
64
|> Jsont.Object.finish
62
65
in
63
-
66
+
64
67
(match Yamlt.decode_string opt_array_codec "values: [a, b, c]" with
65
-
| Ok (Some arr) when Array.length arr = 3 ->
66
-
Printf.printf "✓ Optional array [a, b, c]: Some([3 items])\n"
67
-
| _ -> Printf.printf "✗ FAIL\n");
68
-
68
+
| Ok (Some arr) when Array.length arr = 3 ->
69
+
Printf.printf "✓ Optional array [a, b, c]: Some([3 items])\n"
70
+
| _ -> Printf.printf "✗ FAIL\n");
71
+
69
72
(match Yamlt.decode_string opt_array_codec "{}" with
70
-
| Ok None -> Printf.printf "✓ Missing optional array: None\n"
71
-
| _ -> Printf.printf "✗ FAIL\n");
72
-
73
+
| Ok None -> Printf.printf "✓ Missing optional array: None\n"
74
+
| _ -> Printf.printf "✗ FAIL\n");
75
+
73
76
(* Test 4: Flow encoding *)
74
77
Printf.printf "\n=== FLOW ENCODING ===\n";
75
78
let encode_codec =
···
78
81
|> Jsont.Object.mem "values" (Jsont.array Jsont.number) ~enc:snd
79
82
|> Jsont.Object.finish
80
83
in
81
-
82
-
(match Yamlt.encode_string ~format:Flow encode_codec ("test", [|1.; 2.; 3.|]) with
83
-
| Ok yaml_flow when String.equal yaml_flow "{name: test, values: [1.0, 2.0, 3.0]}\n" ->
84
-
Printf.printf "✓ Flow encoding with comma separator\n"
85
-
| Ok yaml_flow ->
86
-
Printf.printf "✗ FAIL: %S\n" yaml_flow
87
-
| Error e ->
88
-
Printf.printf "✗ ERROR: %s\n" e)
84
+
85
+
match
86
+
Yamlt.encode_string ~format:Flow encode_codec ("test", [| 1.; 2.; 3. |])
87
+
with
88
+
| Ok yaml_flow
89
+
when String.equal yaml_flow "{name: test, values: [1.0, 2.0, 3.0]}\n" ->
90
+
Printf.printf "✓ Flow encoding with comma separator\n"
91
+
| Ok yaml_flow -> Printf.printf "✗ FAIL: %S\n" yaml_flow
92
+
| Error e -> Printf.printf "✗ ERROR: %s\n" e
+32
-32
tests/bin/test_edge.ml
+32
-32
tests/bin/test_edge.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test edge cases with Yamlt *)
7
7
···
27
27
(* Test: Very large numbers *)
28
28
let test_large_numbers file =
29
29
let module M = struct
30
-
type numbers = { large_int: float; large_float: float; small_float: float }
30
+
type numbers = {
31
+
large_int : float;
32
+
large_float : float;
33
+
small_float : float;
34
+
}
31
35
32
36
let numbers_codec =
33
37
Jsont.Object.map ~kind:"Numbers" (fun large_int large_float small_float ->
34
-
{ large_int; large_float; small_float })
38
+
{ large_int; large_float; small_float })
35
39
|> Jsont.Object.mem "large_int" Jsont.number ~enc:(fun n -> n.large_int)
36
-
|> Jsont.Object.mem "large_float" Jsont.number ~enc:(fun n -> n.large_float)
37
-
|> Jsont.Object.mem "small_float" Jsont.number ~enc:(fun n -> n.small_float)
40
+
|> Jsont.Object.mem "large_float" Jsont.number ~enc:(fun n ->
41
+
n.large_float)
42
+
|> Jsont.Object.mem "small_float" Jsont.number ~enc:(fun n ->
43
+
n.small_float)
38
44
|> Jsont.Object.finish
39
45
40
46
let show n =
41
47
Printf.sprintf "large_int=%.0f, large_float=%e, small_float=%e"
42
48
n.large_int n.large_float n.small_float
43
49
end in
44
-
45
50
let yaml = read_file file in
46
51
let json = read_file (file ^ ".json") in
47
52
let json_result = Jsont_bytesrw.decode_string M.numbers_codec json in
···
54
59
(* Test: Special characters in strings *)
55
60
let test_special_chars file =
56
61
let module M = struct
57
-
type text = { content: string }
62
+
type text = { content : string }
58
63
59
64
let text_codec =
60
65
Jsont.Object.map ~kind:"Text" (fun content -> { content })
···
67
72
(String.contains t.content '\n')
68
73
(String.contains t.content '\t')
69
74
end in
70
-
71
75
let yaml = read_file file in
72
76
let json = read_file (file ^ ".json") in
73
77
let json_result = Jsont_bytesrw.decode_string M.text_codec json in
···
80
84
(* Test: Unicode strings *)
81
85
let test_unicode file =
82
86
let module M = struct
83
-
type text = { emoji: string; chinese: string; rtl: string }
87
+
type text = { emoji : string; chinese : string; rtl : string }
84
88
85
89
let text_codec =
86
-
Jsont.Object.map ~kind:"Text" (fun emoji chinese rtl -> { emoji; chinese; rtl })
90
+
Jsont.Object.map ~kind:"Text" (fun emoji chinese rtl ->
91
+
{ emoji; chinese; rtl })
87
92
|> Jsont.Object.mem "emoji" Jsont.string ~enc:(fun t -> t.emoji)
88
93
|> Jsont.Object.mem "chinese" Jsont.string ~enc:(fun t -> t.chinese)
89
94
|> Jsont.Object.mem "rtl" Jsont.string ~enc:(fun t -> t.rtl)
···
92
97
let show t =
93
98
Printf.sprintf "emoji=%S, chinese=%S, rtl=%S" t.emoji t.chinese t.rtl
94
99
end in
95
-
96
100
let yaml = read_file file in
97
101
let json = read_file (file ^ ".json") in
98
102
let json_result = Jsont_bytesrw.decode_string M.text_codec json in
···
105
109
(* Test: Empty collections *)
106
110
let test_empty_collections file =
107
111
let module M = struct
108
-
type data = { empty_array: int array; empty_object_array: unit array }
112
+
type data = { empty_array : int array; empty_object_array : unit array }
109
113
110
114
let data_codec =
111
115
Jsont.Object.map ~kind:"Data" (fun empty_array empty_object_array ->
112
-
{ empty_array; empty_object_array })
113
-
|> Jsont.Object.mem "empty_array" (Jsont.array Jsont.int) ~enc:(fun d -> d.empty_array)
114
-
|> Jsont.Object.mem "empty_object_array" (Jsont.array (Jsont.null ())) ~enc:(fun d -> d.empty_object_array)
116
+
{ empty_array; empty_object_array })
117
+
|> Jsont.Object.mem "empty_array" (Jsont.array Jsont.int) ~enc:(fun d ->
118
+
d.empty_array)
119
+
|> Jsont.Object.mem "empty_object_array"
120
+
(Jsont.array (Jsont.null ()))
121
+
~enc:(fun d -> d.empty_object_array)
115
122
|> Jsont.Object.finish
116
123
117
124
let show d =
···
119
126
(Stdlib.Array.length d.empty_array)
120
127
(Stdlib.Array.length d.empty_object_array)
121
128
end in
122
-
123
129
let yaml = read_file file in
124
130
let json = read_file (file ^ ".json") in
125
131
let json_result = Jsont_bytesrw.decode_string M.data_codec json in
···
138
144
| Ok _ -> "not_object"
139
145
| Error _ -> "decode_error"
140
146
end in
141
-
142
147
let yaml = read_file file in
143
148
let json = read_file (file ^ ".json") in
144
149
let json_result = Jsont_bytesrw.decode_string (Jsont.any ()) json in
···
151
156
(* Test: Single-element arrays *)
152
157
let test_single_element file =
153
158
let module M = struct
154
-
type data = { single: int array }
159
+
type data = { single : int array }
155
160
156
161
let data_codec =
157
162
Jsont.Object.map ~kind:"Data" (fun single -> { single })
158
-
|> Jsont.Object.mem "single" (Jsont.array Jsont.int) ~enc:(fun d -> d.single)
163
+
|> Jsont.Object.mem "single" (Jsont.array Jsont.int) ~enc:(fun d ->
164
+
d.single)
159
165
|> Jsont.Object.finish
160
166
161
167
let show d =
···
163
169
(Stdlib.Array.length d.single)
164
170
(if Stdlib.Array.length d.single > 0 then d.single.(0) else 0)
165
171
end in
166
-
167
172
let yaml = read_file file in
168
173
let json = read_file (file ^ ".json") in
169
174
let json_result = Jsont_bytesrw.decode_string M.data_codec json in
···
184
189
match Sys.argv.(1) with
185
190
| "large-numbers" when Stdlib.Array.length Sys.argv = 3 ->
186
191
test_large_numbers Sys.argv.(2)
187
-
188
192
| "special-chars" when Stdlib.Array.length Sys.argv = 3 ->
189
193
test_special_chars Sys.argv.(2)
190
-
191
-
| "unicode" when Stdlib.Array.length Sys.argv = 3 ->
192
-
test_unicode Sys.argv.(2)
193
-
194
+
| "unicode" when Stdlib.Array.length Sys.argv = 3 -> test_unicode Sys.argv.(2)
194
195
| "empty-collections" when Stdlib.Array.length Sys.argv = 3 ->
195
196
test_empty_collections Sys.argv.(2)
196
-
197
197
| "special-keys" when Stdlib.Array.length Sys.argv = 3 ->
198
198
test_special_keys Sys.argv.(2)
199
-
200
199
| "single-element" when Stdlib.Array.length Sys.argv = 3 ->
201
200
test_single_element Sys.argv.(2)
202
-
203
201
| _ ->
204
202
prerr_endline usage;
205
203
prerr_endline "Commands:";
206
204
prerr_endline " large-numbers <file> - Test very large numbers";
207
-
prerr_endline " special-chars <file> - Test special characters in strings";
205
+
prerr_endline
206
+
" special-chars <file> - Test special characters in strings";
208
207
prerr_endline " unicode <file> - Test Unicode strings";
209
208
prerr_endline " empty-collections <file> - Test empty collections";
210
-
prerr_endline " special-keys <file> - Test special characters in keys";
209
+
prerr_endline
210
+
" special-keys <file> - Test special characters in keys";
211
211
prerr_endline " single-element <file> - Test single-element arrays";
212
212
exit 1
+4
-2
tests/bin/test_flow_newline.ml
+4
-2
tests/bin/test_flow_newline.ml
···
5
5
|> Jsont.Object.mem "values" (Jsont.array Jsont.number) ~enc:snd
6
6
|> Jsont.Object.finish
7
7
in
8
-
9
-
match Yamlt.encode_string ~format:Flow encode_codec ("test", [|1.; 2.; 3.|]) with
8
+
9
+
match
10
+
Yamlt.encode_string ~format:Flow encode_codec ("test", [| 1.; 2.; 3. |])
11
+
with
10
12
| Ok yaml_flow ->
11
13
Printf.printf "Length: %d\n" (String.length yaml_flow);
12
14
Printf.printf "Repr: %S\n" yaml_flow;
+40
-52
tests/bin/test_formats.ml
+40
-52
tests/bin/test_formats.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test format-specific features with Yamlt *)
7
7
···
27
27
(* Test: Multi-line strings - literal style *)
28
28
let test_literal_string file =
29
29
let module M = struct
30
-
type text = { content: string }
30
+
type text = { content : string }
31
31
32
32
let text_codec =
33
33
Jsont.Object.map ~kind:"Text" (fun content -> { content })
···
39
39
(List.length (String.split_on_char '\n' t.content))
40
40
(String.length t.content)
41
41
end in
42
-
43
42
let yaml = read_file file in
44
43
let json = read_file (file ^ ".json") in
45
44
let json_result = Jsont_bytesrw.decode_string M.text_codec json in
···
52
51
(* Test: Multi-line strings - folded style *)
53
52
let test_folded_string file =
54
53
let module M = struct
55
-
type text = { content: string }
54
+
type text = { content : string }
56
55
57
56
let text_codec =
58
57
Jsont.Object.map ~kind:"Text" (fun content -> { content })
···
60
59
|> Jsont.Object.finish
61
60
62
61
let show t =
63
-
Printf.sprintf "length=%d, newlines=%d"
64
-
(String.length t.content)
65
-
(List.length (List.filter (fun c -> c = '\n')
66
-
(List.init (String.length t.content) (String.get t.content))))
62
+
Printf.sprintf "length=%d, newlines=%d" (String.length t.content)
63
+
(List.length
64
+
(List.filter
65
+
(fun c -> c = '\n')
66
+
(List.init (String.length t.content) (String.get t.content))))
67
67
end in
68
-
69
68
let yaml = read_file file in
70
69
let json = read_file (file ^ ".json") in
71
70
let json_result = Jsont_bytesrw.decode_string M.text_codec json in
···
78
77
(* Test: Number formats - hex, octal, binary *)
79
78
let test_number_formats file =
80
79
let module M = struct
81
-
type numbers = { hex: float; octal: float; binary: float }
80
+
type numbers = { hex : float; octal : float; binary : float }
82
81
83
82
let numbers_codec =
84
-
Jsont.Object.map ~kind:"Numbers" (fun hex octal binary -> { hex; octal; binary })
83
+
Jsont.Object.map ~kind:"Numbers" (fun hex octal binary ->
84
+
{ hex; octal; binary })
85
85
|> Jsont.Object.mem "hex" Jsont.number ~enc:(fun n -> n.hex)
86
86
|> Jsont.Object.mem "octal" Jsont.number ~enc:(fun n -> n.octal)
87
87
|> Jsont.Object.mem "binary" Jsont.number ~enc:(fun n -> n.binary)
···
90
90
let show n =
91
91
Printf.sprintf "hex=%.0f, octal=%.0f, binary=%.0f" n.hex n.octal n.binary
92
92
end in
93
-
94
93
let yaml = read_file file in
95
94
let json = read_file (file ^ ".json") in
96
95
let json_result = Jsont_bytesrw.decode_string M.numbers_codec json in
···
103
102
(* Test: Block vs Flow style encoding *)
104
103
let test_encode_styles () =
105
104
let module M = struct
106
-
type data = {
107
-
name: string;
108
-
values: int array;
109
-
nested: nested_data;
110
-
}
111
-
and nested_data = {
112
-
enabled: bool;
113
-
count: int;
114
-
}
105
+
type data = { name : string; values : int array; nested : nested_data }
106
+
and nested_data = { enabled : bool; count : int }
115
107
116
108
let nested_codec =
117
109
Jsont.Object.map ~kind:"Nested" (fun enabled count -> { enabled; count })
···
120
112
|> Jsont.Object.finish
121
113
122
114
let data_codec =
123
-
Jsont.Object.map ~kind:"Data" (fun name values nested -> { name; values; nested })
115
+
Jsont.Object.map ~kind:"Data" (fun name values nested ->
116
+
{ name; values; nested })
124
117
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun d -> d.name)
125
-
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun d -> d.values)
118
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun d ->
119
+
d.values)
126
120
|> Jsont.Object.mem "nested" nested_codec ~enc:(fun d -> d.nested)
127
121
|> Jsont.Object.finish
128
122
end in
129
-
130
-
let data = {
131
-
M.name = "test";
132
-
values = [|1; 2; 3|];
133
-
nested = { enabled = true; count = 5 };
134
-
} in
123
+
let data =
124
+
{
125
+
M.name = "test";
126
+
values = [| 1; 2; 3 |];
127
+
nested = { enabled = true; count = 5 };
128
+
}
129
+
in
135
130
136
131
(* Encode to YAML Block style *)
137
132
(match Yamlt.encode_string ~format:Yamlt.Block M.data_codec data with
138
-
| Ok s -> Printf.printf "YAML Block:\n%s\n" s
139
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
133
+
| Ok s -> Printf.printf "YAML Block:\n%s\n" s
134
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
140
135
141
136
(* Encode to YAML Flow style *)
142
-
(match Yamlt.encode_string ~format:Yamlt.Flow M.data_codec data with
143
-
| Ok s -> Printf.printf "YAML Flow:\n%s\n" s
144
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
137
+
match Yamlt.encode_string ~format:Yamlt.Flow M.data_codec data with
138
+
| Ok s -> Printf.printf "YAML Flow:\n%s\n" s
139
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e
145
140
146
141
(* Test: Comments in YAML (should be ignored) *)
147
142
let test_comments file =
148
143
let module M = struct
149
-
type config = { host: string; port: int; debug: bool }
144
+
type config = { host : string; port : int; debug : bool }
150
145
151
146
let config_codec =
152
-
Jsont.Object.map ~kind:"Config" (fun host port debug -> { host; port; debug })
147
+
Jsont.Object.map ~kind:"Config" (fun host port debug ->
148
+
{ host; port; debug })
153
149
|> Jsont.Object.mem "host" Jsont.string ~enc:(fun c -> c.host)
154
150
|> Jsont.Object.mem "port" Jsont.int ~enc:(fun c -> c.port)
155
151
|> Jsont.Object.mem "debug" Jsont.bool ~enc:(fun c -> c.debug)
···
158
154
let show c =
159
155
Printf.sprintf "host=%S, port=%d, debug=%b" c.host c.port c.debug
160
156
end in
161
-
162
157
let yaml = read_file file in
163
158
let yaml_result = Yamlt.decode_string M.config_codec yaml in
164
159
···
169
164
(* Test: Empty documents and null documents *)
170
165
let test_empty_document file =
171
166
let module M = struct
172
-
type wrapper = { value: string option }
167
+
type wrapper = { value : string option }
173
168
174
169
let wrapper_codec =
175
170
Jsont.Object.map ~kind:"Wrapper" (fun value -> { value })
176
-
|> Jsont.Object.mem "value" (Jsont.some Jsont.string) ~enc:(fun w -> w.value)
171
+
|> Jsont.Object.mem "value" (Jsont.some Jsont.string) ~enc:(fun w ->
172
+
w.value)
177
173
|> Jsont.Object.finish
178
174
179
175
let show w =
···
181
177
| None -> "value=None"
182
178
| Some s -> Printf.sprintf "value=Some(%S)" s
183
179
end in
184
-
185
180
let yaml = read_file file in
186
181
let json = read_file (file ^ ".json") in
187
182
let json_result = Jsont_bytesrw.decode_string M.wrapper_codec json in
···
194
189
(* Test: Explicit typing with tags (if supported) *)
195
190
let test_explicit_tags file =
196
191
let module M = struct
197
-
type value_holder = { data: string }
192
+
type value_holder = { data : string }
198
193
199
194
let value_codec =
200
195
Jsont.Object.map ~kind:"ValueHolder" (fun data -> { data })
···
203
198
204
199
let show v = Printf.sprintf "data=%S" v.data
205
200
end in
206
-
207
201
let yaml = read_file file in
208
202
let yaml_result = Yamlt.decode_string M.value_codec yaml in
209
203
···
222
216
match Sys.argv.(1) with
223
217
| "literal" when Stdlib.Array.length Sys.argv = 3 ->
224
218
test_literal_string Sys.argv.(2)
225
-
226
219
| "folded" when Stdlib.Array.length Sys.argv = 3 ->
227
220
test_folded_string Sys.argv.(2)
228
-
229
221
| "number-formats" when Stdlib.Array.length Sys.argv = 3 ->
230
222
test_number_formats Sys.argv.(2)
231
-
232
223
| "encode-styles" when Stdlib.Array.length Sys.argv = 2 ->
233
224
test_encode_styles ()
234
-
235
225
| "comments" when Stdlib.Array.length Sys.argv = 3 ->
236
226
test_comments Sys.argv.(2)
237
-
238
227
| "empty-doc" when Stdlib.Array.length Sys.argv = 3 ->
239
228
test_empty_document Sys.argv.(2)
240
-
241
229
| "explicit-tags" when Stdlib.Array.length Sys.argv = 3 ->
242
230
test_explicit_tags Sys.argv.(2)
243
-
244
231
| _ ->
245
232
prerr_endline usage;
246
233
prerr_endline "Commands:";
247
234
prerr_endline " literal <file> - Test literal multi-line strings";
248
235
prerr_endline " folded <file> - Test folded multi-line strings";
249
-
prerr_endline " number-formats <file> - Test hex/octal/binary number formats";
236
+
prerr_endline
237
+
" number-formats <file> - Test hex/octal/binary number formats";
250
238
prerr_endline " encode-styles - Test block vs flow encoding";
251
239
prerr_endline " comments <file> - Test YAML with comments";
252
240
prerr_endline " empty-doc <file> - Test empty documents";
+65
-61
tests/bin/test_locations.ml
+65
-61
tests/bin/test_locations.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test location and layout preservation options with Yamlt codec *)
7
7
···
44
44
45
45
(* Nested object codec *)
46
46
let address_codec =
47
-
Jsont.Object.map ~kind:"Address" (fun street city zip -> (street, city, zip))
48
-
|> Jsont.Object.mem "street" Jsont.string ~enc:(fun (s,_,_) -> s)
49
-
|> Jsont.Object.mem "city" Jsont.string ~enc:(fun (_,c,_) -> c)
50
-
|> Jsont.Object.mem "zip" Jsont.int ~enc:(fun (_,_,z) -> z)
47
+
Jsont.Object.map ~kind:"Address" (fun street city zip ->
48
+
(street, city, zip))
49
+
|> Jsont.Object.mem "street" Jsont.string ~enc:(fun (s, _, _) -> s)
50
+
|> Jsont.Object.mem "city" Jsont.string ~enc:(fun (_, c, _) -> c)
51
+
|> Jsont.Object.mem "zip" Jsont.int ~enc:(fun (_, _, z) -> z)
51
52
|> Jsont.Object.finish
52
53
in
53
54
···
98
99
99
100
Printf.printf "=== Without layout (default) ===\n";
100
101
(match Yamlt.decode_string ~layout:false codec yaml with
101
-
| Ok (host, port) ->
102
-
Printf.printf "Decoded: host=%s, port=%d\n" host port;
103
-
Printf.printf "Meta preserved: no\n"
104
-
| Error e -> Printf.printf "Error: %s\n" e);
102
+
| Ok (host, port) ->
103
+
Printf.printf "Decoded: host=%s, port=%d\n" host port;
104
+
Printf.printf "Meta preserved: no\n"
105
+
| Error e -> Printf.printf "Error: %s\n" e);
105
106
106
107
Printf.printf "\n=== With layout=true ===\n";
107
-
(match Yamlt.decode_string ~layout:true codec yaml with
108
-
| Ok (host, port) ->
109
-
Printf.printf "Decoded: host=%s, port=%d\n" host port;
110
-
Printf.printf "Meta preserved: yes (style info available for round-tripping)\n"
111
-
| Error e -> Printf.printf "Error: %s\n" e)
108
+
match Yamlt.decode_string ~layout:true codec yaml with
109
+
| Ok (host, port) ->
110
+
Printf.printf "Decoded: host=%s, port=%d\n" host port;
111
+
Printf.printf
112
+
"Meta preserved: yes (style info available for round-tripping)\n"
113
+
| Error e -> Printf.printf "Error: %s\n" e
112
114
113
115
(* Test: Round-trip with layout preservation *)
114
116
let test_roundtrip_layout file =
···
125
127
126
128
Printf.printf "\n=== Decode without layout, re-encode ===\n";
127
129
(match Yamlt.decode_string ~layout:false codec yaml with
128
-
| Ok items ->
129
-
(match Yamlt.encode_string ~format:Yamlt.Block codec items with
130
-
| Ok yaml_out -> Printf.printf "%s" yaml_out
131
-
| Error e -> Printf.printf "Encode error: %s\n" e)
132
-
| Error e -> Printf.printf "Decode error: %s\n" e);
130
+
| Ok items -> (
131
+
match Yamlt.encode_string ~format:Yamlt.Block codec items with
132
+
| Ok yaml_out -> Printf.printf "%s" yaml_out
133
+
| Error e -> Printf.printf "Encode error: %s\n" e)
134
+
| Error e -> Printf.printf "Decode error: %s\n" e);
133
135
134
-
Printf.printf "\n=== Decode with layout=true, re-encode with Layout format ===\n";
135
-
(match Yamlt.decode_string ~layout:true codec yaml with
136
-
| Ok items ->
137
-
(match Yamlt.encode_string ~format:Yamlt.Layout codec items with
138
-
| Ok yaml_out -> Printf.printf "%s" yaml_out
139
-
| Error e -> Printf.printf "Encode error: %s\n" e)
140
-
| Error e -> Printf.printf "Decode error: %s\n" e)
136
+
Printf.printf
137
+
"\n=== Decode with layout=true, re-encode with Layout format ===\n";
138
+
match Yamlt.decode_string ~layout:true codec yaml with
139
+
| Ok items -> (
140
+
match Yamlt.encode_string ~format:Yamlt.Layout codec items with
141
+
| Ok yaml_out -> Printf.printf "%s" yaml_out
142
+
| Error e -> Printf.printf "Encode error: %s\n" e)
143
+
| Error e -> Printf.printf "Decode error: %s\n" e
141
144
142
145
(* Test: File path in error messages *)
143
146
let test_file_path () =
···
164
167
165
168
let codec =
166
169
Jsont.Object.map ~kind:"Complete" (fun a b c -> (a, b, c))
167
-
|> Jsont.Object.mem "field_a" Jsont.string ~enc:(fun (a,_,_) -> a)
168
-
|> Jsont.Object.mem "field_b" Jsont.int ~enc:(fun (_,b,_) -> b)
169
-
|> Jsont.Object.mem "field_c" Jsont.bool ~enc:(fun (_,_,c) -> c)
170
+
|> Jsont.Object.mem "field_a" Jsont.string ~enc:(fun (a, _, _) -> a)
171
+
|> Jsont.Object.mem "field_b" Jsont.int ~enc:(fun (_, b, _) -> b)
172
+
|> Jsont.Object.mem "field_c" Jsont.bool ~enc:(fun (_, _, c) -> c)
170
173
|> Jsont.Object.finish
171
174
in
172
175
···
183
186
let yaml = read_file file in
184
187
185
188
let codec =
186
-
Jsont.Object.map ~kind:"Settings" (fun timeout retries -> (timeout, retries))
189
+
Jsont.Object.map ~kind:"Settings" (fun timeout retries ->
190
+
(timeout, retries))
187
191
|> Jsont.Object.mem "timeout" Jsont.int ~enc:fst
188
192
|> Jsont.Object.mem "retries" Jsont.int ~enc:snd
189
193
|> Jsont.Object.finish
···
191
195
192
196
Printf.printf "=== locs=false, layout=false (defaults) ===\n";
193
197
(match Yamlt.decode_string ~locs:false ~layout:false codec yaml with
194
-
| Ok (timeout, retries) ->
195
-
Printf.printf "OK: timeout=%d, retries=%d\n" timeout retries
196
-
| Error e -> Printf.printf "Error: %s\n" e);
198
+
| Ok (timeout, retries) ->
199
+
Printf.printf "OK: timeout=%d, retries=%d\n" timeout retries
200
+
| Error e -> Printf.printf "Error: %s\n" e);
197
201
198
202
Printf.printf "\n=== locs=true, layout=false ===\n";
199
203
(match Yamlt.decode_string ~locs:true ~layout:false codec yaml with
200
-
| Ok (timeout, retries) ->
201
-
Printf.printf "OK: timeout=%d, retries=%d (with precise locations)\n" timeout retries
202
-
| Error e -> Printf.printf "Error: %s\n" e);
204
+
| Ok (timeout, retries) ->
205
+
Printf.printf "OK: timeout=%d, retries=%d (with precise locations)\n"
206
+
timeout retries
207
+
| Error e -> Printf.printf "Error: %s\n" e);
203
208
204
209
Printf.printf "\n=== locs=false, layout=true ===\n";
205
210
(match Yamlt.decode_string ~locs:false ~layout:true codec yaml with
206
-
| Ok (timeout, retries) ->
207
-
Printf.printf "OK: timeout=%d, retries=%d (with layout metadata)\n" timeout retries
208
-
| Error e -> Printf.printf "Error: %s\n" e);
211
+
| Ok (timeout, retries) ->
212
+
Printf.printf "OK: timeout=%d, retries=%d (with layout metadata)\n"
213
+
timeout retries
214
+
| Error e -> Printf.printf "Error: %s\n" e);
209
215
210
216
Printf.printf "\n=== locs=true, layout=true (both enabled) ===\n";
211
-
(match Yamlt.decode_string ~locs:true ~layout:true codec yaml with
212
-
| Ok (timeout, retries) ->
213
-
Printf.printf "OK: timeout=%d, retries=%d (with locations and layout)\n" timeout retries
214
-
| Error e -> Printf.printf "Error: %s\n" e)
217
+
match Yamlt.decode_string ~locs:true ~layout:true codec yaml with
218
+
| Ok (timeout, retries) ->
219
+
Printf.printf "OK: timeout=%d, retries=%d (with locations and layout)\n"
220
+
timeout retries
221
+
| Error e -> Printf.printf "Error: %s\n" e
215
222
216
223
let () =
217
224
let usage = "Usage: test_locations <command> [args...]" in
···
224
231
match Sys.argv.(1) with
225
232
| "error-precision" when Array.length Sys.argv = 3 ->
226
233
test_error_precision Sys.argv.(2)
227
-
228
234
| "nested-error" when Array.length Sys.argv = 3 ->
229
235
test_nested_error Sys.argv.(2)
230
-
231
236
| "array-error" when Array.length Sys.argv = 3 ->
232
237
test_array_error Sys.argv.(2)
233
-
234
238
| "layout" when Array.length Sys.argv = 3 ->
235
239
test_layout_preservation Sys.argv.(2)
236
-
237
240
| "roundtrip" when Array.length Sys.argv = 3 ->
238
241
test_roundtrip_layout Sys.argv.(2)
239
-
240
-
| "file-path" ->
241
-
test_file_path ()
242
-
242
+
| "file-path" -> test_file_path ()
243
243
| "missing-field" when Array.length Sys.argv = 3 ->
244
244
test_missing_field Sys.argv.(2)
245
-
246
245
| "combined" when Array.length Sys.argv = 3 ->
247
246
test_combined_options Sys.argv.(2)
248
-
249
247
| _ ->
250
248
prerr_endline usage;
251
249
prerr_endline "Commands:";
252
-
prerr_endline " error-precision <file> - Compare error messages with/without locs";
253
-
prerr_endline " nested-error <file> - Test error locations in nested objects";
254
-
prerr_endline " array-error <file> - Test error locations in arrays";
250
+
prerr_endline
251
+
" error-precision <file> - Compare error messages with/without locs";
252
+
prerr_endline
253
+
" nested-error <file> - Test error locations in nested objects";
254
+
prerr_endline
255
+
" array-error <file> - Test error locations in arrays";
255
256
prerr_endline " layout <file> - Test layout preservation";
256
-
prerr_endline " roundtrip <file> - Test round-tripping with layout";
257
-
prerr_endline " file-path - Test file path in error messages";
258
-
prerr_endline " missing-field <file> - Test missing field errors with locs";
257
+
prerr_endline
258
+
" roundtrip <file> - Test round-tripping with layout";
259
+
prerr_endline
260
+
" file-path - Test file path in error messages";
261
+
prerr_endline
262
+
" missing-field <file> - Test missing field errors with locs";
259
263
prerr_endline " combined <file> - Test locs and layout together";
260
264
exit 1
+13
-9
tests/bin/test_null_complete.ml
+13
-9
tests/bin/test_null_complete.ml
···
8
8
|> Object.finish
9
9
in
10
10
(match Yamlt.decode_string codec1 yaml1 with
11
-
| Ok v -> Printf.printf "Result: %s\n" (match v with None -> "None" | Some s -> "Some(" ^ s ^ ")")
12
-
| Error e -> Printf.printf "Error: %s\n" e);
11
+
| Ok v ->
12
+
Printf.printf "Result: %s\n"
13
+
(match v with None -> "None" | Some s -> "Some(" ^ s ^ ")")
14
+
| Error e -> Printf.printf "Error: %s\n" e);
13
15
14
16
Printf.printf "\n=== Test 2: Jsont.option with YAML string ===\n";
15
17
(match Yamlt.decode_string codec1 "value: hello" with
16
-
| Ok v -> Printf.printf "Result: %s\n" (match v with None -> "None" | Some s -> "Some(" ^ s ^ ")")
17
-
| Error e -> Printf.printf "Error: %s\n" e);
18
+
| Ok v ->
19
+
Printf.printf "Result: %s\n"
20
+
(match v with None -> "None" | Some s -> "Some(" ^ s ^ ")")
21
+
| Error e -> Printf.printf "Error: %s\n" e);
18
22
19
23
Printf.printf "\n=== Test 3: Jsont.string with YAML null (should error) ===\n";
20
24
let codec2 =
···
24
28
|> Object.finish
25
29
in
26
30
(match Yamlt.decode_string codec2 "value: null" with
27
-
| Ok v -> Printf.printf "Result: %s\n" v
28
-
| Error e -> Printf.printf "Error (expected): %s\n" e);
31
+
| Ok v -> Printf.printf "Result: %s\n" v
32
+
| Error e -> Printf.printf "Error (expected): %s\n" e);
29
33
30
34
Printf.printf "\n=== Test 4: Jsont.string with YAML string ===\n";
31
-
(match Yamlt.decode_string codec2 "value: hello" with
32
-
| Ok v -> Printf.printf "Result: %s\n" v
33
-
| Error e -> Printf.printf "Error: %s\n" e)
35
+
match Yamlt.decode_string codec2 "value: hello" with
36
+
| Ok v -> Printf.printf "Result: %s\n" v
37
+
| Error e -> Printf.printf "Error: %s\n" e
+17
-16
tests/bin/test_null_fix.ml
+17
-16
tests/bin/test_null_fix.ml
···
2
2
3
3
let () =
4
4
let module M = struct
5
-
type data = { value: string option }
6
-
5
+
type data = { value : string option }
6
+
7
7
let data_codec =
8
8
Jsont.Object.map ~kind:"Data" (fun value -> { value })
9
-
|> Jsont.Object.mem "value" (Jsont.option Jsont.string) ~enc:(fun d -> d.value)
9
+
|> Jsont.Object.mem "value" (Jsont.option Jsont.string) ~enc:(fun d ->
10
+
d.value)
10
11
|> Jsont.Object.finish
11
12
end in
12
-
13
13
let yaml_null = "value: null" in
14
14
15
15
Printf.printf "Testing YAML null handling with Jsont.option Jsont.string:\n\n";
16
16
17
17
match Yamlt.decode_string M.data_codec yaml_null with
18
-
| Ok data ->
19
-
(match data.M.value with
20
-
| None -> Printf.printf "YAML: value=None (CORRECT)\n"
21
-
| Some s -> Printf.printf "YAML: value=Some(%S) (BUG!)\n" s)
22
-
| Error e -> Printf.printf "YAML ERROR: %s\n" e;
18
+
| Ok data -> (
19
+
match data.M.value with
20
+
| None -> Printf.printf "YAML: value=None (CORRECT)\n"
21
+
| Some s -> Printf.printf "YAML: value=Some(%S) (BUG!)\n" s)
22
+
| Error e -> (
23
+
Printf.printf "YAML ERROR: %s\n" e;
23
24
24
-
let json_null = "{\"value\": null}" in
25
-
match Jsont_bytesrw.decode_string M.data_codec json_null with
26
-
| Ok data ->
27
-
(match data.M.value with
28
-
| None -> Printf.printf "JSON: value=None (CORRECT)\n"
29
-
| Some s -> Printf.printf "JSON: value=Some(%S) (BUG!)\n" s)
30
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e
25
+
let json_null = "{\"value\": null}" in
26
+
match Jsont_bytesrw.decode_string M.data_codec json_null with
27
+
| Ok data -> (
28
+
match data.M.value with
29
+
| None -> Printf.printf "JSON: value=None (CORRECT)\n"
30
+
| Some s -> Printf.printf "JSON: value=Some(%S) (BUG!)\n" s)
31
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e)
+54
-65
tests/bin/test_objects.ml
+54
-65
tests/bin/test_objects.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test object codec functionality with Yamlt *)
7
7
···
27
27
(* Test: Simple object with required fields *)
28
28
let test_simple_object file =
29
29
let module M = struct
30
-
type person = { name: string; age: int }
30
+
type person = { name : string; age : int }
31
31
32
32
let person_codec =
33
33
Jsont.Object.map ~kind:"Person" (fun name age -> { name; age })
···
37
37
38
38
let show p = Printf.sprintf "{name=%S; age=%d}" p.name p.age
39
39
end in
40
-
41
40
let yaml = read_file file in
42
41
let json = read_file (file ^ ".json") in
43
42
let json_result = Jsont_bytesrw.decode_string M.person_codec json in
···
50
49
(* Test: Object with optional fields *)
51
50
let test_optional_fields file =
52
51
let module M = struct
53
-
type config = { host: string; port: int option; debug: bool option }
52
+
type config = { host : string; port : int option; debug : bool option }
54
53
55
54
let config_codec =
56
-
Jsont.Object.map ~kind:"Config"
57
-
(fun host port debug -> { host; port; debug })
55
+
Jsont.Object.map ~kind:"Config" (fun host port debug ->
56
+
{ host; port; debug })
58
57
|> Jsont.Object.mem "host" Jsont.string ~enc:(fun c -> c.host)
59
58
|> Jsont.Object.opt_mem "port" Jsont.int ~enc:(fun c -> c.port)
60
59
|> Jsont.Object.opt_mem "debug" Jsont.bool ~enc:(fun c -> c.debug)
61
60
|> Jsont.Object.finish
62
61
63
62
let show c =
64
-
Printf.sprintf "{host=%S; port=%s; debug=%s}"
65
-
c.host
66
-
(match c.port with None -> "None" | Some p -> Printf.sprintf "Some %d" p)
67
-
(match c.debug with None -> "None" | Some b -> Printf.sprintf "Some %b" b)
63
+
Printf.sprintf "{host=%S; port=%s; debug=%s}" c.host
64
+
(match c.port with
65
+
| None -> "None"
66
+
| Some p -> Printf.sprintf "Some %d" p)
67
+
(match c.debug with
68
+
| None -> "None"
69
+
| Some b -> Printf.sprintf "Some %b" b)
68
70
end in
69
-
70
71
let yaml = read_file file in
71
72
let json = read_file (file ^ ".json") in
72
73
let json_result = Jsont_bytesrw.decode_string M.config_codec json in
···
79
80
(* Test: Object with default values *)
80
81
let test_default_values file =
81
82
let module M = struct
82
-
type settings = { timeout: int; retries: int; verbose: bool }
83
+
type settings = { timeout : int; retries : int; verbose : bool }
83
84
84
85
let settings_codec =
85
-
Jsont.Object.map ~kind:"Settings"
86
-
(fun timeout retries verbose -> { timeout; retries; verbose })
87
-
|> Jsont.Object.mem "timeout" Jsont.int ~enc:(fun s -> s.timeout) ~dec_absent:30
88
-
|> Jsont.Object.mem "retries" Jsont.int ~enc:(fun s -> s.retries) ~dec_absent:3
89
-
|> Jsont.Object.mem "verbose" Jsont.bool ~enc:(fun s -> s.verbose) ~dec_absent:false
86
+
Jsont.Object.map ~kind:"Settings" (fun timeout retries verbose ->
87
+
{ timeout; retries; verbose })
88
+
|> Jsont.Object.mem "timeout" Jsont.int
89
+
~enc:(fun s -> s.timeout)
90
+
~dec_absent:30
91
+
|> Jsont.Object.mem "retries" Jsont.int
92
+
~enc:(fun s -> s.retries)
93
+
~dec_absent:3
94
+
|> Jsont.Object.mem "verbose" Jsont.bool
95
+
~enc:(fun s -> s.verbose)
96
+
~dec_absent:false
90
97
|> Jsont.Object.finish
91
98
92
99
let show s =
93
-
Printf.sprintf "{timeout=%d; retries=%d; verbose=%b}"
94
-
s.timeout s.retries s.verbose
100
+
Printf.sprintf "{timeout=%d; retries=%d; verbose=%b}" s.timeout s.retries
101
+
s.verbose
95
102
end in
96
-
97
103
let yaml = read_file file in
98
104
let json = read_file (file ^ ".json") in
99
105
let json_result = Jsont_bytesrw.decode_string M.settings_codec json in
···
106
112
(* Test: Nested objects *)
107
113
let test_nested_objects file =
108
114
let module M = struct
109
-
type address = { street: string; city: string; zip: string }
110
-
type employee = { name: string; address: address }
115
+
type address = { street : string; city : string; zip : string }
116
+
type employee = { name : string; address : address }
111
117
112
118
let address_codec =
113
-
Jsont.Object.map ~kind:"Address"
114
-
(fun street city zip -> { street; city; zip })
119
+
Jsont.Object.map ~kind:"Address" (fun street city zip ->
120
+
{ street; city; zip })
115
121
|> Jsont.Object.mem "street" Jsont.string ~enc:(fun a -> a.street)
116
122
|> Jsont.Object.mem "city" Jsont.string ~enc:(fun a -> a.city)
117
123
|> Jsont.Object.mem "zip" Jsont.string ~enc:(fun a -> a.zip)
118
124
|> Jsont.Object.finish
119
125
120
126
let employee_codec =
121
-
Jsont.Object.map ~kind:"Employee"
122
-
(fun name address -> { name; address })
127
+
Jsont.Object.map ~kind:"Employee" (fun name address -> { name; address })
123
128
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun e -> e.name)
124
129
|> Jsont.Object.mem "address" address_codec ~enc:(fun e -> e.address)
125
130
|> Jsont.Object.finish
126
131
127
132
let show e =
128
-
Printf.sprintf "{name=%S; address={street=%S; city=%S; zip=%S}}"
129
-
e.name e.address.street e.address.city e.address.zip
133
+
Printf.sprintf "{name=%S; address={street=%S; city=%S; zip=%S}}" e.name
134
+
e.address.street e.address.city e.address.zip
130
135
end in
131
-
132
136
let yaml = read_file file in
133
137
let json = read_file (file ^ ".json") in
134
138
let json_result = Jsont_bytesrw.decode_string M.employee_codec json in
···
141
145
(* Test: Unknown member handling - error *)
142
146
let test_unknown_members_error file =
143
147
let module M = struct
144
-
type strict = { name: string }
148
+
type strict = { name : string }
145
149
146
150
let strict_codec =
147
151
Jsont.Object.map ~kind:"Strict" (fun name -> { name })
148
152
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun s -> s.name)
149
153
|> Jsont.Object.finish
150
154
end in
151
-
152
155
let yaml = read_file file in
153
156
let result = Yamlt.decode_string M.strict_codec yaml in
154
157
match result with
···
158
161
(* Test: Unknown member handling - keep *)
159
162
let test_unknown_members_keep file =
160
163
let module M = struct
161
-
type flexible = { name: string; extra: Jsont.json }
164
+
type flexible = { name : string; extra : Jsont.json }
162
165
163
166
let flexible_codec =
164
167
Jsont.Object.map ~kind:"Flexible" (fun name extra -> { name; extra })
···
166
169
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun f -> f.extra)
167
170
|> Jsont.Object.finish
168
171
169
-
let show f =
170
-
Printf.sprintf "{name=%S; has_extra=true}" f.name
172
+
let show f = Printf.sprintf "{name=%S; has_extra=true}" f.name
171
173
end in
172
-
173
174
let yaml = read_file file in
174
175
let json = read_file (file ^ ".json") in
175
176
let json_result = Jsont_bytesrw.decode_string M.flexible_codec json in
···
182
183
(* Test: Object cases (discriminated unions) - simplified version *)
183
184
let test_object_cases file =
184
185
let module M = struct
185
-
type circle = { type_: string; radius: float }
186
+
type circle = { type_ : string; radius : float }
186
187
187
188
let circle_codec =
188
189
Jsont.Object.map ~kind:"Circle" (fun type_ radius -> { type_; radius })
···
190
191
|> Jsont.Object.mem "radius" Jsont.number ~enc:(fun c -> c.radius)
191
192
|> Jsont.Object.finish
192
193
193
-
let show c =
194
-
Printf.sprintf "Circle{radius=%.2f}" c.radius
194
+
let show c = Printf.sprintf "Circle{radius=%.2f}" c.radius
195
195
end in
196
-
197
196
let yaml = read_file file in
198
197
let json = read_file (file ^ ".json") in
199
198
let json_result = Jsont_bytesrw.decode_string M.circle_codec json in
···
206
205
(* Test: Missing required field error *)
207
206
let test_missing_required file =
208
207
let module M = struct
209
-
type required = { name: string; age: int }
208
+
type required = { name : string; age : int }
210
209
211
210
let required_codec =
212
211
Jsont.Object.map ~kind:"Required" (fun name age -> { name; age })
···
214
213
|> Jsont.Object.mem "age" Jsont.int ~enc:(fun r -> r.age)
215
214
|> Jsont.Object.finish
216
215
end in
217
-
218
216
let yaml = read_file file in
219
217
let result = Yamlt.decode_string M.required_codec yaml in
220
218
match result with
···
224
222
(* Test: Encoding objects to different formats *)
225
223
let test_encode_object () =
226
224
let module M = struct
227
-
type person = { name: string; age: int; active: bool }
225
+
type person = { name : string; age : int; active : bool }
228
226
229
227
let person_codec =
230
-
Jsont.Object.map ~kind:"Person" (fun name age active -> { name; age; active })
228
+
Jsont.Object.map ~kind:"Person" (fun name age active ->
229
+
{ name; age; active })
231
230
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun p -> p.name)
232
231
|> Jsont.Object.mem "age" Jsont.int ~enc:(fun p -> p.age)
233
232
|> Jsont.Object.mem "active" Jsont.bool ~enc:(fun p -> p.active)
234
233
|> Jsont.Object.finish
235
234
end in
236
-
237
235
let person = M.{ name = "Alice"; age = 30; active = true } in
238
236
239
237
(* Encode to JSON *)
240
238
(match Jsont_bytesrw.encode_string M.person_codec person with
241
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
242
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
239
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
240
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
243
241
244
242
(* Encode to YAML Block *)
245
243
(match Yamlt.encode_string ~format:Yamlt.Block M.person_codec person with
246
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
247
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
244
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
245
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
248
246
249
247
(* Encode to YAML Flow *)
250
-
(match Yamlt.encode_string ~format:Yamlt.Flow M.person_codec person with
251
-
| Ok s -> Printf.printf "YAML Flow: %s" s
252
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
248
+
match Yamlt.encode_string ~format:Yamlt.Flow M.person_codec person with
249
+
| Ok s -> Printf.printf "YAML Flow: %s" s
250
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e
253
251
254
252
let () =
255
253
let usage = "Usage: test_objects <command> [args...]" in
···
262
260
match Sys.argv.(1) with
263
261
| "simple" when Stdlib.Array.length Sys.argv = 3 ->
264
262
test_simple_object Sys.argv.(2)
265
-
266
263
| "optional" when Stdlib.Array.length Sys.argv = 3 ->
267
264
test_optional_fields Sys.argv.(2)
268
-
269
265
| "defaults" when Stdlib.Array.length Sys.argv = 3 ->
270
266
test_default_values Sys.argv.(2)
271
-
272
267
| "nested" when Stdlib.Array.length Sys.argv = 3 ->
273
268
test_nested_objects Sys.argv.(2)
274
-
275
269
| "unknown-error" when Stdlib.Array.length Sys.argv = 3 ->
276
270
test_unknown_members_error Sys.argv.(2)
277
-
278
271
| "unknown-keep" when Stdlib.Array.length Sys.argv = 3 ->
279
272
test_unknown_members_keep Sys.argv.(2)
280
-
281
273
| "cases" when Stdlib.Array.length Sys.argv = 3 ->
282
274
test_object_cases Sys.argv.(2)
283
-
284
275
| "missing-required" when Stdlib.Array.length Sys.argv = 3 ->
285
276
test_missing_required Sys.argv.(2)
286
-
287
-
| "encode" when Stdlib.Array.length Sys.argv = 2 ->
288
-
test_encode_object ()
289
-
277
+
| "encode" when Stdlib.Array.length Sys.argv = 2 -> test_encode_object ()
290
278
| _ ->
291
279
prerr_endline usage;
292
280
prerr_endline "Commands:";
···
297
285
prerr_endline " unknown-error <file> - Test unknown member error";
298
286
prerr_endline " unknown-keep <file> - Test keeping unknown members";
299
287
prerr_endline " cases <file> - Test object cases (unions)";
300
-
prerr_endline " missing-required <file> - Test missing required field error";
288
+
prerr_endline
289
+
" missing-required <file> - Test missing required field error";
301
290
prerr_endline " encode - Test encoding objects";
302
291
exit 1
+6
-5
tests/bin/test_opt_array.ml
+6
-5
tests/bin/test_opt_array.ml
···
1
1
let () =
2
2
let codec =
3
3
Jsont.Object.map ~kind:"Test" (fun arr -> arr)
4
-
|> Jsont.Object.opt_mem "values" (Jsont.array Jsont.string) ~enc:(fun arr -> arr)
4
+
|> Jsont.Object.opt_mem "values" (Jsont.array Jsont.string) ~enc:(fun arr ->
5
+
arr)
5
6
|> Jsont.Object.finish
6
7
in
7
8
···
9
10
10
11
Printf.printf "Testing optional array field:\n";
11
12
match Yamlt.decode_string codec yaml with
12
-
| Ok arr ->
13
-
(match arr with
14
-
| None -> Printf.printf "Result: None\n"
15
-
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
13
+
| Ok arr -> (
14
+
match arr with
15
+
| None -> Printf.printf "Result: None\n"
16
+
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
16
17
| Error e -> Printf.printf "Error: %s\n" e
+134
-88
tests/bin/test_roundtrip.ml
+134
-88
tests/bin/test_roundtrip.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test roundtrip encoding/decoding with Yamlt *)
7
7
8
8
(* Test: Roundtrip scalars *)
9
9
let test_scalar_roundtrip () =
10
10
let module M = struct
11
-
type data = { s: string; n: float; b: bool; nul: unit }
11
+
type data = { s : string; n : float; b : bool; nul : unit }
12
12
13
13
let data_codec =
14
14
Jsont.Object.map ~kind:"Data" (fun s n b nul -> { s; n; b; nul })
···
21
21
let equal d1 d2 =
22
22
d1.s = d2.s && d1.n = d2.n && d1.b = d2.b && d1.nul = d2.nul
23
23
end in
24
-
25
24
let original = { M.s = "hello"; n = 42.5; b = true; nul = () } in
26
25
27
26
(* JSON roundtrip *)
28
27
let json_encoded = Jsont_bytesrw.encode_string M.data_codec original in
29
-
let json_decoded = Result.bind json_encoded (Jsont_bytesrw.decode_string M.data_codec) in
28
+
let json_decoded =
29
+
Result.bind json_encoded (Jsont_bytesrw.decode_string M.data_codec)
30
+
in
30
31
(match json_decoded with
31
-
| Ok decoded when M.equal original decoded -> Printf.printf "JSON roundtrip: PASS\n"
32
-
| Ok _ -> Printf.printf "JSON roundtrip: FAIL (data mismatch)\n"
33
-
| Error e -> Printf.printf "JSON roundtrip: FAIL (%s)\n" e);
32
+
| Ok decoded when M.equal original decoded ->
33
+
Printf.printf "JSON roundtrip: PASS\n"
34
+
| Ok _ -> Printf.printf "JSON roundtrip: FAIL (data mismatch)\n"
35
+
| Error e -> Printf.printf "JSON roundtrip: FAIL (%s)\n" e);
34
36
35
37
(* YAML Block roundtrip *)
36
-
let yaml_block_encoded = Yamlt.encode_string ~format:Yamlt.Block M.data_codec original in
37
-
let yaml_block_decoded = Result.bind yaml_block_encoded (Yamlt.decode_string M.data_codec) in
38
+
let yaml_block_encoded =
39
+
Yamlt.encode_string ~format:Yamlt.Block M.data_codec original
40
+
in
41
+
let yaml_block_decoded =
42
+
Result.bind yaml_block_encoded (Yamlt.decode_string M.data_codec)
43
+
in
38
44
(match yaml_block_decoded with
39
-
| Ok decoded when M.equal original decoded -> Printf.printf "YAML Block roundtrip: PASS\n"
40
-
| Ok _ -> Printf.printf "YAML Block roundtrip: FAIL (data mismatch)\n"
41
-
| Error e -> Printf.printf "YAML Block roundtrip: FAIL (%s)\n" e);
45
+
| Ok decoded when M.equal original decoded ->
46
+
Printf.printf "YAML Block roundtrip: PASS\n"
47
+
| Ok _ -> Printf.printf "YAML Block roundtrip: FAIL (data mismatch)\n"
48
+
| Error e -> Printf.printf "YAML Block roundtrip: FAIL (%s)\n" e);
42
49
43
50
(* YAML Flow roundtrip *)
44
-
let yaml_flow_encoded = Yamlt.encode_string ~format:Yamlt.Flow M.data_codec original in
45
-
let yaml_flow_decoded = Result.bind yaml_flow_encoded (Yamlt.decode_string M.data_codec) in
46
-
(match yaml_flow_decoded with
47
-
| Ok decoded when M.equal original decoded -> Printf.printf "YAML Flow roundtrip: PASS\n"
48
-
| Ok _ -> Printf.printf "YAML Flow roundtrip: FAIL (data mismatch)\n"
49
-
| Error e -> Printf.printf "YAML Flow roundtrip: FAIL (%s)\n" e)
51
+
let yaml_flow_encoded =
52
+
Yamlt.encode_string ~format:Yamlt.Flow M.data_codec original
53
+
in
54
+
let yaml_flow_decoded =
55
+
Result.bind yaml_flow_encoded (Yamlt.decode_string M.data_codec)
56
+
in
57
+
match yaml_flow_decoded with
58
+
| Ok decoded when M.equal original decoded ->
59
+
Printf.printf "YAML Flow roundtrip: PASS\n"
60
+
| Ok _ -> Printf.printf "YAML Flow roundtrip: FAIL (data mismatch)\n"
61
+
| Error e -> Printf.printf "YAML Flow roundtrip: FAIL (%s)\n" e
50
62
51
63
(* Test: Roundtrip arrays *)
52
64
let test_array_roundtrip () =
53
65
let module M = struct
54
-
type data = { items: int array; nested: float array array }
66
+
type data = { items : int array; nested : float array array }
55
67
56
68
let data_codec =
57
69
Jsont.Object.map ~kind:"Data" (fun items nested -> { items; nested })
58
-
|> Jsont.Object.mem "items" (Jsont.array Jsont.int) ~enc:(fun d -> d.items)
59
-
|> Jsont.Object.mem "nested" (Jsont.array (Jsont.array Jsont.number)) ~enc:(fun d -> d.nested)
70
+
|> Jsont.Object.mem "items" (Jsont.array Jsont.int) ~enc:(fun d ->
71
+
d.items)
72
+
|> Jsont.Object.mem "nested"
73
+
(Jsont.array (Jsont.array Jsont.number))
74
+
~enc:(fun d -> d.nested)
60
75
|> Jsont.Object.finish
61
76
62
-
let equal d1 d2 =
63
-
d1.items = d2.items && d1.nested = d2.nested
77
+
let equal d1 d2 = d1.items = d2.items && d1.nested = d2.nested
64
78
end in
65
-
66
-
let original = { M.items = [|1; 2; 3; 4; 5|]; nested = [|[|1.0; 2.0|]; [|3.0; 4.0|]|] } in
79
+
let original =
80
+
{
81
+
M.items = [| 1; 2; 3; 4; 5 |];
82
+
nested = [| [| 1.0; 2.0 |]; [| 3.0; 4.0 |] |];
83
+
}
84
+
in
67
85
68
86
(* JSON roundtrip *)
69
-
let json_result = Result.bind
70
-
(Jsont_bytesrw.encode_string M.data_codec original)
71
-
(Jsont_bytesrw.decode_string M.data_codec) in
87
+
let json_result =
88
+
Result.bind
89
+
(Jsont_bytesrw.encode_string M.data_codec original)
90
+
(Jsont_bytesrw.decode_string M.data_codec)
91
+
in
72
92
(match json_result with
73
-
| Ok decoded when M.equal original decoded -> Printf.printf "JSON array roundtrip: PASS\n"
74
-
| Ok _ -> Printf.printf "JSON array roundtrip: FAIL (data mismatch)\n"
75
-
| Error e -> Printf.printf "JSON array roundtrip: FAIL (%s)\n" e);
93
+
| Ok decoded when M.equal original decoded ->
94
+
Printf.printf "JSON array roundtrip: PASS\n"
95
+
| Ok _ -> Printf.printf "JSON array roundtrip: FAIL (data mismatch)\n"
96
+
| Error e -> Printf.printf "JSON array roundtrip: FAIL (%s)\n" e);
76
97
77
98
(* YAML roundtrip *)
78
-
let yaml_result = Result.bind
79
-
(Yamlt.encode_string M.data_codec original)
80
-
(Yamlt.decode_string M.data_codec) in
81
-
(match yaml_result with
82
-
| Ok decoded when M.equal original decoded -> Printf.printf "YAML array roundtrip: PASS\n"
83
-
| Ok _ -> Printf.printf "YAML array roundtrip: FAIL (data mismatch)\n"
84
-
| Error e -> Printf.printf "YAML array roundtrip: FAIL (%s)\n" e)
99
+
let yaml_result =
100
+
Result.bind
101
+
(Yamlt.encode_string M.data_codec original)
102
+
(Yamlt.decode_string M.data_codec)
103
+
in
104
+
match yaml_result with
105
+
| Ok decoded when M.equal original decoded ->
106
+
Printf.printf "YAML array roundtrip: PASS\n"
107
+
| Ok _ -> Printf.printf "YAML array roundtrip: FAIL (data mismatch)\n"
108
+
| Error e -> Printf.printf "YAML array roundtrip: FAIL (%s)\n" e
85
109
86
110
(* Test: Roundtrip objects *)
87
111
let test_object_roundtrip () =
88
112
let module M = struct
89
-
type person = { p_name: string; age: int; active: bool }
90
-
type company = { c_name: string; employees: person array }
113
+
type person = { p_name : string; age : int; active : bool }
114
+
type company = { c_name : string; employees : person array }
91
115
92
116
let person_codec =
93
-
Jsont.Object.map ~kind:"Person" (fun p_name age active -> { p_name; age; active })
117
+
Jsont.Object.map ~kind:"Person" (fun p_name age active ->
118
+
{ p_name; age; active })
94
119
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun p -> p.p_name)
95
120
|> Jsont.Object.mem "age" Jsont.int ~enc:(fun p -> p.age)
96
121
|> Jsont.Object.mem "active" Jsont.bool ~enc:(fun p -> p.active)
97
122
|> Jsont.Object.finish
98
123
99
124
let company_codec =
100
-
Jsont.Object.map ~kind:"Company" (fun c_name employees -> { c_name; employees })
125
+
Jsont.Object.map ~kind:"Company" (fun c_name employees ->
126
+
{ c_name; employees })
101
127
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun c -> c.c_name)
102
-
|> Jsont.Object.mem "employees" (Jsont.array person_codec) ~enc:(fun c -> c.employees)
128
+
|> Jsont.Object.mem "employees" (Jsont.array person_codec) ~enc:(fun c ->
129
+
c.employees)
103
130
|> Jsont.Object.finish
104
131
105
132
let person_equal p1 p2 =
106
133
p1.p_name = p2.p_name && p1.age = p2.age && p1.active = p2.active
107
134
108
135
let equal c1 c2 =
109
-
c1.c_name = c2.c_name &&
110
-
Stdlib.Array.length c1.employees = Stdlib.Array.length c2.employees &&
111
-
Stdlib.Array.for_all2 person_equal c1.employees c2.employees
136
+
c1.c_name = c2.c_name
137
+
&& Stdlib.Array.length c1.employees = Stdlib.Array.length c2.employees
138
+
&& Stdlib.Array.for_all2 person_equal c1.employees c2.employees
112
139
end in
113
-
114
-
let original = {
115
-
M.c_name = "Acme Corp";
116
-
employees = [|
117
-
{ p_name = "Alice"; age = 30; active = true };
118
-
{ p_name = "Bob"; age = 25; active = false };
119
-
|]
120
-
} in
140
+
let original =
141
+
{
142
+
M.c_name = "Acme Corp";
143
+
employees =
144
+
[|
145
+
{ p_name = "Alice"; age = 30; active = true };
146
+
{ p_name = "Bob"; age = 25; active = false };
147
+
|];
148
+
}
149
+
in
121
150
122
151
(* JSON roundtrip *)
123
-
let json_result = Result.bind
124
-
(Jsont_bytesrw.encode_string M.company_codec original)
125
-
(Jsont_bytesrw.decode_string M.company_codec) in
152
+
let json_result =
153
+
Result.bind
154
+
(Jsont_bytesrw.encode_string M.company_codec original)
155
+
(Jsont_bytesrw.decode_string M.company_codec)
156
+
in
126
157
(match json_result with
127
-
| Ok decoded when M.equal original decoded -> Printf.printf "JSON object roundtrip: PASS\n"
128
-
| Ok _ -> Printf.printf "JSON object roundtrip: FAIL (data mismatch)\n"
129
-
| Error e -> Printf.printf "JSON object roundtrip: FAIL (%s)\n" e);
158
+
| Ok decoded when M.equal original decoded ->
159
+
Printf.printf "JSON object roundtrip: PASS\n"
160
+
| Ok _ -> Printf.printf "JSON object roundtrip: FAIL (data mismatch)\n"
161
+
| Error e -> Printf.printf "JSON object roundtrip: FAIL (%s)\n" e);
130
162
131
163
(* YAML roundtrip *)
132
-
let yaml_result = Result.bind
133
-
(Yamlt.encode_string M.company_codec original)
134
-
(Yamlt.decode_string M.company_codec) in
135
-
(match yaml_result with
136
-
| Ok decoded when M.equal original decoded -> Printf.printf "YAML object roundtrip: PASS\n"
137
-
| Ok _ -> Printf.printf "YAML object roundtrip: FAIL (data mismatch)\n"
138
-
| Error e -> Printf.printf "YAML object roundtrip: FAIL (%s)\n" e)
164
+
let yaml_result =
165
+
Result.bind
166
+
(Yamlt.encode_string M.company_codec original)
167
+
(Yamlt.decode_string M.company_codec)
168
+
in
169
+
match yaml_result with
170
+
| Ok decoded when M.equal original decoded ->
171
+
Printf.printf "YAML object roundtrip: PASS\n"
172
+
| Ok _ -> Printf.printf "YAML object roundtrip: FAIL (data mismatch)\n"
173
+
| Error e -> Printf.printf "YAML object roundtrip: FAIL (%s)\n" e
139
174
140
175
(* Test: Roundtrip with optionals *)
141
176
let test_optional_roundtrip () =
142
177
let module M = struct
143
-
type data = { required: string; optional: int option; nullable: string option }
178
+
type data = {
179
+
required : string;
180
+
optional : int option;
181
+
nullable : string option;
182
+
}
144
183
145
184
let data_codec =
146
-
Jsont.Object.map ~kind:"Data" (fun required optional nullable -> { required; optional; nullable })
185
+
Jsont.Object.map ~kind:"Data" (fun required optional nullable ->
186
+
{ required; optional; nullable })
147
187
|> Jsont.Object.mem "required" Jsont.string ~enc:(fun d -> d.required)
148
188
|> Jsont.Object.opt_mem "optional" Jsont.int ~enc:(fun d -> d.optional)
149
-
|> Jsont.Object.mem "nullable" (Jsont.some Jsont.string) ~enc:(fun d -> d.nullable)
189
+
|> Jsont.Object.mem "nullable" (Jsont.some Jsont.string) ~enc:(fun d ->
190
+
d.nullable)
150
191
|> Jsont.Object.finish
151
192
152
193
let equal d1 d2 =
153
-
d1.required = d2.required && d1.optional = d2.optional && d1.nullable = d2.nullable
194
+
d1.required = d2.required && d1.optional = d2.optional
195
+
&& d1.nullable = d2.nullable
154
196
end in
155
-
156
197
let original = { M.required = "test"; optional = Some 42; nullable = None } in
157
198
158
199
(* JSON roundtrip *)
159
-
let json_result = Result.bind
160
-
(Jsont_bytesrw.encode_string M.data_codec original)
161
-
(Jsont_bytesrw.decode_string M.data_codec) in
200
+
let json_result =
201
+
Result.bind
202
+
(Jsont_bytesrw.encode_string M.data_codec original)
203
+
(Jsont_bytesrw.decode_string M.data_codec)
204
+
in
162
205
(match json_result with
163
-
| Ok decoded when M.equal original decoded -> Printf.printf "JSON optional roundtrip: PASS\n"
164
-
| Ok _ -> Printf.printf "JSON optional roundtrip: FAIL (data mismatch)\n"
165
-
| Error e -> Printf.printf "JSON optional roundtrip: FAIL (%s)\n" e);
206
+
| Ok decoded when M.equal original decoded ->
207
+
Printf.printf "JSON optional roundtrip: PASS\n"
208
+
| Ok _ -> Printf.printf "JSON optional roundtrip: FAIL (data mismatch)\n"
209
+
| Error e -> Printf.printf "JSON optional roundtrip: FAIL (%s)\n" e);
166
210
167
211
(* YAML roundtrip *)
168
-
let yaml_result = Result.bind
169
-
(Yamlt.encode_string M.data_codec original)
170
-
(Yamlt.decode_string M.data_codec) in
171
-
(match yaml_result with
172
-
| Ok decoded when M.equal original decoded -> Printf.printf "YAML optional roundtrip: PASS\n"
173
-
| Ok _ -> Printf.printf "YAML optional roundtrip: FAIL (data mismatch)\n"
174
-
| Error e -> Printf.printf "YAML optional roundtrip: FAIL (%s)\n" e)
212
+
let yaml_result =
213
+
Result.bind
214
+
(Yamlt.encode_string M.data_codec original)
215
+
(Yamlt.decode_string M.data_codec)
216
+
in
217
+
match yaml_result with
218
+
| Ok decoded when M.equal original decoded ->
219
+
Printf.printf "YAML optional roundtrip: PASS\n"
220
+
| Ok _ -> Printf.printf "YAML optional roundtrip: FAIL (data mismatch)\n"
221
+
| Error e -> Printf.printf "YAML optional roundtrip: FAIL (%s)\n" e
175
222
176
223
let () =
177
224
let usage = "Usage: test_roundtrip <command>" in
···
186
233
| "array" -> test_array_roundtrip ()
187
234
| "object" -> test_object_roundtrip ()
188
235
| "optional" -> test_optional_roundtrip ()
189
-
190
236
| _ ->
191
237
prerr_endline usage;
192
238
prerr_endline "Commands:";
+80
-93
tests/bin/test_scalars.ml
+80
-93
tests/bin/test_scalars.ml
···
1
1
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
5
6
6
(** Test scalar type resolution with Yamlt codec *)
7
7
···
121
121
let result = Yamlt.decode_string number_codec yaml in
122
122
match result with
123
123
| Ok f ->
124
-
if Float.is_nan f then
125
-
Printf.printf "value: NaN\n"
126
-
else if f = Float.infinity then
127
-
Printf.printf "value: +Infinity\n"
128
-
else if f = Float.neg_infinity then
129
-
Printf.printf "value: -Infinity\n"
130
-
else
131
-
Printf.printf "value: %.17g\n" f
132
-
| Error e ->
133
-
Printf.printf "ERROR: %s\n" e
124
+
if Float.is_nan f then Printf.printf "value: NaN\n"
125
+
else if f = Float.infinity then Printf.printf "value: +Infinity\n"
126
+
else if f = Float.neg_infinity then Printf.printf "value: -Infinity\n"
127
+
else Printf.printf "value: %.17g\n" f
128
+
| Error e -> Printf.printf "ERROR: %s\n" e
134
129
135
130
(* Test: Type mismatch errors *)
136
131
let test_type_mismatch file expected_type =
137
132
let yaml = read_file file in
138
133
139
134
match expected_type with
140
-
| "bool" ->
141
-
let codec =
142
-
Jsont.Object.map ~kind:"BoolTest" (fun b -> b)
143
-
|> Jsont.Object.mem "value" Jsont.bool ~enc:(fun b -> b)
144
-
|> Jsont.Object.finish
145
-
in
146
-
let result = Yamlt.decode_string codec yaml in
147
-
(match result with
148
-
| Ok _ -> Printf.printf "Unexpected success\n"
149
-
| Error e -> Printf.printf "Expected error: %s\n" e)
150
-
| "number" ->
151
-
let codec =
152
-
Jsont.Object.map ~kind:"NumberTest" (fun n -> n)
153
-
|> Jsont.Object.mem "value" Jsont.number ~enc:(fun n -> n)
154
-
|> Jsont.Object.finish
155
-
in
156
-
let result = Yamlt.decode_string codec yaml in
157
-
(match result with
158
-
| Ok _ -> Printf.printf "Unexpected success\n"
159
-
| Error e -> Printf.printf "Expected error: %s\n" e)
160
-
| "null" ->
161
-
let codec =
162
-
Jsont.Object.map ~kind:"NullTest" (fun n -> n)
163
-
|> Jsont.Object.mem "value" (Jsont.null ()) ~enc:(fun n -> n)
164
-
|> Jsont.Object.finish
165
-
in
166
-
let result = Yamlt.decode_string codec yaml in
167
-
(match result with
168
-
| Ok _ -> Printf.printf "Unexpected success\n"
169
-
| Error e -> Printf.printf "Expected error: %s\n" e)
170
-
| _ -> failwith "unknown type"
135
+
| "bool" -> (
136
+
let codec =
137
+
Jsont.Object.map ~kind:"BoolTest" (fun b -> b)
138
+
|> Jsont.Object.mem "value" Jsont.bool ~enc:(fun b -> b)
139
+
|> Jsont.Object.finish
140
+
in
141
+
let result = Yamlt.decode_string codec yaml in
142
+
match result with
143
+
| Ok _ -> Printf.printf "Unexpected success\n"
144
+
| Error e -> Printf.printf "Expected error: %s\n" e)
145
+
| "number" -> (
146
+
let codec =
147
+
Jsont.Object.map ~kind:"NumberTest" (fun n -> n)
148
+
|> Jsont.Object.mem "value" Jsont.number ~enc:(fun n -> n)
149
+
|> Jsont.Object.finish
150
+
in
151
+
let result = Yamlt.decode_string codec yaml in
152
+
match result with
153
+
| Ok _ -> Printf.printf "Unexpected success\n"
154
+
| Error e -> Printf.printf "Expected error: %s\n" e)
155
+
| "null" -> (
156
+
let codec =
157
+
Jsont.Object.map ~kind:"NullTest" (fun n -> n)
158
+
|> Jsont.Object.mem "value" (Jsont.null ()) ~enc:(fun n -> n)
159
+
|> Jsont.Object.finish
160
+
in
161
+
let result = Yamlt.decode_string codec yaml in
162
+
match result with
163
+
| Ok _ -> Printf.printf "Unexpected success\n"
164
+
| Error e -> Printf.printf "Expected error: %s\n" e)
165
+
| _ -> failwith "unknown type"
171
166
172
167
(* Test: Decode with Jsont.json to see auto-resolution *)
173
168
let test_any_resolution file =
···
191
186
(* Test: Encoding to different formats *)
192
187
let test_encode_formats value_type value =
193
188
match value_type with
194
-
| "bool" ->
189
+
| "bool" -> (
195
190
let codec =
196
191
Jsont.Object.map ~kind:"BoolTest" (fun b -> b)
197
192
|> Jsont.Object.mem "value" Jsont.bool ~enc:(fun b -> b)
···
199
194
in
200
195
let v = bool_of_string value in
201
196
(match Jsont_bytesrw.encode_string codec v with
202
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
203
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
197
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
198
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
204
199
(match Yamlt.encode_string ~format:Yamlt.Block codec v with
205
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
206
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
207
-
(match Yamlt.encode_string ~format:Yamlt.Flow codec v with
208
-
| Ok s -> Printf.printf "YAML Flow: %s" s
209
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
210
-
| "number" ->
200
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
201
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
202
+
match Yamlt.encode_string ~format:Yamlt.Flow codec v with
203
+
| Ok s -> Printf.printf "YAML Flow: %s" s
204
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
205
+
| "number" -> (
211
206
let codec =
212
207
Jsont.Object.map ~kind:"NumberTest" (fun n -> n)
213
208
|> Jsont.Object.mem "value" Jsont.number ~enc:(fun n -> n)
···
215
210
in
216
211
let v = float_of_string value in
217
212
(match Jsont_bytesrw.encode_string codec v with
218
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
219
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
213
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
214
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
220
215
(match Yamlt.encode_string ~format:Yamlt.Block codec v with
221
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
222
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
223
-
(match Yamlt.encode_string ~format:Yamlt.Flow codec v with
224
-
| Ok s -> Printf.printf "YAML Flow: %s" s
225
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
226
-
| "string" ->
216
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
217
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
218
+
match Yamlt.encode_string ~format:Yamlt.Flow codec v with
219
+
| Ok s -> Printf.printf "YAML Flow: %s" s
220
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
221
+
| "string" -> (
227
222
let codec =
228
223
Jsont.Object.map ~kind:"StringTest" (fun s -> s)
229
224
|> Jsont.Object.mem "value" Jsont.string ~enc:(fun s -> s)
···
231
226
in
232
227
let v = value in
233
228
(match Jsont_bytesrw.encode_string codec v with
234
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
235
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
229
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
230
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
236
231
(match Yamlt.encode_string ~format:Yamlt.Block codec v with
237
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
238
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
239
-
(match Yamlt.encode_string ~format:Yamlt.Flow codec v with
240
-
| Ok s -> Printf.printf "YAML Flow: %s" s
241
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
242
-
| "null" ->
232
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
233
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
234
+
match Yamlt.encode_string ~format:Yamlt.Flow codec v with
235
+
| Ok s -> Printf.printf "YAML Flow: %s" s
236
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
237
+
| "null" -> (
243
238
let codec =
244
239
Jsont.Object.map ~kind:"NullTest" (fun n -> n)
245
240
|> Jsont.Object.mem "value" (Jsont.null ()) ~enc:(fun n -> n)
···
247
242
in
248
243
let v = () in
249
244
(match Jsont_bytesrw.encode_string codec v with
250
-
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
251
-
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
245
+
| Ok s -> Printf.printf "JSON: %s\n" (String.trim s)
246
+
| Error e -> Printf.printf "JSON ERROR: %s\n" e);
252
247
(match Yamlt.encode_string ~format:Yamlt.Block codec v with
253
-
| Ok s -> Printf.printf "YAML Block:\n%s" s
254
-
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
255
-
(match Yamlt.encode_string ~format:Yamlt.Flow codec v with
256
-
| Ok s -> Printf.printf "YAML Flow: %s" s
257
-
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
248
+
| Ok s -> Printf.printf "YAML Block:\n%s" s
249
+
| Error e -> Printf.printf "YAML Block ERROR: %s\n" e);
250
+
match Yamlt.encode_string ~format:Yamlt.Flow codec v with
251
+
| Ok s -> Printf.printf "YAML Flow: %s" s
252
+
| Error e -> Printf.printf "YAML Flow ERROR: %s\n" e)
258
253
| _ -> failwith "unknown type"
259
254
260
255
let () =
···
266
261
end;
267
262
268
263
match Sys.argv.(1) with
269
-
| "null" when Array.length Sys.argv = 3 ->
270
-
test_null_resolution Sys.argv.(2)
271
-
272
-
| "bool" when Array.length Sys.argv = 3 ->
273
-
test_bool_resolution Sys.argv.(2)
274
-
264
+
| "null" when Array.length Sys.argv = 3 -> test_null_resolution Sys.argv.(2)
265
+
| "bool" when Array.length Sys.argv = 3 -> test_bool_resolution Sys.argv.(2)
275
266
| "number" when Array.length Sys.argv = 3 ->
276
267
test_number_resolution Sys.argv.(2)
277
-
278
268
| "string" when Array.length Sys.argv = 3 ->
279
269
test_string_resolution Sys.argv.(2)
280
-
281
270
| "special-float" when Array.length Sys.argv = 3 ->
282
271
test_special_floats Sys.argv.(2)
283
-
284
272
| "type-mismatch" when Array.length Sys.argv = 4 ->
285
273
test_type_mismatch Sys.argv.(2) Sys.argv.(3)
286
-
287
-
| "any" when Array.length Sys.argv = 3 ->
288
-
test_any_resolution Sys.argv.(2)
289
-
274
+
| "any" when Array.length Sys.argv = 3 -> test_any_resolution Sys.argv.(2)
290
275
| "encode" when Array.length Sys.argv = 4 ->
291
276
test_encode_formats Sys.argv.(2) Sys.argv.(3)
292
-
293
277
| _ ->
294
278
prerr_endline usage;
295
279
prerr_endline "Commands:";
296
280
prerr_endline " null <file> - Test null resolution";
297
-
prerr_endline " bool <file> - Test bool vs string resolution";
281
+
prerr_endline
282
+
" bool <file> - Test bool vs string resolution";
298
283
prerr_endline " number <file> - Test number resolution";
299
284
prerr_endline " string <file> - Test string resolution";
300
285
prerr_endline " special-float <file> - Test .inf, .nan, etc.";
301
-
prerr_endline " type-mismatch <file> <type> - Test error on type mismatch";
302
-
prerr_endline " any <file> - Test Jsont.any auto-resolution";
286
+
prerr_endline
287
+
" type-mismatch <file> <type> - Test error on type mismatch";
288
+
prerr_endline
289
+
" any <file> - Test Jsont.any auto-resolution";
303
290
prerr_endline " encode <type> <value> - Test encoding to JSON/YAML";
304
291
exit 1
+17
-13
tests/bin/test_some_vs_option.ml
+17
-13
tests/bin/test_some_vs_option.ml
···
2
2
(* Using Jsont.some like opt_mem does *)
3
3
let codec1 =
4
4
Jsont.Object.map ~kind:"Test" (fun arr -> arr)
5
-
|> Jsont.Object.mem "values" (Jsont.some (Jsont.array Jsont.string)) ~enc:(fun arr -> arr)
5
+
|> Jsont.Object.mem "values"
6
+
(Jsont.some (Jsont.array Jsont.string))
7
+
~enc:(fun arr -> arr)
6
8
|> Jsont.Object.finish
7
9
in
8
10
···
10
12
11
13
Printf.printf "Test 1: Jsont.some (Jsont.array) - like opt_mem:\n";
12
14
(match Yamlt.decode_string codec1 yaml with
13
-
| Ok arr ->
14
-
(match arr with
15
-
| None -> Printf.printf "Result: None\n"
16
-
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
17
-
| Error e -> Printf.printf "Error: %s\n" e);
15
+
| Ok arr -> (
16
+
match arr with
17
+
| None -> Printf.printf "Result: None\n"
18
+
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
19
+
| Error e -> Printf.printf "Error: %s\n" e);
18
20
19
21
(* Using Jsont.option *)
20
22
let codec2 =
21
23
Jsont.Object.map ~kind:"Test" (fun arr -> arr)
22
-
|> Jsont.Object.mem "values" (Jsont.option (Jsont.array Jsont.string)) ~enc:(fun arr -> arr)
24
+
|> Jsont.Object.mem "values"
25
+
(Jsont.option (Jsont.array Jsont.string))
26
+
~enc:(fun arr -> arr)
23
27
|> Jsont.Object.finish
24
28
in
25
29
26
30
Printf.printf "\nTest 2: Jsont.option (Jsont.array):\n";
27
-
(match Yamlt.decode_string codec2 yaml with
28
-
| Ok arr ->
29
-
(match arr with
30
-
| None -> Printf.printf "Result: None\n"
31
-
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
32
-
| Error e -> Printf.printf "Error: %s\n" e)
31
+
match Yamlt.decode_string codec2 yaml with
32
+
| Ok arr -> (
33
+
match arr with
34
+
| None -> Printf.printf "Result: None\n"
35
+
| Some a -> Printf.printf "Result: Some([%d items])\n" (Array.length a))
36
+
| Error e -> Printf.printf "Error: %s\n" e
+5
yamlt.opam
+5
yamlt.opam
···
3
3
synopsis: "YAML codec using Jsont type descriptions"
4
4
description:
5
5
"Allows the same Jsont.t codec definitions to work for both JSON and YAML"
6
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy"]
8
+
license: "ISC"
9
+
homepage: "https://tangled.org/@anil.recoil.org/ocaml-yamlt"
10
+
bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-yamlt/issues"
6
11
depends: [
7
12
"dune" {>= "3.18"}
8
13
"ocaml" {>= "4.14.0"}