Minimal dependency-free XML parser and serializer
Redesign sexpt with GADT-based codec (Jsont soup paper)
Replace opaque closure record with a GADT that preserves codec
structure, following the approach from Buenzli's "An Alphabet for
Your Data Soups" paper:
- GADT constructors for each S-expression sort (Atom, List, Obj,
Any, Map, Rec, Variant, Pair, Triple, etc.)
- dec_fun GADT with Type.Id for unordered record member decoding
- Heterogeneous Dict for buffering typed member values
- Structural encode/decode by pattern matching on GADT
- New query/update API: get_mem, get_nth, update_mem, delete_mem
Internal redesign only — 'a t stays abstract, all existing tests
pass unchanged.
+611
-194
+27
bench/bench_xmlt.ml
+27
bench/bench_xmlt.ml
···
123
123
let items_codec = Xmlt.(element "items" (list (element "item" string))) in
124
124
bench_codec "codec: 100 items list" items_xml items_codec 1000;
125
125
126
+
(* Selective codec: decode only 2 attrs from element with many children *)
127
+
let selective_xml =
128
+
let buf = Buffer.create 4096 in
129
+
Buffer.add_string buf {|<doc name="test" version="42">|};
130
+
for i = 0 to 99 do
131
+
Printf.bprintf buf {|<entry id="%d"><data>%s</data></entry>|} i
132
+
(String.make 50 'x')
133
+
done;
134
+
Buffer.add_string buf "</doc>";
135
+
Buffer.contents buf
136
+
in
137
+
let selective_codec =
138
+
Xmlt.(
139
+
El.(
140
+
element "doc"
141
+
(obj (fun name version -> (name, version))
142
+
|> attr "name" Attr.string ~enc:(fun (n, _) -> n)
143
+
|> attr "version" Attr.int ~enc:(fun (_, v) -> v)
144
+
|> finish)))
145
+
in
146
+
bench_codec "codec: selective (attrs only)" selective_xml selective_codec 1000;
147
+
148
+
(* Base text codec: decode single text element *)
149
+
let text_xml = "<message>Hello World</message>" in
150
+
let text_codec = Xmlt.(element "message" string) in
151
+
bench_codec "codec: text element" text_xml text_codec 10000;
152
+
126
153
Printf.printf "\n--- Summary ---\n%!";
127
154
Printf.printf "word_size=%d bytes\n%!" word_size;
128
155
+584
-194
lib/xmlt.ml
+584
-194
lib/xmlt.ml
···
7
7
8
8
open Bytesrw
9
9
10
-
(* ── Internal XML tree ──────────────────────────────────────────────── *)
11
-
12
-
module Tree = struct
13
-
type node = Element of element | Text of string
14
-
15
-
and element = {
16
-
tag : string;
17
-
attrs : (string * string) list;
18
-
children : node list;
19
-
}
10
+
(* ── Low-level stream parser ──────────────────────────────────────── *)
20
11
21
-
(* --- Streaming parser --- *)
12
+
(* The stream parser is defined at the top level so that both the Tree
13
+
module (which builds a full in-memory tree) and the codec's streaming
14
+
decode path can share the same parsing primitives. *)
22
15
16
+
module P = struct
23
17
let buf_size = 8192
24
18
25
19
type stream = {
···
115
109
else check (i + 1)
116
110
in
117
111
check 0
112
+
113
+
let skip_n s n =
114
+
s.buf_pos <- s.buf_pos + n;
115
+
s.total_pos <- s.total_pos + n
118
116
119
117
let skip_while s f =
120
118
let continue = ref true in
···
329
327
let rec loop () =
330
328
if at_end s then Error "unterminated comment"
331
329
else if starts_with s "-->" then begin
332
-
s.buf_pos <- s.buf_pos + 3;
333
-
s.total_pos <- s.total_pos + 3;
330
+
skip_n s 3;
334
331
Ok ()
335
332
end
336
333
else begin
···
345
342
let rec loop () =
346
343
if at_end s then Error "unterminated processing instruction"
347
344
else if starts_with s "?>" then begin
348
-
s.buf_pos <- s.buf_pos + 2;
349
-
s.total_pos <- s.total_pos + 2;
345
+
skip_n s 2;
350
346
Ok ()
351
347
end
352
348
else begin
···
362
358
let rec loop () =
363
359
if at_end s then Error "unterminated CDATA section"
364
360
else if starts_with s "]]>" then begin
365
-
s.buf_pos <- s.buf_pos + 3;
366
-
s.total_pos <- s.total_pos + 3;
361
+
skip_n s 3;
367
362
Ok (Buffer.contents buf)
368
363
end
369
364
else begin
···
374
369
in
375
370
loop ()
376
371
377
-
let rec parse_element s =
378
-
skip_ws s;
379
-
match expect_string s "<" with
380
-
| Error e -> Error e
381
-
| Ok () -> (
382
-
match parse_name s with
383
-
| Error e -> Error e
384
-
| Ok tag -> (
385
-
match parse_attrs s with
386
-
| Error e -> Error e
387
-
| Ok attrs -> (
388
-
skip_ws s;
389
-
if starts_with s "/>" then begin
390
-
s.buf_pos <- s.buf_pos + 2;
391
-
s.total_pos <- s.total_pos + 2;
392
-
Ok { tag; attrs; children = [] }
393
-
end
394
-
else
395
-
match expect_string s ">" with
396
-
| Error e -> Error e
397
-
| Ok () -> (
398
-
match parse_children s with
399
-
| Error e -> Error e
400
-
| Ok children -> (
401
-
match expect_string s "</" with
402
-
| Error e -> Error e
403
-
| Ok () -> (
404
-
match parse_name s with
405
-
| Error e -> Error e
406
-
| Ok close_tag ->
407
-
if close_tag <> tag then
408
-
Error
409
-
(Printf.sprintf
410
-
"mismatched tags: opened <%s> but \
411
-
closed </%s>"
412
-
tag close_tag)
413
-
else begin
414
-
skip_ws s;
415
-
match expect_string s ">" with
416
-
| Error e -> Error e
417
-
| Ok () -> Ok { tag; attrs; children }
418
-
end))))))
419
-
420
-
and parse_children s =
421
-
let rec loop acc =
422
-
if at_end s then Error "unexpected end of input (unclosed tag)"
423
-
else if starts_with s "</" then Ok (List.rev acc)
424
-
else if starts_with s "<!--" then begin
425
-
s.buf_pos <- s.buf_pos + 4;
426
-
s.total_pos <- s.total_pos + 4;
427
-
match skip_comment s with Error e -> Error e | Ok () -> loop acc
428
-
end
429
-
else if starts_with s "<?" then begin
430
-
s.buf_pos <- s.buf_pos + 2;
431
-
s.total_pos <- s.total_pos + 2;
432
-
match skip_pi s with Error e -> Error e | Ok () -> loop acc
433
-
end
434
-
else if starts_with s "<![CDATA[" then begin
435
-
s.buf_pos <- s.buf_pos + 9;
436
-
s.total_pos <- s.total_pos + 9;
437
-
match parse_cdata s with
438
-
| Error e -> Error e
439
-
| Ok text -> loop (Text text :: acc)
440
-
end
441
-
else if starts_with s "<" then begin
442
-
match parse_element s with
443
-
| Error e -> Error e
444
-
| Ok el -> loop (Element el :: acc)
445
-
end
446
-
else begin
447
-
match parse_text s with
448
-
| Error e -> Error e
449
-
| Ok text ->
450
-
if String.length text > 0 then loop (Text text :: acc) else loop acc
451
-
end
452
-
in
453
-
loop []
454
-
455
372
let skip_xml_declaration s =
456
373
skip_ws s;
457
374
if starts_with s "<?xml" then begin
458
-
s.buf_pos <- s.buf_pos + 2;
459
-
s.total_pos <- s.total_pos + 2;
375
+
skip_n s 2;
460
376
match skip_pi s with Error e -> Error e | Ok () -> Ok ()
461
377
end
462
378
else Ok ()
···
474
390
else loop depth
475
391
in
476
392
(* Skip past "<!DOCTYPE" *)
477
-
s.buf_pos <- s.buf_pos + 9;
478
-
s.total_pos <- s.total_pos + 9;
393
+
skip_n s 9;
479
394
loop 0
480
395
end
481
396
else Ok ()
482
397
483
-
let of_reader reader =
484
-
let s = make_stream reader in
398
+
(* Skip preamble: XML declaration, DOCTYPE, comments, PIs *)
399
+
let skip_preamble s =
485
400
match skip_xml_declaration s with
486
401
| Error e -> Error e
487
-
| Ok () -> (
488
-
let rec skip_preamble () =
402
+
| Ok () ->
403
+
let rec loop () =
489
404
skip_ws s;
490
405
match skip_doctype s with
491
406
| Error e -> Error e
492
407
| Ok () ->
493
408
skip_ws s;
494
409
if starts_with s "<!--" then begin
495
-
s.buf_pos <- s.buf_pos + 4;
496
-
s.total_pos <- s.total_pos + 4;
410
+
skip_n s 4;
497
411
match skip_comment s with
498
412
| Error e -> Error e
499
-
| Ok () -> skip_preamble ()
413
+
| Ok () -> loop ()
500
414
end
501
415
else if starts_with s "<?" then begin
502
-
s.buf_pos <- s.buf_pos + 2;
503
-
s.total_pos <- s.total_pos + 2;
504
-
match skip_pi s with
505
-
| Error e -> Error e
506
-
| Ok () -> skip_preamble ()
416
+
skip_n s 2;
417
+
match skip_pi s with Error e -> Error e | Ok () -> loop ()
507
418
end
508
419
else Ok ()
509
420
in
510
-
match skip_preamble () with
421
+
loop ()
422
+
423
+
(* Parse a start tag: consumes '<', name, attrs. Leaves stream at
424
+
'/>' or '>'. Returns (tag, attrs, self_close). *)
425
+
let parse_start_tag s =
426
+
match expect_string s "<" with
427
+
| Error e -> Error e
428
+
| Ok () -> (
429
+
match parse_name s with
430
+
| Error e -> Error e
431
+
| Ok tag -> (
432
+
match parse_attrs s with
433
+
| Error e -> Error e
434
+
| Ok attrs -> (
435
+
skip_ws s;
436
+
if starts_with s "/>" then begin
437
+
skip_n s 2;
438
+
Ok (tag, attrs, true)
439
+
end
440
+
else
441
+
match expect_string s ">" with
442
+
| Error e -> Error e
443
+
| Ok () -> Ok (tag, attrs, false))))
444
+
445
+
(* Consume end tag </name> *)
446
+
let consume_end_tag s tag =
447
+
match expect_string s "</" with
448
+
| Error e -> Error e
449
+
| Ok () -> (
450
+
match parse_name s with
451
+
| Error e -> Error e
452
+
| Ok close_tag ->
453
+
if close_tag <> tag then
454
+
Error
455
+
(Printf.sprintf "mismatched tags: opened <%s> but closed </%s>"
456
+
tag close_tag)
457
+
else begin
458
+
skip_ws s;
459
+
expect_string s ">"
460
+
end)
461
+
end
462
+
463
+
(* ── Internal XML tree ──────────────────────────────────────────────── *)
464
+
465
+
module Tree = struct
466
+
type node = Element of element | Text of string
467
+
468
+
and element = {
469
+
tag : string;
470
+
attrs : (string * string) list;
471
+
children : node list;
472
+
}
473
+
474
+
(* --- Build tree from stream --- *)
475
+
476
+
let rec parse_element s =
477
+
P.skip_ws s;
478
+
match P.parse_start_tag s with
479
+
| Error e -> Error e
480
+
| Ok (tag, attrs, true) -> Ok { tag; attrs; children = [] }
481
+
| Ok (tag, attrs, false) -> (
482
+
match parse_children s with
511
483
| Error e -> Error e
512
-
| Ok () ->
513
-
if at_end s then Error "empty document: no root element"
514
-
else parse_element s)
484
+
| Ok children -> (
485
+
match P.consume_end_tag s tag with
486
+
| Error e -> Error e
487
+
| Ok () -> Ok { tag; attrs; children }))
488
+
489
+
and parse_children s =
490
+
let rec loop acc =
491
+
if P.at_end s then Error "unexpected end of input (unclosed tag)"
492
+
else if P.starts_with s "</" then Ok (List.rev acc)
493
+
else if P.starts_with s "<!--" then begin
494
+
P.skip_n s 4;
495
+
match P.skip_comment s with Error e -> Error e | Ok () -> loop acc
496
+
end
497
+
else if P.starts_with s "<?" then begin
498
+
P.skip_n s 2;
499
+
match P.skip_pi s with Error e -> Error e | Ok () -> loop acc
500
+
end
501
+
else if P.starts_with s "<![CDATA[" then begin
502
+
P.skip_n s 9;
503
+
match P.parse_cdata s with
504
+
| Error e -> Error e
505
+
| Ok text -> loop (Text text :: acc)
506
+
end
507
+
else if P.starts_with s "<" then begin
508
+
match parse_element s with
509
+
| Error e -> Error e
510
+
| Ok el -> loop (Element el :: acc)
511
+
end
512
+
else begin
513
+
match P.parse_text s with
514
+
| Error e -> Error e
515
+
| Ok text ->
516
+
if String.length text > 0 then loop (Text text :: acc) else loop acc
517
+
end
518
+
in
519
+
loop []
520
+
521
+
let of_reader reader =
522
+
let s = P.make_stream reader in
523
+
match P.skip_preamble s with
524
+
| Error e -> Error e
525
+
| Ok () ->
526
+
if P.at_end s then Error "empty document: no root element"
527
+
else parse_element s
515
528
516
529
let of_string s =
517
530
let reader = Bytes.Reader.of_string s in
···
691
704
enc_close_start_tag e;
692
705
e.w (Tree.escape_text text)
693
706
694
-
(* ── Codec types ────────────────────────────────────────────────────── *)
707
+
(* ── Stream-based element parser for codec decode ─────────────────── *)
695
708
696
-
(* The core codec type: decode consumes events from a decoder that has
697
-
already consumed the Start_element for the current element; encode
698
-
writes directly to an encoder.
709
+
(* These helpers parse XML elements directly from a P.stream for the
710
+
codec decode path. The codec never builds a Tree; instead it reads
711
+
attrs and children on-demand from the stream.
699
712
700
-
For decoding, the codec receives:
701
-
- attrs: the attributes from the Start_element event
702
-
- children: a lightweight representation of child elements for
703
-
random-access lookup (used by El)
713
+
For El codecs (which need random-access to children by tag name),
714
+
we collect all direct child elements into a lightweight list of
715
+
Tree.element values. This is cheaper than Tree.of_reader because:
716
+
- We only parse the scope needed by the current codec
717
+
- Text-only codecs skip child elements entirely
718
+
- We avoid the two-pass parse+decode pipeline *)
704
719
705
-
For simplicity and correctness (especially for El which needs random
706
-
access to children), the decode path works with a "parsed element"
707
-
representation. The key difference from before is that the encoder
708
-
path writes directly without building a tree. *)
720
+
(* Parse a complete element from the stream into a Tree.element.
721
+
The stream must be positioned at '<'. Returns the parsed element. *)
722
+
let rec stream_parse_element s =
723
+
match P.parse_start_tag s with
724
+
| Error e -> Error e
725
+
| Ok (tag, attrs, true) -> Ok { Tree.tag; attrs; children = [] }
726
+
| Ok (tag, attrs, false) -> (
727
+
match stream_parse_children s with
728
+
| Error e -> Error e
729
+
| Ok children -> (
730
+
match P.consume_end_tag s tag with
731
+
| Error e -> Error e
732
+
| Ok () -> Ok { Tree.tag; attrs; children }))
733
+
734
+
and stream_parse_children s =
735
+
let rec loop acc =
736
+
if P.at_end s then Error "unexpected end of input (unclosed tag)"
737
+
else if P.starts_with s "</" then Ok (List.rev acc)
738
+
else if P.starts_with s "<!--" then begin
739
+
P.skip_n s 4;
740
+
match P.skip_comment s with Error e -> Error e | Ok () -> loop acc
741
+
end
742
+
else if P.starts_with s "<?" then begin
743
+
P.skip_n s 2;
744
+
match P.skip_pi s with Error e -> Error e | Ok () -> loop acc
745
+
end
746
+
else if P.starts_with s "<![CDATA[" then begin
747
+
P.skip_n s 9;
748
+
match P.parse_cdata s with
749
+
| Error e -> Error e
750
+
| Ok text -> loop (Tree.Text text :: acc)
751
+
end
752
+
else if P.starts_with s "<" then begin
753
+
match stream_parse_element s with
754
+
| Error e -> Error e
755
+
| Ok el -> loop (Tree.Element el :: acc)
756
+
end
757
+
else begin
758
+
match P.parse_text s with
759
+
| Error e -> Error e
760
+
| Ok text ->
761
+
if String.length text > 0 then loop (Tree.Text text :: acc)
762
+
else loop acc
763
+
end
764
+
in
765
+
loop []
766
+
767
+
(* Read all text content from the stream, skipping child elements.
768
+
Stops at the closing </tag> but does NOT consume it.
769
+
Returns concatenated direct text content (matching Tree.text). *)
770
+
let rec stream_read_text s =
771
+
let buf = Buffer.create 64 in
772
+
let rec loop () =
773
+
if P.at_end s then Error "unexpected end of input (unclosed tag)"
774
+
else if P.starts_with s "</" then Ok (Buffer.contents buf)
775
+
else if P.starts_with s "<!--" then begin
776
+
P.skip_n s 4;
777
+
match P.skip_comment s with Error e -> Error e | Ok () -> loop ()
778
+
end
779
+
else if P.starts_with s "<?" then begin
780
+
P.skip_n s 2;
781
+
match P.skip_pi s with Error e -> Error e | Ok () -> loop ()
782
+
end
783
+
else if P.starts_with s "<![CDATA[" then begin
784
+
P.skip_n s 9;
785
+
match P.parse_cdata s with
786
+
| Error e -> Error e
787
+
| Ok text ->
788
+
Buffer.add_string buf text;
789
+
loop ()
790
+
end
791
+
else if P.starts_with s "<" then begin
792
+
(* Child element -- skip it entirely *)
793
+
match stream_skip_element s with
794
+
| Error e -> Error e
795
+
| Ok () -> loop ()
796
+
end
797
+
else begin
798
+
match P.parse_text s with
799
+
| Error e -> Error e
800
+
| Ok text ->
801
+
if String.length text > 0 then Buffer.add_string buf text;
802
+
loop ()
803
+
end
804
+
in
805
+
loop ()
806
+
807
+
(* Skip a complete element (from '<' through closing tag) *)
808
+
and stream_skip_element s =
809
+
match P.parse_start_tag s with
810
+
| Error e -> Error e
811
+
| Ok (_tag, _attrs, true) -> Ok ()
812
+
| Ok (tag, _attrs, false) -> (
813
+
match stream_skip_children s with
814
+
| Error e -> Error e
815
+
| Ok () -> P.consume_end_tag s tag)
816
+
817
+
and stream_skip_children s =
818
+
let rec loop () =
819
+
if P.at_end s then Error "unexpected end of input (unclosed tag)"
820
+
else if P.starts_with s "</" then Ok ()
821
+
else if P.starts_with s "<!--" then begin
822
+
P.skip_n s 4;
823
+
match P.skip_comment s with Error e -> Error e | Ok () -> loop ()
824
+
end
825
+
else if P.starts_with s "<?" then begin
826
+
P.skip_n s 2;
827
+
match P.skip_pi s with Error e -> Error e | Ok () -> loop ()
828
+
end
829
+
else if P.starts_with s "<![CDATA[" then begin
830
+
P.skip_n s 9;
831
+
match P.parse_cdata s with Error e -> Error e | Ok _text -> loop ()
832
+
end
833
+
else if P.starts_with s "<" then begin
834
+
match stream_skip_element s with Error e -> Error e | Ok () -> loop ()
835
+
end
836
+
else begin
837
+
match P.parse_text s with Error e -> Error e | Ok _text -> loop ()
838
+
end
839
+
in
840
+
loop ()
841
+
842
+
(* Collect direct child elements from the stream. Also accumulates
843
+
direct text content. Stops at </ but does NOT consume it.
844
+
Returns (child_elements_reversed, text_content). *)
845
+
let stream_collect_children s =
846
+
let text_buf = Buffer.create 32 in
847
+
let rec loop acc =
848
+
if P.at_end s then Error "unexpected end of input (unclosed tag)"
849
+
else if P.starts_with s "</" then Ok (List.rev acc, Buffer.contents text_buf)
850
+
else if P.starts_with s "<!--" then begin
851
+
P.skip_n s 4;
852
+
match P.skip_comment s with Error e -> Error e | Ok () -> loop acc
853
+
end
854
+
else if P.starts_with s "<?" then begin
855
+
P.skip_n s 2;
856
+
match P.skip_pi s with Error e -> Error e | Ok () -> loop acc
857
+
end
858
+
else if P.starts_with s "<![CDATA[" then begin
859
+
P.skip_n s 9;
860
+
match P.parse_cdata s with
861
+
| Error e -> Error e
862
+
| Ok text ->
863
+
Buffer.add_string text_buf text;
864
+
loop acc
865
+
end
866
+
else if P.starts_with s "<" then begin
867
+
match stream_parse_element s with
868
+
| Error e -> Error e
869
+
| Ok el -> loop (el :: acc)
870
+
end
871
+
else begin
872
+
match P.parse_text s with
873
+
| Error e -> Error e
874
+
| Ok text ->
875
+
if String.length text > 0 then Buffer.add_string text_buf text;
876
+
loop acc
877
+
end
878
+
in
879
+
loop []
880
+
881
+
(* ── Codec types ────────────────────────────────────────────────────── *)
882
+
883
+
(* The codec has two decode paths:
884
+
- dec_tree: decodes from a Tree.element (used by Tree escape hatch
885
+
and by El children that have already been parsed)
886
+
- dec_stream: decodes directly from a P.stream. The stream is
887
+
positioned inside an element (after '>' or at '/>'), with tag
888
+
and attrs already extracted. For self-closing elements,
889
+
self_close=true and there is nothing to consume.
890
+
891
+
The encode path writes directly to an encoder (unchanged). *)
709
892
710
893
type 'a t = {
711
-
dec : Tree.element -> ('a, string) result;
894
+
dec_tree : Tree.element -> ('a, string) result;
895
+
dec_stream :
896
+
P.stream ->
897
+
tag:string ->
898
+
attrs:(string * string) list ->
899
+
self_close:bool ->
900
+
('a, string) result;
712
901
enc : encoder -> 'a -> unit;
713
902
}
714
903
715
904
(* ── Base type codecs ───────────────────────────────────────────────── *)
716
905
717
-
let string =
718
-
{ dec = (fun el -> Ok (Tree.text el)); enc = (fun e s -> enc_text e s) }
906
+
(* For base codecs, dec_stream reads text content directly from the stream
907
+
without building Tree nodes. *)
719
908
720
-
let int =
909
+
let make_base_codec ~parse ~enc_fn =
721
910
{
722
-
dec =
911
+
dec_tree =
723
912
(fun el ->
724
913
let s = String.trim (Tree.text el) in
725
-
match int_of_string_opt s with
726
-
| Some n -> Ok n
727
-
| None -> Error (Printf.sprintf "expected integer, got %S" s));
728
-
enc = (fun e n -> enc_text e (string_of_int n));
914
+
parse s);
915
+
dec_stream =
916
+
(fun s ~tag:_ ~attrs:_ ~self_close ->
917
+
if self_close then parse ""
918
+
else
919
+
match stream_read_text s with
920
+
| Error e -> Error e
921
+
| Ok text -> parse (String.trim text));
922
+
enc = enc_fn;
729
923
}
730
924
731
-
let float =
925
+
let string =
732
926
{
733
-
dec =
734
-
(fun el ->
735
-
let s = String.trim (Tree.text el) in
736
-
match float_of_string_opt s with
737
-
| Some f -> Ok f
738
-
| None -> Error (Printf.sprintf "expected float, got %S" s));
739
-
enc = (fun e f -> enc_text e (string_of_float f));
927
+
dec_tree = (fun el -> Ok (Tree.text el));
928
+
dec_stream =
929
+
(fun s ~tag:_ ~attrs:_ ~self_close ->
930
+
if self_close then Ok "" else stream_read_text s);
931
+
enc = (fun e s -> enc_text e s);
740
932
}
741
933
934
+
let int =
935
+
make_base_codec
936
+
~parse:(fun s ->
937
+
match int_of_string_opt s with
938
+
| Some n -> Ok n
939
+
| None -> Error (Printf.sprintf "expected integer, got %S" s))
940
+
~enc_fn:(fun e n -> enc_text e (string_of_int n))
941
+
942
+
let float =
943
+
make_base_codec
944
+
~parse:(fun s ->
945
+
match float_of_string_opt s with
946
+
| Some f -> Ok f
947
+
| None -> Error (Printf.sprintf "expected float, got %S" s))
948
+
~enc_fn:(fun e f -> enc_text e (string_of_float f))
949
+
742
950
let bool =
743
-
{
744
-
dec =
745
-
(fun el ->
746
-
let s = String.trim (Tree.text el) in
747
-
match String.lowercase_ascii s with
748
-
| "true" -> Ok true
749
-
| "false" -> Ok false
750
-
| _ -> Error (Printf.sprintf "expected boolean, got %S" s));
751
-
enc = (fun e b -> enc_text e (string_of_bool b));
752
-
}
951
+
make_base_codec
952
+
~parse:(fun s ->
953
+
match String.lowercase_ascii s with
954
+
| "true" -> Ok true
955
+
| "false" -> Ok false
956
+
| _ -> Error (Printf.sprintf "expected boolean, got %S" s))
957
+
~enc_fn:(fun e b -> enc_text e (string_of_bool b))
753
958
754
959
(* ── Element wrapper ────────────────────────────────────────────────── *)
755
960
961
+
(* element wraps the inner codec in a named element. On streaming decode:
962
+
1. The outer element's dec_stream is called with the element's tag/attrs
963
+
2. It checks the tag matches
964
+
3. It delegates to the inner codec's dec_stream
965
+
4. It consumes the end tag *)
966
+
756
967
let element tag codec =
757
968
{
758
-
dec =
969
+
dec_tree =
759
970
(fun el ->
760
971
if el.tag <> tag then
761
972
Error
762
973
(Printf.sprintf "expected element <%s>, got <%s>" tag el.Tree.tag)
763
-
else codec.dec el);
974
+
else codec.dec_tree el);
975
+
dec_stream =
976
+
(fun s ~tag:actual_tag ~attrs ~self_close ->
977
+
if actual_tag <> tag then
978
+
Error
979
+
(Printf.sprintf "expected element <%s>, got <%s>" tag actual_tag)
980
+
else
981
+
let result = codec.dec_stream s ~tag ~attrs ~self_close in
982
+
if self_close then result
983
+
else
984
+
match result with
985
+
| Error e -> Error e
986
+
| Ok v -> (
987
+
match P.consume_end_tag s tag with
988
+
| Error e -> Error e
989
+
| Ok () -> Ok v));
764
990
enc =
765
991
(fun e v ->
766
992
enc_start_tag e tag;
···
826
1052
(* ── Element builder ────────────────────────────────────────────────── *)
827
1053
828
1054
module El = struct
829
-
(* The builder accumulates steps that, given an element, decode fields one at
830
-
a time, threading through a decoder function that builds the final value.
831
-
The decode side uses Tree.element for random-access children lookup.
832
-
The encode side splits into two phases: attrs (written while the start tag
833
-
is still open) and children (written after the start tag is closed). This
834
-
ensures attrs always appear before children regardless of builder order. *)
1055
+
(* The builder accumulates decode/encode steps. For decode, it supports
1056
+
two paths:
1057
+
- decode_tree: from a Tree.element (for already-parsed elements)
1058
+
- decode_stream: from a P.stream with parsed attrs and collected
1059
+
children (for the streaming codec path)
1060
+
1061
+
Both paths thread through a decoder function that builds the final
1062
+
value by applying one field at a time.
1063
+
1064
+
The encode side splits into two phases: attrs (written while the start
1065
+
tag is still open) and children (written after the start tag is closed).
1066
+
This ensures attrs always appear before children regardless of builder
1067
+
order. *)
835
1068
type ('o, 'dec) t = {
836
-
decode : Tree.element -> ('dec, string) result;
1069
+
decode_tree : Tree.element -> ('dec, string) result;
1070
+
decode_stream :
1071
+
attrs:(string * string) list ->
1072
+
children:Tree.element list ->
1073
+
text:string ->
1074
+
('dec, string) result;
1075
+
needs_children : bool; (* true if any child/children/text field *)
837
1076
encode_attrs : encoder -> 'o -> unit;
838
1077
encode_children : encoder -> 'o -> unit;
839
1078
}
840
1079
841
1080
let obj dec =
842
1081
{
843
-
decode = (fun _el -> Ok dec);
1082
+
decode_tree = (fun _el -> Ok dec);
1083
+
decode_stream = (fun ~attrs:_ ~children:_ ~text:_ -> Ok dec);
1084
+
needs_children = false;
844
1085
encode_attrs = (fun _e _v -> ());
845
1086
encode_children = (fun _e _v -> ());
846
1087
}
847
1088
848
1089
let attr name (codec : 'a Attr.codec) ~enc builder =
1090
+
let decode_attr attrs prev_result =
1091
+
match prev_result with
1092
+
| Error e -> Error e
1093
+
| Ok f -> (
1094
+
match List.assoc_opt name attrs with
1095
+
| None ->
1096
+
Error
1097
+
(Printf.sprintf "missing required attribute %S on element" name)
1098
+
| Some s -> (
1099
+
match codec.dec s with Ok v -> Ok (f v) | Error e -> Error e))
1100
+
in
849
1101
{
850
-
decode =
1102
+
decode_tree =
851
1103
(fun el ->
852
-
match builder.decode el with
1104
+
match builder.decode_tree el with
853
1105
| Error e -> Error e
854
1106
| Ok f -> (
855
1107
match List.assoc_opt name el.Tree.attrs with
···
859
1111
el.tag)
860
1112
| Some s -> (
861
1113
match codec.dec s with Ok v -> Ok (f v) | Error e -> Error e)));
1114
+
decode_stream =
1115
+
(fun ~attrs ~children ~text ->
1116
+
decode_attr attrs (builder.decode_stream ~attrs ~children ~text));
1117
+
needs_children = builder.needs_children;
862
1118
encode_attrs =
863
1119
(fun e v ->
864
1120
builder.encode_attrs e v;
···
867
1123
}
868
1124
869
1125
let attr_opt name (codec : _ Attr.codec) ~enc builder =
1126
+
let decode_attr_opt attrs prev_result =
1127
+
match prev_result with
1128
+
| Error e -> Error e
1129
+
| Ok f -> (
1130
+
match List.assoc_opt name attrs with
1131
+
| None -> Ok (f None)
1132
+
| Some s -> (
1133
+
match codec.dec s with
1134
+
| Ok v -> Ok (f (Some v))
1135
+
| Error e -> Error e))
1136
+
in
870
1137
{
871
-
decode =
1138
+
decode_tree =
872
1139
(fun el ->
873
-
match builder.decode el with
1140
+
match builder.decode_tree el with
874
1141
| Error e -> Error e
875
1142
| Ok f -> (
876
1143
match List.assoc_opt name el.Tree.attrs with
···
879
1146
match codec.dec s with
880
1147
| Ok v -> Ok (f (Some v))
881
1148
| Error e -> Error e)));
1149
+
decode_stream =
1150
+
(fun ~attrs ~children ~text ->
1151
+
decode_attr_opt attrs (builder.decode_stream ~attrs ~children ~text));
1152
+
needs_children = builder.needs_children;
882
1153
encode_attrs =
883
1154
(fun e v ->
884
1155
builder.encode_attrs e v;
···
888
1159
encode_children = (fun e v -> builder.encode_children e v);
889
1160
}
890
1161
1162
+
(* Helper: find first child element by tag in a list *)
1163
+
let find_child tag children =
1164
+
let rec loop = function
1165
+
| [] -> None
1166
+
| el :: _ when el.Tree.tag = tag -> Some el
1167
+
| _ :: rest -> loop rest
1168
+
in
1169
+
loop children
1170
+
1171
+
(* Helper: find all child elements by tag in a list *)
1172
+
let find_all_children tag children =
1173
+
List.filter (fun el -> el.Tree.tag = tag) children
1174
+
891
1175
let write_child_element e tag codec child_v =
892
1176
enc_close_start_tag e;
893
1177
enc_start_tag e tag;
···
897
1181
898
1182
let child tag codec ~enc builder =
899
1183
{
900
-
decode =
1184
+
decode_tree =
901
1185
(fun el ->
902
-
match builder.decode el with
1186
+
match builder.decode_tree el with
903
1187
| Error e -> Error e
904
1188
| Ok f -> (
905
1189
match Tree.find tag el with
···
908
1192
(Printf.sprintf
909
1193
"missing required child element <%s> in <%s>" tag el.tag)
910
1194
| Some child_el -> (
911
-
match codec.dec child_el with
1195
+
match codec.dec_tree child_el with
1196
+
| Ok v -> Ok (f v)
1197
+
| Error e -> Error e)));
1198
+
decode_stream =
1199
+
(fun ~attrs ~children ~text ->
1200
+
match builder.decode_stream ~attrs ~children ~text with
1201
+
| Error e -> Error e
1202
+
| Ok f -> (
1203
+
match find_child tag children with
1204
+
| None ->
1205
+
Error
1206
+
(Printf.sprintf "missing required child element <%s>" tag)
1207
+
| Some child_el -> (
1208
+
match codec.dec_tree child_el with
912
1209
| Ok v -> Ok (f v)
913
1210
| Error e -> Error e)));
1211
+
needs_children = true;
914
1212
encode_attrs = (fun e v -> builder.encode_attrs e v);
915
1213
encode_children =
916
1214
(fun e v ->
···
920
1218
921
1219
let child_opt tag codec ~enc builder =
922
1220
{
923
-
decode =
1221
+
decode_tree =
924
1222
(fun el ->
925
-
match builder.decode el with
1223
+
match builder.decode_tree el with
926
1224
| Error e -> Error e
927
1225
| Ok f -> (
928
1226
match Tree.find tag el with
929
1227
| None -> Ok (f None)
930
1228
| Some child_el -> (
931
-
match codec.dec child_el with
1229
+
match codec.dec_tree child_el with
1230
+
| Ok v -> Ok (f (Some v))
1231
+
| Error e -> Error e)));
1232
+
decode_stream =
1233
+
(fun ~attrs ~children ~text ->
1234
+
match builder.decode_stream ~attrs ~children ~text with
1235
+
| Error e -> Error e
1236
+
| Ok f -> (
1237
+
match find_child tag children with
1238
+
| None -> Ok (f None)
1239
+
| Some child_el -> (
1240
+
match codec.dec_tree child_el with
932
1241
| Ok v -> Ok (f (Some v))
933
1242
| Error e -> Error e)));
1243
+
needs_children = true;
934
1244
encode_attrs = (fun e v -> builder.encode_attrs e v);
935
1245
encode_children =
936
1246
(fun e v ->
···
942
1252
943
1253
let children tag codec ~enc builder =
944
1254
{
945
-
decode =
1255
+
decode_tree =
946
1256
(fun el ->
947
-
match builder.decode el with
1257
+
match builder.decode_tree el with
948
1258
| Error e -> Error e
949
1259
| Ok f ->
950
1260
let child_els = Tree.find_all tag el in
951
1261
let rec decode_all acc = function
952
1262
| [] -> Ok (f (List.rev acc))
953
1263
| child_el :: rest -> (
954
-
match codec.dec child_el with
1264
+
match codec.dec_tree child_el with
955
1265
| Ok v -> decode_all (v :: acc) rest
956
1266
| Error e -> Error e)
957
1267
in
958
1268
decode_all [] child_els);
1269
+
decode_stream =
1270
+
(fun ~attrs ~children:child_list ~text ->
1271
+
match builder.decode_stream ~attrs ~children:child_list ~text with
1272
+
| Error e -> Error e
1273
+
| Ok f ->
1274
+
let child_els = find_all_children tag child_list in
1275
+
let rec decode_all acc = function
1276
+
| [] -> Ok (f (List.rev acc))
1277
+
| child_el :: rest -> (
1278
+
match codec.dec_tree child_el with
1279
+
| Ok v -> decode_all (v :: acc) rest
1280
+
| Error e -> Error e)
1281
+
in
1282
+
decode_all [] child_els);
1283
+
needs_children = true;
959
1284
encode_attrs = (fun e v -> builder.encode_attrs e v);
960
1285
encode_children =
961
1286
(fun e v ->
···
967
1292
968
1293
let text ~enc builder =
969
1294
{
970
-
decode =
1295
+
decode_tree =
971
1296
(fun el ->
972
-
match builder.decode el with
1297
+
match builder.decode_tree el with
973
1298
| Error e -> Error e
974
1299
| Ok f -> Ok (f (Tree.text el)));
1300
+
decode_stream =
1301
+
(fun ~attrs ~children:_ ~text ->
1302
+
match builder.decode_stream ~attrs ~children:[] ~text with
1303
+
| Error e -> Error e
1304
+
| Ok f -> Ok (f text));
1305
+
needs_children = true;
975
1306
encode_attrs = (fun e v -> builder.encode_attrs e v);
976
1307
encode_children =
977
1308
(fun e v ->
···
985
1316
986
1317
let finish builder =
987
1318
{
988
-
dec = builder.decode;
1319
+
dec_tree = builder.decode_tree;
1320
+
dec_stream =
1321
+
(fun s ~tag:_ ~attrs ~self_close ->
1322
+
if self_close then
1323
+
(* Self-closing element: no children, no text *)
1324
+
builder.decode_stream ~attrs ~children:[] ~text:""
1325
+
else if builder.needs_children then
1326
+
(* Builder has child/text fields: collect children from stream *)
1327
+
match stream_collect_children s with
1328
+
| Error e -> Error e
1329
+
| Ok (children, text) ->
1330
+
builder.decode_stream ~attrs ~children ~text
1331
+
else
1332
+
(* Builder only has attr fields: skip children entirely *)
1333
+
match stream_skip_children s with
1334
+
| Error e -> Error e
1335
+
| Ok () -> builder.decode_stream ~attrs ~children:[] ~text:"");
989
1336
enc =
990
1337
(fun e v ->
991
1338
(* Phase 1: write all attributes (start tag is still open) *)
···
999
1346
1000
1347
let map ?dec ?enc codec =
1001
1348
{
1002
-
dec =
1349
+
dec_tree =
1003
1350
(fun el ->
1004
-
match codec.dec el with
1351
+
match codec.dec_tree el with
1352
+
| Error e -> Error e
1353
+
| Ok v -> (
1354
+
match dec with Some f -> f v | None -> Error "no decoder provided"));
1355
+
dec_stream =
1356
+
(fun s ~tag ~attrs ~self_close ->
1357
+
match codec.dec_stream s ~tag ~attrs ~self_close with
1005
1358
| Error e -> Error e
1006
1359
| Ok v -> (
1007
1360
match dec with Some f -> f v | None -> Error "no decoder provided"));
1008
1361
enc = (fun e v -> match enc with Some f -> codec.enc e (f v) | None -> ());
1009
1362
}
1010
1363
1011
-
let const v = { dec = (fun _el -> Ok v); enc = (fun _e _v -> ()) }
1364
+
let const v =
1365
+
{
1366
+
dec_tree = (fun _el -> Ok v);
1367
+
dec_stream = (fun _s ~tag:_ ~attrs:_ ~self_close:_ -> Ok v);
1368
+
enc = (fun _e _v -> ());
1369
+
}
1012
1370
1013
1371
let option codec =
1014
1372
{
1015
-
dec =
1373
+
dec_tree =
1016
1374
(fun el ->
1017
-
(* An option codec tries to decode; the caller controls presence *)
1018
-
match codec.dec el with
1375
+
match codec.dec_tree el with Ok v -> Ok (Some v) | Error _ -> Ok None);
1376
+
dec_stream =
1377
+
(fun s ~tag ~attrs ~self_close ->
1378
+
match codec.dec_stream s ~tag ~attrs ~self_close with
1019
1379
| Ok v -> Ok (Some v)
1020
1380
| Error _ -> Ok None);
1021
1381
enc = (fun e v -> match v with Some v -> codec.enc e v | None -> ());
···
1023
1383
1024
1384
let list codec =
1025
1385
{
1026
-
dec =
1386
+
dec_tree =
1027
1387
(fun el ->
1028
1388
let child_els =
1029
1389
List.filter_map
···
1033
1393
let rec decode_all acc = function
1034
1394
| [] -> Ok (List.rev acc)
1035
1395
| child_el :: rest -> (
1036
-
match codec.dec child_el with
1396
+
match codec.dec_tree child_el with
1037
1397
| Ok v -> decode_all (v :: acc) rest
1038
1398
| Error e -> Error e)
1039
1399
in
1040
1400
decode_all [] child_els);
1401
+
dec_stream =
1402
+
(fun s ~tag:_ ~attrs:_ ~self_close ->
1403
+
if self_close then Ok []
1404
+
else
1405
+
(* Parse child elements from stream and decode each *)
1406
+
match stream_collect_children s with
1407
+
| Error e -> Error e
1408
+
| Ok (children, _text) ->
1409
+
let rec decode_all acc = function
1410
+
| [] -> Ok (List.rev acc)
1411
+
| child_el :: rest -> (
1412
+
match codec.dec_tree child_el with
1413
+
| Ok v -> decode_all (v :: acc) rest
1414
+
| Error e -> Error e)
1415
+
in
1416
+
decode_all [] children);
1041
1417
enc =
1042
1418
(fun e vs ->
1043
1419
List.iter
···
1049
1425
1050
1426
(* ── Decode / Encode ────────────────────────────────────────────────── *)
1051
1427
1052
-
let decode_string codec s =
1053
-
match Tree.of_string s with
1428
+
(* Stream-based decode: parse the XML preamble, then decode the root
1429
+
element directly from the stream using the codec's dec_stream path. *)
1430
+
let decode_stream codec s =
1431
+
match P.skip_preamble s with
1054
1432
| Error e -> Error (Printf.sprintf "parse error: %s" e)
1055
-
| Ok el -> codec.dec el
1433
+
| Ok () -> (
1434
+
if P.at_end s then Error "parse error: empty document: no root element"
1435
+
else
1436
+
match P.parse_start_tag s with
1437
+
| Error e -> Error (Printf.sprintf "parse error: %s" e)
1438
+
| Ok (tag, attrs, self_close) -> (
1439
+
match codec.dec_stream s ~tag ~attrs ~self_close with
1440
+
| Error e -> Error e
1441
+
| Ok v -> Ok v))
1442
+
1443
+
let decode_string codec s =
1444
+
let reader = Bytes.Reader.of_string s in
1445
+
let stream = P.make_stream reader in
1446
+
decode_stream codec stream
1056
1447
1057
1448
let encode_string ?(indent = 0) codec v =
1058
1449
let buf = Buffer.create 256 in
···
1061
1452
Buffer.contents buf
1062
1453
1063
1454
let decode codec reader =
1064
-
match Tree.of_reader reader with
1065
-
| Error e -> Error (Printf.sprintf "parse error: %s" e)
1066
-
| Ok el -> codec.dec el
1455
+
let stream = P.make_stream reader in
1456
+
decode_stream codec stream
1067
1457
1068
1458
let encode ?(indent = 0) codec v writer =
1069
1459
let e = make_encoder ~indent (Bytes.Writer.write_string writer) in