Minimal dependency-free XML parser and serializer
Clean up debug files, update serialization libraries
Remove ocaml-rice/test/debug/ (temporary libaec debug stubs).
Update ocaml-crypto, ocaml-csvt, ocaml-sexpt, ocaml-tomlt, ocaml-xmlt.
+138
-125
+11
-13
bench/bench_xmlt.ml
+11
-13
bench/bench_xmlt.ml
···
9
9
let buf = Buffer.create 4096 in
10
10
Buffer.add_string buf "<?xml version=\"1.0\"?>\n";
11
11
let rec node d =
12
-
let tag = Printf.sprintf "level%d" d in
12
+
let tag = Fmt.str "level%d" d in
13
13
Buffer.add_char buf '<';
14
14
Buffer.add_string buf tag;
15
15
for i = 0 to attr_count - 1 do
···
47
47
in
48
48
let alloc_per_round = alloc_words /. float_of_int rounds in
49
49
let alloc_per_byte = alloc_per_round /. float_of_int len in
50
-
Printf.printf
51
-
"%-30s input=%6d bytes alloc=%.0f words/round (%.1f words/byte)\n%!" name
52
-
len alloc_per_round alloc_per_byte
50
+
Fmt.pr "%-30s input=%6d bytes alloc=%.0f words/round (%.1f words/byte)\n%!"
51
+
name len alloc_per_round alloc_per_byte
53
52
54
53
let bench_codec name xml codec rounds =
55
54
let len = String.length xml in
···
70
69
in
71
70
let alloc_per_round = alloc_words /. float_of_int rounds in
72
71
let alloc_per_byte = alloc_per_round /. float_of_int len in
73
-
Printf.printf
74
-
"%-30s input=%6d bytes alloc=%.0f words/round (%.1f words/byte)\n%!" name
75
-
len alloc_per_round alloc_per_byte
72
+
Fmt.pr "%-30s input=%6d bytes alloc=%.0f words/round (%.1f words/byte)\n%!"
73
+
name len alloc_per_round alloc_per_byte
76
74
77
75
let () =
78
-
Printf.printf "=== xmlt allocation benchmark ===\n\n";
79
-
Printf.printf "--- Tree parse + serialize ---\n%!";
76
+
Fmt.pr "=== xmlt allocation benchmark ===\n\n";
77
+
Fmt.pr "--- Tree parse + serialize ---\n%!";
80
78
81
79
let small = gen_xml ~depth:2 ~children:3 ~attr_count:2 in
82
80
let medium = gen_xml ~depth:3 ~children:5 ~attr_count:3 in
···
92
90
bench "deep (depth=50)" deep 1000;
93
91
bench "attr-heavy (50 attrs)" attrvy 1000;
94
92
95
-
Printf.printf "\n--- Codec decode + encode ---\n%!";
93
+
Fmt.pr "\n--- Codec decode + encode ---\n%!";
96
94
97
95
(* Simple record codec *)
98
96
let person_xml =
···
150
148
let text_codec = Xmlt.(element "message" string) in
151
149
bench_codec "codec: text element" text_xml text_codec 10000;
152
150
153
-
Printf.printf "\n--- Summary ---\n%!";
154
-
Printf.printf "word_size=%d bytes\n%!" word_size;
151
+
Fmt.pr "\n--- Summary ---\n%!";
152
+
Fmt.pr "word_size=%d bytes\n%!" word_size;
155
153
156
154
(* Check live memory after all benchmarks *)
157
155
Gc.compact ();
158
156
let s = Gc.stat () in
159
-
Printf.printf "live_words=%d (%d KB)\n%!" s.Gc.live_words
157
+
Fmt.pr "live_words=%d (%d KB)\n%!" s.Gc.live_words
160
158
(s.Gc.live_words * word_size / 1024)
+1
-1
bench/dune
+1
-1
bench/dune
+1
dune-project
+1
dune-project
+11
-11
fuzz/dune
+11
-11
fuzz/dune
···
1
-
; Crowbar fuzz testing for XML parsing
2
-
;
3
-
; Quick check (runs tests with random inputs):
4
-
; dune build @fuzz
5
-
;
6
-
; With AFL instrumentation (use crow orchestrator):
7
-
; crow start --cpus=4
8
-
9
1
(executable
10
2
(name fuzz)
11
3
(modules fuzz fuzz_xmlt)
12
-
(libraries xmlt alcobar))
4
+
(libraries xmlt alcobar fmt))
5
+
6
+
(executable
7
+
(name gen_corpus)
8
+
(modules gen_corpus)
9
+
(libraries unix))
13
10
14
11
(rule
15
12
(alias runtest)
···
25
22
(alias fuzz)
26
23
(enabled_if
27
24
(= %{profile} afl))
28
-
(deps fuzz.exe)
25
+
(deps
26
+
fuzz.exe
27
+
gen_corpus.exe
28
+
(source_tree corpus))
29
29
(action
30
30
(progn
31
-
(run %{exe:fuzz.exe} --gen-corpus corpus)
31
+
(run %{exe:gen_corpus.exe})
32
32
(run afl-fuzz -V 60 -i corpus -o _fuzz -- %{exe:fuzz.exe} @@))))
+19
-25
fuzz/fuzz_xmlt.ml
+19
-25
fuzz/fuzz_xmlt.ml
···
21
21
match Xmlt.Tree.of_string s1 with
22
22
| Error e ->
23
23
failwith
24
-
(Printf.sprintf
24
+
(Fmt.str
25
25
"roundtrip failed: parsed then serialized, but could not \
26
26
re-parse: %s\n\
27
27
Serialized: %s"
···
30
30
let s2 = Xmlt.Tree.to_string el2 in
31
31
if s1 <> s2 then
32
32
failwith
33
-
(Printf.sprintf "roundtrip mismatch:\n first: %s\n second: %s"
34
-
s1 s2))
33
+
(Fmt.str "roundtrip mismatch:\n first: %s\n second: %s" s1 s2))
35
34
36
35
(* ── Generators for valid-ish XML ─────────────────────────────────── *)
37
36
···
88
87
(* Generate a random attribute pair *)
89
88
let xml_attr : string gen =
90
89
map [ xml_name; xml_attr_value ] (fun name value ->
91
-
Printf.sprintf " %s=\"%s\"" name value)
90
+
Fmt.str " %s=\"%s\"" name value)
92
91
93
92
(* Generate a valid XML element (possibly with children, bounded depth) *)
94
93
let xml_element : string gen =
···
98
97
(* Self-closing element *)
99
98
map
100
99
[ xml_name; list xml_attr ]
101
-
(fun tag attrs ->
102
-
Printf.sprintf "<%s%s/>" tag (String.concat "" attrs));
100
+
(fun tag attrs -> Fmt.str "<%s%s/>" tag (String.concat "" attrs));
103
101
(* Element with text content *)
104
102
map
105
103
[ xml_name; list xml_attr; xml_safe_text ]
106
104
(fun tag attrs text ->
107
-
Printf.sprintf "<%s%s>%s</%s>" tag (String.concat "" attrs) text
108
-
tag);
105
+
Fmt.str "<%s%s>%s</%s>" tag (String.concat "" attrs) text tag);
109
106
(* Element with one child (limits depth via randomness) *)
110
107
map [ xml_name; self ] (fun tag child ->
111
-
Printf.sprintf "<%s>%s</%s>" tag child tag);
108
+
Fmt.str "<%s>%s</%s>" tag child tag);
112
109
])
113
110
114
111
(* ── Parse random bytes then roundtrip ────────────────────────────── *)
···
122
119
match Xmlt.Tree.of_string s1 with
123
120
| Error e ->
124
121
Alcobar.fail
125
-
(Printf.sprintf "re-parse failed after serialize: %s\nXML: %s" e s1)
122
+
(Fmt.str "re-parse failed after serialize: %s\nXML: %s" e s1)
126
123
| Ok el2 ->
127
124
let s2 = Xmlt.Tree.to_string el2 in
128
125
if s1 <> s2 then
129
126
Alcobar.fail
130
-
(Printf.sprintf "roundtrip mismatch:\n first: %s\n second: %s"
131
-
s1 s2))
127
+
(Fmt.str "roundtrip mismatch:\n first: %s\n second: %s" s1 s2))
132
128
133
129
(* ── Generated valid XML should always parse ──────────────────────── *)
134
130
···
136
132
match Xmlt.Tree.of_string xml with
137
133
| Ok _ -> ()
138
134
| Error e ->
139
-
Alcobar.fail
140
-
(Printf.sprintf "valid-ish XML failed to parse: %s\nXML: %s" e xml)
135
+
Alcobar.fail (Fmt.str "valid-ish XML failed to parse: %s\nXML: %s" e xml)
141
136
142
137
(* ── Generated valid XML roundtrips ───────────────────────────────── *)
143
138
···
152
147
match Xmlt.Tree.of_string s1 with
153
148
| Error e ->
154
149
Alcobar.fail
155
-
(Printf.sprintf
150
+
(Fmt.str
156
151
"roundtrip failed on generated XML: %s\n\
157
152
Original: %s\n\
158
153
Serialized: %s"
···
161
156
let s2 = Xmlt.Tree.to_string el2 in
162
157
if s1 <> s2 then
163
158
Alcobar.fail
164
-
(Printf.sprintf
159
+
(Fmt.str
165
160
"roundtrip mismatch on generated XML:\n\
166
161
\ first: %s\n\
167
162
\ second: %s"
···
187
182
match Xmlt.decode_string codec encoded with
188
183
| Error e ->
189
184
Alcobar.fail
190
-
(Printf.sprintf "codec string roundtrip failed: %s\nvalue: %S\nXML: %s"
191
-
e value encoded)
185
+
(Fmt.str "codec string roundtrip failed: %s\nvalue: %S\nXML: %s" e value
186
+
encoded)
192
187
| Ok decoded ->
193
188
if value <> decoded then
194
189
Alcobar.fail
195
-
(Printf.sprintf
190
+
(Fmt.str
196
191
"codec string roundtrip mismatch:\n original: %S\n decoded: %S"
197
192
value decoded)
198
193
···
202
197
let encoded = Xmlt.encode_string codec value in
203
198
match Xmlt.decode_string codec encoded with
204
199
| Error e ->
205
-
Alcobar.fail
206
-
(Printf.sprintf "codec int roundtrip failed: %s\nvalue: %d" e value)
200
+
Alcobar.fail (Fmt.str "codec int roundtrip failed: %s\nvalue: %d" e value)
207
201
| Ok decoded ->
208
202
if value <> decoded then
209
203
Alcobar.fail
210
-
(Printf.sprintf "codec int roundtrip mismatch: %d vs %d" value decoded)
204
+
(Fmt.str "codec int roundtrip mismatch: %d vs %d" value decoded)
211
205
212
206
(* Codec roundtrip for record with special-char attribute values *)
213
207
let test_codec_attr_roundtrip value =
···
220
214
match Xmlt.decode_string codec encoded with
221
215
| Error e ->
222
216
Alcobar.fail
223
-
(Printf.sprintf "codec attr roundtrip failed: %s\nvalue: %S\nXML: %s" e
224
-
value encoded)
217
+
(Fmt.str "codec attr roundtrip failed: %s\nvalue: %S\nXML: %s" e value
218
+
encoded)
225
219
| Ok decoded ->
226
220
if value <> decoded then
227
221
Alcobar.fail
228
-
(Printf.sprintf
222
+
(Fmt.str
229
223
"codec attr roundtrip mismatch:\n original: %S\n decoded: %S"
230
224
value decoded)
231
225
+27
fuzz/gen_corpus.ml
+27
fuzz/gen_corpus.ml
···
1
+
let () =
2
+
let dir = "corpus" in
3
+
(try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
4
+
let write name content =
5
+
let oc = open_out (Filename.concat dir name) in
6
+
output_string oc content;
7
+
close_out oc
8
+
in
9
+
write "empty.xml" "<root/>";
10
+
write "text.xml" "<root>hello world</root>";
11
+
write "attrs.xml" {|<root a="1" b="2" c="3"/>|};
12
+
write "nested.xml" "<a><b><c>deep</c></b></a>";
13
+
write "list.xml" "<items><item>1</item><item>2</item><item>3</item></items>";
14
+
write "mixed.xml" "<p>Hello <b>world</b> and <i>more</i></p>";
15
+
write "cdata.xml" "<data><![CDATA[<not & xml>]]></data>";
16
+
write "entities.xml" "<t>&<>"'</t>";
17
+
write "ns.xml"
18
+
{|<ns:root xmlns:ns="http://example.com"><ns:child/></ns:root>|};
19
+
write "large.xml"
20
+
(let buf = Buffer.create 4096 in
21
+
Buffer.add_string buf "<root>";
22
+
for i = 0 to 99 do
23
+
Printf.bprintf buf "<item id=\"%d\">value %d</item>" i i
24
+
done;
25
+
Buffer.add_string buf "</root>";
26
+
Buffer.contents buf);
27
+
Printf.printf "Generated %d corpus files in %s/\n" 10 dir
+1
-1
lib/dune
+1
-1
lib/dune
+32
-42
lib/xmlt.ml
+32
-42
lib/xmlt.ml
···
137
137
ensure s len;
138
138
let avail = s.buf_len - s.buf_pos in
139
139
if avail < len then
140
-
Error (Printf.sprintf "unexpected end of input, expected %S" str)
140
+
Error (Fmt.str "unexpected end of input, expected %S" str)
141
141
else
142
142
let rec check i =
143
143
if i >= len then begin
···
146
146
Ok ()
147
147
end
148
148
else if Stdlib.Bytes.get s.buf (s.buf_pos + i) <> str.[i] then
149
-
Error (Printf.sprintf "expected %S at position %d" str s.total_pos)
149
+
Error (Fmt.str "expected %S at position %d" str s.total_pos)
150
150
else check (i + 1)
151
151
in
152
152
check 0
···
159
159
160
160
let parse_name s =
161
161
match peek s with
162
-
| None ->
163
-
Error
164
-
(Printf.sprintf "expected element name at position %d" s.total_pos)
162
+
| None -> Error (Fmt.str "expected element name at position %d" s.total_pos)
165
163
| Some c when not (is_name_start_char c) ->
166
-
Error
167
-
(Printf.sprintf "expected element name at position %d" s.total_pos)
164
+
Error (Fmt.str "expected element name at position %d" s.total_pos)
168
165
| _ ->
169
166
let nbuf = Buffer.create 16 in
170
167
let rec loop () =
···
186
183
| "gt" -> Ok '>'
187
184
| "quot" -> Ok '"'
188
185
| "apos" -> Ok '\''
189
-
| name -> Error (Printf.sprintf "unknown entity reference: &%s;" name)
186
+
| name -> Error (Fmt.str "unknown entity reference: &%s;" name)
190
187
191
188
let decode_char_ref s =
192
189
let n =
···
194
191
else int_of_string_opt s
195
192
in
196
193
match n with
197
-
| None -> Error (Printf.sprintf "invalid character reference: &#%s;" s)
194
+
| None -> Error (Fmt.str "invalid character reference: &#%s;" s)
198
195
| Some code ->
199
196
if code < 0 || code > 0x10FFFF then
200
-
Error (Printf.sprintf "character reference out of range: &#%s;" s)
197
+
Error (Fmt.str "character reference out of range: &#%s;" s)
201
198
else
202
199
let buf = Buffer.create 4 in
203
200
if code < 0x80 then Buffer.add_char buf (Char.chr code)
···
260
257
let quote = consume s in
261
258
if quote <> '"' && quote <> '\'' then
262
259
Error
263
-
(Printf.sprintf "expected quote character at position %d"
264
-
(s.total_pos - 1))
260
+
(Fmt.str "expected quote character at position %d" (s.total_pos - 1))
265
261
else
266
262
let buf = Buffer.create 32 in
267
263
let rec loop () =
···
452
448
| Ok close_tag ->
453
449
if close_tag <> tag then
454
450
Error
455
-
(Printf.sprintf "mismatched tags: opened <%s> but closed </%s>"
456
-
tag close_tag)
451
+
(Fmt.str "mismatched tags: opened <%s> but closed </%s>" tag
452
+
close_tag)
457
453
else begin
458
454
skip_ws s;
459
455
expect_string s ">"
···
660
656
mutable in_start_tag : bool;
661
657
}
662
658
663
-
let make_encoder ?(indent = 0) w =
664
-
{ w; indent; depth = 0; in_start_tag = false }
659
+
let encoder ?(indent = 0) w = { w; indent; depth = 0; in_start_tag = false }
665
660
666
661
let enc_start_tag (e : encoder) tag =
667
662
if e.indent > 0 && e.depth > 0 then begin
···
920
915
(fun s ->
921
916
match int_of_string_opt s with
922
917
| Some n -> Ok n
923
-
| None ->
924
-
Error (Printf.sprintf "expected integer attribute, got %S" s));
918
+
| None -> Error (Fmt.str "expected integer attribute, got %S" s));
925
919
enc = string_of_int;
926
920
}
927
921
···
931
925
(fun s ->
932
926
match float_of_string_opt s with
933
927
| Some f -> Ok f
934
-
| None -> Error (Printf.sprintf "expected float attribute, got %S" s));
928
+
| None -> Error (Fmt.str "expected float attribute, got %S" s));
935
929
enc = string_of_float;
936
930
}
937
931
···
942
936
match String.lowercase_ascii s with
943
937
| "true" -> Ok true
944
938
| "false" -> Ok false
945
-
| _ -> Error (Printf.sprintf "expected boolean attribute, got %S" s));
939
+
| _ -> Error (Fmt.str "expected boolean attribute, got %S" s));
946
940
enc = string_of_bool;
947
941
}
948
942
···
1037
1031
m.base_dec s
1038
1032
| Element (tag, inner) ->
1039
1033
if el.Tree.tag <> tag then
1040
-
Error (Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag)
1034
+
Error (Fmt.str "expected element <%s>, got <%s>" tag el.Tree.tag)
1041
1035
else dec_tree inner el
1042
1036
| El (tag, map) ->
1043
1037
if tag <> "" && el.Tree.tag <> tag then
1044
-
Error (Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag)
1038
+
Error (Fmt.str "expected element <%s>, got <%s>" tag el.Tree.tag)
1045
1039
else dec_tree_el map el
1046
1040
| Raw -> Ok el
1047
1041
| Map mw -> (
···
1107
1101
match field with
1108
1102
| Attr (name, codec, id, _enc) -> (
1109
1103
match List.assoc_opt name attrs with
1110
-
| None ->
1111
-
Error (Printf.sprintf "missing required attribute %S on element" name)
1104
+
| None -> Error (Fmt.str "missing required attribute %S on element" name)
1112
1105
| Some s -> (
1113
1106
match codec.dec s with
1114
1107
| Ok v -> Ok (Dict.add id v dict)
···
1130
1123
loop children
1131
1124
in
1132
1125
match child_el with
1133
-
| None -> Error (Printf.sprintf "missing required child element <%s>" tag)
1126
+
| None -> Error (Fmt.str "missing required child element <%s>" tag)
1134
1127
| Some el -> (
1135
1128
match dec_tree inner el with
1136
1129
| Ok v -> Ok (Dict.add id v dict)
···
1182
1175
| Ok text -> m.base_dec (String.trim text))
1183
1176
| Element (el_tag, inner) -> (
1184
1177
if tag <> el_tag then
1185
-
Error (Printf.sprintf "expected element <%s>, got <%s>" el_tag tag)
1178
+
Error (Fmt.str "expected element <%s>, got <%s>" el_tag tag)
1186
1179
else
1187
1180
let result = dec_stream inner s ~tag ~attrs ~self_close in
1188
1181
if self_close then result
···
1195
1188
| Ok () -> Ok v))
1196
1189
| El (el_tag, map) -> (
1197
1190
if el_tag <> "" && tag <> el_tag then
1198
-
Error (Printf.sprintf "expected element <%s>, got <%s>" el_tag tag)
1191
+
Error (Fmt.str "expected element <%s>, got <%s>" el_tag tag)
1199
1192
else
1200
1193
let result = dec_stream_el map s ~attrs ~self_close in
1201
1194
if self_close then result
···
1356
1349
(fun s ->
1357
1350
match int_of_string_opt s with
1358
1351
| Some n -> Ok n
1359
-
| None -> Error (Printf.sprintf "expected integer, got %S" s));
1352
+
| None -> Error (Fmt.str "expected integer, got %S" s));
1360
1353
base_enc = string_of_int;
1361
1354
}
1362
1355
···
1368
1361
(fun s ->
1369
1362
match float_of_string_opt s with
1370
1363
| Some f -> Ok f
1371
-
| None -> Error (Printf.sprintf "expected float, got %S" s));
1364
+
| None -> Error (Fmt.str "expected float, got %S" s));
1372
1365
base_enc = string_of_float;
1373
1366
}
1374
1367
···
1381
1374
match String.lowercase_ascii s with
1382
1375
| "true" -> Ok true
1383
1376
| "false" -> Ok false
1384
-
| _ -> Error (Printf.sprintf "expected boolean, got %S" s));
1377
+
| _ -> Error (Fmt.str "expected boolean, got %S" s));
1385
1378
base_enc = string_of_bool;
1386
1379
}
1387
1380
···
1490
1483
1491
1484
let decode_stream codec s =
1492
1485
match P.skip_preamble s with
1493
-
| Error e -> Error (Printf.sprintf "parse error: %s" e)
1486
+
| Error e -> Error (Fmt.str "parse error: %s" e)
1494
1487
| Ok () -> (
1495
1488
if P.at_end s then Error "parse error: empty document: no root element"
1496
1489
else
1497
1490
match P.parse_start_tag s with
1498
-
| Error e -> Error (Printf.sprintf "parse error: %s" e)
1491
+
| Error e -> Error (Fmt.str "parse error: %s" e)
1499
1492
| Ok (tag, attrs, self_close) -> (
1500
1493
match dec_stream codec s ~tag ~attrs ~self_close with
1501
1494
| Error e -> Error e
···
1508
1501
1509
1502
let encode_string ?(indent = 0) codec v =
1510
1503
let buf = Buffer.create 256 in
1511
-
let e = make_encoder ~indent (Buffer.add_string buf) in
1504
+
let e = encoder ~indent (Buffer.add_string buf) in
1512
1505
enc_value codec e v;
1513
1506
Buffer.contents buf
1514
1507
···
1517
1510
decode_stream codec stream
1518
1511
1519
1512
let encode ?(indent = 0) codec v writer =
1520
-
let e = make_encoder ~indent (Bytes.Writer.write_string writer) in
1513
+
let e = encoder ~indent (Bytes.Writer.write_string writer) in
1521
1514
enc_value codec e v
1522
1515
1523
1516
(* ── Queries ─────────────────────────────────────────────────────────── *)
1524
1517
1525
-
let get_child tag c =
1518
+
let child tag c =
1526
1519
(* Build an El with a single required child field that extracts the
1527
1520
child with the given tag and decodes it with c. The El uses an
1528
1521
empty-string sentinel tag so it matches any outer element. *)
···
1535
1528
el_needs_children = true;
1536
1529
} )
1537
1530
1538
-
let get_attr name =
1531
+
let attr name =
1539
1532
(* Build an El with a single required attribute field *)
1540
1533
let id = Type.Id.make () in
1541
1534
El
···
1546
1539
el_needs_children = false;
1547
1540
} )
1548
1541
1549
-
let get_nth n c =
1542
+
let nth n c =
1550
1543
(* Map over a List codec that extracts the nth child element *)
1551
1544
Map
1552
1545
{
···
1557
1550
| Some v -> Ok v
1558
1551
| None ->
1559
1552
Error
1560
-
(Printf.sprintf
1561
-
"index %d out of bounds (element has %d children)" n
1553
+
(Fmt.str "index %d out of bounds (element has %d children)" n
1562
1554
(List.length items)));
1563
1555
map_enc = (fun v -> [ v ]);
1564
1556
}
···
1582
1574
match dec_tree c child_el with
1583
1575
| Ok v -> (
1584
1576
let buf = Buffer.create 64 in
1585
-
let e =
1586
-
make_encoder ~indent:0 (Buffer.add_string buf)
1587
-
in
1577
+
let e = encoder ~indent:0 (Buffer.add_string buf) in
1588
1578
enc_start_tag e tag;
1589
1579
enc_value c e v;
1590
1580
if e.in_start_tag then enc_end_tag_empty e
+13
-10
lib/xmlt.mli
+13
-10
lib/xmlt.mli
···
32
32
{v
33
33
let () =
34
34
match Xmlt.decode_string person "<person name=\"Alice\" age=\"30\"/>" with
35
-
| Ok p -> Printf.printf "Name: %s\n" p.name
35
+
| Ok p -> Fmt.pr "Name: %s\n" p.name
36
36
| Error e -> prerr_endline e
37
37
v}
38
38
···
65
65
66
66
A value of type ['a t] can decode XML elements to type ['a] and encode
67
67
values of type ['a] to XML elements. *)
68
+
69
+
val pp : 'a t Fmt.t
70
+
(** [pp] pretty-prints the codec structure (for debugging). *)
68
71
69
72
val string : string t
70
73
(** Codec for text content as a string. *)
···
268
271
equivalent of Jsont's "soup" approach: they navigate into the structure of
269
272
an already-parsed element. *)
270
273
271
-
val get_child : string -> 'a t -> 'a t
272
-
(** [get_child tag c] queries a child element by tag name. On decoding, finds
273
-
the first direct child element with [tag] and decodes it with [c]. Other
274
+
val child : string -> 'a t -> 'a t
275
+
(** [child tag c] queries a child element by tag name. On decoding, finds the
276
+
first direct child element with [tag] and decodes it with [c]. Other
274
277
children are ignored. Errors if no child with that tag exists. *)
275
278
276
-
val get_attr : string -> string t
277
-
(** [get_attr name] queries an attribute value. On decoding, extracts the string
279
+
val attr : string -> string t
280
+
(** [attr name] queries an attribute value. On decoding, extracts the string
278
281
value of attribute [name] from the element. Errors if the attribute is
279
282
absent. *)
280
283
281
-
val get_nth : int -> 'a t -> 'a t
282
-
(** [get_nth n c] queries the [n]th child element. On decoding, collects all
283
-
child elements, decodes them with [c], and returns the [n]th one. Errors if
284
-
[n] is out of bounds. *)
284
+
val nth : int -> 'a t -> 'a t
285
+
(** [nth n c] queries the [n]th child element. On decoding, collects all child
286
+
elements, decodes them with [c], and returns the [n]th one. Errors if [n] is
287
+
out of bounds. *)
285
288
286
289
(** {1:updates Updates} *)
287
290
+1
-1
test/dune
+1
-1
test/dune
+20
-21
test/test_xmlt.ml
+20
-21
test/test_xmlt.ml
···
8
8
let parse_ok s =
9
9
match Xmlt.Tree.of_string s with
10
10
| Ok el -> el
11
-
| Error e -> Alcotest.fail (Printf.sprintf "parse error: %s" e)
11
+
| Error e -> Alcotest.fail (Fmt.str "parse error: %s" e)
12
12
13
13
let parse_err s =
14
14
match Xmlt.Tree.of_string s with
···
155
155
let el2 = parse_ok serialized in
156
156
let reserialized = Xmlt.Tree.to_string el2 in
157
157
Alcotest.(check string)
158
-
(Printf.sprintf "roundtrip: %s" input)
158
+
(Fmt.str "roundtrip: %s" input)
159
159
serialized reserialized)
160
160
inputs
161
161
···
354
354
let decode_ok codec s =
355
355
match Xmlt.decode_string codec s with
356
356
| Ok v -> v
357
-
| Error e -> Alcotest.fail (Printf.sprintf "decode error: %s" e)
357
+
| Error e -> Alcotest.fail (Fmt.str "decode error: %s" e)
358
358
359
359
let decode_err codec s =
360
360
match Xmlt.decode_string codec s with
···
462
462
Alcotest.(check (option string))
463
463
"email roundtrip" (Some "a@b.c") decoded.email
464
464
465
-
let test_codec_record_children_roundtrip_none () =
465
+
let test_codec_record_children_rt_none () =
466
466
let p = { name = "Bob"; age = 25; email = None } in
467
467
let encoded = Xmlt.encode_string person_codec p in
468
468
let decoded = decode_ok person_codec encoded in
···
605
605
~dec:(fun s ->
606
606
match int_of_string_opt ("0x" ^ s) with
607
607
| Some n -> Ok n
608
-
| None -> Error (Printf.sprintf "bad hex: %S" s))
609
-
~enc:(fun n -> Printf.sprintf "%x" n)
608
+
| None -> Error (Fmt.str "bad hex: %S" s))
609
+
~enc:(fun n -> Fmt.str "%x" n)
610
610
Xmlt.string
611
611
in
612
612
let codec = Xmlt.element "hex" hex_codec in
···
619
619
let reader = Bytesrw.Bytes.Reader.of_string "<msg>hello</msg>" in
620
620
match Xmlt.decode codec reader with
621
621
| Ok v -> Alcotest.(check string) "bytesrw decode" "hello" v
622
-
| Error e -> Alcotest.fail (Printf.sprintf "bytesrw decode error: %s" e)
622
+
| Error e -> Alcotest.fail (Fmt.str "bytesrw decode error: %s" e)
623
623
624
624
let test_codec_bytesrw_encode () =
625
625
let codec = Xmlt.element "msg" Xmlt.string in
···
755
755
let test_long_attr_value () =
756
756
let len = 100_000 in
757
757
let value = String.make len 'v' in
758
-
let xml = Printf.sprintf {|<a x="%s"/>|} value in
758
+
let xml = Fmt.str {|<a x="%s"/>|} value in
759
759
let el = parse_ok xml in
760
760
Alcotest.(check (option string))
761
761
"long attr" (Some value) (Xmlt.Tree.attr "x" el)
···
766
766
let buf = Buffer.create (n * 20) in
767
767
Buffer.add_string buf "<a";
768
768
for i = 0 to n - 1 do
769
-
Buffer.add_string buf (Printf.sprintf " a%d=\"%d\"" i i)
769
+
Buffer.add_string buf (Fmt.str " a%d=\"%d\"" i i)
770
770
done;
771
771
Buffer.add_string buf "/>";
772
772
let el = parse_ok (Buffer.contents buf) in
···
776
776
Alcotest.(check (option string))
777
777
"last attr"
778
778
(Some (string_of_int (n - 1)))
779
-
(Xmlt.Tree.attr (Printf.sprintf "a%d" (n - 1)) el)
779
+
(Xmlt.Tree.attr (Fmt.str "a%d" (n - 1)) el)
780
780
781
781
(* 12. Many children on a single element *)
782
782
let test_many_children () =
···
784
784
let buf = Buffer.create (n * 10) in
785
785
Buffer.add_string buf "<root>";
786
786
for i = 0 to n - 1 do
787
-
Buffer.add_string buf (Printf.sprintf "<c>%d</c>" i)
787
+
Buffer.add_string buf (Fmt.str "<c>%d</c>" i)
788
788
done;
789
789
Buffer.add_string buf "</root>";
790
790
let el = parse_ok (Buffer.contents buf) in
···
833
833
Alcotest.(check string) "comment with --->" "r" el.tag
834
834
835
835
(* 18. Attribute value with both quote types *)
836
-
let test_attr_single_quote_with_dquote () =
836
+
let test_attr_squote_with_dquote () =
837
837
let el = parse_ok "<a x='value with \"quotes\"'/>" in
838
838
Alcotest.(check (option string))
839
839
"single-quoted with dquote" (Some "value with \"quotes\"")
···
1073
1073
let test_val s =
1074
1074
let encoded = Xmlt.encode_string codec s in
1075
1075
let decoded = decode_ok codec encoded in
1076
-
Alcotest.(check string) (Printf.sprintf "roundtrip %S" s) s decoded
1076
+
Alcotest.(check string) (Fmt.str "roundtrip %S" s) s decoded
1077
1077
in
1078
1078
test_val "hello & world";
1079
1079
test_val "a < b > c";
···
1082
1082
test_val "newlines\nand\ttabs"
1083
1083
1084
1084
(* Additional roundtrip: codec with special chars in attributes *)
1085
-
let test_codec_attr_special_chars_roundtrip () =
1085
+
let test_codec_attr_special_chars_rt () =
1086
1086
let p = { x = 1.0; y = 2.0; label = "a&b<c>d\"e" } in
1087
1087
let encoded = Xmlt.encode_string point_codec p in
1088
1088
let decoded = decode_ok point_codec encoded in
···
1119
1119
List.init n (fun i ->
1120
1120
Xmlt.Tree.Element
1121
1121
{
1122
-
tag = Printf.sprintf "item%d" i;
1122
+
tag = Fmt.str "item%d" i;
1123
1123
attrs = [ ("id", string_of_int i) ];
1124
1124
children = [ Xmlt.Tree.Text (string_of_int (i * i)) ];
1125
1125
})
···
1188
1188
let v = decode_ok codec "<items><a>x</a><b>y</b><c>z</c></items>" in
1189
1189
Alcotest.(check string) "get_nth 2" "z" v
1190
1190
1191
-
let test_get_nth_out_of_bounds () =
1191
+
let test_get_nth_oob () =
1192
1192
let codec = Xmlt.get_nth 5 Xmlt.string in
1193
1193
decode_err codec "<items><a>x</a></items>"
1194
1194
···
1301
1301
Alcotest.test_case "codec record children roundtrip" `Quick
1302
1302
test_codec_record_children_roundtrip;
1303
1303
Alcotest.test_case "codec record children roundtrip none" `Quick
1304
-
test_codec_record_children_roundtrip_none;
1304
+
test_codec_record_children_rt_none;
1305
1305
Alcotest.test_case "codec children list" `Quick test_codec_children_list;
1306
1306
Alcotest.test_case "codec children list empty" `Quick
1307
1307
test_codec_children_list_empty;
···
1364
1364
test_comment_triple_dash_end;
1365
1365
(* Attribute quoting *)
1366
1366
Alcotest.test_case "attr single quote with dquote" `Quick
1367
-
test_attr_single_quote_with_dquote;
1367
+
test_attr_squote_with_dquote;
1368
1368
Alcotest.test_case "attr single quotes" `Quick test_attr_single_quotes;
1369
1369
Alcotest.test_case "empty attr value" `Quick test_empty_attr_value;
1370
1370
(* Whitespace-only text *)
···
1418
1418
Alcotest.test_case "codec special chars roundtrip" `Quick
1419
1419
test_codec_special_chars_roundtrip;
1420
1420
Alcotest.test_case "codec attr special chars roundtrip" `Quick
1421
-
test_codec_attr_special_chars_roundtrip;
1421
+
test_codec_attr_special_chars_rt;
1422
1422
Alcotest.test_case "tree roundtrip mixed" `Quick test_tree_roundtrip_mixed;
1423
1423
Alcotest.test_case "tree roundtrip large" `Quick test_tree_roundtrip_large;
1424
1424
(* Queries *)
···
1432
1432
Alcotest.test_case "get_nth 1" `Quick test_get_nth;
1433
1433
Alcotest.test_case "get_nth 0" `Quick test_get_nth_first;
1434
1434
Alcotest.test_case "get_nth 2" `Quick test_get_nth_last;
1435
-
Alcotest.test_case "get_nth out of bounds" `Quick
1436
-
test_get_nth_out_of_bounds;
1435
+
Alcotest.test_case "get_nth out of bounds" `Quick test_get_nth_oob;
1437
1436
(* Updates *)
1438
1437
Alcotest.test_case "update_child" `Quick test_update_child;
1439
1438
(* Introspection *)