forked from
anil.recoil.org/ocaml-yamlrw
Pure OCaml Yaml 1.2 reader and writer using Bytesrw
test(ocaml-git): add unit and fuzz tests for Git.Tree.add deduplication
Add a unit test that catches the duplicate-entry bug (add same name twice
should replace, not accumulate). Add a Crowbar model-based fuzz suite that
applies random Add/Remove sequences to both Git.Tree.t and a Map reference,
checking no-duplicates, sorted-order, and model-agreement invariants after
every step. The roundtrip-after-ops test also exercises serialization across
arbitrary op sequences.
+2195
-2135
+43
-49
bin/yamlcat.ml
+43
-49
bin/yamlcat.ml
···
41
41
json_to_string buf v;
42
42
Buffer.contents buf
43
43
44
+
let to_json_value ~resolve_aliases ~max_nodes ~max_depth yaml =
45
+
Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml
46
+
47
+
let print_yaml_doc ~resolve_aliases ~max_nodes ~max_depth ~layout_style doc =
48
+
match (doc : Yamlrw.document).root with
49
+
| None -> print_endline ""
50
+
| Some yaml ->
51
+
let value = to_json_value ~resolve_aliases ~max_nodes ~max_depth yaml in
52
+
print_string (Yamlrw.to_string ?layout_style value)
53
+
54
+
let print_json_doc ~resolve_aliases ~max_nodes ~max_depth doc =
55
+
match (doc : Yamlrw.document).root with
56
+
| None -> ()
57
+
| Some yaml ->
58
+
let value = to_json_value ~resolve_aliases ~max_nodes ~max_depth yaml in
59
+
print_endline (value_to_json value)
60
+
61
+
let print_debug_doc i (doc : Yamlrw.document) =
62
+
Fmt.pr "Document %d:@." (i + 1);
63
+
let doc' : Yamlrw.Document.t =
64
+
{
65
+
Yamlrw.Document.version = doc.version;
66
+
Yamlrw.Document.tags = doc.tags;
67
+
Yamlrw.Document.root = (doc.root :> Yamlrw.Yaml.t option);
68
+
Yamlrw.Document.implicit_start = doc.implicit_start;
69
+
Yamlrw.Document.implicit_end = doc.implicit_end;
70
+
}
71
+
in
72
+
Fmt.pr "%a@." Yamlrw.Document.pp doc'
73
+
44
74
let process_string ~format ~resolve_aliases ~max_nodes ~max_depth content =
45
75
try
46
-
(* Always parse as multi-document stream *)
47
76
let documents = Yamlrw.documents_of_string content in
48
-
77
+
let pr = print_yaml_doc ~resolve_aliases ~max_nodes ~max_depth in
49
78
match format with
50
79
| Yaml ->
51
-
(* Convert through Value to apply tag-based type coercion *)
52
80
let first = ref true in
53
81
List.iter
54
-
(fun (doc : Yamlrw.document) ->
82
+
(fun doc ->
55
83
if not !first then print_string "---\n";
56
84
first := false;
57
-
match doc.root with
58
-
| None -> print_endline ""
59
-
| Some yaml ->
60
-
let value =
61
-
Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml
62
-
in
63
-
print_string (Yamlrw.to_string value))
85
+
pr ~layout_style:None doc)
64
86
documents
65
87
| Flow ->
66
-
(* Convert through Value to apply tag-based type coercion *)
67
88
let first = ref true in
68
89
List.iter
69
-
(fun (doc : Yamlrw.document) ->
90
+
(fun doc ->
70
91
if not !first then print_string "---\n";
71
92
first := false;
72
-
match doc.root with
73
-
| None -> print_endline ""
74
-
| Some yaml ->
75
-
let value =
76
-
Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml
77
-
in
78
-
print_string (Yamlrw.to_string ~layout_style:`Flow value))
93
+
pr ~layout_style:(Some `Flow) doc)
79
94
documents
80
95
| Json ->
81
96
let first = ref true in
82
97
List.iter
83
-
(fun (doc : Yamlrw.document) ->
84
-
match doc.root with
85
-
| None -> ()
86
-
| Some yaml ->
87
-
if not !first then print_endline "---";
88
-
first := false;
89
-
let value =
90
-
Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml
91
-
in
92
-
print_endline (value_to_json value))
93
-
documents
94
-
| Debug ->
95
-
List.iteri
96
-
(fun i (doc : Yamlrw.document) ->
97
-
Format.printf "Document %d:@." (i + 1);
98
-
(* Convert back to Document.t for printing *)
99
-
let doc' : Yamlrw.Document.t =
100
-
{
101
-
Yamlrw.Document.version = doc.version;
102
-
Yamlrw.Document.tags = doc.tags;
103
-
Yamlrw.Document.root = (doc.root :> Yamlrw.Yaml.t option);
104
-
Yamlrw.Document.implicit_start = doc.implicit_start;
105
-
Yamlrw.Document.implicit_end = doc.implicit_end;
106
-
}
107
-
in
108
-
Format.printf "%a@." Yamlrw.Document.pp doc')
98
+
(fun doc ->
99
+
if not !first then print_endline "---";
100
+
print_json_doc ~resolve_aliases ~max_nodes ~max_depth doc;
101
+
first := false)
109
102
documents
103
+
| Debug -> List.iteri print_debug_doc documents
110
104
with Yamlrw.Yamlrw_error e ->
111
-
Printf.eprintf "Error: %s\n" (Yamlrw.Error.to_string e);
105
+
Fmt.epr "Error: %s\n" (Yamlrw.Error.to_string e);
112
106
exit 1
113
107
114
108
let process_file ~format ~resolve_aliases ~max_nodes ~max_depth filename =
···
177
171
let doc = "YAML file(s) to process. Use '-' for stdin." in
178
172
Arg.(value & pos_all file [] & info [] ~docv:"FILE" ~doc)
179
173
180
-
let combined_format format json flow debug =
174
+
let combined_format format ~json ~flow ~debug =
181
175
if json then Json else if flow then Flow else if debug then Debug else format
182
176
183
177
let term =
184
178
let combine format json flow debug all no_resolve max_nodes max_depth files =
185
-
let format = combined_format format json flow debug in
179
+
let format = combined_format format ~json ~flow ~debug in
186
180
let resolve_aliases = not no_resolve in
187
181
run format all resolve_aliases max_nodes max_depth files
188
182
in
+2
-2
doc/tutorial.mld
+2
-2
doc/tutorial.mld
···
432
432
{2 Serializing Multiple Documents}
433
433
434
434
{@ocaml skip[
435
-
# let doc1 = Document.make (Some (of_json (Util.obj ["x", Util.int 1])));;
435
+
# let doc1 = Document.v (Some (of_json (Util.obj ["x", Util.int 1])));;
436
436
val doc1 : Document.t =
437
437
{Document.version = None; tags = []; root = Some (`O <abstr>);
438
438
implicit_start = true; implicit_end = true}
439
-
# let doc2 = Document.make (Some (of_json (Util.obj ["x", Util.int 2])));;
439
+
# let doc2 = Document.v (Some (of_json (Util.obj ["x", Util.int 2])));;
440
440
val doc2 : Document.t =
441
441
{Document.version = None; tags = []; root = Some (`O <abstr>);
442
442
implicit_start = true; implicit_end = true}
+1
-1
fuzz/dune
+1
-1
fuzz/dune
+2
-2
fuzz/fuzz_chomping.ml
+2
-2
fuzz/fuzz_chomping.ml
···
42
42
| 1 -> Yamlrw.Chomping.Clip
43
43
| _ -> Yamlrw.Chomping.Keep
44
44
in
45
-
let _ = Format.asprintf "%a" Yamlrw.Chomping.pp chomping in
45
+
let _ = Fmt.str "%a" Yamlrw.Chomping.pp chomping in
46
46
check true
47
47
48
48
(** Test equality is reflexive *)
···
75
75
(fun c ->
76
76
match Yamlrw.Chomping.of_char c with
77
77
| None -> ()
78
-
| Some _ -> fail (Printf.sprintf "char '%c' should not be valid" c))
78
+
| Some _ -> fail (Fmt.str "char '%c' should not be valid" c))
79
79
invalid_chars;
80
80
check true
81
81
+8
fuzz/fuzz_chomping.mli
+8
fuzz/fuzz_chomping.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for YAML block scalar chomping. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for chomping behavior. *)
+2
-2
fuzz/fuzz_emitter.ml
+2
-2
fuzz/fuzz_emitter.ml
···
138
138
Yamlrw.Stream.document_start emitter ();
139
139
for i = 1 to depth do
140
140
Yamlrw.Stream.mapping_start emitter ();
141
-
Yamlrw.Stream.scalar emitter (Printf.sprintf "key%d" i)
141
+
Yamlrw.Stream.scalar emitter (Fmt.str "key%d" i)
142
142
done;
143
143
Yamlrw.Stream.scalar emitter value;
144
144
for _ = 1 to depth do
···
248
248
Yamlrw.Stream.stream_start emitter `Utf8;
249
249
for i = 1 to count do
250
250
Yamlrw.Stream.document_start emitter ~implicit:false ();
251
-
Yamlrw.Stream.scalar emitter (Printf.sprintf "%s%d" value i);
251
+
Yamlrw.Stream.scalar emitter (Fmt.str "%s%d" value i);
252
252
Yamlrw.Stream.document_end emitter ~implicit:false ()
253
253
done;
254
254
Yamlrw.Stream.stream_end emitter;
+8
fuzz/fuzz_emitter.mli
+8
fuzz/fuzz_emitter.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for the YAML emitter. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for emitter behavior. *)
+1
-1
fuzz/fuzz_encoding.ml
+1
-1
fuzz/fuzz_encoding.ml
···
21
21
(** Test that pp never crashes *)
22
22
let test_pp_after_detect buf =
23
23
let enc, _ = Yamlrw.Encoding.detect buf in
24
-
let _ = Format.asprintf "%a" Yamlrw.Encoding.pp enc in
24
+
let _ = Fmt.str "%a" Yamlrw.Encoding.pp enc in
25
25
check true
26
26
27
27
(** Test encoding equality is reflexive *)
+8
fuzz/fuzz_encoding.mli
+8
fuzz/fuzz_encoding.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for YAML encoding and decoding. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for encoding behavior. *)
+2
-2
fuzz/fuzz_tag.ml
+2
-2
fuzz/fuzz_tag.ml
···
39
39
match Yamlrw.Tag.of_string buf with
40
40
| None -> check true
41
41
| Some tag ->
42
-
let _ = Format.asprintf "%a" Yamlrw.Tag.pp tag in
42
+
let _ = Fmt.str "%a" Yamlrw.Tag.pp tag in
43
43
check true
44
44
45
45
(** Test equality is reflexive *)
···
64
64
65
65
(** Test make function *)
66
66
let test_make handle suffix =
67
-
let tag = Yamlrw.Tag.make ~handle ~suffix in
67
+
let tag = Yamlrw.Tag.v ~handle ~suffix in
68
68
let _ = Yamlrw.Tag.to_string tag in
69
69
let _ = Yamlrw.Tag.to_uri tag in
70
70
check true
+8
fuzz/fuzz_tag.mli
+8
fuzz/fuzz_tag.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for the YAML Tag module. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for Tag behavior. *)
+1
-1
fuzz/fuzz_value.ml
+1
-1
fuzz/fuzz_value.ml
+8
fuzz/fuzz_value.mli
+8
fuzz/fuzz_value.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for the YAML Value module. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for Value behavior. *)
+3
-3
fuzz/fuzz_yamlrw.ml
+3
-3
fuzz/fuzz_yamlrw.ml
···
82
82
let test_pp buf =
83
83
(try
84
84
let v = Yamlrw.of_string buf in
85
-
let _ = Format.asprintf "%a" Yamlrw.pp v in
85
+
let _ = Fmt.str "%a" Yamlrw.pp v in
86
86
()
87
87
with Yamlrw.Yamlrw_error _ -> ());
88
88
check true
···
341
341
let test_multiple_anchors name1 name2 =
342
342
if String.length name1 > 0 && String.length name2 > 0 then begin
343
343
let yaml =
344
-
Printf.sprintf "a: &%s value1\nb: &%s value2\nc: *%s\nd: *%s" name1 name2
345
-
name1 name2
344
+
Fmt.str "a: &%s value1\nb: &%s value2\nc: *%s\nd: *%s" name1 name2 name1
345
+
name2
346
346
in
347
347
(try
348
348
let _ = Yamlrw.of_string yaml in
+8
fuzz/fuzz_yamlrw.mli
+8
fuzz/fuzz_yamlrw.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for the main Yamlrw parse/emit pipeline. *)
7
+
1
8
val suite : string * Crowbar.test_case list
9
+
(** [suite] is the fuzz test suite for the Yamlrw parse/emit pipeline. *)
+1
-1
fuzz/gen_corpus.ml
+1
-1
fuzz/gen_corpus.ml
+2
-2
fuzz/helpers/fuzz_helpers.mli
+2
-2
fuzz/helpers/fuzz_helpers.mli
···
22
22
(** Generator for identifier-like strings. *)
23
23
24
24
val catch_invalid_arg : (unit -> unit) -> unit
25
-
(** Catch [Invalid_argument] exceptions. *)
25
+
(** [catch_invalid_arg f] calls [f ()] ignoring Invalid_argument exceptions. *)
26
26
27
27
val catch_yamlrw_error : (unit -> unit) -> unit
28
-
(** Catch [Yamlrw.Yamlrw_error] exceptions. *)
28
+
(** [catch_yamlrw_error f] calls [f ()] ignoring Yamlrw_error exceptions. *)
+11
-10
lib/char_class.mli
+11
-10
lib/char_class.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Character classification for YAML parsing *)
6
+
(** Character classification for YAML parsing. *)
7
7
8
8
val is_break : char -> bool
9
-
(** Line break characters (\n or \r) *)
9
+
(** [is_break c] returns [true] if [c] is a line break character (\n or \r). *)
10
10
11
11
val is_blank : char -> bool
12
-
(** Blank (space or tab) *)
12
+
(** [is_blank c] returns [true] if [c] is blank (space or tab). *)
13
13
14
14
val is_whitespace : char -> bool
15
-
(** Whitespace (break or blank) *)
15
+
(** [is_whitespace c] returns [true] if [c] is whitespace (break or blank). *)
16
16
17
17
val is_digit : char -> bool
18
-
(** Decimal digit *)
18
+
(** [is_digit c] returns [true] if [c] is a decimal digit. *)
19
19
20
20
val is_hex : char -> bool
21
-
(** Hexadecimal digit *)
21
+
(** [is_hex c] returns [true] if [c] is a hexadecimal digit. *)
22
22
23
23
val is_alpha : char -> bool
24
-
(** Alphabetic character *)
24
+
(** [is_alpha c] returns [true] if [c] is an alphabetic character. *)
25
25
26
26
val is_alnum : char -> bool
27
-
(** Alphanumeric character *)
27
+
(** [is_alnum c] returns [true] if [c] is an alphanumeric character. *)
28
28
29
29
val is_indicator : char -> bool
30
-
(** YAML indicator characters *)
30
+
(** [is_indicator c] returns [true] if [c] is a YAML indicator character. *)
31
31
32
32
val is_flow_indicator : char -> bool
33
-
(** Flow context indicator characters (comma and brackets) *)
33
+
(** [is_flow_indicator c] returns [true] if [c] is a flow context indicator
34
+
(comma or bracket). *)
+11
-9
lib/chomping.mli
+11
-9
lib/chomping.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Block scalar chomping indicators *)
6
+
(** Block scalar chomping indicators. *)
7
7
8
8
type t =
9
-
| Strip (** Remove final line break and trailing empty lines *)
10
-
| Clip (** Keep final line break, remove trailing empty lines (default) *)
11
-
| Keep (** Keep final line break and trailing empty lines *)
9
+
| Strip (** Remove final line break and trailing empty lines. *)
10
+
| Clip (** Keep final line break, remove trailing empty lines (default). *)
11
+
| Keep (** Keep final line break and trailing empty lines. *)
12
12
13
13
val to_string : t -> string
14
-
(** Convert chomping mode to string *)
14
+
(** [to_string c] converts the chomping mode [c] to a string. *)
15
15
16
16
val pp : Format.formatter -> t -> unit
17
-
(** Pretty-print a chomping mode *)
17
+
(** [pp ppf c] pretty-prints the chomping mode [c] to [ppf]. *)
18
18
19
19
val of_char : char -> t option
20
-
(** Parse chomping indicator from character *)
20
+
(** [of_char c] parses a chomping indicator character, returning [None] if
21
+
unrecognized. *)
21
22
22
23
val to_char : t -> char option
23
-
(** Convert chomping mode to indicator character (None for Clip) *)
24
+
(** [to_char c] converts the chomping mode [c] to its indicator character, or
25
+
[None] for Clip. *)
24
26
25
27
val equal : t -> t -> bool
26
-
(** Test equality of two chomping modes *)
28
+
(** [equal a b] returns [true] if chomping modes [a] and [b] are equal. *)
+1
-1
lib/document.ml
+1
-1
lib/document.ml
···
13
13
implicit_end : bool;
14
14
}
15
15
16
-
let make ?(version : (int * int) option) ?(tags : (string * string) list = [])
16
+
let v ?(version : (int * int) option) ?(tags : (string * string) list = [])
17
17
?(implicit_start = true) ?(implicit_end = true) root =
18
18
{ version; tags; root; implicit_start; implicit_end }
19
19
+23
-3
lib/document.mli
+23
-3
lib/document.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML document with directives and content *)
6
+
(** YAML document with directives and content. *)
7
7
8
8
type t = {
9
9
version : (int * int) option;
···
13
13
implicit_end : bool;
14
14
}
15
15
16
-
val make :
16
+
val v :
17
17
?version:int * int ->
18
18
?tags:(string * string) list ->
19
19
?implicit_start:bool ->
20
20
?implicit_end:bool ->
21
21
Yaml.t option ->
22
22
t
23
-
(** Create a document *)
23
+
(** [v ?version ?tags ?implicit_start ?implicit_end root] creates a document. *)
24
24
25
25
(** {2 Accessors} *)
26
26
27
27
val version : t -> (int * int) option
28
+
(** [version doc] returns the YAML version directive of the document. *)
29
+
28
30
val tags : t -> (string * string) list
31
+
(** [tags doc] returns the tag directives of the document. *)
32
+
29
33
val root : t -> Yaml.t option
34
+
(** [root doc] returns the root YAML node of the document. *)
35
+
30
36
val implicit_start : t -> bool
37
+
(** [implicit_start doc] returns whether the document start marker is implicit.
38
+
*)
39
+
31
40
val implicit_end : t -> bool
41
+
(** [implicit_end doc] returns whether the document end marker is implicit. *)
32
42
33
43
(** {2 Modifiers} *)
34
44
35
45
val with_version : int * int -> t -> t
46
+
(** [with_version v doc] returns a copy of [doc] with the given version. *)
47
+
36
48
val with_tags : (string * string) list -> t -> t
49
+
(** [with_tags tags doc] returns a copy of [doc] with the given tag directives.
50
+
*)
51
+
37
52
val with_root : Yaml.t -> t -> t
53
+
(** [with_root root doc] returns a copy of [doc] with the given root node. *)
38
54
39
55
(** {2 Comparison} *)
40
56
41
57
val pp : Format.formatter -> t -> unit
58
+
(** [pp ppf doc] pretty-prints the document [doc] to [ppf]. *)
59
+
42
60
val equal : t -> t -> bool
61
+
(** [equal a b] returns [true] if documents [a] and [b] are structurally equal.
62
+
*)
+6
-6
lib/eio/yamlrw_eio.mli
+6
-6
lib/eio/yamlrw_eio.mli
···
218
218
(** Read a value from a file path.
219
219
220
220
@param fs
221
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
221
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
222
222
223
223
val yaml_of_file :
224
224
?resolve_aliases:bool ->
···
230
230
(** Read full YAML from a file path.
231
231
232
232
@param fs
233
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
233
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
234
234
235
235
val documents_of_file : fs:_ Eio.Path.t -> string -> document list
236
236
(** Read documents from a file path.
237
237
238
238
@param fs
239
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
239
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
240
240
241
241
val to_file :
242
242
?encoding:Yamlrw.Encoding.t ->
···
249
249
(** Write a value to a file path.
250
250
251
251
@param fs
252
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
252
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
253
253
254
254
val yaml_to_file :
255
255
?encoding:Yamlrw.Encoding.t ->
···
262
262
(** Write full YAML to a file path.
263
263
264
264
@param fs
265
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
265
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
266
266
267
267
val documents_to_file :
268
268
?encoding:Yamlrw.Encoding.t ->
···
276
276
(** Write documents to a file path.
277
277
278
278
@param fs
279
-
The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)
279
+
The filesystem path (e.g., Eio.Stdenv.fs env or Eio.Stdenv.cwd env). *)
+368
-334
lib/emitter.ml
+368
-334
lib/emitter.ml
···
55
55
mutable need_separator : bool;
56
56
}
57
57
58
-
let create ?(config = default_config) () =
58
+
let v ?(config = default_config) () =
59
59
{
60
60
config;
61
61
sink = Buffer_sink (Buffer.create 1024);
···
254
254
255
255
(** Emit events *)
256
256
257
-
let emit t (ev : Event.t) =
258
-
match ev with
259
-
| Event.Stream_start _ -> t.state <- Stream_started
260
-
| Event.Stream_end -> t.state <- Stream_ended
261
-
| Event.Document_start { version; implicit } ->
262
-
if not implicit then begin
263
-
(match version with
264
-
| Some (maj, min) -> write t (Fmt.str "%%YAML %d.%d\n" maj min)
265
-
| None -> ());
266
-
write t "---";
257
+
let emit_document_start t ~version ~implicit =
258
+
if not implicit then begin
259
+
(match version with
260
+
| Some (maj, min) -> write t (Fmt.str "%%YAML %d.%d\n" maj min)
261
+
| None -> ());
262
+
write t "---";
263
+
write_newline t
264
+
end;
265
+
t.state <- Document_started
266
+
267
+
let emit_document_end t ~implicit =
268
+
if not implicit then begin
269
+
write t "...";
270
+
write_newline t
271
+
end;
272
+
t.state <- Document_ended
273
+
274
+
let emit_alias t ~anchor =
275
+
if t.flow_level > 0 then begin
276
+
if t.need_separator then write t ", ";
277
+
t.need_separator <- true;
278
+
write_char t '*';
279
+
write t anchor
280
+
end
281
+
else begin
282
+
match t.state with
283
+
| In_block_sequence _ ->
284
+
write_indent t;
285
+
write t "- *";
286
+
write t anchor;
267
287
write_newline t
268
-
end;
269
-
t.state <- Document_started
270
-
| Event.Document_end { implicit } ->
271
-
if not implicit then begin
272
-
write t "...";
288
+
| In_block_mapping_key _ ->
289
+
write_indent t;
290
+
write_char t '*';
291
+
write t anchor;
292
+
write t ": ";
293
+
t.state <- In_block_mapping_value t.indent
294
+
| In_block_mapping_value indent ->
295
+
write_char t '*';
296
+
write t anchor;
297
+
write_newline t;
298
+
t.state <- In_block_mapping_key indent
299
+
| _ ->
300
+
write_char t '*';
301
+
write t anchor;
273
302
write_newline t
274
-
end;
275
-
t.state <- Document_ended
276
-
| Event.Alias { anchor } ->
277
-
if t.flow_level > 0 then begin
278
-
if t.need_separator then write t ", ";
303
+
end
304
+
305
+
let emit_flow_scalar t ~anchor ~tag ~value ~plain_implicit ~style =
306
+
match t.state with
307
+
| In_flow_mapping_key ->
308
+
if t.need_separator then write t ", ";
309
+
write_anchor t anchor;
310
+
write_tag t ~implicit:plain_implicit tag;
311
+
let (_ : bool) = write_scalar t ~style value in
312
+
write t ": ";
313
+
t.need_separator <- false;
314
+
t.state <- In_flow_mapping_value
315
+
| In_flow_mapping_value ->
316
+
if t.need_separator then begin
317
+
(* We just finished a nested structure (array/mapping),
318
+
so this scalar is the next key, not a value *)
319
+
write t ", ";
320
+
write_anchor t anchor;
321
+
write_tag t ~implicit:plain_implicit tag;
322
+
let (_ : bool) = write_scalar t ~style value in
323
+
write t ": ";
324
+
t.need_separator <- false;
325
+
t.state <- In_flow_mapping_value
326
+
end
327
+
else begin
328
+
(* Normal value scalar *)
329
+
write_anchor t anchor;
330
+
write_tag t ~implicit:plain_implicit tag;
331
+
let (_ : bool) = write_scalar t ~style value in
279
332
t.need_separator <- true;
280
-
write_char t '*';
281
-
write t anchor
333
+
t.state <- In_flow_mapping_key
334
+
end
335
+
| _ ->
336
+
if t.need_separator then write t ", ";
337
+
t.need_separator <- true;
338
+
write_anchor t anchor;
339
+
write_tag t ~implicit:plain_implicit tag;
340
+
let (_ : bool) = write_scalar t ~style value in
341
+
()
342
+
343
+
let emit_block_scalar t ~anchor ~tag ~value ~plain_implicit ~style =
344
+
match t.state with
345
+
| In_block_sequence _ ->
346
+
write_indent t;
347
+
write t "- ";
348
+
write_anchor t anchor;
349
+
write_tag t ~implicit:plain_implicit tag;
350
+
let (_ : bool) = write_scalar t ~style value in
351
+
write_newline t
352
+
| In_block_mapping_key indent ->
353
+
write_indent t;
354
+
write_anchor t anchor;
355
+
write_tag t ~implicit:plain_implicit tag;
356
+
let (_ : bool) = write_scalar t ~style value in
357
+
write_char t ':';
358
+
t.state <- In_block_mapping_value indent
359
+
| In_block_mapping_first_key indent ->
360
+
(* First key after "- ", no indent needed *)
361
+
write_anchor t anchor;
362
+
write_tag t ~implicit:plain_implicit tag;
363
+
let (_ : bool) = write_scalar t ~style value in
364
+
write_char t ':';
365
+
t.state <- In_block_mapping_value indent
366
+
| In_block_mapping_value indent ->
367
+
write_char t ' ';
368
+
write_anchor t anchor;
369
+
write_tag t ~implicit:plain_implicit tag;
370
+
let (_ : bool) = write_scalar t ~style value in
371
+
write_newline t;
372
+
t.state <- In_block_mapping_key indent
373
+
| _ ->
374
+
write_anchor t anchor;
375
+
write_tag t ~implicit:plain_implicit tag;
376
+
let (_ : bool) = write_scalar t ~style value in
377
+
write_newline t
378
+
379
+
let emit_scalar t ~anchor ~tag ~value ~plain_implicit ~style =
380
+
if t.flow_level > 0 then
381
+
emit_flow_scalar t ~anchor ~tag ~value ~plain_implicit ~style
382
+
else emit_block_scalar t ~anchor ~tag ~value ~plain_implicit ~style
383
+
384
+
let emit_flow_sequence_start t ~anchor ~tag ~implicit =
385
+
match t.state with
386
+
| In_flow_mapping_key ->
387
+
if t.need_separator then write t ", ";
388
+
write_anchor t anchor;
389
+
write_tag t ~implicit tag;
390
+
write_char t '[';
391
+
t.flow_level <- t.flow_level + 1;
392
+
t.need_separator <- false;
393
+
push_state t In_flow_mapping_value;
394
+
(* After ] we'll be in value position but sequence handles it *)
395
+
t.state <- In_flow_sequence
396
+
| In_flow_mapping_value ->
397
+
write_anchor t anchor;
398
+
write_tag t ~implicit tag;
399
+
write_char t '[';
400
+
t.flow_level <- t.flow_level + 1;
401
+
t.need_separator <- false;
402
+
push_state t In_flow_mapping_key;
403
+
t.state <- In_flow_sequence
404
+
| _ ->
405
+
if t.need_separator then write t ", ";
406
+
write_anchor t anchor;
407
+
write_tag t ~implicit tag;
408
+
write_char t '[';
409
+
t.flow_level <- t.flow_level + 1;
410
+
t.need_separator <- false;
411
+
push_state t In_flow_sequence
412
+
413
+
let emit_block_sequence_start t ~anchor ~tag ~implicit ~use_flow =
414
+
match t.state with
415
+
| In_block_sequence _ ->
416
+
write_indent t;
417
+
write t "- ";
418
+
write_anchor t anchor;
419
+
write_tag t ~implicit tag;
420
+
if use_flow then begin
421
+
write_char t '[';
422
+
t.flow_level <- t.flow_level + 1;
423
+
t.need_separator <- false;
424
+
push_state t In_flow_sequence
282
425
end
283
426
else begin
284
-
match t.state with
285
-
| In_block_sequence _ ->
286
-
write_indent t;
287
-
write t "- *";
288
-
write t anchor;
289
-
write_newline t
290
-
| In_block_mapping_key _ ->
291
-
write_indent t;
292
-
write_char t '*';
293
-
write t anchor;
294
-
write t ": ";
295
-
t.state <- In_block_mapping_value t.indent
296
-
| In_block_mapping_value indent ->
297
-
write_char t '*';
298
-
write t anchor;
299
-
write_newline t;
300
-
t.state <- In_block_mapping_key indent
301
-
| _ ->
302
-
write_char t '*';
303
-
write t anchor;
304
-
write_newline t
427
+
write_newline t;
428
+
push_state t (In_block_sequence t.indent);
429
+
t.indent <- t.indent + t.config.indent
305
430
end
306
-
| Event.Scalar { anchor; tag; value; plain_implicit; style; _ } ->
307
-
if t.flow_level > 0 then begin
308
-
match t.state with
309
-
| In_flow_mapping_key ->
310
-
if t.need_separator then write t ", ";
311
-
write_anchor t anchor;
312
-
write_tag t ~implicit:plain_implicit tag;
313
-
let (_ : bool) = write_scalar t ~style value in
314
-
write t ": ";
315
-
t.need_separator <- false;
316
-
t.state <- In_flow_mapping_value
317
-
| In_flow_mapping_value ->
318
-
if t.need_separator then begin
319
-
(* We just finished a nested structure (array/mapping),
320
-
so this scalar is the next key, not a value *)
321
-
write t ", ";
322
-
write_anchor t anchor;
323
-
write_tag t ~implicit:plain_implicit tag;
324
-
let (_ : bool) = write_scalar t ~style value in
325
-
write t ": ";
326
-
t.need_separator <- false;
327
-
t.state <- In_flow_mapping_value
328
-
end
329
-
else begin
330
-
(* Normal value scalar *)
331
-
write_anchor t anchor;
332
-
write_tag t ~implicit:plain_implicit tag;
333
-
let (_ : bool) = write_scalar t ~style value in
334
-
t.need_separator <- true;
335
-
t.state <- In_flow_mapping_key
336
-
end
337
-
| _ ->
338
-
if t.need_separator then write t ", ";
339
-
t.need_separator <- true;
340
-
write_anchor t anchor;
341
-
write_tag t ~implicit:plain_implicit tag;
342
-
let (_ : bool) = write_scalar t ~style value in
343
-
()
431
+
| In_block_mapping_key indent ->
432
+
write_indent t;
433
+
write_anchor t anchor;
434
+
write_tag t ~implicit tag;
435
+
write t ":";
436
+
write_newline t;
437
+
push_state t (In_block_mapping_key indent);
438
+
t.indent <- t.indent + t.config.indent;
439
+
t.state <- In_block_sequence t.indent
440
+
| In_block_mapping_first_key indent ->
441
+
(* First key after "- " with sequence value - no indent *)
442
+
write_anchor t anchor;
443
+
write_tag t ~implicit tag;
444
+
write t ":";
445
+
write_newline t;
446
+
push_state t (In_block_mapping_key indent);
447
+
t.indent <- t.indent + t.config.indent;
448
+
t.state <- In_block_sequence t.indent
449
+
| In_block_mapping_value indent ->
450
+
write_anchor t anchor;
451
+
write_tag t ~implicit tag;
452
+
if use_flow then begin
453
+
write_char t ' ';
454
+
write_char t '[';
455
+
t.flow_level <- t.flow_level + 1;
456
+
t.need_separator <- false;
457
+
(* Save key state to return to after flow sequence *)
458
+
t.state <- In_block_mapping_key indent;
459
+
push_state t In_flow_sequence
344
460
end
345
461
else begin
346
-
match t.state with
347
-
| In_block_sequence _ ->
348
-
write_indent t;
349
-
write t "- ";
350
-
write_anchor t anchor;
351
-
write_tag t ~implicit:plain_implicit tag;
352
-
let (_ : bool) = write_scalar t ~style value in
353
-
write_newline t
354
-
| In_block_mapping_key indent ->
355
-
write_indent t;
356
-
write_anchor t anchor;
357
-
write_tag t ~implicit:plain_implicit tag;
358
-
let (_ : bool) = write_scalar t ~style value in
359
-
write_char t ':';
360
-
t.state <- In_block_mapping_value indent
361
-
| In_block_mapping_first_key indent ->
362
-
(* First key after "- ", no indent needed *)
363
-
write_anchor t anchor;
364
-
write_tag t ~implicit:plain_implicit tag;
365
-
let (_ : bool) = write_scalar t ~style value in
366
-
write_char t ':';
367
-
t.state <- In_block_mapping_value indent
368
-
| In_block_mapping_value indent ->
369
-
write_char t ' ';
370
-
write_anchor t anchor;
371
-
write_tag t ~implicit:plain_implicit tag;
372
-
let (_ : bool) = write_scalar t ~style value in
373
-
write_newline t;
374
-
t.state <- In_block_mapping_key indent
375
-
| _ ->
376
-
write_anchor t anchor;
377
-
write_tag t ~implicit:plain_implicit tag;
378
-
let (_ : bool) = write_scalar t ~style value in
379
-
write_newline t
462
+
write_newline t;
463
+
(* Save key state to return to after nested sequence *)
464
+
t.state <- In_block_mapping_key indent;
465
+
push_state t (In_block_sequence (t.indent + t.config.indent));
466
+
t.indent <- t.indent + t.config.indent
380
467
end
381
-
| Event.Sequence_start { anchor; tag; implicit; style } ->
382
-
let use_flow = style = `Flow || t.flow_level > 0 in
383
-
if t.flow_level > 0 then begin
384
-
match t.state with
385
-
| In_flow_mapping_key ->
386
-
if t.need_separator then write t ", ";
387
-
write_anchor t anchor;
388
-
write_tag t ~implicit tag;
389
-
write_char t '[';
390
-
t.flow_level <- t.flow_level + 1;
391
-
t.need_separator <- false;
392
-
push_state t In_flow_mapping_value;
393
-
(* After ] we'll be in value position but sequence handles it *)
394
-
t.state <- In_flow_sequence
395
-
| In_flow_mapping_value ->
396
-
write_anchor t anchor;
397
-
write_tag t ~implicit tag;
398
-
write_char t '[';
399
-
t.flow_level <- t.flow_level + 1;
400
-
t.need_separator <- false;
401
-
push_state t In_flow_mapping_key;
402
-
t.state <- In_flow_sequence
403
-
| _ ->
404
-
if t.need_separator then write t ", ";
405
-
write_anchor t anchor;
406
-
write_tag t ~implicit tag;
407
-
write_char t '[';
408
-
t.flow_level <- t.flow_level + 1;
409
-
t.need_separator <- false;
410
-
push_state t In_flow_sequence
468
+
| _ ->
469
+
write_anchor t anchor;
470
+
write_tag t ~implicit tag;
471
+
if use_flow then begin
472
+
write_char t '[';
473
+
t.flow_level <- t.flow_level + 1;
474
+
t.need_separator <- false;
475
+
push_state t In_flow_sequence
411
476
end
412
477
else begin
413
-
match t.state with
414
-
| In_block_sequence _ ->
415
-
write_indent t;
416
-
write t "- ";
417
-
write_anchor t anchor;
418
-
write_tag t ~implicit tag;
419
-
if use_flow then begin
420
-
write_char t '[';
421
-
t.flow_level <- t.flow_level + 1;
422
-
t.need_separator <- false;
423
-
push_state t In_flow_sequence
424
-
end
425
-
else begin
426
-
write_newline t;
427
-
push_state t (In_block_sequence t.indent);
428
-
t.indent <- t.indent + t.config.indent
429
-
end
430
-
| In_block_mapping_key indent ->
431
-
write_indent t;
432
-
write_anchor t anchor;
433
-
write_tag t ~implicit tag;
434
-
write t ":";
435
-
write_newline t;
436
-
push_state t (In_block_mapping_key indent);
437
-
t.indent <- t.indent + t.config.indent;
438
-
t.state <- In_block_sequence t.indent
439
-
| In_block_mapping_first_key indent ->
440
-
(* First key after "- " with sequence value - no indent *)
441
-
write_anchor t anchor;
442
-
write_tag t ~implicit tag;
443
-
write t ":";
444
-
write_newline t;
445
-
push_state t (In_block_mapping_key indent);
446
-
t.indent <- t.indent + t.config.indent;
447
-
t.state <- In_block_sequence t.indent
448
-
| In_block_mapping_value indent ->
449
-
write_anchor t anchor;
450
-
write_tag t ~implicit tag;
451
-
if use_flow then begin
452
-
write_char t ' ';
453
-
write_char t '[';
454
-
t.flow_level <- t.flow_level + 1;
455
-
t.need_separator <- false;
456
-
(* Save key state to return to after flow sequence *)
457
-
t.state <- In_block_mapping_key indent;
458
-
push_state t In_flow_sequence
459
-
end
460
-
else begin
461
-
write_newline t;
462
-
(* Save key state to return to after nested sequence *)
463
-
t.state <- In_block_mapping_key indent;
464
-
push_state t (In_block_sequence (t.indent + t.config.indent));
465
-
t.indent <- t.indent + t.config.indent
466
-
end
467
-
| _ ->
468
-
write_anchor t anchor;
469
-
write_tag t ~implicit tag;
470
-
if use_flow then begin
471
-
write_char t '[';
472
-
t.flow_level <- t.flow_level + 1;
473
-
t.need_separator <- false;
474
-
push_state t In_flow_sequence
475
-
end
476
-
else begin
477
-
push_state t (In_block_sequence t.indent);
478
-
t.state <- In_block_sequence t.indent
479
-
end
478
+
push_state t (In_block_sequence t.indent);
479
+
t.state <- In_block_sequence t.indent
480
480
end
481
-
| Event.Sequence_end ->
482
-
if t.flow_level > 0 then begin
483
-
write_char t ']';
484
-
t.flow_level <- t.flow_level - 1;
485
-
t.need_separator <- true;
486
-
pop_state t;
487
-
(* Write newline if returning to block context *)
488
-
match t.state with
489
-
| In_block_mapping_key _ | In_block_sequence _ -> write_newline t
490
-
| _ -> ()
481
+
482
+
let emit_sequence_start t ~anchor ~tag ~implicit ~style =
483
+
let use_flow = style = `Flow || t.flow_level > 0 in
484
+
if t.flow_level > 0 then emit_flow_sequence_start t ~anchor ~tag ~implicit
485
+
else emit_block_sequence_start t ~anchor ~tag ~implicit ~use_flow
486
+
487
+
let emit_sequence_end t =
488
+
if t.flow_level > 0 then begin
489
+
write_char t ']';
490
+
t.flow_level <- t.flow_level - 1;
491
+
t.need_separator <- true;
492
+
pop_state t;
493
+
(* Write newline if returning to block context *)
494
+
match t.state with
495
+
| In_block_mapping_key _ | In_block_sequence _ -> write_newline t
496
+
| _ -> ()
497
+
end
498
+
else begin
499
+
t.indent <- t.indent - t.config.indent;
500
+
pop_state t
501
+
end
502
+
503
+
let emit_flow_mapping_start t ~anchor ~tag ~implicit =
504
+
match t.state with
505
+
| In_flow_mapping_key ->
506
+
if t.need_separator then write t ", ";
507
+
write_anchor t anchor;
508
+
write_tag t ~implicit tag;
509
+
write_char t '{';
510
+
t.flow_level <- t.flow_level + 1;
511
+
t.need_separator <- false;
512
+
push_state t In_flow_mapping_value;
513
+
t.state <- In_flow_mapping_key
514
+
| In_flow_mapping_value ->
515
+
write_anchor t anchor;
516
+
write_tag t ~implicit tag;
517
+
write_char t '{';
518
+
t.flow_level <- t.flow_level + 1;
519
+
t.need_separator <- false;
520
+
push_state t In_flow_mapping_key;
521
+
t.state <- In_flow_mapping_key
522
+
| _ ->
523
+
if t.need_separator then write t ", ";
524
+
write_anchor t anchor;
525
+
write_tag t ~implicit tag;
526
+
write_char t '{';
527
+
t.flow_level <- t.flow_level + 1;
528
+
t.need_separator <- false;
529
+
push_state t In_flow_mapping_key
530
+
531
+
let emit_block_mapping_start t ~anchor ~tag ~implicit ~use_flow =
532
+
match t.state with
533
+
| In_block_sequence _ ->
534
+
write_indent t;
535
+
write t "- ";
536
+
write_anchor t anchor;
537
+
write_tag t ~implicit tag;
538
+
if use_flow then begin
539
+
write_char t '{';
540
+
t.flow_level <- t.flow_level + 1;
541
+
t.need_separator <- false;
542
+
push_state t In_flow_mapping_key
491
543
end
492
544
else begin
493
-
t.indent <- t.indent - t.config.indent;
494
-
pop_state t
545
+
(* Don't write newline - first key goes on same line as "- " *)
546
+
push_state t (In_block_sequence t.indent);
547
+
t.indent <- t.indent + t.config.indent;
548
+
t.state <- In_block_mapping_first_key t.indent
495
549
end
496
-
| Event.Mapping_start { anchor; tag; implicit; style } ->
497
-
let use_flow = style = `Flow || t.flow_level > 0 in
498
-
if t.flow_level > 0 then begin
499
-
match t.state with
500
-
| In_flow_mapping_key ->
501
-
if t.need_separator then write t ", ";
502
-
write_anchor t anchor;
503
-
write_tag t ~implicit tag;
504
-
write_char t '{';
505
-
t.flow_level <- t.flow_level + 1;
506
-
t.need_separator <- false;
507
-
push_state t In_flow_mapping_value;
508
-
t.state <- In_flow_mapping_key
509
-
| In_flow_mapping_value ->
510
-
write_anchor t anchor;
511
-
write_tag t ~implicit tag;
512
-
write_char t '{';
513
-
t.flow_level <- t.flow_level + 1;
514
-
t.need_separator <- false;
515
-
push_state t In_flow_mapping_key;
516
-
t.state <- In_flow_mapping_key
517
-
| _ ->
518
-
if t.need_separator then write t ", ";
519
-
write_anchor t anchor;
520
-
write_tag t ~implicit tag;
521
-
write_char t '{';
522
-
t.flow_level <- t.flow_level + 1;
523
-
t.need_separator <- false;
524
-
push_state t In_flow_mapping_key
550
+
| In_block_mapping_key indent ->
551
+
write_indent t;
552
+
write_anchor t anchor;
553
+
write_tag t ~implicit tag;
554
+
write t ":";
555
+
write_newline t;
556
+
push_state t (In_block_mapping_key indent);
557
+
t.indent <- t.indent + t.config.indent;
558
+
t.state <- In_block_mapping_key t.indent
559
+
| In_block_mapping_first_key indent ->
560
+
(* First key after "- " with mapping value - no indent *)
561
+
write_anchor t anchor;
562
+
write_tag t ~implicit tag;
563
+
write t ":";
564
+
write_newline t;
565
+
push_state t (In_block_mapping_key indent);
566
+
t.indent <- t.indent + t.config.indent;
567
+
t.state <- In_block_mapping_key t.indent
568
+
| In_block_mapping_value indent ->
569
+
write_anchor t anchor;
570
+
write_tag t ~implicit tag;
571
+
if use_flow then begin
572
+
write_char t ' ';
573
+
write_char t '{';
574
+
t.flow_level <- t.flow_level + 1;
575
+
t.need_separator <- false;
576
+
(* Save key state to return to after flow mapping *)
577
+
t.state <- In_block_mapping_key indent;
578
+
push_state t In_flow_mapping_key
525
579
end
526
580
else begin
527
-
match t.state with
528
-
| In_block_sequence _ ->
529
-
write_indent t;
530
-
write t "- ";
531
-
write_anchor t anchor;
532
-
write_tag t ~implicit tag;
533
-
if use_flow then begin
534
-
write_char t '{';
535
-
t.flow_level <- t.flow_level + 1;
536
-
t.need_separator <- false;
537
-
push_state t In_flow_mapping_key
538
-
end
539
-
else begin
540
-
(* Don't write newline - first key goes on same line as "- " *)
541
-
push_state t (In_block_sequence t.indent);
542
-
t.indent <- t.indent + t.config.indent;
543
-
t.state <- In_block_mapping_first_key t.indent
544
-
end
545
-
| In_block_mapping_key indent ->
546
-
write_indent t;
547
-
write_anchor t anchor;
548
-
write_tag t ~implicit tag;
549
-
write t ":";
550
-
write_newline t;
551
-
push_state t (In_block_mapping_key indent);
552
-
t.indent <- t.indent + t.config.indent;
553
-
t.state <- In_block_mapping_key t.indent
554
-
| In_block_mapping_first_key indent ->
555
-
(* First key after "- " with mapping value - no indent *)
556
-
write_anchor t anchor;
557
-
write_tag t ~implicit tag;
558
-
write t ":";
559
-
write_newline t;
560
-
push_state t (In_block_mapping_key indent);
561
-
t.indent <- t.indent + t.config.indent;
562
-
t.state <- In_block_mapping_key t.indent
563
-
| In_block_mapping_value indent ->
564
-
write_anchor t anchor;
565
-
write_tag t ~implicit tag;
566
-
if use_flow then begin
567
-
write_char t ' ';
568
-
write_char t '{';
569
-
t.flow_level <- t.flow_level + 1;
570
-
t.need_separator <- false;
571
-
(* Save key state to return to after flow mapping *)
572
-
t.state <- In_block_mapping_key indent;
573
-
push_state t In_flow_mapping_key
574
-
end
575
-
else begin
576
-
write_newline t;
577
-
(* Save key state to return to after nested mapping *)
578
-
t.state <- In_block_mapping_key indent;
579
-
push_state t (In_block_mapping_key (t.indent + t.config.indent));
580
-
t.indent <- t.indent + t.config.indent
581
-
end
582
-
| _ ->
583
-
write_anchor t anchor;
584
-
write_tag t ~implicit tag;
585
-
if use_flow then begin
586
-
write_char t '{';
587
-
t.flow_level <- t.flow_level + 1;
588
-
t.need_separator <- false;
589
-
push_state t In_flow_mapping_key
590
-
end
591
-
else begin
592
-
push_state t (In_block_mapping_key t.indent);
593
-
t.state <- In_block_mapping_key t.indent
594
-
end
581
+
write_newline t;
582
+
(* Save key state to return to after nested mapping *)
583
+
t.state <- In_block_mapping_key indent;
584
+
push_state t (In_block_mapping_key (t.indent + t.config.indent));
585
+
t.indent <- t.indent + t.config.indent
595
586
end
596
-
| Event.Mapping_end ->
597
-
if t.flow_level > 0 then begin
598
-
write_char t '}';
599
-
t.flow_level <- t.flow_level - 1;
600
-
t.need_separator <- true;
601
-
pop_state t;
602
-
(* Write newline if returning to block context *)
603
-
match t.state with
604
-
| In_block_mapping_key _ | In_block_sequence _ -> write_newline t
605
-
| _ -> ()
587
+
| _ ->
588
+
write_anchor t anchor;
589
+
write_tag t ~implicit tag;
590
+
if use_flow then begin
591
+
write_char t '{';
592
+
t.flow_level <- t.flow_level + 1;
593
+
t.need_separator <- false;
594
+
push_state t In_flow_mapping_key
606
595
end
607
596
else begin
608
-
t.indent <- t.indent - t.config.indent;
609
-
pop_state t
597
+
push_state t (In_block_mapping_key t.indent);
598
+
t.state <- In_block_mapping_key t.indent
610
599
end
611
600
601
+
let emit_mapping_start t ~anchor ~tag ~implicit ~style =
602
+
let use_flow = style = `Flow || t.flow_level > 0 in
603
+
if t.flow_level > 0 then emit_flow_mapping_start t ~anchor ~tag ~implicit
604
+
else emit_block_mapping_start t ~anchor ~tag ~implicit ~use_flow
605
+
606
+
let emit_mapping_end t =
607
+
if t.flow_level > 0 then begin
608
+
write_char t '}';
609
+
t.flow_level <- t.flow_level - 1;
610
+
t.need_separator <- true;
611
+
pop_state t;
612
+
(* Write newline if returning to block context *)
613
+
match t.state with
614
+
| In_block_mapping_key _ | In_block_sequence _ -> write_newline t
615
+
| _ -> ()
616
+
end
617
+
else begin
618
+
t.indent <- t.indent - t.config.indent;
619
+
pop_state t
620
+
end
621
+
622
+
let emit t (ev : Event.t) =
623
+
match ev with
624
+
| Event.Stream_start _ -> t.state <- Stream_started
625
+
| Event.Stream_end -> t.state <- Stream_ended
626
+
| Event.Document_start { version; implicit } ->
627
+
emit_document_start t ~version ~implicit
628
+
| Event.Document_end { implicit } -> emit_document_end t ~implicit
629
+
| Event.Alias { anchor } -> emit_alias t ~anchor
630
+
| Event.Scalar { anchor; tag; value; plain_implicit; style; _ } ->
631
+
emit_scalar t ~anchor ~tag ~value ~plain_implicit ~style
632
+
| Event.Sequence_start { anchor; tag; implicit; style } ->
633
+
emit_sequence_start t ~anchor ~tag ~implicit ~style
634
+
| Event.Sequence_end -> emit_sequence_end t
635
+
| Event.Mapping_start { anchor; tag; implicit; style } ->
636
+
emit_mapping_start t ~anchor ~tag ~implicit ~style
637
+
| Event.Mapping_end -> emit_mapping_end t
638
+
612
639
(** Access to the underlying buffer for advanced use. Returns None if emitter is
613
640
writing to a Writer instead of Buffer. *)
614
641
let buffer t =
···
626
653
match t.sink with
627
654
| Writer_sink w -> Bytesrw.Bytes.Writer.write_eod w
628
655
| Buffer_sink _ -> ()
656
+
657
+
(** Pretty-print the current emitter state *)
658
+
let pp ppf t =
659
+
let sink_str =
660
+
match t.sink with Buffer_sink _ -> "buffer" | Writer_sink _ -> "writer"
661
+
in
662
+
Fmt.pf ppf "<emitter sink=%s>" sink_str
+18
-12
lib/emitter.mli
+18
-12
lib/emitter.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Emitter - converts YAML data structures to string output
6
+
(** Emitter - converts YAML data structures to string output.
7
7
8
8
The emitter can write to either a Buffer (default) or directly to a bytesrw
9
9
Bytes.Writer for streaming output. *)
···
20
20
}
21
21
22
22
val default_config : config
23
-
(** Default emitter configuration *)
23
+
(** [default_config] is the default emitter configuration. *)
24
24
25
25
(** {1 Emitter Type} *)
26
26
27
27
type t
28
28
29
+
val pp : Format.formatter -> t -> unit
30
+
(** [pp ppf e] pretty-prints the emitter state [e] to [ppf]. *)
31
+
29
32
(** {1 Constructors} *)
30
33
31
-
val create : ?config:config -> unit -> t
32
-
(** Create an emitter that writes to an internal buffer *)
34
+
val v : ?config:config -> unit -> t
35
+
(** [v ?config ()] creates an emitter that writes to an internal buffer. *)
33
36
34
37
val of_writer : ?config:config -> Bytesrw.Bytes.Writer.t -> t
35
-
(** Create an emitter that writes directly to a Bytes.Writer *)
38
+
(** [of_writer ?config writer] creates an emitter that writes directly to
39
+
[writer]. *)
36
40
37
41
(** {1 Output} *)
38
42
39
43
val contents : t -> string
40
-
(** Get accumulated output. Returns empty string for writer-based emitters. *)
44
+
(** [contents e] returns the accumulated output, or an empty string for
45
+
writer-based emitters. *)
41
46
42
47
val reset : t -> unit
43
-
(** Reset emitter state and clear buffer *)
48
+
(** [reset e] resets the emitter state and clears the buffer. *)
44
49
45
50
val buffer : t -> Buffer.t option
46
-
(** Access underlying buffer (None for writer-based emitters) *)
51
+
(** [buffer e] returns the underlying buffer, or [None] for writer-based
52
+
emitters. *)
47
53
48
54
val flush : t -> unit
49
-
(** Flush writer sink (no-op for buffer-based emitters) *)
55
+
(** [flush e] flushes the writer sink (no-op for buffer-based emitters). *)
50
56
51
57
(** {1 Event Emission} *)
52
58
53
59
val emit : t -> Event.t -> unit
54
-
(** Emit a single event *)
60
+
(** [emit e event] emits a single event. *)
55
61
56
62
(** {1 Accessors} *)
57
63
58
64
val config : t -> config
59
-
(** Get emitter configuration *)
65
+
(** [config e] returns the emitter configuration. *)
60
66
61
67
val is_streaming : t -> bool
62
-
(** Check if emitter is writing to a Writer (vs buffer) *)
68
+
(** [is_streaming e] returns [true] if the emitter is writing to a Writer. *)
+6
-5
lib/encoding.mli
+6
-5
lib/encoding.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Character encoding detection and handling *)
6
+
(** Character encoding detection and handling. *)
7
7
8
8
type t = [ `Utf8 | `Utf16be | `Utf16le | `Utf32be | `Utf32le ]
9
9
10
10
val to_string : t -> string
11
-
(** Convert encoding to string representation *)
11
+
(** [to_string e] converts the encoding [e] to its string representation. *)
12
12
13
13
val pp : Format.formatter -> t -> unit
14
-
(** Pretty-print an encoding *)
14
+
(** [pp ppf e] pretty-prints the encoding [e] to [ppf]. *)
15
15
16
16
val detect : string -> t * int
17
-
(** Detect encoding from BOM or first bytes. Returns (encoding, bom_length) *)
17
+
(** [detect s] detects the encoding from a BOM or first bytes of [s], returning
18
+
the encoding and BOM length. *)
18
19
19
20
val equal : t -> t -> bool
20
-
(** Test equality of two encodings *)
21
+
(** [equal a b] returns [true] if encodings [a] and [b] are equal. *)
+2
-2
lib/error.ml
+2
-2
lib/error.ml
···
253
253
@param context Context stack (defaults to empty)
254
254
@param source Source text
255
255
@param kind Error classification *)
256
-
let make ?span ?(context = []) ?source kind = { kind; span; context; source }
256
+
let v ?span ?(context = []) ?source kind = { kind; span; context; source }
257
257
258
258
(** [raise ?span ?context ?source kind] constructs and raises an error.
259
259
···
265
265
@param kind Error classification
266
266
@raise Yamlrw_error *)
267
267
let raise ?span ?context ?source kind =
268
-
Stdlib.raise (Yamlrw_error (make ?span ?context ?source kind))
268
+
Stdlib.raise (Yamlrw_error (v ?span ?context ?source kind))
269
269
270
270
(** [raise_at pos kind] raises an error at a specific position.
271
271
+2
-2
lib/error.mli
+2
-2
lib/error.mli
···
87
87
88
88
(** {2 Error Construction} *)
89
89
90
-
val make : ?span:Span.t -> ?context:string list -> ?source:string -> kind -> t
91
-
(** Construct an error value. *)
90
+
val v : ?span:Span.t -> ?context:string list -> ?source:string -> kind -> t
91
+
(** [v ?span ?context ?source kind] constructs an error value. *)
92
92
93
93
val raise : ?span:Span.t -> ?context:string list -> ?source:string -> kind -> 'a
94
94
(** Construct and raise an error. *)
+3
-3
lib/event.mli
+3
-3
lib/event.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML parser events *)
6
+
(** YAML parser events. *)
7
7
8
8
type t =
9
9
| Stream_start of { encoding : Encoding.t }
···
37
37
type spanned = { event : t; span : Span.t }
38
38
39
39
val pp : Format.formatter -> t -> unit
40
-
(** Pretty-print an event *)
40
+
(** [pp ppf e] pretty-prints the event [e] to [ppf]. *)
41
41
42
42
val pp_spanned : Format.formatter -> spanned -> unit
43
-
(** Pretty-print a spanned event *)
43
+
(** [pp_spanned ppf e] pretty-prints the spanned event [e] to [ppf]. *)
+3
lib/input.ml
+3
lib/input.ml
+45
-21
lib/input.mli
+45
-21
lib/input.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Character input source with lookahead, based on Bytes.Reader.t
6
+
(** Character input source with lookahead, based on Bytes.Reader.t.
7
7
8
8
This module wraps a bytesrw [Bytes.Reader.t] to provide
9
9
character-by-character access with lookahead for the YAML scanner. *)
···
16
16
17
17
type t
18
18
19
+
val pp : Format.formatter -> t -> unit
20
+
(** [pp ppf input] pretty-prints the current state of [input] to [ppf]. *)
21
+
19
22
(** {2 Constructors} *)
20
23
21
24
val of_reader : ?initial_position:Position.t -> Bytesrw.Bytes.Reader.t -> t
22
-
(** Create input from a Bytes.Reader.t *)
25
+
(** [of_reader ?initial_position reader] creates input from a Bytes.Reader.t. *)
23
26
24
27
val of_string : string -> t
25
-
(** Create input from a string *)
28
+
(** [of_string s] creates input from a string. *)
26
29
27
30
(** {2 Position and State} *)
28
31
29
32
val position : t -> Position.t
30
-
(** Get current position *)
33
+
(** [position input] returns the current position. *)
31
34
32
35
val is_eof : t -> bool
33
-
(** Check if at end of input *)
36
+
(** [is_eof input] returns [true] if at end of input. *)
34
37
35
38
val mark : t -> Position.t
36
-
(** Mark current position for span creation *)
39
+
(** [mark input] marks the current position for span creation. *)
37
40
38
41
(** {2 Lookahead} *)
39
42
40
43
val peek : t -> char option
41
-
(** Peek at current character without advancing *)
44
+
(** [peek input] peeks at the current character without advancing. *)
42
45
43
46
val peek_exn : t -> char
44
-
(** Peek at current character, raising on EOF *)
47
+
(** [peek_exn input] peeks at the current character, raising on EOF. *)
45
48
46
49
val peek_nth : t -> int -> char option
47
-
(** Peek at nth character (0-indexed from current position) *)
50
+
(** [peek_nth input n] peeks at the nth character (0-indexed from current
51
+
position). *)
48
52
49
53
val peek_string : t -> int -> string
50
-
(** Peek at up to n characters as a string *)
54
+
(** [peek_string input n] peeks at up to [n] characters as a string. *)
51
55
52
56
val peek_back : t -> char option
53
-
(** Get the character before the current position *)
57
+
(** [peek_back input] returns the character before the current position. *)
54
58
55
59
(** {2 Consumption} *)
56
60
57
61
val next : t -> char option
58
-
(** Consume and return next character *)
62
+
(** [next input] consumes and returns the next character. *)
59
63
60
64
val next_exn : t -> char
61
-
(** Consume and return next character, raising on EOF *)
65
+
(** [next_exn input] consumes and returns the next character, raising on EOF. *)
62
66
63
67
val skip : t -> int -> unit
64
-
(** Skip n characters *)
68
+
(** [skip input n] skips [n] characters. *)
65
69
66
70
val skip_while : t -> (char -> bool) -> unit
67
-
(** Skip characters while predicate holds *)
71
+
(** [skip_while input pred] skips characters while [pred] holds. *)
68
72
69
73
val consume_break : t -> unit
70
-
(** Consume line break, handling \r\n as single break *)
74
+
(** [consume_break input] consumes a line break, handling [\r\n] as a single
75
+
break. *)
71
76
72
77
(** {2 Predicates} *)
73
78
74
79
val next_is : (char -> bool) -> t -> bool
75
-
(** Check if next char satisfies predicate *)
80
+
(** [next_is pred input] checks if the next character satisfies [pred]. *)
76
81
77
82
val next_is_break : t -> bool
83
+
(** [next_is_break input] returns [true] if the next character is a line break.
84
+
*)
85
+
78
86
val next_is_blank : t -> bool
87
+
(** [next_is_blank input] returns [true] if the next character is a blank (space
88
+
or tab). *)
89
+
79
90
val next_is_whitespace : t -> bool
91
+
(** [next_is_whitespace input] returns [true] if the next character is
92
+
whitespace. *)
93
+
80
94
val next_is_digit : t -> bool
95
+
(** [next_is_digit input] returns [true] if the next character is a digit. *)
96
+
81
97
val next_is_hex : t -> bool
98
+
(** [next_is_hex input] returns [true] if the next character is a hex digit. *)
99
+
82
100
val next_is_alpha : t -> bool
101
+
(** [next_is_alpha input] returns [true] if the next character is alphabetic. *)
102
+
83
103
val next_is_indicator : t -> bool
104
+
(** [next_is_indicator input] returns [true] if the next character is a YAML
105
+
indicator. *)
84
106
85
107
val at_document_boundary : t -> bool
86
-
(** Check if at document boundary (--- or ...) *)
108
+
(** [at_document_boundary input] checks if at a document boundary (--- or ...).
109
+
*)
87
110
88
111
(** {2 Utilities} *)
89
112
90
113
val remaining : t -> string
91
-
(** Get remaining content from current position *)
114
+
(** [remaining input] returns the remaining content from the current position.
115
+
*)
92
116
93
117
val source : t -> string
94
-
(** Get a sample of the source for encoding detection *)
118
+
(** [source input] returns a sample of the source for encoding detection. *)
95
119
96
120
val byte_pos : t -> int
97
-
(** Get the byte position in the underlying stream *)
121
+
(** [byte_pos input] returns the byte position in the underlying stream. *)
+8
-8
lib/layout_style.mli
+8
-8
lib/layout_style.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Collection layout styles *)
6
+
(** Collection layout styles. *)
7
7
8
8
type t =
9
-
[ `Any (** Let emitter choose *)
10
-
| `Block (** Indentation-based *)
11
-
| `Flow (** Inline with brackets *) ]
9
+
[ `Any (** Let emitter choose. *)
10
+
| `Block (** Indentation-based. *)
11
+
| `Flow (** Inline with brackets. *) ]
12
12
13
13
val to_string : t -> string
14
-
(** Convert style to string representation *)
14
+
(** [to_string s] converts the layout style [s] to its string representation. *)
15
15
16
16
val pp : Format.formatter -> t -> unit
17
-
(** Pretty-print a style *)
17
+
(** [pp ppf s] pretty-prints the layout style [s] to [ppf]. *)
18
18
19
19
val equal : t -> t -> bool
20
-
(** Test equality of two styles *)
20
+
(** [equal a b] returns [true] if layout styles [a] and [b] are equal. *)
21
21
22
22
val compare : t -> t -> int
23
-
(** Compare two styles *)
23
+
(** [compare a b] compares layout styles [a] and [b]. *)
+17
-21
lib/loader.ml
+17
-21
lib/loader.ml
···
31
31
mutable doc_implicit_start : bool;
32
32
}
33
33
34
-
let create_state () =
34
+
let state () =
35
35
{
36
36
stack = [];
37
37
current = None;
···
50
50
state.doc_implicit_start <- implicit
51
51
| Event.Document_end { implicit } ->
52
52
let doc =
53
-
Document.make ?version:state.doc_version
53
+
Document.v ?version:state.doc_version
54
54
~implicit_start:state.doc_implicit_start ~implicit_end:implicit
55
55
state.current
56
56
in
···
64
64
| Event.Scalar { anchor; tag; value; plain_implicit; quoted_implicit; style }
65
65
->
66
66
let scalar =
67
-
Scalar.make ?anchor ?tag ~plain_implicit ~quoted_implicit ~style value
67
+
Scalar.v ?anchor ?tag ~plain_implicit ~quoted_implicit ~style value
68
68
in
69
69
let node : Yaml.t = `Scalar scalar in
70
70
add_node state node
···
74
74
| Event.Sequence_end -> (
75
75
match state.stack with
76
76
| Sequence_frame { anchor; tag; implicit; style; items } :: rest ->
77
-
let seq =
78
-
Sequence.make ?anchor ?tag ~implicit ~style (List.rev items)
79
-
in
77
+
let seq = Sequence.v ?anchor ?tag ~implicit ~style (List.rev items) in
80
78
let node : Yaml.t = `A seq in
81
79
state.stack <- rest;
82
80
add_node state node
···
92
90
| Mapping_frame
93
91
{ anchor; tag; implicit; style; pairs; pending_key = None }
94
92
:: rest ->
95
-
let map =
96
-
Mapping.make ?anchor ?tag ~implicit ~style (List.rev pairs)
97
-
in
93
+
let map = Mapping.v ?anchor ?tag ~implicit ~style (List.rev pairs) in
98
94
let node : Yaml.t = `O map in
99
95
state.stack <- rest;
100
96
add_node state node
···
123
119
124
120
(** Internal: parse all documents from a parser *)
125
121
let parse_all_documents parser =
126
-
let state = create_state () in
122
+
let state = state () in
127
123
Parser.iter (process_event state) parser;
128
124
List.rev state.documents
129
125
···
143
139
?(max_nodes = Yaml.default_max_alias_nodes)
144
140
?(max_depth = Yaml.default_max_alias_depth) s =
145
141
let docs = parse_all_documents (Parser.of_string s) in
146
-
let doc = single_document_or_error docs ~empty:(Document.make None) in
142
+
let doc = single_document_or_error docs ~empty:(Document.v None) in
147
143
match Document.root doc with
148
144
| None -> `Null
149
145
| Some yaml ->
···
159
155
?(max_nodes = Yaml.default_max_alias_nodes)
160
156
?(max_depth = Yaml.default_max_alias_depth) s =
161
157
let docs = parse_all_documents (Parser.of_string s) in
162
-
let doc = single_document_or_error docs ~empty:(Document.make None) in
158
+
let doc = single_document_or_error docs ~empty:(Document.v None) in
163
159
match Document.root doc with
164
-
| None -> `Scalar (Scalar.make "")
160
+
| None -> `Scalar (Scalar.v "")
165
161
| Some yaml ->
166
162
if resolve_aliases then Yaml.resolve_aliases ~max_nodes ~max_depth yaml
167
163
else yaml
···
180
176
?(max_nodes = Yaml.default_max_alias_nodes)
181
177
?(max_depth = Yaml.default_max_alias_depth) reader =
182
178
let docs = parse_all_documents (Parser.of_reader reader) in
183
-
let doc = single_document_or_error docs ~empty:(Document.make None) in
179
+
let doc = single_document_or_error docs ~empty:(Document.v None) in
184
180
match Document.root doc with
185
181
| None -> `Null
186
182
| Some yaml ->
···
196
192
?(max_nodes = Yaml.default_max_alias_nodes)
197
193
?(max_depth = Yaml.default_max_alias_depth) reader =
198
194
let docs = parse_all_documents (Parser.of_reader reader) in
199
-
let doc = single_document_or_error docs ~empty:(Document.make None) in
195
+
let doc = single_document_or_error docs ~empty:(Document.v None) in
200
196
match Document.root doc with
201
-
| None -> `Scalar (Scalar.make "")
197
+
| None -> `Scalar (Scalar.v "")
202
198
| Some yaml ->
203
199
if resolve_aliases then Yaml.resolve_aliases ~max_nodes ~max_depth yaml
204
200
else yaml
···
214
210
215
211
(** Generic document loader using event source function *)
216
212
let load_generic_fn extract next_event =
217
-
let state = create_state () in
213
+
let state = state () in
218
214
let rec loop () =
219
215
match next_event () with
220
216
| None -> None
···
257
253
let load_yaml parser =
258
254
load_generic
259
255
(fun doc ->
260
-
Document.root doc |> Option.value ~default:(`Scalar (Scalar.make "")))
256
+
Document.root doc |> Option.value ~default:(`Scalar (Scalar.v "")))
261
257
parser
262
258
263
259
(** Load single Document from parser *)
···
314
310
load_generic_fn
315
311
(fun doc ->
316
312
match Document.root doc with
317
-
| None -> `Scalar (Scalar.make "")
313
+
| None -> `Scalar (Scalar.v "")
318
314
| Some yaml ->
319
315
if resolve_aliases then
320
316
Yaml.resolve_aliases ~max_nodes ~max_depth yaml
···
322
318
next_event
323
319
with
324
320
| Some v -> v
325
-
| None -> `Scalar (Scalar.make "")
321
+
| None -> `Scalar (Scalar.v "")
326
322
327
323
(** Load single Document from event source *)
328
324
let document_of_parser next_event = load_generic_fn Fun.id next_event
329
325
330
326
(** Load all documents from event source *)
331
327
let documents_of_parser next_event =
332
-
let state = create_state () in
328
+
let state = state () in
333
329
let rec loop () =
334
330
match next_event () with
335
331
| None -> List.rev state.documents
+36
-24
lib/loader.mli
+36
-24
lib/loader.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Loader - converts parser events to YAML data structures *)
6
+
(** Loader - converts parser events to YAML data structures. *)
7
7
8
8
(** {1 String-based loading} *)
9
9
10
10
val value_of_string :
11
11
?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> Value.t
12
-
(** Load single document as Value.
12
+
(** [value_of_string ?resolve_aliases ?max_nodes ?max_depth s] loads a single
13
+
document as a Value.
13
14
14
-
@param resolve_aliases Whether to resolve aliases (default true)
15
-
@param max_nodes Maximum nodes during alias expansion (default 10M)
16
-
@param max_depth Maximum alias nesting depth (default 100) *)
15
+
@param resolve_aliases Whether to resolve aliases (default true).
16
+
@param max_nodes Maximum nodes during alias expansion (default 10M).
17
+
@param max_depth Maximum alias nesting depth (default 100). *)
17
18
18
19
val yaml_of_string :
19
20
?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> Yaml.t
20
-
(** Load single document as Yaml.
21
+
(** [yaml_of_string ?resolve_aliases ?max_nodes ?max_depth s] loads a single
22
+
document as a Yaml.
21
23
22
-
@param resolve_aliases Whether to resolve aliases (default false)
23
-
@param max_nodes Maximum nodes during alias expansion (default 10M)
24
-
@param max_depth Maximum alias nesting depth (default 100) *)
24
+
@param resolve_aliases Whether to resolve aliases (default false).
25
+
@param max_nodes Maximum nodes during alias expansion (default 10M).
26
+
@param max_depth Maximum alias nesting depth (default 100). *)
25
27
26
28
val documents_of_string : string -> Document.t list
27
-
(** Load all documents from a string *)
29
+
(** [documents_of_string s] loads all documents from a string. *)
28
30
29
31
(** {1 Reader-based loading} *)
30
32
···
34
36
?max_depth:int ->
35
37
Bytesrw.Bytes.Reader.t ->
36
38
Value.t
37
-
(** Load single document as Value from a Bytes.Reader *)
39
+
(** [value_of_reader ?resolve_aliases ?max_nodes ?max_depth reader] loads a
40
+
single document as a Value from a Bytes.Reader. *)
38
41
39
42
val yaml_of_reader :
40
43
?resolve_aliases:bool ->
···
42
45
?max_depth:int ->
43
46
Bytesrw.Bytes.Reader.t ->
44
47
Yaml.t
45
-
(** Load single document as Yaml from a Bytes.Reader *)
48
+
(** [yaml_of_reader ?resolve_aliases ?max_nodes ?max_depth reader] loads a
49
+
single document as a Yaml from a Bytes.Reader. *)
46
50
47
51
val documents_of_reader : Bytesrw.Bytes.Reader.t -> Document.t list
48
-
(** Load all documents from a Bytes.Reader *)
52
+
(** [documents_of_reader reader] loads all documents from a Bytes.Reader. *)
49
53
50
54
(** {1 Parser-based loading} *)
51
55
···
55
59
?max_depth:int ->
56
60
Parser.t ->
57
61
Value.t option
58
-
(** Load single Value from parser *)
62
+
(** [load_value ?resolve_aliases ?max_nodes ?max_depth parser] loads a single
63
+
Value from the parser. *)
59
64
60
65
val load_yaml : Parser.t -> Yaml.t option
61
-
(** Load single Yaml from parser *)
66
+
(** [load_yaml parser] loads a single Yaml node from the parser. *)
62
67
63
68
val load_document : Parser.t -> Document.t option
64
-
(** Load single Document from parser *)
69
+
(** [load_document parser] loads a single Document from the parser. *)
65
70
66
71
val iter_documents : (Document.t -> unit) -> Parser.t -> unit
67
-
(** Iterate over documents from parser *)
72
+
(** [iter_documents f parser] iterates over documents from the parser, calling
73
+
[f] on each. *)
68
74
69
75
val fold_documents : ('a -> Document.t -> 'a) -> 'a -> Parser.t -> 'a
70
-
(** Fold over documents from parser *)
76
+
(** [fold_documents f acc parser] folds [f] over documents from the parser. *)
71
77
72
78
(** {1 Event function-based loading}
73
79
···
80
86
?max_depth:int ->
81
87
(unit -> Event.spanned option) ->
82
88
Value.t
83
-
(** Load single Value from event source function *)
89
+
(** [value_of_parser ?resolve_aliases ?max_nodes ?max_depth next] loads a single
90
+
Value from an event source function. *)
84
91
85
92
val yaml_of_parser :
86
93
?resolve_aliases:bool ->
···
88
95
?max_depth:int ->
89
96
(unit -> Event.spanned option) ->
90
97
Yaml.t
91
-
(** Load single Yaml from event source function *)
98
+
(** [yaml_of_parser ?resolve_aliases ?max_nodes ?max_depth next] loads a single
99
+
Yaml node from an event source function. *)
92
100
93
101
val document_of_parser : (unit -> Event.spanned option) -> Document.t option
94
-
(** Load single Document from event source function *)
102
+
(** [document_of_parser next] loads a single Document from an event source
103
+
function. *)
95
104
96
105
val documents_of_parser : (unit -> Event.spanned option) -> Document.t list
97
-
(** Load all documents from event source function *)
106
+
(** [documents_of_parser next] loads all documents from an event source
107
+
function. *)
98
108
99
109
val iter_documents_parser :
100
110
(Document.t -> unit) -> (unit -> Event.spanned option) -> unit
101
-
(** Iterate over documents from event source function *)
111
+
(** [iter_documents_parser f next] iterates over documents from an event source
112
+
function, calling [f] on each. *)
102
113
103
114
val fold_documents_parser :
104
115
('a -> Document.t -> 'a) -> 'a -> (unit -> Event.spanned option) -> 'a
105
-
(** Fold over documents from event source function *)
116
+
(** [fold_documents_parser f acc next] folds [f] over documents from an event
117
+
source function. *)
+2
-2
lib/mapping.ml
+2
-2
lib/mapping.ml
···
13
13
members : ('k * 'v) list;
14
14
}
15
15
16
-
let make ?(anchor : string option) ?(tag : string option) ?(implicit = true)
16
+
let v ?(anchor : string option) ?(tag : string option) ?(implicit = true)
17
17
?(style = `Any) members =
18
18
{ anchor; tag; implicit; style; members }
19
19
···
39
39
let find pred t =
40
40
List.find_opt (fun (k, _) -> pred k) t.members |> Option.map snd
41
41
42
-
let find_key pred t = List.find_opt (fun (k, _) -> pred k) t.members
42
+
let key pred t = List.find_opt (fun (k, _) -> pred k) t.members
43
43
let mem pred t = List.exists (fun (k, _) -> pred k) t.members
44
44
let keys t = List.map fst t.members
45
45
let values t = List.map snd t.members
+47
-4
lib/mapping.mli
+47
-4
lib/mapping.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML mapping (object) values with metadata *)
6
+
(** YAML mapping (object) values with metadata. *)
7
7
8
8
type ('k, 'v) t
9
9
10
-
val make :
10
+
val v :
11
11
?anchor:string ->
12
12
?tag:string ->
13
13
?implicit:bool ->
14
14
?style:Layout_style.t ->
15
15
('k * 'v) list ->
16
16
('k, 'v) t
17
-
(** Create a mapping *)
17
+
(** [v ?anchor ?tag ?implicit ?style members] creates a mapping. *)
18
18
19
19
(** {2 Accessors} *)
20
20
21
21
val members : ('k, 'v) t -> ('k * 'v) list
22
+
(** [members m] returns the key-value pairs of the mapping. *)
23
+
22
24
val anchor : ('k, 'v) t -> string option
25
+
(** [anchor m] returns the anchor name of the mapping, if any. *)
26
+
23
27
val tag : ('k, 'v) t -> string option
28
+
(** [tag m] returns the tag of the mapping, if any. *)
29
+
24
30
val implicit : ('k, 'v) t -> bool
31
+
(** [implicit m] returns whether the mapping has an implicit tag. *)
32
+
25
33
val style : ('k, 'v) t -> Layout_style.t
34
+
(** [style m] returns the layout style of the mapping. *)
26
35
27
36
(** {2 Modifiers} *)
28
37
29
38
val with_anchor : string -> ('k, 'v) t -> ('k, 'v) t
39
+
(** [with_anchor anchor m] returns a copy of [m] with the given anchor. *)
40
+
30
41
val with_tag : string -> ('k, 'v) t -> ('k, 'v) t
42
+
(** [with_tag tag m] returns a copy of [m] with the given tag. *)
43
+
31
44
val with_style : Layout_style.t -> ('k, 'v) t -> ('k, 'v) t
45
+
(** [with_style style m] returns a copy of [m] with the given layout style. *)
32
46
33
47
(** {2 Operations} *)
34
48
35
49
val map_keys : ('k -> 'k2) -> ('k, 'v) t -> ('k2, 'v) t
50
+
(** [map_keys f m] applies [f] to all keys in [m]. *)
51
+
36
52
val map_values : ('v -> 'v2) -> ('k, 'v) t -> ('k, 'v2) t
53
+
(** [map_values f m] applies [f] to all values in [m]. *)
54
+
37
55
val map : ('k -> 'v -> 'k2 * 'v2) -> ('k, 'v) t -> ('k2, 'v2) t
56
+
(** [map f m] applies [f] to each key-value pair in [m]. *)
57
+
38
58
val length : ('k, 'v) t -> int
59
+
(** [length m] returns the number of key-value pairs in [m]. *)
60
+
39
61
val is_empty : ('k, 'v) t -> bool
62
+
(** [is_empty m] returns [true] if [m] has no key-value pairs. *)
63
+
40
64
val find : ('k -> bool) -> ('k, 'v) t -> 'v option
41
-
val find_key : ('k -> bool) -> ('k, 'v) t -> ('k * 'v) option
65
+
(** [find pred m] returns the value of the first key satisfying [pred], if any.
66
+
*)
67
+
68
+
val key : ('k -> bool) -> ('k, 'v) t -> ('k * 'v) option
69
+
(** [key pred m] returns the first key-value pair whose key satisfies [pred], if
70
+
any. *)
71
+
42
72
val mem : ('k -> bool) -> ('k, 'v) t -> bool
73
+
(** [mem pred m] returns [true] if any key in [m] satisfies [pred]. *)
74
+
43
75
val keys : ('k, 'v) t -> 'k list
76
+
(** [keys m] returns all keys in [m]. *)
77
+
44
78
val values : ('k, 'v) t -> 'v list
79
+
(** [values m] returns all values in [m]. *)
80
+
45
81
val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit
82
+
(** [iter f m] calls [f] on each key-value pair in [m]. *)
83
+
46
84
val fold : ('a -> 'k -> 'v -> 'a) -> 'a -> ('k, 'v) t -> 'a
85
+
(** [fold f acc m] folds [f] over the key-value pairs of [m]. *)
47
86
48
87
(** {2 Comparison} *)
49
88
···
53
92
Format.formatter ->
54
93
('k, 'v) t ->
55
94
unit
95
+
(** [pp pp_k pp_v ppf m] pretty-prints the mapping [m] using [pp_k] and [pp_v].
96
+
*)
56
97
57
98
val equal :
58
99
('k -> 'k -> bool) -> ('v -> 'v -> bool) -> ('k, 'v) t -> ('k, 'v) t -> bool
100
+
(** [equal eq_k eq_v a b] returns [true] if mappings [a] and [b] are equal. *)
59
101
60
102
val compare :
61
103
('k -> 'k -> int) -> ('v -> 'v -> int) -> ('k, 'v) t -> ('k, 'v) t -> int
104
+
(** [compare cmp_k cmp_v a b] compares mappings [a] and [b]. *)
+109
-114
lib/parser.ml
+109
-114
lib/parser.ml
···
43
43
(** True if we haven't emitted any documents yet *)
44
44
}
45
45
46
-
let create scanner =
46
+
let v scanner =
47
47
{
48
48
scanner;
49
49
state = Stream_start;
···
56
56
stream_start = true;
57
57
}
58
58
59
-
let of_string s = create (Scanner.of_string s)
60
-
let of_scanner = create
61
-
let of_input i = create (Scanner.of_input i)
62
-
let of_reader r = create (Scanner.of_reader r)
59
+
let of_string s = v (Scanner.of_string s)
60
+
let of_scanner = v
61
+
let of_input i = v (Scanner.of_input i)
62
+
let of_reader r = v (Scanner.of_reader r)
63
63
64
64
(** Get current token, fetching if needed *)
65
65
let current_token t =
···
232
232
t.state <- Implicit_document_start;
233
233
(Event.Document_end { implicit }, span)
234
234
235
+
(** Parse a node that already has anchor/tag properties resolved *)
236
+
let parse_node_with_props t ~block ~indentless ~anchor ~tag
237
+
(tok : Token.spanned) =
238
+
match tok.token with
239
+
| Token.Block_entry when indentless ->
240
+
t.state <- Indentless_sequence_entry;
241
+
( Event.Sequence_start
242
+
{ anchor; tag; implicit = tag = None; style = `Block },
243
+
tok.span )
244
+
| Token.Block_sequence_start when block ->
245
+
t.state <- Block_sequence_first_entry;
246
+
skip_token t;
247
+
( Event.Sequence_start
248
+
{ anchor; tag; implicit = tag = None; style = `Block },
249
+
tok.span )
250
+
| Token.Block_mapping_start when block ->
251
+
t.state <- Block_mapping_first_key;
252
+
skip_token t;
253
+
( Event.Mapping_start
254
+
{ anchor; tag; implicit = tag = None; style = `Block },
255
+
tok.span )
256
+
| Token.Flow_sequence_start ->
257
+
t.state <- Flow_sequence_first_entry;
258
+
skip_token t;
259
+
( Event.Sequence_start
260
+
{ anchor; tag; implicit = tag = None; style = `Flow },
261
+
tok.span )
262
+
| Token.Flow_mapping_start ->
263
+
t.state <- Flow_mapping_first_key;
264
+
skip_token t;
265
+
( Event.Mapping_start { anchor; tag; implicit = tag = None; style = `Flow },
266
+
tok.span )
267
+
| Token.Scalar { style; value } ->
268
+
skip_token t;
269
+
t.state <- pop_state t;
270
+
let plain_implicit = tag = None && style = `Plain in
271
+
let quoted_implicit = tag = None && style <> `Plain in
272
+
( Event.Scalar
273
+
{ anchor; tag; value; plain_implicit; quoted_implicit; style },
274
+
tok.span )
275
+
| _ ->
276
+
t.state <- pop_state t;
277
+
empty_scalar_event ~anchor ~tag tok.span
278
+
235
279
(** Parse node in various contexts *)
236
280
let parse_node t ~block ~indentless =
237
281
let tok = current_token t in
···
240
284
skip_token t;
241
285
t.state <- pop_state t;
242
286
(Event.Alias { anchor = name }, tok.span)
243
-
| Token.Anchor _ | Token.Tag _ -> (
287
+
| Token.Anchor _ | Token.Tag _ ->
244
288
let anchor, tag = parse_properties t in
245
289
let tok = current_token t in
246
-
match tok.token with
247
-
| Token.Block_entry when indentless ->
248
-
t.state <- Indentless_sequence_entry;
249
-
( Event.Sequence_start
250
-
{ anchor; tag; implicit = tag = None; style = `Block },
251
-
tok.span )
252
-
| Token.Block_sequence_start when block ->
253
-
t.state <- Block_sequence_first_entry;
254
-
skip_token t;
255
-
( Event.Sequence_start
256
-
{ anchor; tag; implicit = tag = None; style = `Block },
257
-
tok.span )
258
-
| Token.Block_mapping_start when block ->
259
-
t.state <- Block_mapping_first_key;
260
-
skip_token t;
261
-
( Event.Mapping_start
262
-
{ anchor; tag; implicit = tag = None; style = `Block },
263
-
tok.span )
264
-
| Token.Flow_sequence_start ->
265
-
t.state <- Flow_sequence_first_entry;
266
-
skip_token t;
267
-
( Event.Sequence_start
268
-
{ anchor; tag; implicit = tag = None; style = `Flow },
269
-
tok.span )
270
-
| Token.Flow_mapping_start ->
271
-
t.state <- Flow_mapping_first_key;
272
-
skip_token t;
273
-
( Event.Mapping_start
274
-
{ anchor; tag; implicit = tag = None; style = `Flow },
275
-
tok.span )
276
-
| Token.Scalar { style; value } ->
277
-
skip_token t;
278
-
t.state <- pop_state t;
279
-
let plain_implicit = tag = None && style = `Plain in
280
-
let quoted_implicit = tag = None && style <> `Plain in
281
-
( Event.Scalar
282
-
{ anchor; tag; value; plain_implicit; quoted_implicit; style },
283
-
tok.span )
284
-
| _ ->
285
-
(* Empty node *)
286
-
t.state <- pop_state t;
287
-
empty_scalar_event ~anchor ~tag tok.span)
290
+
parse_node_with_props t ~block ~indentless ~anchor ~tag tok
288
291
| Token.Block_sequence_start when block ->
289
292
t.state <- Block_sequence_first_entry;
290
293
skip_token t;
···
330
333
},
331
334
tok.span )
332
335
| _ ->
333
-
(* Empty node *)
334
336
t.state <- pop_state t;
335
337
empty_scalar_event ~anchor:None ~tag:None tok.span
336
338
···
475
477
parse_node t ~block:false ~indentless:false
476
478
477
479
(** Parse flow sequence entry mapping *)
478
-
let parse_flow_sequence_entry_mapping_key t =
480
+
let flow_seq_entry_map_key t =
479
481
let tok = current_token t in
480
482
if
481
483
check t (function
···
490
492
parse_node t ~block:false ~indentless:false
491
493
end
492
494
493
-
let parse_flow_sequence_entry_mapping_value t =
495
+
let flow_seq_entry_map_value t =
494
496
let tok = current_token t in
495
497
match tok.token with
496
498
| Token.Value ->
···
511
513
t.state <- Flow_sequence_entry_mapping_end;
512
514
empty_scalar_event ~anchor:None ~tag:None tok.span
513
515
514
-
let parse_flow_sequence_entry_mapping_end t =
516
+
let flow_seq_entry_map_end t =
515
517
let tok = current_token t in
516
518
t.state <- Flow_sequence_entry;
517
519
(Event.Mapping_end, tok.span)
···
586
588
t.state <- Flow_mapping_key;
587
589
empty_scalar_event ~anchor:None ~tag:None tok.span
588
590
591
+
(** Check if token is a document boundary token *)
592
+
let is_document_boundary_token = function
593
+
| Token.Version_directive _ | Token.Tag_directive _ | Token.Document_start
594
+
| Token.Document_end | Token.Stream_end ->
595
+
true
596
+
| _ -> false
597
+
598
+
(** Parse implicit document start state *)
599
+
let parse_implicit_document_start t =
600
+
while check t (function Token.Document_end -> true | _ -> false) do
601
+
t.explicit_doc_end <- true;
602
+
skip_token t
603
+
done;
604
+
let tok = current_token t in
605
+
match tok.token with
606
+
| Token.Stream_end ->
607
+
skip_token t;
608
+
t.state <- End;
609
+
t.finished <- true;
610
+
(Event.Stream_end, tok.span)
611
+
| Token.Version_directive _ | Token.Tag_directive _ ->
612
+
if (not t.stream_start) && not t.explicit_doc_end then
613
+
Error.raise_span tok.span
614
+
(Invalid_directive
615
+
"directives require explicit document end '...' before them");
616
+
parse_document_start t ~implicit:false
617
+
| Token.Document_start -> parse_document_start t ~implicit:false
618
+
| Token.Flow_sequence_end | Token.Flow_mapping_end | Token.Flow_entry
619
+
| Token.Block_end | Token.Value ->
620
+
Error.raise_span tok.span
621
+
(Unexpected_token "unexpected token at document start")
622
+
| _ -> parse_document_start t ~implicit:true
623
+
624
+
(** Parse document content state *)
625
+
let parse_document_content t =
626
+
if check t is_document_boundary_token then begin
627
+
let tok = current_token t in
628
+
t.state <- pop_state t;
629
+
empty_scalar_event ~anchor:None ~tag:None tok.span
630
+
end
631
+
else begin
632
+
push_state t Document_content_done;
633
+
parse_node t ~block:true ~indentless:false
634
+
end
635
+
589
636
(** Main state machine dispatcher *)
590
637
let rec parse t =
591
638
match t.state with
592
639
| Stream_start -> parse_stream_start t
593
-
| Implicit_document_start -> (
594
-
(* Skip any document end markers before checking what's next *)
595
-
while check t (function Token.Document_end -> true | _ -> false) do
596
-
t.explicit_doc_end <- true;
597
-
(* Seeing ... counts as explicit end *)
598
-
skip_token t
599
-
done;
600
-
601
-
let tok = current_token t in
602
-
match tok.token with
603
-
| Token.Stream_end ->
604
-
skip_token t;
605
-
t.state <- End;
606
-
t.finished <- true;
607
-
(Event.Stream_end, tok.span)
608
-
| Token.Version_directive _ | Token.Tag_directive _ ->
609
-
(* Directives are only allowed at stream start or after explicit ... (MUS6/01) *)
610
-
if (not t.stream_start) && not t.explicit_doc_end then
611
-
Error.raise_span tok.span
612
-
(Invalid_directive
613
-
"directives require explicit document end '...' before them");
614
-
parse_document_start t ~implicit:false
615
-
| Token.Document_start -> parse_document_start t ~implicit:false
616
-
(* These tokens are invalid at document start - they indicate leftover junk *)
617
-
| Token.Flow_sequence_end | Token.Flow_mapping_end | Token.Flow_entry
618
-
| Token.Block_end | Token.Value ->
619
-
Error.raise_span tok.span
620
-
(Unexpected_token "unexpected token at document start")
621
-
| _ -> parse_document_start t ~implicit:true)
622
-
| Document_content ->
623
-
if
624
-
check t (function
625
-
| Token.Version_directive _ | Token.Tag_directive _
626
-
| Token.Document_start | Token.Document_end | Token.Stream_end ->
627
-
true
628
-
| _ -> false)
629
-
then begin
630
-
let tok = current_token t in
631
-
t.state <- pop_state t;
632
-
empty_scalar_event ~anchor:None ~tag:None tok.span
633
-
end
634
-
else begin
635
-
(* Push Document_content_done so we return there after parsing the node.
636
-
This allows us to check for unexpected content after the node. *)
637
-
push_state t Document_content_done;
638
-
parse_node t ~block:true ~indentless:false
639
-
end
640
+
| Implicit_document_start -> parse_implicit_document_start t
641
+
| Document_content -> parse_document_content t
640
642
| Document_content_done ->
641
-
(* After parsing a node in document content, check for unexpected content *)
642
-
if
643
-
check t (function
644
-
| Token.Version_directive _ | Token.Tag_directive _
645
-
| Token.Document_start | Token.Document_end | Token.Stream_end ->
646
-
true
647
-
| _ -> false)
648
-
then begin
649
-
(* Valid document boundary - continue to Document_end *)
643
+
if check t is_document_boundary_token then begin
650
644
t.state <- pop_state t;
651
-
parse t (* Continue to emit the next event *)
645
+
parse t
652
646
end
653
647
else begin
654
-
(* Unexpected content after document value - this is an error (KS4U, BS4K) *)
655
648
let tok = current_token t in
656
649
Error.raise_span tok.span
657
650
(Unexpected_token "content not allowed after document value")
···
669
662
| Block_mapping_value -> parse_block_mapping_value t
670
663
| Flow_sequence_first_entry -> parse_flow_sequence_entry t ~first:true
671
664
| Flow_sequence_entry -> parse_flow_sequence_entry t ~first:false
672
-
| Flow_sequence_entry_mapping_key -> parse_flow_sequence_entry_mapping_key t
673
-
| Flow_sequence_entry_mapping_value ->
674
-
parse_flow_sequence_entry_mapping_value t
675
-
| Flow_sequence_entry_mapping_end -> parse_flow_sequence_entry_mapping_end t
665
+
| Flow_sequence_entry_mapping_key -> flow_seq_entry_map_key t
666
+
| Flow_sequence_entry_mapping_value -> flow_seq_entry_map_value t
667
+
| Flow_sequence_entry_mapping_end -> flow_seq_entry_map_end t
676
668
| Flow_mapping_first_key -> parse_flow_mapping_key t ~first:true
677
669
| Flow_mapping_key -> parse_flow_mapping_key t ~first:false
678
670
| Flow_mapping_value -> parse_flow_mapping_value t ~empty:false
···
708
700
709
701
(** Convert to list *)
710
702
let to_list t = fold (fun acc ev -> ev :: acc) [] t |> List.rev
703
+
704
+
(** Pretty-print the current state *)
705
+
let pp ppf _t = Fmt.pf ppf "<parser state=active>"
+12
-9
lib/parser.mli
+12
-9
lib/parser.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML parser - converts tokens to semantic events via state machine *)
6
+
(** YAML parser - converts tokens to semantic events via state machine. *)
7
7
8
8
type t
9
9
10
+
val pp : Format.formatter -> t -> unit
11
+
(** [pp ppf p] pretty-prints the current parser state [p] to [ppf]. *)
12
+
10
13
(** {2 Constructors} *)
11
14
12
15
val of_string : string -> t
13
-
(** Create parser from a string *)
16
+
(** [of_string s] creates a parser from a string. *)
14
17
15
18
val of_scanner : Scanner.t -> t
16
-
(** Create parser from a scanner *)
19
+
(** [of_scanner scanner] creates a parser from a scanner. *)
17
20
18
21
val of_input : Input.t -> t
19
-
(** Create parser from an input source *)
22
+
(** [of_input input] creates a parser from an input source. *)
20
23
21
24
val of_reader : Bytesrw.Bytes.Reader.t -> t
22
-
(** Create parser from a Bytes.Reader *)
25
+
(** [of_reader reader] creates a parser from a Bytes.Reader. *)
23
26
24
27
(** {2 Event Access} *)
25
28
26
29
val next : t -> Event.spanned option
27
-
(** Get next event *)
30
+
(** [next p] returns the next event, advancing the parser. *)
28
31
29
32
(** {2 Iteration} *)
30
33
31
34
val iter : (Event.spanned -> unit) -> t -> unit
32
-
(** Iterate over all events *)
35
+
(** [iter f p] iterates over all events, calling [f] on each. *)
33
36
34
37
val fold : ('a -> Event.spanned -> 'a) -> 'a -> t -> 'a
35
-
(** Fold over all events *)
38
+
(** [fold f acc p] folds [f] over all events. *)
36
39
37
40
val to_list : t -> Event.spanned list
38
-
(** Convert to list of events *)
41
+
(** [to_list p] converts the parser output to a list of events. *)
+18
-15
lib/position.mli
+18
-15
lib/position.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Position tracking for source locations *)
6
+
(** Position tracking for source locations. *)
7
7
8
8
type t = {
9
-
index : int; (** Byte offset from start *)
10
-
line : int; (** 1-indexed line number *)
11
-
column : int; (** 1-indexed column number *)
9
+
index : int; (** Byte offset from start. *)
10
+
line : int; (** 1-indexed line number. *)
11
+
column : int; (** 1-indexed column number. *)
12
12
}
13
13
14
14
val initial : t
15
-
(** Initial position (index=0, line=1, column=1) *)
15
+
(** [initial] is the initial position (index=0, line=1, column=1). *)
16
16
17
17
val advance_byte : t -> t
18
-
(** Advance by one byte (increments index and column) *)
18
+
(** [advance_byte pos] advances [pos] by one byte (increments index and column).
19
+
*)
19
20
20
21
val advance_line : t -> t
21
-
(** Advance to next line (increments index and line, resets column to 1) *)
22
+
(** [advance_line pos] advances [pos] to the next line (increments index and
23
+
line, resets column to 1). *)
22
24
23
25
val advance_char : char -> t -> t
24
-
(** Advance by one character, handling newlines appropriately *)
26
+
(** [advance_char c pos] advances [pos] by one character [c], handling newlines.
27
+
*)
25
28
26
29
val advance_utf8 : Uchar.t -> t -> t
27
-
(** Advance by one Unicode character, handling newlines and multi-byte
28
-
characters *)
30
+
(** [advance_utf8 u pos] advances [pos] by one Unicode character [u], handling
31
+
newlines and multi-byte characters. *)
29
32
30
33
val advance_bytes : int -> t -> t
31
-
(** Advance by n bytes *)
34
+
(** [advance_bytes n pos] advances [pos] by [n] bytes. *)
32
35
33
36
val pp : Format.formatter -> t -> unit
34
-
(** Pretty-print a position *)
37
+
(** [pp ppf pos] pretty-prints the position [pos] to [ppf]. *)
35
38
36
39
val to_string : t -> string
37
-
(** Convert position to string *)
40
+
(** [to_string pos] converts the position [pos] to a string. *)
38
41
39
42
val compare : t -> t -> int
40
-
(** Compare two positions by index *)
43
+
(** [compare a b] compares positions [a] and [b] by index. *)
41
44
42
45
val equal : t -> t -> bool
43
-
(** Test equality of two positions *)
46
+
(** [equal a b] returns [true] if positions [a] and [b] are equal. *)
+1
-1
lib/quoting.ml
+1
-1
lib/quoting.ml
+16
-11
lib/quoting.mli
+16
-11
lib/quoting.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML scalar quoting detection *)
6
+
(** YAML scalar quoting detection. *)
7
7
8
8
val needs_quoting : string -> bool
9
-
(** Check if a string value needs quoting in YAML output. Returns true if the
10
-
string:
11
-
- Is empty
12
-
- Starts with an indicator character
13
-
- Is a reserved word (null, true, false, yes, no, etc.)
14
-
- Contains characters that would be ambiguous
15
-
- Looks like a number *)
9
+
(** [needs_quoting s] returns [true] if the string [s] needs quoting in YAML
10
+
output.
11
+
12
+
Returns [true] if [s]:
13
+
- Is empty.
14
+
- Starts with an indicator character.
15
+
- Is a reserved word (null, true, false, yes, no, etc.).
16
+
- Contains characters that would be ambiguous.
17
+
- Looks like a number. *)
16
18
17
19
val needs_double_quotes : string -> bool
18
-
(** Check if a string requires double quotes (vs single quotes). Returns true if
19
-
the string contains characters that need escape sequences. *)
20
+
(** [needs_double_quotes s] returns [true] if [s] requires double quotes (vs
21
+
single quotes).
22
+
23
+
Returns [true] if [s] contains characters that need escape sequences. *)
20
24
21
25
val choose_style : string -> [> `Plain | `Single_quoted | `Double_quoted ]
22
-
(** Choose the appropriate quoting style for a string value *)
26
+
(** [choose_style s] chooses the appropriate quoting style for the string value
27
+
[s]. *)
+2
-3
lib/scalar.ml
+2
-3
lib/scalar.ml
···
14
14
style : Scalar_style.t;
15
15
}
16
16
17
-
let make ?(anchor : string option) ?(tag : string option)
18
-
?(plain_implicit = true) ?(quoted_implicit = false) ?(style = `Plain) value
19
-
=
17
+
let v ?(anchor : string option) ?(tag : string option) ?(plain_implicit = true)
18
+
?(quoted_implicit = false) ?(style = `Plain) value =
20
19
{ anchor; tag; value; plain_implicit; quoted_implicit; style }
21
20
22
21
let value t = t.value
+26
-3
lib/scalar.mli
+26
-3
lib/scalar.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML scalar values with metadata *)
6
+
(** YAML scalar values with metadata. *)
7
7
8
8
type t
9
9
10
-
val make :
10
+
val v :
11
11
?anchor:string ->
12
12
?tag:string ->
13
13
?plain_implicit:bool ->
···
15
15
?style:Scalar_style.t ->
16
16
string ->
17
17
t
18
-
(** Create a scalar value *)
18
+
(** [v ?anchor ?tag ?plain_implicit ?quoted_implicit ?style value] creates a
19
+
scalar value. *)
19
20
20
21
(** {2 Accessors} *)
21
22
22
23
val value : t -> string
24
+
(** [value s] returns the string content of the scalar. *)
25
+
23
26
val anchor : t -> string option
27
+
(** [anchor s] returns the anchor name of the scalar, if any. *)
28
+
24
29
val tag : t -> string option
30
+
(** [tag s] returns the tag of the scalar, if any. *)
31
+
25
32
val style : t -> Scalar_style.t
33
+
(** [style s] returns the scalar style. *)
34
+
26
35
val plain_implicit : t -> bool
36
+
(** [plain_implicit s] returns whether the scalar has an implicit plain tag. *)
37
+
27
38
val quoted_implicit : t -> bool
39
+
(** [quoted_implicit s] returns whether the scalar has an implicit quoted tag.
40
+
*)
28
41
29
42
(** {2 Modifiers} *)
30
43
31
44
val with_anchor : string -> t -> t
45
+
(** [with_anchor anchor s] returns a copy of [s] with the given anchor. *)
46
+
32
47
val with_tag : string -> t -> t
48
+
(** [with_tag tag s] returns a copy of [s] with the given tag. *)
49
+
33
50
val with_style : Scalar_style.t -> t -> t
51
+
(** [with_style style s] returns a copy of [s] with the given style. *)
34
52
35
53
(** {2 Comparison} *)
36
54
37
55
val pp : Format.formatter -> t -> unit
56
+
(** [pp ppf s] pretty-prints the scalar [s] to [ppf]. *)
57
+
38
58
val equal : t -> t -> bool
59
+
(** [equal a b] returns [true] if scalars [a] and [b] are equal. *)
60
+
39
61
val compare : t -> t -> int
62
+
(** [compare a b] compares scalars [a] and [b]. *)
+11
-11
lib/scalar_style.mli
+11
-11
lib/scalar_style.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Scalar formatting styles *)
6
+
(** Scalar formatting styles. *)
7
7
8
8
type t =
9
-
[ `Any (** Let emitter choose *)
10
-
| `Plain (** Unquoted: foo *)
11
-
| `Single_quoted (** 'foo' *)
12
-
| `Double_quoted (** "foo" *)
13
-
| `Literal (** | block *)
14
-
| `Folded (** > block *) ]
9
+
[ `Any (** Let emitter choose. *)
10
+
| `Plain (** Unquoted: foo. *)
11
+
| `Single_quoted (** 'foo'. *)
12
+
| `Double_quoted (** "foo". *)
13
+
| `Literal (** | block. *)
14
+
| `Folded (** > block. *) ]
15
15
16
16
val to_string : t -> string
17
-
(** Convert style to string representation *)
17
+
(** [to_string s] converts the scalar style [s] to its string representation. *)
18
18
19
19
val pp : Format.formatter -> t -> unit
20
-
(** Pretty-print a style *)
20
+
(** [pp ppf s] pretty-prints the scalar style [s] to [ppf]. *)
21
21
22
22
val equal : t -> t -> bool
23
-
(** Test equality of two styles *)
23
+
(** [equal a b] returns [true] if scalar styles [a] and [b] are equal. *)
24
24
25
25
val compare : t -> t -> int
26
-
(** Compare two styles *)
26
+
(** [compare a b] compares scalar styles [a] and [b]. *)
+498
-667
lib/scanner.ml
+498
-667
lib/scanner.ml
···
44
44
(** Stack of whether each flow level is a mapping *)
45
45
}
46
46
47
-
let create input =
47
+
let v input =
48
48
{
49
49
input;
50
50
tokens = Queue.create ();
···
65
65
flow_mapping_stack = [];
66
66
}
67
67
68
-
let of_string s = create (Input.of_string s)
69
-
let of_input = create
70
-
let of_reader r = create (Input.of_reader r)
68
+
let of_string s = v (Input.of_string s)
69
+
let of_input = v
70
+
let of_reader r = v (Input.of_reader r)
71
71
let position t = Input.position t.input
72
72
73
73
(** Add a token to the queue *)
···
122
122
done;
123
123
(!found_tab, !found_space)
124
124
125
-
(** Skip whitespace and comments, return true if at newline *)
126
-
let rec skip_to_next_token t =
127
-
(* Check for tabs used as indentation in block context *)
128
-
(match Input.peek t.input with
125
+
(** Check block-context tab indentation and raise error if invalid *)
126
+
let check_block_tab_indentation t =
127
+
match Input.peek t.input with
129
128
| Some '\t'
130
129
when t.flow_level = 0 && t.leading_whitespace
131
130
&& column t - 1 < current_indent t ->
132
-
(* Tab found in indentation zone - this is invalid *)
133
-
(* Skip to end of line to check if line has content *)
134
131
let start_pos = Input.mark t.input in
135
132
while Input.next_is_blank t.input do
136
133
ignore (Input.next t.input)
137
134
done;
138
-
(* If we have content on this line with a tab, raise error *)
139
135
if (not (Input.next_is_break t.input)) && not (Input.is_eof t.input) then
140
136
Error.raise_at start_pos Tab_in_indentation
141
-
| _ -> ());
137
+
| _ -> ()
138
+
139
+
(** Handle flow-context line break: check for tab indentation errors *)
140
+
let handle_flow_line_break t cont =
141
+
Input.consume_break t.input;
142
+
t.allow_simple_key <- true;
143
+
if Input.next_is (( = ) '\t') t.input then begin
144
+
let start_mark = Input.mark t.input in
145
+
while Input.next_is (( = ) '\t') t.input do
146
+
ignore (Input.next t.input)
147
+
done;
148
+
if
149
+
(not (Input.next_is_break t.input))
150
+
&& (not (Input.is_eof t.input))
151
+
&& column t < t.flow_indent
152
+
then Error.raise_at start_mark Invalid_flow_indentation
153
+
end;
154
+
cont ()
142
155
143
-
(* Skip blanks and validate comments *)
156
+
(** Skip whitespace and comments, return true if at newline *)
157
+
let rec skip_to_next_token t =
158
+
check_block_tab_indentation t;
144
159
skip_whitespace_and_comment t;
145
-
(* Skip line break in block context *)
146
160
if t.flow_level = 0 && Input.next_is_break t.input then begin
147
161
Input.consume_break t.input;
148
162
t.allow_simple_key <- true;
···
150
164
skip_to_next_token t
151
165
end
152
166
else if t.flow_level > 0 && Input.next_is_whitespace t.input then begin
153
-
(* In flow context, skip all whitespace including line breaks *)
154
-
if Input.next_is_break t.input then begin
155
-
Input.consume_break t.input;
156
-
(* Allow simple keys after line breaks in flow context *)
157
-
t.allow_simple_key <- true;
158
-
(* After line break in flow, check for tabs at start of line (Y79Y/03)
159
-
Tabs are not allowed as indentation - if tab is first char and results
160
-
in a column less than flow_indent, it's an error *)
161
-
if Input.next_is (( = ) '\t') t.input then begin
162
-
(* Tab at start of line in flow context - skip tabs and check position *)
163
-
let start_mark = Input.mark t.input in
164
-
while Input.next_is (( = ) '\t') t.input do
165
-
ignore (Input.next t.input)
166
-
done;
167
-
(* If only tabs were used (no spaces) and column < flow_indent, error *)
168
-
if
169
-
(not (Input.next_is_break t.input))
170
-
&& (not (Input.is_eof t.input))
171
-
&& column t < t.flow_indent
172
-
then Error.raise_at start_mark Invalid_flow_indentation
173
-
end;
174
-
skip_to_next_token t
175
-
end
167
+
if Input.next_is_break t.input then
168
+
handle_flow_line_break t (fun () -> skip_to_next_token t)
176
169
else begin
177
170
ignore (Input.next t.input);
178
171
skip_to_next_token t
···
281
274
let name = Buffer.contents buf in
282
275
if String.length name = 0 then
283
276
Error.raise_at start (Invalid_anchor "empty anchor name");
284
-
(name, Span.make ~start ~stop:(Input.mark t.input))
277
+
(name, Span.v ~start ~stop:(Input.mark t.input))
285
278
286
279
(** Scan tag handle *)
287
280
let scan_tag_handle t =
···
352
345
done;
353
346
Buffer.contents buf
354
347
348
+
(** Scan verbatim tag !<...> - returns ("", uri) *)
349
+
let scan_tag_verbatim t =
350
+
ignore (Input.next t.input);
351
+
(* consume < *)
352
+
let buf = Buffer.create 32 in
353
+
while
354
+
match Input.peek t.input with
355
+
| Some '>' -> false
356
+
| Some c ->
357
+
Buffer.add_char buf c;
358
+
ignore (Input.next t.input);
359
+
true
360
+
| None ->
361
+
Error.raise_at (Input.mark t.input)
362
+
(Invalid_tag "unclosed verbatim tag")
363
+
do
364
+
()
365
+
done;
366
+
ignore (Input.next t.input);
367
+
(* consume > *)
368
+
("", Buffer.contents buf)
369
+
370
+
(** Scan primary handle or named handle: !foo or !e!foo *)
371
+
let scan_tag_primary_or_named t =
372
+
let buf = Buffer.create 16 in
373
+
while
374
+
match Input.peek t.input with
375
+
| Some c when Input.is_alnum c || c = '-' ->
376
+
Buffer.add_char buf c;
377
+
ignore (Input.next t.input);
378
+
true
379
+
| _ -> false
380
+
do
381
+
()
382
+
done;
383
+
match Input.peek t.input with
384
+
| Some '!' ->
385
+
ignore (Input.next t.input);
386
+
let handle_name = Buffer.contents buf in
387
+
let suffix = scan_tag_suffix t in
388
+
("!" ^ handle_name ^ "!", suffix)
389
+
| _ -> ("!", Buffer.contents buf ^ scan_tag_suffix t)
390
+
355
391
(** Scan a tag *)
356
392
let scan_tag t =
357
393
let start = Input.mark t.input in
···
359
395
(* consume ! *)
360
396
let handle, suffix =
361
397
match Input.peek t.input with
362
-
| Some '<' ->
363
-
(* Verbatim tag: !<...> - handle is empty, suffix is full URI *)
364
-
ignore (Input.next t.input);
365
-
let buf = Buffer.create 32 in
366
-
while
367
-
match Input.peek t.input with
368
-
| Some '>' -> false
369
-
| Some c ->
370
-
Buffer.add_char buf c;
371
-
ignore (Input.next t.input);
372
-
true
373
-
| None ->
374
-
Error.raise_at (Input.mark t.input)
375
-
(Invalid_tag "unclosed verbatim tag")
376
-
do
377
-
()
378
-
done;
379
-
ignore (Input.next t.input);
380
-
(* consume > *)
381
-
("", Buffer.contents buf)
398
+
| Some '<' -> scan_tag_verbatim t
382
399
| Some c when Input.is_whitespace c || Input.is_flow_indicator c ->
383
400
(* Non-specific tag: ! *)
384
401
("!", "")
385
402
| Some '!' ->
386
403
(* Secondary handle: !! *)
387
404
ignore (Input.next t.input);
388
-
(* consume second ! *)
389
405
let suffix = scan_tag_suffix t in
390
406
("!!", suffix)
391
-
| _ -> (
392
-
(* Primary handle or just suffix: !foo or !e!foo *)
393
-
(* Read alphanumeric characters *)
394
-
let buf = Buffer.create 16 in
395
-
while
396
-
match Input.peek t.input with
397
-
| Some c when Input.is_alnum c || c = '-' ->
398
-
Buffer.add_char buf c;
399
-
ignore (Input.next t.input);
400
-
true
401
-
| _ -> false
402
-
do
403
-
()
404
-
done;
405
-
(* Check if next character is ! - if so, this is a named handle *)
406
-
match Input.peek t.input with
407
-
| Some '!' ->
408
-
(* Named handle like !e! *)
409
-
ignore (Input.next t.input);
410
-
let handle_name = Buffer.contents buf in
411
-
let suffix = scan_tag_suffix t in
412
-
("!" ^ handle_name ^ "!", suffix)
413
-
| _ ->
414
-
(* Just ! followed by suffix *)
415
-
("!", Buffer.contents buf ^ scan_tag_suffix t))
407
+
| _ -> scan_tag_primary_or_named t
416
408
in
417
-
(* Validate that tag is followed by whitespace, break, or (in flow) flow indicator *)
418
409
(match Input.peek t.input with
419
-
| None -> () (* EOF is ok *)
410
+
| None -> ()
420
411
| Some c when Input.is_whitespace c || Input.is_break c -> ()
421
412
| Some c when t.flow_level > 0 && Input.is_flow_indicator c -> ()
422
413
| _ ->
423
414
Error.raise_at start
424
415
(Invalid_tag "expected whitespace or line break after tag"));
425
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
416
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
426
417
(handle, suffix, span)
427
418
419
+
(** Check indentation validity in a quoted scalar context; raise error if bad *)
420
+
let check_quoted_indent t =
421
+
let col = column t in
422
+
let indent = current_indent t in
423
+
if
424
+
(not (Input.is_eof t.input))
425
+
&& (not (Input.next_is_break t.input))
426
+
&& col <= indent && indent >= 0
427
+
then
428
+
Error.raise_at (Input.mark t.input)
429
+
(Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar")
430
+
431
+
(** Process a line break in a single-quoted scalar: skip whitespace, count empty
432
+
lines, apply folding, and call [cont] to continue scanning *)
433
+
let scan_single_quoted_break t ~start ~buf cont =
434
+
Input.consume_break t.input;
435
+
while Input.next_is_blank t.input do
436
+
ignore (Input.next t.input)
437
+
done;
438
+
if Input.at_document_boundary t.input then
439
+
Error.raise_at start Unclosed_single_quote;
440
+
check_quoted_indent t;
441
+
let empty_lines = ref 0 in
442
+
while Input.next_is_break t.input do
443
+
incr empty_lines;
444
+
Input.consume_break t.input;
445
+
while Input.next_is_blank t.input do
446
+
ignore (Input.next t.input)
447
+
done;
448
+
if Input.at_document_boundary t.input then
449
+
Error.raise_at start Unclosed_single_quote;
450
+
check_quoted_indent t
451
+
done;
452
+
if !empty_lines > 0 then
453
+
for _ = 1 to !empty_lines do
454
+
Buffer.add_char buf '\n'
455
+
done
456
+
else Buffer.add_char buf ' ';
457
+
cont ()
458
+
428
459
(** Scan single-quoted scalar *)
429
460
let scan_single_quoted t =
430
461
let start = Input.mark t.input in
···
432
463
(* consume opening single-quote *)
433
464
let buf = Buffer.create 64 in
434
465
let whitespace = Buffer.create 16 in
435
-
(* Track trailing whitespace *)
436
466
437
467
let flush_whitespace () =
438
468
if Buffer.length whitespace > 0 then begin
···
446
476
| None -> Error.raise_at start Unclosed_single_quote
447
477
| Some '\'' -> (
448
478
ignore (Input.next t.input);
449
-
(* Check for escaped quote ('') *)
450
479
match Input.peek t.input with
451
480
| Some '\'' ->
452
481
flush_whitespace ();
453
482
Buffer.add_char buf '\'';
454
483
ignore (Input.next t.input);
455
484
loop ()
456
-
| _ ->
457
-
(* End of string - flush any trailing whitespace *)
458
-
flush_whitespace ())
485
+
| _ -> flush_whitespace ())
459
486
| Some ' ' | Some '\t' ->
460
-
(* Track whitespace - don't add to buf yet *)
461
487
Buffer.add_char whitespace (Option.get (Input.peek t.input));
462
488
ignore (Input.next t.input);
463
489
loop ()
464
490
| Some '\n' | Some '\r' ->
465
-
(* Discard trailing whitespace before line break *)
466
491
Buffer.clear whitespace;
467
-
Input.consume_break t.input;
468
-
(* Skip leading whitespace on next line *)
469
-
while Input.next_is_blank t.input do
470
-
ignore (Input.next t.input)
471
-
done;
472
-
(* Check for document boundary *)
473
-
if Input.at_document_boundary t.input then
474
-
Error.raise_at start Unclosed_single_quote;
475
-
(* Check indentation: continuation must be > block indent (QB6E, DK95) *)
476
-
let col = column t in
477
-
let indent = current_indent t in
478
-
if
479
-
(not (Input.is_eof t.input))
480
-
&& (not (Input.next_is_break t.input))
481
-
&& col <= indent && indent >= 0
482
-
then
483
-
Error.raise_at (Input.mark t.input)
484
-
(Invalid_quoted_scalar_indentation
485
-
"invalid indentation in quoted scalar");
486
-
(* Count empty lines (consecutive line breaks) *)
487
-
let empty_lines = ref 0 in
488
-
while Input.next_is_break t.input do
489
-
incr empty_lines;
490
-
Input.consume_break t.input;
491
-
while Input.next_is_blank t.input do
492
-
ignore (Input.next t.input)
493
-
done;
494
-
if Input.at_document_boundary t.input then
495
-
Error.raise_at start Unclosed_single_quote;
496
-
(* Check indentation after each empty line too *)
497
-
let col = column t in
498
-
let indent = current_indent t in
499
-
if
500
-
(not (Input.is_eof t.input))
501
-
&& (not (Input.next_is_break t.input))
502
-
&& col <= indent && indent >= 0
503
-
then
504
-
Error.raise_at (Input.mark t.input)
505
-
(Invalid_quoted_scalar_indentation
506
-
"invalid indentation in quoted scalar")
507
-
done;
508
-
(* Apply folding rules *)
509
-
if !empty_lines > 0 then begin
510
-
(* Empty lines: preserve as newlines *)
511
-
for _ = 1 to !empty_lines do
512
-
Buffer.add_char buf '\n'
513
-
done
514
-
end
515
-
else
516
-
(* Single break: fold to space (even at start of string) *)
517
-
Buffer.add_char buf ' ';
518
-
loop ()
492
+
scan_single_quoted_break t ~start ~buf loop
519
493
| Some c ->
520
494
flush_whitespace ();
521
495
Buffer.add_char buf c;
···
523
497
loop ()
524
498
in
525
499
loop ();
526
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
500
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
527
501
(Buffer.contents buf, span)
528
502
529
503
(** Decode hex escape of given length *)
···
560
534
String.init 4 (fun i ->
561
535
Char.chr (match i with 0 -> b1 | 1 -> b2 | 2 -> b3 | _ -> b4))
562
536
537
+
(** Process a YAML double-quoted escape sequence after consuming the backslash
538
+
*)
539
+
let scan_double_quoted_escape t ~start ~buf =
540
+
ignore (Input.next t.input);
541
+
match Input.peek t.input with
542
+
| None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>")
543
+
| Some '0' ->
544
+
Buffer.add_char buf '\x00';
545
+
ignore (Input.next t.input)
546
+
| Some 'a' ->
547
+
Buffer.add_char buf '\x07';
548
+
ignore (Input.next t.input)
549
+
| Some 'b' ->
550
+
Buffer.add_char buf '\x08';
551
+
ignore (Input.next t.input)
552
+
| Some 't' | Some '\t' ->
553
+
Buffer.add_char buf '\t';
554
+
ignore (Input.next t.input)
555
+
| Some 'n' ->
556
+
Buffer.add_char buf '\n';
557
+
ignore (Input.next t.input)
558
+
| Some 'v' ->
559
+
Buffer.add_char buf '\x0B';
560
+
ignore (Input.next t.input)
561
+
| Some 'f' ->
562
+
Buffer.add_char buf '\x0C';
563
+
ignore (Input.next t.input)
564
+
| Some 'r' ->
565
+
Buffer.add_char buf '\r';
566
+
ignore (Input.next t.input)
567
+
| Some 'e' ->
568
+
Buffer.add_char buf '\x1B';
569
+
ignore (Input.next t.input)
570
+
| Some ' ' ->
571
+
Buffer.add_char buf ' ';
572
+
ignore (Input.next t.input)
573
+
| Some '"' ->
574
+
Buffer.add_char buf '"';
575
+
ignore (Input.next t.input)
576
+
| Some '/' ->
577
+
Buffer.add_char buf '/';
578
+
ignore (Input.next t.input)
579
+
| Some '\\' ->
580
+
Buffer.add_char buf '\\';
581
+
ignore (Input.next t.input)
582
+
| Some 'N' ->
583
+
Buffer.add_string buf "\xC2\x85";
584
+
ignore (Input.next t.input)
585
+
| Some '_' ->
586
+
Buffer.add_string buf "\xC2\xA0";
587
+
ignore (Input.next t.input)
588
+
| Some 'L' ->
589
+
Buffer.add_string buf "\xE2\x80\xA8";
590
+
ignore (Input.next t.input)
591
+
| Some 'P' ->
592
+
Buffer.add_string buf "\xE2\x80\xA9";
593
+
ignore (Input.next t.input)
594
+
| Some 'x' ->
595
+
ignore (Input.next t.input);
596
+
Buffer.add_string buf (decode_hex t 2)
597
+
| Some 'u' ->
598
+
ignore (Input.next t.input);
599
+
Buffer.add_string buf (decode_hex t 4)
600
+
| Some 'U' ->
601
+
ignore (Input.next t.input);
602
+
Buffer.add_string buf (decode_hex t 8)
603
+
| Some '\n' | Some '\r' ->
604
+
Input.consume_break t.input;
605
+
while Input.next_is_blank t.input do
606
+
ignore (Input.next t.input)
607
+
done
608
+
| Some c ->
609
+
Error.raise_at (Input.mark t.input)
610
+
(Invalid_escape_sequence (Fmt.str "\\%c" c))
611
+
612
+
(** Process a line break in a double-quoted scalar *)
613
+
let scan_double_quoted_break t ~start ~buf cont =
614
+
Input.consume_break t.input;
615
+
let empty_lines = ref 0 in
616
+
let continue_loop = ref true in
617
+
let started_with_tab = ref false in
618
+
while !continue_loop do
619
+
if Input.next_is (( = ) '\t') t.input then started_with_tab := true;
620
+
while Input.next_is_blank t.input do
621
+
ignore (Input.next t.input)
622
+
done;
623
+
if Input.next_is_break t.input then begin
624
+
Input.consume_break t.input;
625
+
incr empty_lines;
626
+
started_with_tab := false
627
+
end
628
+
else continue_loop := false
629
+
done;
630
+
if Input.at_document_boundary t.input then
631
+
Error.raise_at start Unclosed_double_quote;
632
+
let col = column t in
633
+
let indent = current_indent t in
634
+
let start_col = start.column in
635
+
if (not (Input.is_eof t.input)) && !started_with_tab && col < start_col then
636
+
Error.raise_at (Input.mark t.input)
637
+
(Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar");
638
+
if (not (Input.is_eof t.input)) && col <= indent && indent >= 0 then
639
+
Error.raise_at (Input.mark t.input)
640
+
(Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar");
641
+
if !empty_lines > 0 then
642
+
for _ = 1 to !empty_lines do
643
+
Buffer.add_char buf '\n'
644
+
done
645
+
else Buffer.add_char buf ' ';
646
+
cont ()
647
+
563
648
(** Scan double-quoted scalar *)
564
649
let scan_double_quoted t =
565
650
let start = Input.mark t.input in
···
567
652
(* consume opening double-quote *)
568
653
let buf = Buffer.create 64 in
569
654
let whitespace = Buffer.create 16 in
570
-
(* Track pending whitespace *)
571
655
572
656
let flush_whitespace () =
573
657
if Buffer.length whitespace > 0 then begin
···
580
664
match Input.peek t.input with
581
665
| None -> Error.raise_at start Unclosed_double_quote
582
666
| Some '"' ->
583
-
(* Flush trailing whitespace before closing quote to preserve it *)
584
667
flush_whitespace ();
585
668
ignore (Input.next t.input)
586
669
| (Some ' ' | Some '\t') as c_opt ->
587
-
(* Track whitespace - don't add to buf yet *)
588
670
let c = match c_opt with Some c -> c | None -> assert false in
589
671
Buffer.add_char whitespace c;
590
672
ignore (Input.next t.input);
591
673
loop ()
592
674
| Some '\\' ->
593
-
(* Escape sequence - this is non-whitespace content *)
594
675
flush_whitespace ();
595
-
(* Commit any pending whitespace *)
596
-
ignore (Input.next t.input);
597
-
(match Input.peek t.input with
598
-
| None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>")
599
-
| Some '0' ->
600
-
Buffer.add_char buf '\x00';
601
-
ignore (Input.next t.input)
602
-
| Some 'a' ->
603
-
Buffer.add_char buf '\x07';
604
-
ignore (Input.next t.input)
605
-
| Some 'b' ->
606
-
Buffer.add_char buf '\x08';
607
-
ignore (Input.next t.input)
608
-
| Some 't' | Some '\t' ->
609
-
Buffer.add_char buf '\t';
610
-
ignore (Input.next t.input)
611
-
| Some 'n' ->
612
-
Buffer.add_char buf '\n';
613
-
ignore (Input.next t.input)
614
-
| Some 'v' ->
615
-
Buffer.add_char buf '\x0B';
616
-
ignore (Input.next t.input)
617
-
| Some 'f' ->
618
-
Buffer.add_char buf '\x0C';
619
-
ignore (Input.next t.input)
620
-
| Some 'r' ->
621
-
Buffer.add_char buf '\r';
622
-
ignore (Input.next t.input)
623
-
| Some 'e' ->
624
-
Buffer.add_char buf '\x1B';
625
-
ignore (Input.next t.input)
626
-
| Some ' ' ->
627
-
Buffer.add_char buf ' ';
628
-
ignore (Input.next t.input)
629
-
| Some '"' ->
630
-
Buffer.add_char buf '"';
631
-
ignore (Input.next t.input)
632
-
| Some '/' ->
633
-
Buffer.add_char buf '/';
634
-
ignore (Input.next t.input)
635
-
| Some '\\' ->
636
-
Buffer.add_char buf '\\';
637
-
ignore (Input.next t.input)
638
-
| Some 'N' ->
639
-
Buffer.add_string buf "\xC2\x85";
640
-
ignore (Input.next t.input) (* NEL *)
641
-
| Some '_' ->
642
-
Buffer.add_string buf "\xC2\xA0";
643
-
ignore (Input.next t.input) (* NBSP *)
644
-
| Some 'L' ->
645
-
Buffer.add_string buf "\xE2\x80\xA8";
646
-
ignore (Input.next t.input) (* LS *)
647
-
| Some 'P' ->
648
-
Buffer.add_string buf "\xE2\x80\xA9";
649
-
ignore (Input.next t.input) (* PS *)
650
-
| Some 'x' ->
651
-
ignore (Input.next t.input);
652
-
Buffer.add_string buf (decode_hex t 2)
653
-
| Some 'u' ->
654
-
ignore (Input.next t.input);
655
-
Buffer.add_string buf (decode_hex t 4)
656
-
| Some 'U' ->
657
-
ignore (Input.next t.input);
658
-
Buffer.add_string buf (decode_hex t 8)
659
-
| Some '\n' | Some '\r' ->
660
-
(* Line continuation escape *)
661
-
Input.consume_break t.input;
662
-
while Input.next_is_blank t.input do
663
-
ignore (Input.next t.input)
664
-
done
665
-
| Some c ->
666
-
Error.raise_at (Input.mark t.input)
667
-
(Invalid_escape_sequence (Fmt.str "\\%c" c)));
676
+
scan_double_quoted_escape t ~start ~buf;
668
677
loop ()
669
678
| Some '\n' | Some '\r' ->
670
-
(* Line break: discard any pending trailing whitespace *)
671
679
Buffer.clear whitespace;
672
-
Input.consume_break t.input;
673
-
(* Count consecutive line breaks (empty lines) *)
674
-
let empty_lines = ref 0 in
675
-
let continue = ref true in
676
-
let started_with_tab = ref false in
677
-
while !continue do
678
-
(* Track if we start with a tab (for DK95/01 check) *)
679
-
if Input.next_is (( = ) '\t') t.input then started_with_tab := true;
680
-
(* Skip blanks (spaces/tabs) on the line *)
681
-
while Input.next_is_blank t.input do
682
-
ignore (Input.next t.input)
683
-
done;
684
-
(* Check if we hit another line break (empty line) *)
685
-
if Input.next_is_break t.input then begin
686
-
Input.consume_break t.input;
687
-
incr empty_lines;
688
-
started_with_tab := false (* Reset for next line *)
689
-
end
690
-
else continue := false
691
-
done;
692
-
(* Check for document boundary - this terminates the quoted string *)
693
-
if Input.at_document_boundary t.input then
694
-
Error.raise_at start Unclosed_double_quote;
695
-
(* Check indentation: continuation must be > block indent (QB6E, DK95)
696
-
Note: must be strictly greater than block indent, not just equal *)
697
-
let col = column t in
698
-
let indent = current_indent t in
699
-
let start_col = start.column in
700
-
(* DK95/01: if continuation started with tabs and column < start column, error *)
701
-
if (not (Input.is_eof t.input)) && !started_with_tab && col < start_col
702
-
then
703
-
Error.raise_at (Input.mark t.input)
704
-
(Invalid_quoted_scalar_indentation
705
-
"invalid indentation in quoted scalar");
706
-
if (not (Input.is_eof t.input)) && col <= indent && indent >= 0 then
707
-
Error.raise_at (Input.mark t.input)
708
-
(Invalid_quoted_scalar_indentation
709
-
"invalid indentation in quoted scalar");
710
-
(* Per YAML spec: single break = space, break + empty lines = newlines *)
711
-
if !empty_lines > 0 then begin
712
-
(* Empty lines: output N newlines where N = number of empty lines *)
713
-
for _ = 1 to !empty_lines do
714
-
Buffer.add_char buf '\n'
715
-
done
716
-
end
717
-
else
718
-
(* Single break folds to space *)
719
-
Buffer.add_char buf ' ';
720
-
loop ()
680
+
scan_double_quoted_break t ~start ~buf loop
721
681
| Some c ->
722
-
(* Non-whitespace character *)
723
682
flush_whitespace ();
724
-
(* Commit any pending whitespace *)
725
683
Buffer.add_char buf c;
726
684
ignore (Input.next t.input);
727
685
loop ()
728
686
in
729
687
loop ();
730
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
688
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
731
689
(Buffer.contents buf, span)
732
690
733
691
(** Check if character can appear in plain scalar at this position *)
···
753
711
| _ when Input.is_break c -> false
754
712
| _ -> true
755
713
714
+
(** Trim trailing spaces and tabs from a string *)
715
+
let trim_trailing_whitespace value =
716
+
let len = String.length value in
717
+
let rec find_end i =
718
+
if i < 0 then 0
719
+
else match value.[i] with ' ' | '\t' -> find_end (i - 1) | _ -> i + 1
720
+
in
721
+
String.sub value 0 (find_end (len - 1))
722
+
723
+
(** Flush accumulated spaces to buf, applying fold rules for leading blanks *)
724
+
let flush_spaces_to_buf ~buf ~spaces ~leading_blanks =
725
+
if Buffer.length spaces > 0 then begin
726
+
if !leading_blanks then begin
727
+
if Buffer.contents spaces = "\n" then Buffer.add_char buf ' '
728
+
else begin
729
+
let s = Buffer.contents spaces in
730
+
Buffer.add_substring buf s 1 (String.length s - 1)
731
+
end
732
+
end
733
+
else Buffer.add_buffer buf spaces;
734
+
Buffer.clear spaces
735
+
end
736
+
756
737
(** Scan plain scalar *)
757
738
let scan_plain_scalar t =
758
739
let start = Input.mark t.input in
759
740
let in_flow = t.flow_level > 0 in
760
741
let indent = current_indent t in
761
-
(* In flow context, scalars must be indented more than the current block indent.
762
-
This ensures that content at block indent or less ends the flow context. *)
763
742
if in_flow && column t - 1 < indent then
764
743
Error.raise_at start Invalid_flow_indentation;
765
744
let buf = Buffer.create 64 in
766
745
let spaces = Buffer.create 16 in
767
746
let whitespace = Buffer.create 16 in
768
-
(* Track whitespace within a line *)
769
747
let leading_blanks = ref false in
770
748
771
749
let rec scan_line () =
772
750
match Input.peek t.input with
773
751
| None -> ()
774
752
| Some c when Input.is_blank c && can_continue_plain t c ~in_flow ->
775
-
(* Blank character within a line - save to whitespace buffer *)
776
753
Buffer.add_char whitespace c;
777
754
ignore (Input.next t.input);
778
755
scan_line ()
779
756
| Some c when can_continue_plain t c ~in_flow ->
780
-
(* Non-blank character - process any pending breaks/whitespace first *)
781
-
begin
782
-
if Buffer.length spaces > 0 then begin
783
-
if !leading_blanks then begin
784
-
(* Fold line break *)
785
-
if Buffer.contents spaces = "\n" then Buffer.add_char buf ' '
786
-
else begin
787
-
(* Multiple breaks - preserve all but first *)
788
-
let s = Buffer.contents spaces in
789
-
Buffer.add_substring buf s 1 (String.length s - 1)
790
-
end
791
-
end
792
-
else Buffer.add_buffer buf spaces;
793
-
Buffer.clear spaces
794
-
end;
795
-
(* Add any pending whitespace from within the line *)
796
-
if Buffer.length whitespace > 0 then begin
797
-
Buffer.add_buffer buf whitespace;
798
-
Buffer.clear whitespace
799
-
end;
800
-
(* Add the character *)
801
-
Buffer.add_char buf c;
802
-
ignore (Input.next t.input);
803
-
leading_blanks := false;
804
-
scan_line ()
805
-
end
757
+
flush_spaces_to_buf ~buf ~spaces ~leading_blanks;
758
+
if Buffer.length whitespace > 0 then begin
759
+
Buffer.add_buffer buf whitespace;
760
+
Buffer.clear whitespace
761
+
end;
762
+
Buffer.add_char buf c;
763
+
ignore (Input.next t.input);
764
+
leading_blanks := false;
765
+
scan_line ()
806
766
| _ -> ()
807
767
in
808
768
809
769
let rec scan_lines () =
810
770
scan_line ();
811
-
(* Check for line continuation *)
812
771
if Input.next_is_break t.input then begin
813
-
(* Discard any trailing whitespace from the current line *)
814
772
Buffer.clear whitespace;
815
-
(* Save the line break *)
816
-
if !leading_blanks then begin
817
-
(* We already had a break - this is an additional break (empty line) *)
818
-
Buffer.add_char spaces '\n'
819
-
end
773
+
if !leading_blanks then Buffer.add_char spaces '\n'
820
774
else begin
821
-
(* First line break *)
822
775
Buffer.clear spaces;
823
776
Buffer.add_char spaces '\n';
824
777
leading_blanks := true
825
778
end;
826
779
Input.consume_break t.input;
827
-
(* Note: We do NOT set allow_simple_key here during plain scalar scanning.
828
-
Setting it here would incorrectly allow ':' that appears on a continuation
829
-
line to become a mapping indicator. The flag will be set properly after
830
-
the scalar ends and skip_to_next_token processes line breaks. *)
831
-
(* Skip leading blanks on the next line *)
832
780
while Input.next_is_blank t.input do
833
781
ignore (Input.next t.input)
834
782
done;
835
783
let col = (Input.position t.input).column in
836
-
(* Check indentation - stop if we're at or before the containing block's indent *)
837
-
(* However, allow empty lines (line breaks) to continue even if dedented *)
838
-
if Input.next_is_break t.input then
839
-
scan_lines () (* Empty line - continue *)
784
+
if Input.next_is_break t.input then scan_lines ()
840
785
else if (not in_flow) && col <= indent then ()
841
-
(* Stop - dedented or at parent level in block context *)
842
786
else if Input.at_document_boundary t.input then ()
843
-
(* Stop - document boundary *)
844
787
else scan_lines ()
845
788
end
846
789
in
847
790
848
791
scan_lines ();
849
-
let value = Buffer.contents buf in
850
-
(* Trim trailing whitespace (spaces and tabs) *)
851
-
let value =
852
-
let len = String.length value in
853
-
let rec find_end i =
854
-
if i < 0 then 0
855
-
else match value.[i] with ' ' | '\t' -> find_end (i - 1) | _ -> i + 1
856
-
in
857
-
let end_pos = find_end (len - 1) in
858
-
String.sub value 0 end_pos
859
-
in
860
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
861
-
(* Return value, span, and whether we ended with leading blanks (crossed a line break) *)
792
+
let value = trim_trailing_whitespace (Buffer.contents buf) in
793
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
862
794
(value, span, !leading_blanks)
863
795
864
-
(** Scan block scalar (literal | or folded >) *)
865
-
let scan_block_scalar t literal =
866
-
let start = Input.mark t.input in
867
-
ignore (Input.next t.input);
796
+
(** Skip explicit-indent empty lines in a block scalar. Returns the number of
797
+
spaces consumed for indentation check. *)
798
+
let rec skip_explicit_indent t ~literal ~content_indent ~trailing_breaks () =
799
+
let spaces_skipped = ref 0 in
800
+
while
801
+
!spaces_skipped < !content_indent && Input.next_is (( = ) ' ') t.input
802
+
do
803
+
incr spaces_skipped;
804
+
ignore (Input.next t.input)
805
+
done;
806
+
if Input.next_is_break t.input then begin
807
+
Buffer.add_char trailing_breaks '\n';
808
+
Input.consume_break t.input;
809
+
skip_explicit_indent t ~literal ~content_indent ~trailing_breaks ()
810
+
end
811
+
else if !spaces_skipped < !content_indent then !spaces_skipped
812
+
else if Input.next_is_blank t.input then begin
813
+
if literal then !content_indent
814
+
else begin
815
+
let idx = ref 0 in
816
+
while
817
+
match Input.peek_nth t.input !idx with
818
+
| Some c when Input.is_blank c ->
819
+
incr idx;
820
+
true
821
+
| _ -> false
822
+
do
823
+
()
824
+
done;
825
+
match Input.peek_nth t.input !idx with
826
+
| None | Some '\n' | Some '\r' ->
827
+
while Input.next_is_blank t.input do
828
+
ignore (Input.next t.input)
829
+
done;
830
+
Buffer.add_char trailing_breaks '\n';
831
+
Input.consume_break t.input;
832
+
skip_explicit_indent t ~literal ~content_indent ~trailing_breaks ()
833
+
| _ -> !content_indent
834
+
end
835
+
end
836
+
else !content_indent
868
837
869
-
(* consume | or > *)
838
+
(** Skip implicit-indent empty lines in a block scalar. Returns 0 when content
839
+
is available. *)
840
+
let rec skip_implicit_indent t ~content_indent ~trailing_breaks
841
+
~max_empty_line_indent () =
842
+
if Input.next_is_break t.input then begin
843
+
Buffer.add_char trailing_breaks '\n';
844
+
Input.consume_break t.input;
845
+
skip_implicit_indent t ~content_indent ~trailing_breaks
846
+
~max_empty_line_indent ()
847
+
end
848
+
else if Input.next_is (( = ) ' ') t.input then begin
849
+
let idx = ref 0 in
850
+
while
851
+
match Input.peek_nth t.input !idx with
852
+
| Some ' ' ->
853
+
incr idx;
854
+
true
855
+
| _ -> false
856
+
do
857
+
()
858
+
done;
859
+
match Input.peek_nth t.input !idx with
860
+
| None | Some '\n' | Some '\r' ->
861
+
if !idx > !max_empty_line_indent then max_empty_line_indent := !idx;
862
+
while Input.next_is (( = ) ' ') t.input do
863
+
ignore (Input.next t.input)
864
+
done;
865
+
Buffer.add_char trailing_breaks '\n';
866
+
Input.consume_break t.input;
867
+
skip_implicit_indent t ~content_indent ~trailing_breaks
868
+
~max_empty_line_indent ()
869
+
| _ -> 0
870
+
end
871
+
else if Input.next_is (( = ) '\t') t.input then
872
+
Error.raise_at (Input.mark t.input) Tab_in_indentation
873
+
else 0
870
874
871
-
(* Parse header: optional indentation indicator and chomping *)
875
+
(** Skip to content indent position in block scalar, handling empty lines *)
876
+
let skip_to_content_indent t ~literal ~content_indent ~trailing_breaks
877
+
~max_empty_line_indent () =
878
+
if !content_indent > 0 then
879
+
skip_explicit_indent t ~literal ~content_indent ~trailing_breaks ()
880
+
else
881
+
skip_implicit_indent t ~content_indent ~trailing_breaks
882
+
~max_empty_line_indent ()
883
+
884
+
(** Apply folded-style break collapsing to buf when there are trailing breaks *)
885
+
let apply_folded_breaks ~buf ~trailing_breaks ~leading_blank ~trailing_blank =
886
+
let breaks = Buffer.contents trailing_breaks in
887
+
if (not !leading_blank) && not trailing_blank then begin
888
+
if String.length breaks = 1 then Buffer.add_char buf ' '
889
+
else Buffer.add_substring buf breaks 1 (String.length breaks - 1)
890
+
end
891
+
else Buffer.add_buffer buf trailing_breaks
892
+
893
+
(** Add trailing breaks to buf applying folding rules for block scalars *)
894
+
let add_block_scalar_breaks ~buf ~trailing_breaks ~leading_blank ~trailing_blank
895
+
~literal =
896
+
if Buffer.length buf > 0 then begin
897
+
if Buffer.length trailing_breaks > 0 then begin
898
+
if literal then Buffer.add_buffer buf trailing_breaks
899
+
else
900
+
apply_folded_breaks ~buf ~trailing_breaks ~leading_blank ~trailing_blank
901
+
end
902
+
else if not literal then Buffer.add_char buf ' '
903
+
end
904
+
else Buffer.add_buffer buf trailing_breaks;
905
+
Buffer.clear trailing_breaks
906
+
907
+
(** Parse block scalar header (indentation and chomping indicators) *)
908
+
let parse_block_scalar_header t =
872
909
let explicit_indent = ref None in
873
910
let chomping = ref Chomping.Clip in
874
-
875
-
(* First character of header *)
876
911
(match Input.peek t.input with
877
912
| Some c when Input.is_digit c && c <> '0' ->
878
913
explicit_indent := Some (Char.code c - Char.code '0');
···
884
919
chomping := Chomping.Keep;
885
920
ignore (Input.next t.input)
886
921
| _ -> ());
887
-
888
-
(* Second character of header *)
889
922
(match Input.peek t.input with
890
923
| Some c when Input.is_digit c && c <> '0' && !explicit_indent = None ->
891
924
explicit_indent := Some (Char.code c - Char.code '0');
···
897
930
chomping := Chomping.Keep;
898
931
ignore (Input.next t.input)
899
932
| _ -> ());
933
+
(!explicit_indent, !chomping)
900
934
901
-
(* Skip whitespace and optional comment *)
935
+
(** Scan block scalar (literal | or folded >) *)
936
+
let scan_block_scalar t literal =
937
+
let start = Input.mark t.input in
938
+
ignore (Input.next t.input);
939
+
let explicit_indent, chomping = parse_block_scalar_header t in
902
940
skip_whitespace_and_comment t;
903
-
904
-
(* Consume line break *)
905
941
if Input.next_is_break t.input then Input.consume_break t.input
906
942
else if not (Input.is_eof t.input) then
907
943
Error.raise_at (Input.mark t.input)
908
944
(Invalid_block_scalar_header "expected newline after header");
909
-
910
945
let base_indent = current_indent t in
911
-
(* base_indent is the indent level from the stack, -1 if empty.
912
-
It's used directly for comparisons in implicit indent case. *)
913
946
let content_indent =
914
947
ref
915
-
(match !explicit_indent with
916
-
| Some n ->
917
-
(* Explicit indent: base_indent is 1-indexed column, convert to 0-indexed.
918
-
content_indent = (base_indent - 1) + n, but at least n for document level. *)
919
-
let base_level = max 0 (base_indent - 1) in
920
-
base_level + n
921
-
| None -> 0 (* Will be determined by first non-empty line *))
948
+
(match explicit_indent with
949
+
| Some n -> max 0 (base_indent - 1) + n
950
+
| None -> 0)
922
951
in
923
-
924
952
let buf = Buffer.create 256 in
925
953
let trailing_breaks = Buffer.create 16 in
926
954
let leading_blank = ref false in
927
-
(* Was the previous line "more indented"? *)
928
955
let max_empty_line_indent = ref 0 in
929
-
(* Track max indent of empty lines before first content *)
930
-
931
-
(* Skip to content indentation, skipping empty lines.
932
-
Returns the number of spaces actually skipped (important for detecting dedentation). *)
933
-
let rec skip_to_content_indent () =
934
-
if !content_indent > 0 then begin
935
-
(* Explicit indent - skip up to content_indent spaces *)
936
-
let spaces_skipped = ref 0 in
937
-
while
938
-
!spaces_skipped < !content_indent && Input.next_is (( = ) ' ') t.input
939
-
do
940
-
incr spaces_skipped;
941
-
ignore (Input.next t.input)
942
-
done;
943
-
944
-
(* Check if this line is empty (only spaces/tabs until break/eof) *)
945
-
if Input.next_is_break t.input then begin
946
-
(* Empty line - record the break and continue *)
947
-
Buffer.add_char trailing_breaks '\n';
948
-
Input.consume_break t.input;
949
-
skip_to_content_indent ()
950
-
end
951
-
else if !spaces_skipped < !content_indent then begin
952
-
(* Line starts with fewer spaces than content_indent - dedented *)
953
-
!spaces_skipped
954
-
end
955
-
else if Input.next_is_blank t.input then begin
956
-
(* Line has spaces/tabs beyond content_indent - could be whitespace content or empty line.
957
-
For literal scalars, whitespace-only lines ARE content (not empty).
958
-
For folded scalars, whitespace-only lines that are "more indented" are preserved. *)
959
-
if literal then
960
-
(* Literal: whitespace beyond content_indent is content, let read_lines handle it *)
961
-
!content_indent
962
-
else begin
963
-
(* Folded: check if rest is only blanks *)
964
-
let idx = ref 0 in
965
-
while
966
-
match Input.peek_nth t.input !idx with
967
-
| Some c when Input.is_blank c ->
968
-
incr idx;
969
-
true
970
-
| _ -> false
971
-
do
972
-
()
973
-
done;
974
-
match Input.peek_nth t.input !idx with
975
-
| None | Some '\n' | Some '\r' ->
976
-
(* Empty/whitespace-only line in folded - skip spaces *)
977
-
while Input.next_is_blank t.input do
978
-
ignore (Input.next t.input)
979
-
done;
980
-
Buffer.add_char trailing_breaks '\n';
981
-
Input.consume_break t.input;
982
-
skip_to_content_indent ()
983
-
| _ ->
984
-
(* Has non-whitespace content *)
985
-
!content_indent
986
-
end
987
-
end
988
-
else !content_indent
989
-
end
990
-
else begin
991
-
(* Implicit indent - skip empty lines without consuming spaces.
992
-
Note: Only SPACES count as indentation. Tabs are content, not indentation.
993
-
So we only check for spaces when determining if a line is "empty". *)
994
-
if Input.next_is_break t.input then begin
995
-
Buffer.add_char trailing_breaks '\n';
996
-
Input.consume_break t.input;
997
-
skip_to_content_indent ()
998
-
end
999
-
else if Input.next_is (( = ) ' ') t.input then begin
1000
-
(* Check if line is empty (only spaces before break) *)
1001
-
let idx = ref 0 in
1002
-
while
1003
-
match Input.peek_nth t.input !idx with
1004
-
| Some ' ' ->
1005
-
incr idx;
1006
-
true
1007
-
| _ -> false
1008
-
do
1009
-
()
1010
-
done;
1011
-
match Input.peek_nth t.input !idx with
1012
-
| None | Some '\n' | Some '\r' ->
1013
-
(* Line has only spaces - empty line *)
1014
-
(* Track max indent of empty lines for later validation *)
1015
-
if !idx > !max_empty_line_indent then max_empty_line_indent := !idx;
1016
-
while Input.next_is (( = ) ' ') t.input do
1017
-
ignore (Input.next t.input)
1018
-
done;
1019
-
Buffer.add_char trailing_breaks '\n';
1020
-
Input.consume_break t.input;
1021
-
skip_to_content_indent ()
1022
-
| _ ->
1023
-
(* Has content (including tabs which are content, not indentation) *)
1024
-
0
1025
-
end
1026
-
else if Input.next_is (( = ) '\t') t.input then begin
1027
-
(* Tab at start of line in implicit indent mode - this is an error (Y79Y)
1028
-
because tabs cannot be used as indentation in YAML *)
1029
-
Error.raise_at (Input.mark t.input) Tab_in_indentation
1030
-
end
1031
-
else
1032
-
(* Not at break or space - other content character *)
1033
-
0
1034
-
end
1035
-
in
1036
-
1037
-
(* Read content *)
1038
956
let rec read_lines () =
1039
-
let spaces_skipped = skip_to_content_indent () in
1040
-
1041
-
(* Check if we're at content *)
1042
-
if Input.is_eof t.input then ()
1043
-
else if Input.at_document_boundary t.input then ()
957
+
let spaces_skipped =
958
+
skip_to_content_indent t ~literal ~content_indent ~trailing_breaks
959
+
~max_empty_line_indent ()
960
+
in
961
+
if Input.is_eof t.input || Input.at_document_boundary t.input then ()
1044
962
else begin
1045
-
(* Count additional leading spaces beyond what was skipped *)
1046
963
let extra_spaces = ref 0 in
1047
964
while Input.next_is (( = ) ' ') t.input do
1048
965
incr extra_spaces;
1049
966
ignore (Input.next t.input)
1050
967
done;
1051
-
1052
-
(* Calculate actual line indentation *)
1053
968
let line_indent = spaces_skipped + !extra_spaces in
1054
-
1055
-
(* Determine content indent from first content line (implicit case) *)
1056
969
let first_line = !content_indent = 0 in
1057
-
(* base_indent is 1-indexed column, convert to 0-indexed for comparison with line_indent.
1058
-
If base_indent = -1 (empty stack), then base_level = -1 means col 0 is valid. *)
1059
970
let base_level = base_indent - 1 in
1060
971
let should_process =
1061
972
if !content_indent = 0 then begin
1062
-
(* For implicit indent, content must be more indented than base_level. *)
1063
973
if line_indent <= base_level then false
1064
-
(* No content - first line not indented enough *)
1065
974
else begin
1066
-
(* Validate: first content line must be indented at least as much as
1067
-
the maximum indent seen on empty lines before it (5LLU, S98Z, W9L4) *)
1068
975
if line_indent < !max_empty_line_indent && line_indent > base_level
1069
976
then
1070
977
Error.raise_at (Input.mark t.input)
···
1075
982
end
1076
983
end
1077
984
else if line_indent < !content_indent then false
1078
-
(* Dedented - done with content *)
1079
985
else true
1080
986
in
1081
-
1082
987
if should_process then begin
1083
-
(* Check if current line is "more indented" (has extra indent or starts with whitespace).
1084
-
For folded scalars, lines that start with any whitespace (space or tab) after the
1085
-
content indentation are "more indented" and preserve breaks.
1086
-
Note: we check Input.next_is_blank BEFORE reading content to see if content starts with whitespace. *)
1087
988
let trailing_blank =
1088
989
line_indent > !content_indent || Input.next_is_blank t.input
1089
990
in
1090
-
1091
-
(* Add trailing breaks to buffer *)
1092
-
if Buffer.length buf > 0 then begin
1093
-
if Buffer.length trailing_breaks > 0 then begin
1094
-
if literal then Buffer.add_buffer buf trailing_breaks
1095
-
else begin
1096
-
(* Folded scalar: fold only if both previous and current lines are not more-indented *)
1097
-
if (not !leading_blank) && not trailing_blank then begin
1098
-
let breaks = Buffer.contents trailing_breaks in
1099
-
if String.length breaks = 1 then Buffer.add_char buf ' '
1100
-
else Buffer.add_substring buf breaks 1 (String.length breaks - 1)
1101
-
end
1102
-
else begin
1103
-
(* Preserve breaks for more-indented lines *)
1104
-
Buffer.add_buffer buf trailing_breaks
1105
-
end
1106
-
end
1107
-
end
1108
-
else if not literal then Buffer.add_char buf ' '
1109
-
end
1110
-
else Buffer.add_buffer buf trailing_breaks;
1111
-
Buffer.clear trailing_breaks;
1112
-
1113
-
(* Add extra indentation for literal or more-indented folded lines *)
1114
-
(* On the first line (when determining content_indent), we've already consumed all spaces,
1115
-
so we should NOT add any back. On subsequent lines, we add only the spaces beyond content_indent. *)
1116
-
if (not first_line) && (literal || (!extra_spaces > 0 && not literal))
1117
-
then begin
991
+
add_block_scalar_breaks ~buf ~trailing_breaks ~leading_blank
992
+
~trailing_blank ~literal;
993
+
if (not first_line) && (literal || !extra_spaces > 0) then
1118
994
for _ = 1 to !extra_spaces do
1119
995
Buffer.add_char buf ' '
1120
-
done
1121
-
end;
1122
-
1123
-
(* Read line content *)
996
+
done;
1124
997
while
1125
998
(not (Input.is_eof t.input)) && not (Input.next_is_break t.input)
1126
999
do
1127
1000
Buffer.add_char buf (Input.next_exn t.input)
1128
1001
done;
1129
-
1130
-
(* Record trailing break *)
1131
1002
if Input.next_is_break t.input then begin
1132
1003
Buffer.add_char trailing_breaks '\n';
1133
1004
Input.consume_break t.input
1134
1005
end;
1135
-
1136
-
(* Update leading_blank for next iteration *)
1137
1006
leading_blank := trailing_blank;
1138
-
1139
1007
read_lines ()
1140
1008
end
1141
1009
end
1142
1010
in
1143
-
1144
1011
read_lines ();
1145
-
1146
-
(* Apply chomping *)
1147
1012
let value =
1148
1013
let content = Buffer.contents buf in
1149
-
match !chomping with
1014
+
match chomping with
1150
1015
| Chomping.Strip -> content
1151
1016
| Chomping.Clip ->
1152
1017
if String.length content > 0 then content ^ "\n" else content
1153
1018
| Chomping.Keep -> content ^ Buffer.contents trailing_breaks
1154
1019
in
1155
-
1156
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1020
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1157
1021
let style = if literal then `Literal else `Folded in
1158
1022
(value, style, span)
1159
1023
1024
+
(** Scan %YAML version directive body (after name and blanks) *)
1025
+
let scan_yaml_directive t ~start =
1026
+
let major = ref 0 in
1027
+
let minor = ref 0 in
1028
+
while Input.next_is_digit t.input do
1029
+
major := (!major * 10) + (Char.code (Input.next_exn t.input) - Char.code '0')
1030
+
done;
1031
+
(match Input.peek t.input with
1032
+
| Some '.' -> ignore (Input.next t.input)
1033
+
| _ ->
1034
+
Error.raise_at (Input.mark t.input) (Invalid_yaml_version "expected '.'"));
1035
+
while Input.next_is_digit t.input do
1036
+
minor := (!minor * 10) + (Char.code (Input.next_exn t.input) - Char.code '0')
1037
+
done;
1038
+
skip_whitespace_and_comment t;
1039
+
if (not (Input.next_is_break t.input)) && not (Input.is_eof t.input) then
1040
+
Error.raise_at (Input.mark t.input)
1041
+
(Invalid_directive "expected comment or line break after version");
1042
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1043
+
(Token.Version_directive { major = !major; minor = !minor }, span)
1044
+
1045
+
(** Scan %TAG directive body (after name and blanks) *)
1046
+
let scan_tag_directive t ~start =
1047
+
let handle = scan_tag_handle t in
1048
+
while Input.next_is_blank t.input do
1049
+
ignore (Input.next t.input)
1050
+
done;
1051
+
let prefix_buf = Buffer.create 32 in
1052
+
while
1053
+
match Input.peek t.input with
1054
+
| Some c when not (Input.is_whitespace c) ->
1055
+
Buffer.add_char prefix_buf c;
1056
+
ignore (Input.next t.input);
1057
+
true
1058
+
| _ -> false
1059
+
do
1060
+
()
1061
+
done;
1062
+
let prefix = Buffer.contents prefix_buf in
1063
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1064
+
(Token.Tag_directive { handle; prefix }, span)
1065
+
1160
1066
(** Scan directive (after %) *)
1161
1067
let scan_directive t =
1162
1068
let start = Input.mark t.input in
1163
1069
ignore (Input.next t.input);
1164
-
1165
1070
(* consume % *)
1166
-
1167
-
(* Read directive name *)
1168
1071
let name_buf = Buffer.create 16 in
1169
1072
while
1170
1073
match Input.peek t.input with
···
1177
1080
()
1178
1081
done;
1179
1082
let name = Buffer.contents name_buf in
1180
-
1181
-
(* Skip blanks *)
1182
1083
while Input.next_is_blank t.input do
1183
1084
ignore (Input.next t.input)
1184
1085
done;
1185
-
1186
1086
match name with
1187
-
| "YAML" ->
1188
-
(* Version directive: %YAML 1.2 *)
1189
-
let major = ref 0 in
1190
-
let minor = ref 0 in
1191
-
(* Read major version *)
1192
-
while Input.next_is_digit t.input do
1193
-
major :=
1194
-
(!major * 10) + (Char.code (Input.next_exn t.input) - Char.code '0')
1195
-
done;
1196
-
(* Expect . *)
1197
-
(match Input.peek t.input with
1198
-
| Some '.' -> ignore (Input.next t.input)
1199
-
| _ ->
1200
-
Error.raise_at (Input.mark t.input)
1201
-
(Invalid_yaml_version "expected '.'"));
1202
-
(* Read minor version *)
1203
-
while Input.next_is_digit t.input do
1204
-
minor :=
1205
-
(!minor * 10) + (Char.code (Input.next_exn t.input) - Char.code '0')
1206
-
done;
1207
-
(* Validate: only whitespace and comments allowed before line break (MUS6) *)
1208
-
skip_whitespace_and_comment t;
1209
-
if (not (Input.next_is_break t.input)) && not (Input.is_eof t.input) then
1210
-
Error.raise_at (Input.mark t.input)
1211
-
(Invalid_directive "expected comment or line break after version");
1212
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1213
-
(Token.Version_directive { major = !major; minor = !minor }, span)
1214
-
| "TAG" ->
1215
-
(* Tag directive: %TAG !foo! tag:example.com,2000: *)
1216
-
let handle = scan_tag_handle t in
1217
-
(* Skip blanks *)
1218
-
while Input.next_is_blank t.input do
1219
-
ignore (Input.next t.input)
1220
-
done;
1221
-
(* Read prefix *)
1222
-
let prefix_buf = Buffer.create 32 in
1223
-
while
1224
-
match Input.peek t.input with
1225
-
| Some c when not (Input.is_whitespace c) ->
1226
-
Buffer.add_char prefix_buf c;
1227
-
ignore (Input.next t.input);
1228
-
true
1229
-
| _ -> false
1230
-
do
1231
-
()
1232
-
done;
1233
-
let prefix = Buffer.contents prefix_buf in
1234
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1235
-
(Token.Tag_directive { handle; prefix }, span)
1087
+
| "YAML" -> scan_yaml_directive t ~start
1088
+
| "TAG" -> scan_tag_directive t ~start
1236
1089
| _ ->
1237
-
(* Reserved/Unknown directive - skip to end of line and ignore *)
1238
-
(* Per YAML spec, reserved directives should be ignored with a warning *)
1239
1090
while (not (Input.is_eof t.input)) && not (Input.next_is_break t.input) do
1240
1091
ignore (Input.next t.input)
1241
1092
done;
1242
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1243
-
(* Return an empty tag directive token to indicate directive was processed but ignored *)
1093
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1244
1094
(Token.Tag_directive { handle = ""; prefix = "" }, span)
1245
1095
1246
1096
(** Fetch the next token(s) into the queue *)
···
1301
1151
let start = Input.mark t.input in
1302
1152
let indicator = Input.peek_string t.input 3 in
1303
1153
Input.skip t.input 3;
1304
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1154
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1305
1155
let token =
1306
1156
if indicator = "---" then Token.Document_start else Token.Document_end
1307
1157
in
···
1354
1204
t.document_has_content <- true;
1355
1205
let start = Input.mark t.input in
1356
1206
ignore (Input.next t.input);
1357
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1207
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1358
1208
emit t span token_type
1359
1209
1360
1210
and fetch_flow_collection_end t token_type =
···
1369
1219
(* Allow adjacent values after flow collection ends *)
1370
1220
if t.flow_level > 0 then
1371
1221
t.adjacent_value_allowed_at <- Some (Input.position t.input);
1372
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1222
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1373
1223
emit t span token_type
1374
1224
1375
1225
and fetch_flow_entry t =
···
1377
1227
t.allow_simple_key <- true;
1378
1228
let start = Input.mark t.input in
1379
1229
ignore (Input.next t.input);
1380
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1230
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1381
1231
emit t span Token.Flow_entry
1382
1232
1383
1233
and check_block_entry t =
···
1419
1269
| _ -> ()
1420
1270
end;
1421
1271
1422
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1272
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1423
1273
emit t span Token.Block_entry
1424
1274
1425
1275
and check_key t =
···
1452
1302
Error.raise_at start Tab_in_indentation
1453
1303
end;
1454
1304
1455
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1305
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1456
1306
emit t span Token.Key
1457
1307
1458
1308
and check_value t =
···
1472
1322
&& pos.Position.column = (Input.position t.input).Position.column
1473
1323
| None -> false)
1474
1324
1325
+
and fetch_value_use_simple_key t sk ~start =
1326
+
let is_implicit_flow_mapping =
1327
+
match t.flow_mapping_stack with false :: _ -> true | _ -> false
1328
+
in
1329
+
if
1330
+
is_implicit_flow_mapping
1331
+
&& sk.sk_position.line < (Input.position t.input).line
1332
+
then Error.raise_at start Illegal_flow_key_line;
1333
+
let key_span = Span.point sk.sk_position in
1334
+
let key_token = { Token.token = Token.Key; span = key_span } in
1335
+
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
1336
+
Queue.clear t.tokens;
1337
+
let insert_pos = sk.sk_token_number - t.tokens_taken in
1338
+
Array.iteri
1339
+
(fun i tok ->
1340
+
if i = insert_pos then Queue.add key_token t.tokens;
1341
+
Queue.add tok t.tokens)
1342
+
tokens;
1343
+
if insert_pos >= Array.length tokens then Queue.add key_token t.tokens;
1344
+
t.token_number <- t.token_number + 1;
1345
+
if t.flow_level = 0 then begin
1346
+
let col = sk.sk_position.column in
1347
+
if roll_indent t col then begin
1348
+
let span = Span.point sk.sk_position in
1349
+
let bm_token = { Token.token = Token.Block_mapping_start; span } in
1350
+
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
1351
+
Queue.clear t.tokens;
1352
+
Array.iteri
1353
+
(fun i tok ->
1354
+
if i = insert_pos then Queue.add bm_token t.tokens;
1355
+
Queue.add tok t.tokens)
1356
+
tokens;
1357
+
if insert_pos >= Array.length tokens then Queue.add bm_token t.tokens;
1358
+
t.token_number <- t.token_number + 1
1359
+
end
1360
+
end;
1361
+
t.simple_keys <- None :: List.tl t.simple_keys;
1362
+
true
1363
+
1475
1364
and fetch_value t =
1476
1365
let start = Input.mark t.input in
1477
-
(* Check for simple key *)
1478
1366
let used_simple_key =
1479
1367
match t.simple_keys with
1480
-
| Some sk :: _ when sk.sk_possible ->
1481
-
(* In implicit flow mapping (inside a flow sequence), key and : must be on the same line.
1482
-
In explicit flow mapping { }, key and : can span lines. *)
1483
-
let is_implicit_flow_mapping =
1484
-
match t.flow_mapping_stack with
1485
-
| false :: _ ->
1486
-
true (* false = we're in a sequence, so any mapping is implicit *)
1487
-
| _ -> false
1488
-
in
1489
-
if
1490
-
is_implicit_flow_mapping
1491
-
&& sk.sk_position.line < (Input.position t.input).line
1492
-
then Error.raise_at start Illegal_flow_key_line;
1493
-
(* Insert KEY token before the simple key value *)
1494
-
let key_span = Span.point sk.sk_position in
1495
-
let key_token = { Token.token = Token.Key; span = key_span } in
1496
-
(* We need to insert at the right position *)
1497
-
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
1498
-
Queue.clear t.tokens;
1499
-
let insert_pos = sk.sk_token_number - t.tokens_taken in
1500
-
Array.iteri
1501
-
(fun i tok ->
1502
-
if i = insert_pos then Queue.add key_token t.tokens;
1503
-
Queue.add tok t.tokens)
1504
-
tokens;
1505
-
if insert_pos >= Array.length tokens then Queue.add key_token t.tokens;
1506
-
t.token_number <- t.token_number + 1;
1507
-
(* Roll indent for implicit block mapping *)
1508
-
if t.flow_level = 0 then begin
1509
-
let col = sk.sk_position.column in
1510
-
if roll_indent t col then begin
1511
-
let span = Span.point sk.sk_position in
1512
-
(* Insert block mapping start before key *)
1513
-
let bm_token = { Token.token = Token.Block_mapping_start; span } in
1514
-
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
1515
-
Queue.clear t.tokens;
1516
-
Array.iteri
1517
-
(fun i tok ->
1518
-
if i = insert_pos then Queue.add bm_token t.tokens;
1519
-
Queue.add tok t.tokens)
1520
-
tokens;
1521
-
if insert_pos >= Array.length tokens then
1522
-
Queue.add bm_token t.tokens;
1523
-
t.token_number <- t.token_number + 1
1524
-
end
1525
-
end;
1526
-
t.simple_keys <- None :: List.tl t.simple_keys;
1527
-
true
1368
+
| Some sk :: _ when sk.sk_possible -> fetch_value_use_simple_key t sk ~start
1528
1369
| _ ->
1529
-
(* No simple key - this is a complex value (or empty key) *)
1530
1370
if t.flow_level = 0 then begin
1531
1371
if not t.allow_simple_key then
1532
1372
Error.raise_at (Input.mark t.input) Expected_key;
···
1535
1375
let span = Span.point (Input.mark t.input) in
1536
1376
emit t span Token.Block_mapping_start
1537
1377
end
1538
-
(* Note: We don't emit KEY here. Empty key handling is done by the parser,
1539
-
which emits empty scalar when it sees VALUE without preceding KEY. *)
1540
1378
end;
1541
1379
false
1542
1380
in
1543
1381
remove_simple_key t;
1544
-
(* In block context without simple key, allow simple keys for compact mappings like ": moon: white"
1545
-
In flow context or after using a simple key, disallow simple keys *)
1546
1382
t.allow_simple_key <- (not used_simple_key) && t.flow_level = 0;
1547
1383
t.document_has_content <- true;
1548
1384
let start = Input.mark t.input in
1549
1385
ignore (Input.next t.input);
1550
-
1551
-
(* Check for tabs after : : patterns like :\t- or :\tkey: are invalid in block context (Y79Y/09)
1552
-
However, :\t bar (tab followed by space then content) is valid (6BCT) *)
1553
1386
let found_tabs, found_spaces = skip_blanks_check_tabs t in
1554
1387
if found_tabs && (not found_spaces) && t.flow_level = 0 then begin
1555
-
(* In block context, tabs-only after : followed by indicator or alphanumeric are not allowed *)
1556
1388
match Input.peek t.input with
1557
1389
| Some ('-' | '?') -> Error.raise_at start Tab_in_indentation
1558
1390
| Some c
1559
1391
when (c >= 'a' && c <= 'z')
1560
1392
|| (c >= 'A' && c <= 'Z')
1561
1393
|| (c >= '0' && c <= '9') ->
1562
-
(* Tab-only followed by alphanumeric - likely a key, which is invalid *)
1563
1394
Error.raise_at start Tab_in_indentation
1564
1395
| _ -> ()
1565
1396
end;
1566
-
1567
-
(* Skip any comment that may follow the colon and whitespace *)
1568
1397
skip_whitespace_and_comment t;
1569
-
1570
-
let span = Span.make ~start ~stop:(Input.mark t.input) in
1398
+
let span = Span.v ~start ~stop:(Input.mark t.input) in
1571
1399
emit t span Token.Value
1572
1400
1573
1401
and fetch_anchor_or_alias t ~is_alias =
···
1578
1406
ignore (Input.next t.input);
1579
1407
(* consume * or & *)
1580
1408
let name, span = scan_anchor_alias t in
1581
-
let span = Span.make ~start ~stop:span.stop in
1409
+
let span = Span.v ~start ~stop:span.stop in
1582
1410
let token = if is_alias then Token.Alias name else Token.Anchor name in
1583
1411
emit t span token
1584
1412
···
1699
1527
1700
1528
(** Convert to list *)
1701
1529
let to_list t = fold (fun acc tok -> tok :: acc) [] t |> List.rev
1530
+
1531
+
(** Pretty-print the current state *)
1532
+
let pp ppf t = Fmt.pf ppf "<scanner at %a>" Position.pp (Input.position t.input)
+13
-10
lib/scanner.mli
+13
-10
lib/scanner.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML tokenizer/scanner with lookahead for ambiguity resolution *)
6
+
(** YAML tokenizer/scanner with lookahead for ambiguity resolution. *)
7
7
8
8
type t
9
9
10
+
val pp : Format.formatter -> t -> unit
11
+
(** [pp ppf s] pretty-prints the current scanner state [s] to [ppf]. *)
12
+
10
13
(** {2 Constructors} *)
11
14
12
15
val of_string : string -> t
13
-
(** Create scanner from a string *)
16
+
(** [of_string s] creates a scanner from a string. *)
14
17
15
18
val of_input : Input.t -> t
16
-
(** Create scanner from an input source *)
19
+
(** [of_input input] creates a scanner from an input source. *)
17
20
18
21
val of_reader : Bytesrw.Bytes.Reader.t -> t
19
-
(** Create scanner from a Bytes.Reader *)
22
+
(** [of_reader reader] creates a scanner from a Bytes.Reader. *)
20
23
21
24
(** {2 Position} *)
22
25
23
26
val position : t -> Position.t
24
-
(** Get current position in input *)
27
+
(** [position s] returns the current position in the input. *)
25
28
26
29
(** {2 Token Access} *)
27
30
28
31
val next : t -> Token.spanned option
29
-
(** Get next token *)
32
+
(** [next s] returns the next token, advancing the scanner. *)
30
33
31
34
val peek : t -> Token.spanned option
32
-
(** Peek at next token without consuming *)
35
+
(** [peek s] peeks at the next token without consuming it. *)
33
36
34
37
(** {2 Iteration} *)
35
38
36
39
val iter : (Token.spanned -> unit) -> t -> unit
37
-
(** Iterate over all tokens *)
40
+
(** [iter f s] iterates over all tokens, calling [f] on each. *)
38
41
39
42
val fold : ('a -> Token.spanned -> 'a) -> 'a -> t -> 'a
40
-
(** Fold over all tokens *)
43
+
(** [fold f acc s] folds [f] over all tokens. *)
41
44
42
45
val to_list : t -> Token.spanned list
43
-
(** Convert to list of tokens *)
46
+
(** [to_list s] converts the scanner output to a list of tokens. *)
+1
-1
lib/sequence.ml
+1
-1
lib/sequence.ml
+36
-3
lib/sequence.mli
+36
-3
lib/sequence.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML sequence (array) values with metadata *)
6
+
(** YAML sequence (array) values with metadata. *)
7
7
8
8
type 'a t
9
9
10
-
val make :
10
+
val v :
11
11
?anchor:string ->
12
12
?tag:string ->
13
13
?implicit:bool ->
14
14
?style:Layout_style.t ->
15
15
'a list ->
16
16
'a t
17
-
(** Create a sequence *)
17
+
(** [v ?anchor ?tag ?implicit ?style members] creates a sequence. *)
18
18
19
19
(** {2 Accessors} *)
20
20
21
21
val members : 'a t -> 'a list
22
+
(** [members s] returns the elements of the sequence. *)
23
+
22
24
val anchor : 'a t -> string option
25
+
(** [anchor s] returns the anchor name of the sequence, if any. *)
26
+
23
27
val tag : 'a t -> string option
28
+
(** [tag s] returns the tag of the sequence, if any. *)
29
+
24
30
val implicit : 'a t -> bool
31
+
(** [implicit s] returns whether the sequence has an implicit tag. *)
32
+
25
33
val style : 'a t -> Layout_style.t
34
+
(** [style s] returns the layout style of the sequence. *)
26
35
27
36
(** {2 Modifiers} *)
28
37
29
38
val with_anchor : string -> 'a t -> 'a t
39
+
(** [with_anchor anchor s] returns a copy of [s] with the given anchor. *)
40
+
30
41
val with_tag : string -> 'a t -> 'a t
42
+
(** [with_tag tag s] returns a copy of [s] with the given tag. *)
43
+
31
44
val with_style : Layout_style.t -> 'a t -> 'a t
45
+
(** [with_style style s] returns a copy of [s] with the given layout style. *)
32
46
33
47
(** {2 Operations} *)
34
48
35
49
val map : ('a -> 'b) -> 'a t -> 'b t
50
+
(** [map f s] applies [f] to each element of [s]. *)
51
+
36
52
val length : 'a t -> int
53
+
(** [length s] returns the number of elements in [s]. *)
54
+
37
55
val is_empty : 'a t -> bool
56
+
(** [is_empty s] returns [true] if [s] has no elements. *)
57
+
38
58
val nth : 'a t -> int -> 'a
59
+
(** [nth s i] returns the [i]-th element of [s], raising if out of bounds. *)
60
+
39
61
val nth_opt : 'a t -> int -> 'a option
62
+
(** [nth_opt s i] returns the [i]-th element of [s], or [None] if out of bounds.
63
+
*)
64
+
40
65
val iter : ('a -> unit) -> 'a t -> unit
66
+
(** [iter f s] calls [f] on each element of [s]. *)
67
+
41
68
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
69
+
(** [fold f acc s] folds [f] over the elements of [s]. *)
42
70
43
71
(** {2 Comparison} *)
44
72
45
73
val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
74
+
(** [pp pp_elem ppf s] pretty-prints the sequence [s] using [pp_elem]. *)
75
+
46
76
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
77
+
(** [equal eq a b] returns [true] if sequences [a] and [b] are equal. *)
78
+
47
79
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
80
+
(** [compare cmp a b] compares sequences [a] and [b]. *)
+39
-59
lib/serialize.ml
+39
-59
lib/serialize.ml
···
59
59
members;
60
60
emit Event.Mapping_end
61
61
62
+
(** Emit a plain scalar event with no anchor or tag *)
63
+
let emit_plain_scalar ~emit value =
64
+
emit
65
+
(Event.Scalar
66
+
{
67
+
anchor = None;
68
+
tag = None;
69
+
value;
70
+
plain_implicit = true;
71
+
quoted_implicit = false;
72
+
style = `Plain;
73
+
})
74
+
75
+
(** Format a float value as a YAML string *)
76
+
let float_to_yaml_string f =
77
+
match Float.classify_float f with
78
+
| FP_nan -> ".nan"
79
+
| FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
80
+
| _ ->
81
+
if Float.is_integer f && Float.abs f < 1e15 then Fmt.str "%.0f" f
82
+
else
83
+
let s = Fmt.str "%g" f in
84
+
if Float.equal (Float.of_string s) f then s else Fmt.str "%.17g" f
85
+
86
+
(** Determine sequence/mapping style from config and emptiness *)
87
+
let collection_style is_empty (config : Emitter.config) =
88
+
if is_empty || config.layout_style = `Flow then `Flow else `Block
89
+
62
90
(** Emit a Value node using an emit function. This is the core implementation
63
91
used by both Emitter.t and function-based APIs. *)
64
92
let rec emit_value_node_impl ~emit ~config (value : Value.t) =
65
93
match value with
66
-
| `Null ->
67
-
emit
68
-
(Event.Scalar
69
-
{
70
-
anchor = None;
71
-
tag = None;
72
-
value = "null";
73
-
plain_implicit = true;
74
-
quoted_implicit = false;
75
-
style = `Plain;
76
-
})
77
-
| `Bool b ->
78
-
emit
79
-
(Event.Scalar
80
-
{
81
-
anchor = None;
82
-
tag = None;
83
-
value = (if b then "true" else "false");
84
-
plain_implicit = true;
85
-
quoted_implicit = false;
86
-
style = `Plain;
87
-
})
88
-
| `Float f ->
89
-
let value =
90
-
match Float.classify_float f with
91
-
| FP_nan -> ".nan"
92
-
| FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
93
-
| _ ->
94
-
if Float.is_integer f && Float.abs f < 1e15 then Fmt.str "%.0f" f
95
-
else
96
-
let s = Fmt.str "%g" f in
97
-
if Float.equal (Float.of_string s) f then s else Fmt.str "%.17g" f
98
-
in
99
-
emit
100
-
(Event.Scalar
101
-
{
102
-
anchor = None;
103
-
tag = None;
104
-
value;
105
-
plain_implicit = true;
106
-
quoted_implicit = false;
107
-
style = `Plain;
108
-
})
94
+
| `Null -> emit_plain_scalar ~emit "null"
95
+
| `Bool b -> emit_plain_scalar ~emit (if b then "true" else "false")
96
+
| `Float f -> emit_plain_scalar ~emit (float_to_yaml_string f)
109
97
| `String s ->
110
98
let style = Quoting.choose_style s in
111
99
emit
···
119
107
style;
120
108
})
121
109
| `A items ->
122
-
(* Force flow style for empty sequences, otherwise use config *)
123
-
let style =
124
-
if items = [] || config.Emitter.layout_style = `Flow then `Flow
125
-
else `Block
126
-
in
110
+
let style = collection_style (items = []) config in
127
111
emit
128
112
(Event.Sequence_start
129
113
{ anchor = None; tag = None; implicit = true; style });
130
114
List.iter (emit_value_node_impl ~emit ~config) items;
131
115
emit Event.Sequence_end
132
116
| `O pairs ->
133
-
(* Force flow style for empty mappings, otherwise use config *)
134
-
let style =
135
-
if pairs = [] || config.Emitter.layout_style = `Flow then `Flow
136
-
else `Block
137
-
in
117
+
let style = collection_style (pairs = []) config in
138
118
emit
139
119
(Event.Mapping_start
140
120
{ anchor = None; tag = None; implicit = true; style });
···
162
142
if Option.is_none (Scalar.anchor s) then yaml
163
143
else
164
144
`Scalar
165
-
(Scalar.make ?tag:(Scalar.tag s)
145
+
(Scalar.v ?tag:(Scalar.tag s)
166
146
~plain_implicit:(Scalar.plain_implicit s)
167
147
~quoted_implicit:(Scalar.quoted_implicit s) ~style:(Scalar.style s)
168
148
(Scalar.value s))
169
149
| `Alias _ -> yaml
170
150
| `A seq ->
171
151
`A
172
-
(Sequence.make ?tag:(Sequence.tag seq) ~implicit:(Sequence.implicit seq)
152
+
(Sequence.v ?tag:(Sequence.tag seq) ~implicit:(Sequence.implicit seq)
173
153
~style:(Sequence.style seq)
174
154
(List.map strip_anchors (Sequence.members seq)))
175
155
| `O map ->
176
156
`O
177
-
(Mapping.make ?tag:(Mapping.tag map) ~implicit:(Mapping.implicit map)
157
+
(Mapping.v ?tag:(Mapping.tag map) ~implicit:(Mapping.implicit map)
178
158
~style:(Mapping.style map)
179
159
(List.map
180
160
(fun (k, v) -> (strip_anchors k, strip_anchors v))
···
249
229
@return The buffer containing serialized YAML *)
250
230
let value_to_buffer ?(config = Emitter.default_config) ?buffer value =
251
231
let buf = Option.value buffer ~default:(Buffer.create 1024) in
252
-
let t = Emitter.create ~config () in
232
+
let t = Emitter.v ~config () in
253
233
emit_value t value;
254
234
Buffer.add_string buf (Emitter.contents t);
255
235
buf
···
261
241
@return The buffer containing serialized YAML *)
262
242
let yaml_to_buffer ?(config = Emitter.default_config) ?buffer yaml =
263
243
let buf = Option.value buffer ~default:(Buffer.create 1024) in
264
-
let t = Emitter.create ~config () in
244
+
let t = Emitter.v ~config () in
265
245
emit_yaml t yaml;
266
246
Buffer.add_string buf (Emitter.contents t);
267
247
buf
···
276
256
let documents_to_buffer ?(config = Emitter.default_config)
277
257
?(resolve_aliases = true) ?buffer documents =
278
258
let buf = Option.value buffer ~default:(Buffer.create 1024) in
279
-
let t = Emitter.create ~config () in
259
+
let t = Emitter.v ~config () in
280
260
Emitter.emit t (Event.Stream_start { encoding = config.encoding });
281
261
List.iter (emit_document ~resolve_aliases t) documents;
282
262
Emitter.emit t Event.Stream_end;
+41
-29
lib/serialize.mli
+41
-29
lib/serialize.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Serialize - high-level serialization to buffers and event streams
6
+
(** Serialize - high-level serialization to buffers and event streams.
7
7
8
8
This module provides functions to convert YAML values to events and strings.
9
9
Both {!Emitter.t}-based and function-based emission APIs are provided. *)
···
11
11
(** {1 Emitter.t-based API} *)
12
12
13
13
val emit_yaml_node : Emitter.t -> Yaml.t -> unit
14
-
(** Emit a YAML node to an emitter *)
14
+
(** [emit_yaml_node emitter yaml] emits a YAML node to the emitter. *)
15
15
16
16
val emit_yaml : Emitter.t -> Yaml.t -> unit
17
-
(** Emit a complete YAML document to an emitter (includes stream/document
18
-
markers) *)
17
+
(** [emit_yaml emitter yaml] emits a complete YAML document to the emitter
18
+
(includes stream/document markers). *)
19
19
20
20
val emit_value_node : Emitter.t -> Value.t -> unit
21
-
(** Emit a Value node to an emitter *)
21
+
(** [emit_value_node emitter value] emits a Value node to the emitter. *)
22
22
23
23
val emit_value : Emitter.t -> Value.t -> unit
24
-
(** Emit a complete Value document to an emitter (includes stream/document
25
-
markers) *)
24
+
(** [emit_value emitter value] emits a complete Value document to the emitter
25
+
(includes stream/document markers). *)
26
26
27
27
val emit_document : ?resolve_aliases:bool -> Emitter.t -> Document.t -> unit
28
-
(** Emit a document to an emitter
28
+
(** [emit_document ?resolve_aliases emitter doc] emits a document to the
29
+
emitter.
29
30
30
31
@param resolve_aliases
31
-
Whether to resolve aliases before emission (default true) *)
32
+
Whether to resolve aliases before emission (default true). *)
32
33
33
34
(** {1 Buffer-based API} *)
34
35
35
36
val value_to_buffer :
36
37
?config:Emitter.config -> ?buffer:Buffer.t -> Value.t -> Buffer.t
37
-
(** Serialize a Value to a buffer
38
+
(** [value_to_buffer ?config ?buffer value] serializes a Value to a buffer.
38
39
39
-
@param config Emitter configuration (default: {!Emitter.default_config})
40
-
@param buffer Optional buffer to append to; creates new one if not provided
41
-
*)
40
+
@param config Emitter configuration (default: {!Emitter.default_config}).
41
+
@param buffer
42
+
Optional buffer to append to; creates a new one if not provided. *)
42
43
43
44
val yaml_to_buffer :
44
45
?config:Emitter.config -> ?buffer:Buffer.t -> Yaml.t -> Buffer.t
45
-
(** Serialize a Yaml.t to a buffer *)
46
+
(** [yaml_to_buffer ?config ?buffer yaml] serializes a Yaml.t to a buffer. *)
46
47
47
48
val documents_to_buffer :
48
49
?config:Emitter.config ->
···
50
51
?buffer:Buffer.t ->
51
52
Document.t list ->
52
53
Buffer.t
53
-
(** Serialize documents to a buffer
54
+
(** [documents_to_buffer ?config ?resolve_aliases ?buffer docs] serializes
55
+
documents to a buffer.
54
56
55
57
@param resolve_aliases
56
-
Whether to resolve aliases before emission (default true) *)
58
+
Whether to resolve aliases before emission (default true). *)
57
59
58
60
(** {1 String-based API} *)
59
61
60
62
val value_to_string : ?config:Emitter.config -> Value.t -> string
61
-
(** Serialize a Value to a string *)
63
+
(** [value_to_string ?config value] serializes a Value to a string. *)
62
64
63
65
val yaml_to_string : ?config:Emitter.config -> Yaml.t -> string
64
-
(** Serialize a Yaml.t to a string *)
66
+
(** [yaml_to_string ?config yaml] serializes a Yaml.t to a string. *)
65
67
66
68
val documents_to_string :
67
69
?config:Emitter.config -> ?resolve_aliases:bool -> Document.t list -> string
68
-
(** Serialize documents to a string *)
70
+
(** [documents_to_string ?config ?resolve_aliases docs] serializes documents to
71
+
a string. *)
69
72
70
73
(** {1 Writer-based API}
71
74
···
78
81
Bytesrw.Bytes.Writer.t ->
79
82
Value.t ->
80
83
unit
81
-
(** Serialize a Value directly to a Bytes.Writer
84
+
(** [value_to_writer ?config ?eod writer value] serializes a Value directly to a
85
+
Bytes.Writer.
82
86
83
-
@param eod Whether to write end-of-data after serialization (default true)
87
+
@param eod Whether to write end-of-data after serialization (default true).
84
88
*)
85
89
86
90
val yaml_to_writer :
···
89
93
Bytesrw.Bytes.Writer.t ->
90
94
Yaml.t ->
91
95
unit
92
-
(** Serialize a Yaml.t directly to a Bytes.Writer *)
96
+
(** [yaml_to_writer ?config ?eod writer yaml] serializes a Yaml.t directly to a
97
+
Bytes.Writer. *)
93
98
94
99
val documents_to_writer :
95
100
?config:Emitter.config ->
···
98
103
Bytesrw.Bytes.Writer.t ->
99
104
Document.t list ->
100
105
unit
101
-
(** Serialize documents directly to a Bytes.Writer *)
106
+
(** [documents_to_writer ?config ?resolve_aliases ?eod writer docs] serializes
107
+
documents directly to a Bytes.Writer. *)
102
108
103
109
(** {1 Function-based API}
104
110
···
106
112
{!Emitter.t}, allowing them to work with any event sink. *)
107
113
108
114
val emit_yaml_node_fn : emitter:(Event.t -> unit) -> Yaml.t -> unit
109
-
(** Emit a YAML node using an emitter function *)
115
+
(** [emit_yaml_node_fn ~emitter yaml] emits a YAML node using an emitter
116
+
function. *)
110
117
111
118
val emit_yaml_fn :
112
119
emitter:(Event.t -> unit) -> config:Emitter.config -> Yaml.t -> unit
113
-
(** Emit a complete YAML stream using an emitter function *)
120
+
(** [emit_yaml_fn ~emitter ~config yaml] emits a complete YAML stream using an
121
+
emitter function. *)
114
122
115
123
val emit_value_node_fn :
116
124
emitter:(Event.t -> unit) -> config:Emitter.config -> Value.t -> unit
117
-
(** Emit a Value node using an emitter function *)
125
+
(** [emit_value_node_fn ~emitter ~config value] emits a Value node using an
126
+
emitter function. *)
118
127
119
128
val emit_value_fn :
120
129
emitter:(Event.t -> unit) -> config:Emitter.config -> Value.t -> unit
121
-
(** Emit a complete Value stream using an emitter function *)
130
+
(** [emit_value_fn ~emitter ~config value] emits a complete Value stream using
131
+
an emitter function. *)
122
132
123
133
val emit_document_fn :
124
134
?resolve_aliases:bool -> emitter:(Event.t -> unit) -> Document.t -> unit
125
-
(** Emit a document using an emitter function *)
135
+
(** [emit_document_fn ?resolve_aliases ~emitter doc] emits a document using an
136
+
emitter function. *)
126
137
127
138
val emit_documents :
128
139
emitter:(Event.t -> unit) ->
···
130
141
?resolve_aliases:bool ->
131
142
Document.t list ->
132
143
unit
133
-
(** Emit multiple documents using an emitter function *)
144
+
(** [emit_documents ~emitter ~config ?resolve_aliases docs] emits multiple
145
+
documents using an emitter function. *)
+1
-1
lib/span.ml
+1
-1
lib/span.ml
+10
-10
lib/span.mli
+10
-10
lib/span.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Source spans representing ranges in input *)
6
+
(** Source spans representing ranges in input. *)
7
7
8
8
type t = { start : Position.t; stop : Position.t }
9
9
10
-
val make : start:Position.t -> stop:Position.t -> t
11
-
(** Create a span from start and stop positions *)
10
+
val v : start:Position.t -> stop:Position.t -> t
11
+
(** [v ~start ~stop] creates a span from start and stop positions. *)
12
12
13
13
val point : Position.t -> t
14
-
(** Create a zero-width span at a single position *)
14
+
(** [point pos] creates a zero-width span at [pos]. *)
15
15
16
16
val merge : t -> t -> t
17
-
(** Merge two spans into one covering both *)
17
+
(** [merge a b] merges spans [a] and [b] into one covering both. *)
18
18
19
19
val extend : t -> Position.t -> t
20
-
(** Extend a span to a new stop position *)
20
+
(** [extend span pos] extends [span] to include [pos] as the new stop. *)
21
21
22
22
val pp : Format.formatter -> t -> unit
23
-
(** Pretty-print a span *)
23
+
(** [pp ppf span] pretty-prints the span [span] to [ppf]. *)
24
24
25
25
val to_string : t -> string
26
-
(** Convert span to string *)
26
+
(** [to_string span] converts the span [span] to a string. *)
27
27
28
28
val compare : t -> t -> int
29
-
(** Compare two spans *)
29
+
(** [compare a b] compares spans [a] and [b]. *)
30
30
31
31
val equal : t -> t -> bool
32
-
(** Test equality of two spans *)
32
+
(** [equal a b] returns [true] if spans [a] and [b] are equal. *)
+1
-1
lib/tag.ml
+1
-1
lib/tag.ml
+39
-9
lib/tag.mli
+39
-9
lib/tag.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML tags for type information *)
6
+
(** YAML tags for type information. *)
7
7
8
8
type t = {
9
9
handle : string; (** e.g., "!" or "!!" or "!foo!" *)
10
10
suffix : string; (** e.g., "str", "int", "custom/type" *)
11
11
}
12
12
13
-
val make : handle:string -> suffix:string -> t
14
-
(** Create a tag from handle and suffix *)
13
+
val v : handle:string -> suffix:string -> t
14
+
(** [v ~handle ~suffix] creates a tag from handle and suffix. *)
15
15
16
16
val of_string : string -> t option
17
-
(** Parse a tag string *)
17
+
(** [of_string s] parses a tag string, returning [None] if invalid. *)
18
18
19
19
val to_string : t -> string
20
-
(** Convert tag to string representation *)
20
+
(** [to_string t] converts the tag to its string representation. *)
21
21
22
22
val to_uri : t -> string
23
-
(** Convert tag to full URI representation *)
23
+
(** [to_uri t] converts the tag to its full URI representation. *)
24
24
25
25
val pp : Format.formatter -> t -> unit
26
-
(** Pretty-print a tag *)
26
+
(** [pp ppf t] pretty-prints the tag [t] to [ppf]. *)
27
27
28
28
val equal : t -> t -> bool
29
-
(** Test equality of two tags *)
29
+
(** [equal a b] returns [true] if tags [a] and [b] are equal. *)
30
30
31
31
val compare : t -> t -> int
32
-
(** Compare two tags *)
32
+
(** [compare a b] compares tags [a] and [b]. *)
33
33
34
34
(** {2 Standard Tags} *)
35
35
36
36
val null : t
37
+
(** [null] is the standard YAML null tag. *)
38
+
37
39
val bool : t
40
+
(** [bool] is the standard YAML bool tag. *)
41
+
38
42
val int : t
43
+
(** [int] is the standard YAML int tag. *)
44
+
39
45
val float : t
46
+
(** [float] is the standard YAML float tag. *)
47
+
40
48
val str : t
49
+
(** [str] is the standard YAML str tag. *)
50
+
41
51
val seq : t
52
+
(** [seq] is the standard YAML seq tag. *)
53
+
42
54
val map : t
55
+
(** [map] is the standard YAML map tag. *)
56
+
43
57
val binary : t
58
+
(** [binary] is the standard YAML binary tag. *)
59
+
44
60
val timestamp : t
61
+
(** [timestamp] is the standard YAML timestamp tag. *)
45
62
46
63
(** {2 Tag Predicates} *)
47
64
48
65
val is_null : t -> bool
66
+
(** [is_null t] returns [true] if [t] is the null tag. *)
67
+
49
68
val is_bool : t -> bool
69
+
(** [is_bool t] returns [true] if [t] is the bool tag. *)
70
+
50
71
val is_int : t -> bool
72
+
(** [is_int t] returns [true] if [t] is the int tag. *)
73
+
51
74
val is_float : t -> bool
75
+
(** [is_float t] returns [true] if [t] is the float tag. *)
76
+
52
77
val is_str : t -> bool
78
+
(** [is_str t] returns [true] if [t] is the str tag. *)
79
+
53
80
val is_seq : t -> bool
81
+
(** [is_seq t] returns [true] if [t] is the seq tag. *)
82
+
54
83
val is_map : t -> bool
84
+
(** [is_map t] returns [true] if [t] is the map tag. *)
+17
-17
lib/token.mli
+17
-17
lib/token.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** YAML token types produced by the scanner *)
6
+
(** YAML token types produced by the scanner. *)
7
7
8
8
type t =
9
9
| Stream_start of Encoding.t
10
10
| Stream_end
11
11
| Version_directive of { major : int; minor : int }
12
12
| Tag_directive of { handle : string; prefix : string }
13
-
| Document_start (** --- *)
14
-
| Document_end (** ... *)
13
+
| Document_start (** ---. *)
14
+
| Document_end (** .... *)
15
15
| Block_sequence_start
16
16
| Block_mapping_start
17
-
| Block_entry (** [-] *)
18
-
| Block_end (** implicit, from dedent *)
19
-
| Flow_sequence_start (** \[ *)
20
-
| Flow_sequence_end (** \] *)
21
-
| Flow_mapping_start (** \{ *)
22
-
| Flow_mapping_end (** \} *)
23
-
| Flow_entry (** , *)
24
-
| Key (** ? or implicit key *)
25
-
| Value (** : *)
26
-
| Anchor of string (** &name *)
27
-
| Alias of string (** *name *)
17
+
| Block_entry (** [-]. *)
18
+
| Block_end (** Implicit, from dedent. *)
19
+
| Flow_sequence_start (** \[. *)
20
+
| Flow_sequence_end (** \]. *)
21
+
| Flow_mapping_start (** \{. *)
22
+
| Flow_mapping_end (** \}. *)
23
+
| Flow_entry (** ,. *)
24
+
| Key (** ? or implicit key. *)
25
+
| Value (** :. *)
26
+
| Anchor of string (** &name. *)
27
+
| Alias of string (** *name. *)
28
28
| Tag of { handle : string; suffix : string }
29
29
| Scalar of { style : Scalar_style.t; value : string }
30
30
31
31
type spanned = { token : t; span : Span.t }
32
32
33
33
val pp_token : Format.formatter -> t -> unit
34
-
(** Pretty-print a token *)
34
+
(** [pp_token ppf t] pretty-prints the token [t] to [ppf]. *)
35
35
36
36
val pp : Format.formatter -> t -> unit
37
-
(** Pretty-print a token (alias for pp_token) *)
37
+
(** [pp ppf t] pretty-prints the token [t] to [ppf] (alias for [pp_token]). *)
38
38
39
39
val pp_spanned : Format.formatter -> spanned -> unit
40
-
(** Pretty-print a spanned token *)
40
+
(** [pp_spanned ppf t] pretty-prints the spanned token [t] to [ppf]. *)
+2
-2
lib/unix/yamlrw_unix.mli
+2
-2
lib/unix/yamlrw_unix.mli
···
26
26
27
27
@param resolve_aliases Whether to expand aliases (default: true)
28
28
@param max_nodes Maximum nodes during alias expansion (default: 10M)
29
-
@param max_depth Maximum alias nesting depth (default: 100) *)
29
+
@param max_depth Maximum alias nesting depth (default: 100). *)
30
30
31
31
val yaml_of_channel :
32
32
?resolve_aliases:bool ->
···
38
38
39
39
@param resolve_aliases Whether to expand aliases (default: false)
40
40
@param max_nodes Maximum nodes during alias expansion (default: 10M)
41
-
@param max_depth Maximum alias nesting depth (default: 100) *)
41
+
@param max_depth Maximum alias nesting depth (default: 100). *)
42
42
43
43
val documents_of_channel : in_channel -> document list
44
44
(** Parse multiple YAML documents from an input channel. *)
+64
-2
lib/value.mli
+64
-2
lib/value.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** JSON-compatible YAML value representation *)
6
+
(** JSON-compatible YAML value representation. *)
7
7
8
8
type t =
9
9
[ `Null
···
16
16
(** {2 Constructors} *)
17
17
18
18
val null : t
19
+
(** [null] is the null value. *)
20
+
19
21
val bool : bool -> t
22
+
(** [bool b] constructs a boolean value. *)
23
+
20
24
val int : int -> t
25
+
(** [int n] constructs an integer value as a float. *)
26
+
21
27
val float : float -> t
28
+
(** [float f] constructs a float value. *)
29
+
22
30
val string : string -> t
31
+
(** [string s] constructs a string value. *)
32
+
23
33
val list : ('a -> t) -> 'a list -> t
34
+
(** [list f xs] constructs a list value by applying [f] to each element. *)
35
+
24
36
val obj : (string * t) list -> t
37
+
(** [obj pairs] constructs an object value from key-value pairs. *)
25
38
26
39
(** {2 Type Name} *)
27
40
28
41
val type_name : t -> string
29
-
(** Get the type name for error messages *)
42
+
(** [type_name v] returns the type name of [v] for error messages. *)
30
43
31
44
(** {2 Safe Accessors} *)
32
45
33
46
val as_null : t -> unit option
47
+
(** [as_null v] returns [Some ()] if [v] is null, otherwise [None]. *)
48
+
34
49
val as_bool : t -> bool option
50
+
(** [as_bool v] returns [Some b] if [v] is a boolean, otherwise [None]. *)
51
+
35
52
val as_float : t -> float option
53
+
(** [as_float v] returns [Some f] if [v] is a float, otherwise [None]. *)
54
+
36
55
val as_string : t -> string option
56
+
(** [as_string v] returns [Some s] if [v] is a string, otherwise [None]. *)
57
+
37
58
val as_list : t -> t list option
59
+
(** [as_list v] returns [Some lst] if [v] is a list, otherwise [None]. *)
60
+
38
61
val as_assoc : t -> (string * t) list option
62
+
(** [as_assoc v] returns [Some pairs] if [v] is an object, otherwise [None]. *)
63
+
39
64
val as_int : t -> int option
65
+
(** [as_int v] returns [Some n] if [v] is an integer float, otherwise [None]. *)
40
66
41
67
(** {2 Unsafe Accessors} *)
42
68
43
69
val to_null : t -> unit
70
+
(** [to_null v] returns [()] if [v] is null, raising otherwise. *)
71
+
44
72
val to_bool : t -> bool
73
+
(** [to_bool v] returns the boolean value of [v], raising if not a boolean. *)
74
+
45
75
val to_float : t -> float
76
+
(** [to_float v] returns the float value of [v], raising if not a float. *)
77
+
46
78
val to_string : t -> string
79
+
(** [to_string v] returns the string value of [v], raising if not a string. *)
80
+
47
81
val to_list : t -> t list
82
+
(** [to_list v] returns the list elements of [v], raising if not a list. *)
83
+
48
84
val to_assoc : t -> (string * t) list
85
+
(** [to_assoc v] returns the key-value pairs of [v], raising if not an object.
86
+
*)
87
+
49
88
val to_int : t -> int
89
+
(** [to_int v] returns the integer value of [v], raising if not an integer
90
+
float. *)
50
91
51
92
(** {2 Object Access} *)
52
93
53
94
val mem : string -> t -> bool
95
+
(** [mem key v] returns [true] if [v] is an object with key [key]. *)
96
+
54
97
val find : string -> t -> t option
98
+
(** [find key v] returns the value for [key] in [v] if it is an object. *)
99
+
55
100
val get : string -> t -> t
101
+
(** [get key v] returns the value for [key] in [v], raising if absent. *)
102
+
56
103
val keys : t -> string list
104
+
(** [keys v] returns all keys of [v] if it is an object, otherwise [[]]. *)
105
+
57
106
val values : t -> t list
107
+
(** [values v] returns all values of [v] if it is an object, otherwise [[]]. *)
58
108
59
109
(** {2 Combinators} *)
60
110
61
111
val combine : t -> t -> t
112
+
(** [combine a b] merges two objects, with [b] overriding [a] on duplicate keys.
113
+
*)
114
+
62
115
val map : (t -> t) -> t -> t
116
+
(** [map f v] applies [f] to each element if [v] is a list. *)
117
+
63
118
val filter : (t -> bool) -> t -> t
119
+
(** [filter pred v] retains elements of [v] satisfying [pred] if [v] is a list.
120
+
*)
64
121
65
122
(** {2 Comparison} *)
66
123
67
124
val pp : Format.formatter -> t -> unit
125
+
(** [pp ppf v] pretty-prints the value [v] to [ppf]. *)
126
+
68
127
val equal : t -> t -> bool
128
+
(** [equal a b] returns [true] if values [a] and [b] are structurally equal. *)
129
+
69
130
val compare : t -> t -> int
131
+
(** [compare a b] compares values [a] and [b]. *)
+31
-69
lib/yaml.ml
+31
-69
lib/yaml.ml
···
34
34
35
35
let rec of_value (v : Value.t) : t =
36
36
match v with
37
-
| `Null -> `Scalar (Scalar.make "null")
38
-
| `Bool true -> `Scalar (Scalar.make "true")
39
-
| `Bool false -> `Scalar (Scalar.make "false")
37
+
| `Null -> `Scalar (Scalar.v "null")
38
+
| `Bool true -> `Scalar (Scalar.v "true")
39
+
| `Bool false -> `Scalar (Scalar.v "false")
40
40
| `Float f ->
41
41
let s =
42
42
match Float.classify_float f with
···
48
48
let s = Fmt.str "%g" f in
49
49
if Float.equal (Float.of_string s) f then s else Fmt.str "%.17g" f
50
50
in
51
-
`Scalar (Scalar.make s)
52
-
| `String s -> `Scalar (Scalar.make s ~style:`Double_quoted)
53
-
| `A items -> `A (Sequence.make (List.map of_value items))
51
+
`Scalar (Scalar.v s)
52
+
| `String s -> `Scalar (Scalar.v s ~style:`Double_quoted)
53
+
| `A items -> `A (Sequence.v (List.map of_value items))
54
54
| `O pairs ->
55
55
`O
56
-
(Mapping.make
57
-
(List.map
58
-
(fun (k, v) -> (`Scalar (Scalar.make k), of_value v))
59
-
pairs))
56
+
(Mapping.v
57
+
(List.map (fun (k, v) -> (`Scalar (Scalar.v k), of_value v)) pairs))
60
58
61
59
(** Default limits for alias expansion (protection against billion laughs
62
60
attack) *)
···
93
91
?(max_depth = default_max_alias_depth) (root : t) : t =
94
92
let anchors = Hashtbl.create 16 in
95
93
let node_count = ref 0 in
96
-
97
-
(* Check node limit *)
98
94
let check_node_limit () =
99
95
incr node_count;
100
96
if !node_count > max_nodes then
101
97
Error.raise (Alias_expansion_node_limit max_nodes)
102
98
in
103
-
104
-
(* Register anchor if present on a node *)
105
-
let register_anchor name resolved_node =
106
-
Hashtbl.replace anchors name resolved_node
107
-
in
108
-
109
-
(* Resolve an alias by looking up and expanding the target *)
99
+
let register_anchor name node = Hashtbl.replace anchors name node in
110
100
let rec expand_alias ~depth name =
111
101
if depth >= max_depth then
112
102
Error.raise (Alias_expansion_depth_limit max_depth);
113
103
match Hashtbl.find_opt anchors name with
114
104
| Some target ->
115
-
(* The target is already resolved, but may contain aliases that
116
-
need expansion if it was registered before those anchors existed *)
105
+
(* May contain aliases registered after this anchor was stored. *)
117
106
resolve ~depth:(depth + 1) target
118
107
| None -> Error.raise (Undefined_alias name)
119
-
(* Single pass: process in document order, registering anchors and resolving aliases *)
108
+
and resolve_pair ~depth (k, v) = (resolve ~depth k, resolve ~depth v)
120
109
and resolve ~depth (v : t) : t =
121
110
check_node_limit ();
122
111
match v with
123
112
| `Scalar s ->
124
-
(* Register anchor after we have the resolved node *)
125
113
Option.iter (fun name -> register_anchor name v) (Scalar.anchor s);
126
114
v
127
115
| `Alias name -> expand_alias ~depth name
128
116
| `A seq ->
129
-
(* Register anchor with ORIGINAL node BEFORE resolving members.
130
-
This ensures that when this anchor is expanded later through
131
-
an alias chain, the internal aliases still need resolution,
132
-
allowing the depth counter to properly accumulate. *)
117
+
(* Register BEFORE resolving members so alias chains track depth. *)
133
118
Option.iter (fun name -> register_anchor name v) (Sequence.anchor seq);
134
-
(* Now resolve all members in order *)
135
-
let resolved_members =
136
-
List.map (resolve ~depth) (Sequence.members seq)
137
-
in
119
+
let members = List.map (resolve ~depth) (Sequence.members seq) in
138
120
`A
139
-
(Sequence.make ?anchor:(Sequence.anchor seq) ?tag:(Sequence.tag seq)
121
+
(Sequence.v ?anchor:(Sequence.anchor seq) ?tag:(Sequence.tag seq)
140
122
~implicit:(Sequence.implicit seq) ~style:(Sequence.style seq)
141
-
resolved_members)
123
+
members)
142
124
| `O map ->
143
-
(* Register anchor with ORIGINAL node BEFORE resolving members.
144
-
This ensures proper depth tracking for alias chains. *)
145
125
Option.iter (fun name -> register_anchor name v) (Mapping.anchor map);
146
-
(* Process key-value pairs in document order *)
147
-
let resolved_pairs =
148
-
List.map
149
-
(fun (k, v) ->
150
-
let resolved_k = resolve ~depth k in
151
-
let resolved_v = resolve ~depth v in
152
-
(resolved_k, resolved_v))
153
-
(Mapping.members map)
154
-
in
126
+
let pairs = List.map (resolve_pair ~depth) (Mapping.members map) in
155
127
`O
156
-
(Mapping.make ?anchor:(Mapping.anchor map) ?tag:(Mapping.tag map)
157
-
~implicit:(Mapping.implicit map) ~style:(Mapping.style map)
158
-
resolved_pairs)
128
+
(Mapping.v ?anchor:(Mapping.anchor map) ?tag:(Mapping.tag map)
129
+
~implicit:(Mapping.implicit map) ~style:(Mapping.style map) pairs)
159
130
in
160
131
resolve ~depth:0 root
161
132
···
175
146
| _ -> Error.raise (Invalid_scalar_conversion (value, "bool")))
176
147
| Some "tag:yaml.org,2002:int" | Some "!!int" -> (
177
148
try `Float (Float.of_string value)
178
-
with _ -> Error.raise (Invalid_scalar_conversion (value, "int")))
149
+
with Failure _ -> Error.raise (Invalid_scalar_conversion (value, "int")))
179
150
| Some "tag:yaml.org,2002:float" | Some "!!float" -> (
180
151
try `Float (Float.of_string value)
181
-
with _ -> Error.raise (Invalid_scalar_conversion (value, "float")))
152
+
with Failure _ ->
153
+
Error.raise (Invalid_scalar_conversion (value, "float")))
182
154
| Some "tag:yaml.org,2002:str" | Some "!!str" -> `String value
183
155
| Some _ ->
184
156
(* Unknown tag - treat as string *)
···
204
176
| _ -> try_parse_number value
205
177
206
178
(** Try to parse as number *)
179
+
and parse_leading_zero value =
180
+
match value.[1] with
181
+
| 'x' | 'X' | 'o' | 'O' | 'b' | 'B' ->
182
+
Some (`Float (Float.of_int (int_of_string value)))
183
+
| _ -> Some (`Float (Float.of_string value))
184
+
207
185
and try_parse_number value =
208
-
(* Check if value looks like a valid YAML number (not inf/nan without dot)
209
-
This guards against OCaml's Float.of_string accepting "inf", "nan", etc.
186
+
(* Guards against OCaml's Float.of_string accepting "inf", "nan", etc.
210
187
See: https://github.com/avsm/ocaml-yaml/issues/82 *)
211
188
let looks_like_number () =
212
189
let len = String.length value in
···
216
193
if first >= '0' && first <= '9' then true
217
194
else if (first = '-' || first = '+') && len >= 2 then
218
195
let second = value.[1] in
219
-
(* After sign, must be digit or dot-digit (for +.5, -.5) *)
220
196
(second >= '0' && second <= '9')
221
197
|| (second = '.' && len >= 3 && value.[2] >= '0' && value.[2] <= '9')
222
198
else false
223
199
in
224
-
(* Try integer/float *)
225
200
let try_numeric () =
226
201
if looks_like_number () then
227
202
try
228
-
(* Handle octal: 0o prefix or leading 0 *)
229
203
if String.length value > 2 && value.[0] = '0' then
230
-
match value.[1] with
231
-
| 'x' | 'X' ->
232
-
(* Hex *)
233
-
Some (`Float (Float.of_int (int_of_string value)))
234
-
| 'o' | 'O' ->
235
-
(* Octal *)
236
-
Some (`Float (Float.of_int (int_of_string value)))
237
-
| 'b' | 'B' ->
238
-
(* Binary *)
239
-
Some (`Float (Float.of_int (int_of_string value)))
240
-
| _ ->
241
-
(* Decimal with leading zero or octal in YAML 1.1 *)
242
-
Some (`Float (Float.of_string value))
204
+
parse_leading_zero value
243
205
else Some (`Float (Float.of_string value))
244
-
with _ -> None
206
+
with Failure _ -> None
245
207
else None
246
208
in
247
209
match try_numeric () with
···
257
219
&& value.[0] = '.'
258
220
&& value.[1] >= '0'
259
221
&& value.[1] <= '9'
260
-
then try `Float (Float.of_string value) with _ -> `String value
222
+
then try `Float (Float.of_string value) with Failure _ -> `String value
261
223
else `String value
262
224
263
225
(** Convert to JSON-compatible Value.
+22
-15
lib/yaml.mli
+22
-15
lib/yaml.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Full YAML representation with anchors, tags, and aliases *)
6
+
(** Full YAML representation with anchors, tags, and aliases. *)
7
7
8
8
type t =
9
9
[ `Scalar of Scalar.t
···
14
14
(** {2 Pretty Printing} *)
15
15
16
16
val pp : Format.formatter -> t -> unit
17
+
(** [pp ppf v] pretty-prints the YAML value [v] to [ppf]. *)
17
18
18
19
(** {2 Equality} *)
19
20
20
21
val equal : t -> t -> bool
22
+
(** [equal a b] returns [true] if YAML values [a] and [b] are structurally
23
+
equal. *)
21
24
22
25
(** {2 Conversion from Value} *)
23
26
24
27
val of_value : Value.t -> t
25
-
(** Construct from JSON-compatible Value *)
28
+
(** [of_value v] constructs a YAML value from a JSON-compatible Value. *)
26
29
27
30
(** {2 Alias Resolution} *)
28
31
29
32
val default_max_alias_nodes : int
30
-
(** Default maximum nodes during alias expansion (10 million) *)
33
+
(** [default_max_alias_nodes] is the default maximum nodes during alias
34
+
expansion (10 million). *)
31
35
32
36
val default_max_alias_depth : int
33
-
(** Default maximum alias nesting depth (100) *)
37
+
(** [default_max_alias_depth] is the default maximum alias nesting depth (100).
38
+
*)
34
39
35
40
val resolve_aliases : ?max_nodes:int -> ?max_depth:int -> t -> t
36
-
(** Resolve aliases by replacing them with referenced nodes.
41
+
(** [resolve_aliases ?max_nodes ?max_depth t] resolves aliases by replacing them
42
+
with referenced nodes.
37
43
38
-
@param max_nodes Maximum number of nodes to create during expansion
39
-
@param max_depth Maximum depth of alias-within-alias resolution
40
-
@raise Error.Yamlrw_error if limits exceeded or undefined alias found *)
44
+
@param max_nodes Maximum number of nodes to create during expansion.
45
+
@param max_depth Maximum depth of alias-within-alias resolution.
46
+
@raise Error.Yamlrw_error if limits exceeded or undefined alias found. *)
41
47
42
48
(** {2 Conversion to Value} *)
43
49
···
47
53
?max_depth:int ->
48
54
t ->
49
55
Value.t
50
-
(** Convert to JSON-compatible Value.
56
+
(** [to_value ?resolve_aliases_first ?max_nodes ?max_depth t] converts a YAML
57
+
value to a JSON-compatible Value.
51
58
52
59
@param resolve_aliases_first
53
-
Whether to resolve aliases before conversion (default true)
54
-
@param max_nodes Maximum nodes during alias expansion
55
-
@param max_depth Maximum alias nesting depth
56
-
@raise Error.Yamlrw_error if unresolved aliases encountered *)
60
+
Whether to resolve aliases before conversion (default true).
61
+
@param max_nodes Maximum nodes during alias expansion.
62
+
@param max_depth Maximum alias nesting depth.
63
+
@raise Error.Yamlrw_error if unresolved aliases encountered. *)
57
64
58
65
(** {2 Node Accessors} *)
59
66
60
67
val anchor : t -> string option
61
-
(** Get anchor from any node *)
68
+
(** [anchor t] returns the anchor from any YAML node, if present. *)
62
69
63
70
val tag : t -> string option
64
-
(** Get tag from any node *)
71
+
(** [tag t] returns the tag from any YAML node, if present. *)
+5
-5
lib/yamlrw.ml
+5
-5
lib/yamlrw.ml
···
123
123
124
124
(** {2 Serialization} *)
125
125
126
-
let make_config ~encoding ~scalar_style ~layout_style =
126
+
let config ~encoding ~scalar_style ~layout_style =
127
127
{ Emitter.default_config with encoding; scalar_style; layout_style }
128
128
129
129
(** Serialize a value to a buffer.
···
136
136
@return The buffer containing the serialized YAML *)
137
137
let to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any)
138
138
?buffer (value : value) =
139
-
let config = make_config ~encoding ~scalar_style ~layout_style in
139
+
let config = config ~encoding ~scalar_style ~layout_style in
140
140
Serialize.value_to_buffer ~config ?buffer (value :> Value.t)
141
141
142
142
(** Serialize a value to a YAML string.
···
158
158
@return The buffer containing the serialized YAML *)
159
159
let yaml_to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any)
160
160
?(layout_style = `Any) ?buffer (yaml : yaml) =
161
-
let config = make_config ~encoding ~scalar_style ~layout_style in
161
+
let config = config ~encoding ~scalar_style ~layout_style in
162
162
Serialize.yaml_to_buffer ~config ?buffer (yaml :> Yaml.t)
163
163
164
164
(** Serialize a full YAML value to a string.
···
182
182
let documents_to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any)
183
183
?(layout_style = `Any) ?(resolve_aliases = true) ?buffer
184
184
(documents : document list) =
185
-
let config = make_config ~encoding ~scalar_style ~layout_style in
185
+
let config = config ~encoding ~scalar_style ~layout_style in
186
186
let docs' =
187
187
List.map
188
188
(fun (d : document) : Document.t ->
···
515
515
(** A streaming YAML emitter. *)
516
516
517
517
(** Create a new emitter. *)
518
-
let emitter ?len:_ () = Emitter.create ()
518
+
let emitter ?len:_ () = Emitter.v ()
519
519
520
520
(** Get the emitted YAML string. *)
521
521
let contents e = Emitter.contents e
+56
-48
lib/yamlrw.mli
+56
-48
lib/yamlrw.mli
···
111
111
112
112
val of_string :
113
113
?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> value
114
-
(** Parse a YAML string into a JSON-compatible value.
114
+
(** [of_string ?resolve_aliases ?max_nodes ?max_depth s] parses a YAML string
115
+
into a JSON-compatible value.
115
116
116
-
@param resolve_aliases Whether to expand aliases (default: true)
117
-
@param max_nodes Maximum nodes during alias expansion (default: 10M)
118
-
@param max_depth Maximum alias nesting depth (default: 100)
119
-
@raise Yamlrw_error on parse error or if multiple documents found *)
117
+
@param resolve_aliases Whether to expand aliases (default: true).
118
+
@param max_nodes Maximum nodes during alias expansion (default: 10M).
119
+
@param max_depth Maximum alias nesting depth (default: 100).
120
+
@raise Yamlrw_error on parse error or if multiple documents found. *)
120
121
121
122
val yaml_of_string :
122
123
?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> yaml
123
-
(** Parse a YAML string preserving full YAML metadata (anchors, tags, etc).
124
+
(** [yaml_of_string ?resolve_aliases ?max_nodes ?max_depth s] parses a YAML
125
+
string preserving full YAML metadata (anchors, tags, etc).
124
126
125
127
By default, aliases are NOT resolved, preserving the document structure.
126
128
127
-
@param resolve_aliases Whether to expand aliases (default: false)
128
-
@param max_nodes Maximum nodes during alias expansion (default: 10M)
129
-
@param max_depth Maximum alias nesting depth (default: 100)
130
-
@raise Yamlrw_error on parse error or if multiple documents found *)
129
+
@param resolve_aliases Whether to expand aliases (default: false).
130
+
@param max_nodes Maximum nodes during alias expansion (default: 10M).
131
+
@param max_depth Maximum alias nesting depth (default: 100).
132
+
@raise Yamlrw_error on parse error or if multiple documents found. *)
131
133
132
134
val documents_of_string : string -> document list
133
-
(** Parse a multi-document YAML stream.
135
+
(** [documents_of_string s] parses a multi-document YAML stream.
134
136
135
137
Use this when your YAML input contains multiple documents separated by
136
138
document markers (---).
137
139
138
-
@raise Yamlrw_error on parse error *)
140
+
@raise Yamlrw_error on parse error. *)
139
141
140
142
(** {2 Formatting Styles} *)
141
143
···
151
153
?buffer:Buffer.t ->
152
154
value ->
153
155
Buffer.t
154
-
(** Serialize a value to a buffer.
156
+
(** [to_buffer ?encoding ?scalar_style ?layout_style ?buffer value] serializes a
157
+
value to a buffer.
155
158
156
-
@param encoding Output encoding (default: UTF-8)
157
-
@param scalar_style Preferred scalar style (default: Any)
158
-
@param layout_style Preferred layout style (default: Any)
159
+
@param encoding Output encoding (default: UTF-8).
160
+
@param scalar_style Preferred scalar style (default: Any).
161
+
@param layout_style Preferred layout style (default: Any).
159
162
@param buffer
160
-
Optional buffer to append to (allocates new one if not provided)
161
-
@return The buffer containing the serialized YAML *)
163
+
Optional buffer to append to (allocates new one if not provided).
164
+
@return The buffer containing the serialized YAML. *)
162
165
163
166
val to_string :
164
167
?encoding:Encoding.t ->
···
166
169
?layout_style:Layout_style.t ->
167
170
value ->
168
171
string
169
-
(** Serialize a value to a YAML string.
172
+
(** [to_string ?encoding ?scalar_style ?layout_style value] serializes a value
173
+
to a YAML string.
170
174
171
-
@param encoding Output encoding (default: UTF-8)
172
-
@param scalar_style Preferred scalar style (default: Any)
173
-
@param layout_style Preferred layout style (default: Any) *)
175
+
@param encoding Output encoding (default: UTF-8).
176
+
@param scalar_style Preferred scalar style (default: Any).
177
+
@param layout_style Preferred layout style (default: Any). *)
174
178
175
179
val yaml_to_buffer :
176
180
?encoding:Encoding.t ->
···
179
183
?buffer:Buffer.t ->
180
184
yaml ->
181
185
Buffer.t
182
-
(** Serialize a full YAML value to a buffer.
186
+
(** [yaml_to_buffer ?encoding ?scalar_style ?layout_style ?buffer yaml]
187
+
serializes a full YAML value to a buffer.
183
188
184
-
@param encoding Output encoding (default: UTF-8)
185
-
@param scalar_style Preferred scalar style (default: Any)
186
-
@param layout_style Preferred layout style (default: Any)
189
+
@param encoding Output encoding (default: UTF-8).
190
+
@param scalar_style Preferred scalar style (default: Any).
191
+
@param layout_style Preferred layout style (default: Any).
187
192
@param buffer
188
-
Optional buffer to append to (allocates new one if not provided)
189
-
@return The buffer containing the serialized YAML *)
193
+
Optional buffer to append to (allocates new one if not provided).
194
+
@return The buffer containing the serialized YAML. *)
190
195
191
196
val yaml_to_string :
192
197
?encoding:Encoding.t ->
···
194
199
?layout_style:Layout_style.t ->
195
200
yaml ->
196
201
string
197
-
(** Serialize a full YAML value to a string.
202
+
(** [yaml_to_string ?encoding ?scalar_style ?layout_style yaml] serializes a
203
+
full YAML value to a string.
198
204
199
-
@param encoding Output encoding (default: UTF-8)
200
-
@param scalar_style Preferred scalar style (default: Any)
201
-
@param layout_style Preferred layout style (default: Any) *)
205
+
@param encoding Output encoding (default: UTF-8).
206
+
@param scalar_style Preferred scalar style (default: Any).
207
+
@param layout_style Preferred layout style (default: Any). *)
202
208
203
209
val documents_to_buffer :
204
210
?encoding:Encoding.t ->
···
208
214
?buffer:Buffer.t ->
209
215
document list ->
210
216
Buffer.t
211
-
(** Serialize multiple documents to a buffer.
217
+
(** [documents_to_buffer ?encoding ?scalar_style ?layout_style ?resolve_aliases
218
+
?buffer docs] serializes multiple documents to a buffer.
212
219
213
-
@param encoding Output encoding (default: UTF-8)
214
-
@param scalar_style Preferred scalar style (default: Any)
215
-
@param layout_style Preferred layout style (default: Any)
216
-
@param resolve_aliases Whether to expand aliases (default: true)
220
+
@param encoding Output encoding (default: UTF-8).
221
+
@param scalar_style Preferred scalar style (default: Any).
222
+
@param layout_style Preferred layout style (default: Any).
223
+
@param resolve_aliases Whether to expand aliases (default: true).
217
224
@param buffer
218
-
Optional buffer to append to (allocates new one if not provided)
219
-
@return The buffer containing the serialized YAML *)
225
+
Optional buffer to append to (allocates new one if not provided).
226
+
@return The buffer containing the serialized YAML. *)
220
227
221
228
val documents_to_string :
222
229
?encoding:Encoding.t ->
···
225
232
?resolve_aliases:bool ->
226
233
document list ->
227
234
string
228
-
(** Serialize multiple documents to a YAML stream.
235
+
(** [documents_to_string ?encoding ?scalar_style ?layout_style ?resolve_aliases
236
+
docs] serializes multiple documents to a YAML stream.
229
237
230
-
@param encoding Output encoding (default: UTF-8)
231
-
@param scalar_style Preferred scalar style (default: Any)
232
-
@param layout_style Preferred layout style (default: Any)
233
-
@param resolve_aliases Whether to expand aliases (default: true) *)
238
+
@param encoding Output encoding (default: UTF-8).
239
+
@param scalar_style Preferred scalar style (default: Any).
240
+
@param layout_style Preferred layout style (default: Any).
241
+
@param resolve_aliases Whether to expand aliases (default: true). *)
234
242
235
243
(** {2 Buffer Parsing} *)
236
244
···
241
249
@param resolve_aliases Whether to expand aliases (default: true)
242
250
@param max_nodes Maximum nodes during alias expansion (default: 10M)
243
251
@param max_depth Maximum alias nesting depth (default: 100)
244
-
@raise Yamlrw_error on parse error or if multiple documents found *)
252
+
@raise Yamlrw_error on parse error or if multiple documents found. *)
245
253
246
254
val yaml_of_buffer :
247
255
?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> Buffer.t -> yaml
···
250
258
@param resolve_aliases Whether to expand aliases (default: false)
251
259
@param max_nodes Maximum nodes during alias expansion (default: 10M)
252
260
@param max_depth Maximum alias nesting depth (default: 100)
253
-
@raise Yamlrw_error on parse error or if multiple documents found *)
261
+
@raise Yamlrw_error on parse error or if multiple documents found. *)
254
262
255
263
val documents_of_buffer : Buffer.t -> document list
256
264
(** Parse a multi-document YAML stream from a buffer.
257
265
258
-
@raise Yamlrw_error on parse error *)
266
+
@raise Yamlrw_error on parse error. *)
259
267
260
268
(** {2 Conversion} *)
261
269
···
266
274
@param resolve_aliases Whether to expand aliases (default: true)
267
275
@param max_nodes Maximum nodes during alias expansion (default: 10M)
268
276
@param max_depth Maximum alias nesting depth (default: 100)
269
-
@raise Yamlrw_error if alias limits exceeded or complex keys found *)
277
+
@raise Yamlrw_error if alias limits exceeded or complex keys found. *)
270
278
271
279
val of_json : value -> yaml
272
280
(** Convert JSON-compatible value to full YAML representation. *)
+2
-2
tests/dune
+2
-2
tests/dune
+178
-215
tests/run_all_tests.ml
+178
-215
tests/run_all_tests.ml
···
76
76
if compare_json expected_json actual_json then (`Pass, actual_json)
77
77
else (`Fail "JSON mismatch", actual_json)
78
78
with
79
-
| Yamlrw_error e ->
80
-
(`Fail (Format.asprintf "Parse error: %a" Error.pp e), "")
81
-
| exn ->
82
-
(`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)), "")
83
-
)
79
+
| Yamlrw_error e -> (`Fail (Fmt.str "Parse error: %a" Error.pp e), "")
80
+
| exn -> (`Fail (Fmt.str "Exception: %s" (Printexc.to_string exn)), ""))
81
+
82
+
let run_error_test base yaml =
83
+
try
84
+
let parser = Parser.of_string yaml in
85
+
let events = Parser.to_list parser in
86
+
let tree = TF.of_spanned_events events in
87
+
{ base with status = `Fail "Expected parsing to fail"; output = tree }
88
+
with
89
+
| Yamlrw_error e ->
90
+
{ base with status = `Pass; output = Fmt.str "%a" Error.pp e }
91
+
| exn -> { base with status = `Pass; output = Printexc.to_string exn }
92
+
93
+
let run_tree_test base yaml expected =
94
+
try
95
+
let parser = Parser.of_string yaml in
96
+
let events = Parser.to_list parser in
97
+
let actual = TF.of_spanned_events events in
98
+
let expected_norm = normalize_tree expected in
99
+
let actual_norm = normalize_tree actual in
100
+
if expected_norm = actual_norm then
101
+
{ base with status = `Pass; output = actual }
102
+
else
103
+
{
104
+
base with
105
+
status = `Fail (Fmt.str "Tree mismatch");
106
+
output =
107
+
Fmt.str "Expected:\n%s\n\nActual:\n%s" expected_norm actual_norm;
108
+
}
109
+
with exn ->
110
+
{
111
+
base with
112
+
status = `Fail (Fmt.str "Exception: %s" (Printexc.to_string exn));
113
+
output = Printexc.to_string exn;
114
+
}
115
+
116
+
let run_no_tree_test base yaml json =
117
+
match json with
118
+
| Some _ -> (
119
+
try
120
+
let parser = Parser.of_string yaml in
121
+
let events = Parser.to_list parser in
122
+
let tree = TF.of_spanned_events events in
123
+
{ base with status = `Pass; output = tree }
124
+
with exn ->
125
+
{
126
+
base with
127
+
status =
128
+
`Fail (Fmt.str "Should parse but got: %s" (Printexc.to_string exn));
129
+
output = Printexc.to_string exn;
130
+
})
131
+
| None -> { base with status = `Skip; output = "(no expected tree or json)" }
84
132
85
133
let run_test (test : TL.test_case) : test_result =
86
134
let json_status, json_actual = run_json_test test in
···
97
145
json_actual;
98
146
}
99
147
in
100
-
if test.fail then begin
101
-
try
102
-
let parser = Parser.of_string test.yaml in
103
-
let events = Parser.to_list parser in
104
-
let tree = TF.of_spanned_events events in
105
-
{ base with status = `Fail "Expected parsing to fail"; output = tree }
106
-
with
107
-
| Yamlrw_error e ->
108
-
{ base with status = `Pass; output = Format.asprintf "%a" Error.pp e }
109
-
| exn -> { base with status = `Pass; output = Printexc.to_string exn }
110
-
end
111
-
else begin
148
+
if test.fail then run_error_test base test.yaml
149
+
else
112
150
match test.tree with
113
-
| None -> (
114
-
(* No expected tree - check if json indicates expected success *)
115
-
match test.json with
116
-
| Some _ -> (
117
-
(* Has json output, so should parse successfully *)
118
-
try
119
-
let parser = Parser.of_string test.yaml in
120
-
let events = Parser.to_list parser in
121
-
let tree = TF.of_spanned_events events in
122
-
{ base with status = `Pass; output = tree }
123
-
with exn ->
124
-
{
125
-
base with
126
-
status =
127
-
`Fail
128
-
(Printf.sprintf "Should parse but got: %s"
129
-
(Printexc.to_string exn));
130
-
output = Printexc.to_string exn;
131
-
})
132
-
| None ->
133
-
(* No tree, no json, no fail - ambiguous edge case, skip *)
134
-
{ base with status = `Skip; output = "(no expected tree or json)" })
135
-
| Some expected -> (
136
-
try
137
-
let parser = Parser.of_string test.yaml in
138
-
let events = Parser.to_list parser in
139
-
let actual = TF.of_spanned_events events in
140
-
let expected_norm = normalize_tree expected in
141
-
let actual_norm = normalize_tree actual in
142
-
if expected_norm = actual_norm then
143
-
{ base with status = `Pass; output = actual }
144
-
else
145
-
{
146
-
base with
147
-
status = `Fail (Printf.sprintf "Tree mismatch");
148
-
output =
149
-
Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm
150
-
actual_norm;
151
-
}
152
-
with exn ->
153
-
{
154
-
base with
155
-
status =
156
-
`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn));
157
-
output = Printexc.to_string exn;
158
-
})
159
-
end
151
+
| None -> run_no_tree_test base test.yaml test.json
152
+
| Some expected -> run_tree_test base test.yaml expected
160
153
161
154
let status_class = function
162
155
| `Pass -> "pass"
···
168
161
| `Fail _ -> "FAIL"
169
162
| `Skip -> "SKIP"
170
163
171
-
let generate_html results output_file =
172
-
let oc = open_out output_file in
173
-
let pass_count =
174
-
List.length (List.filter (fun r -> r.status = `Pass) results)
175
-
in
176
-
let fail_count =
177
-
List.length
178
-
(List.filter
179
-
(fun r -> match r.status with `Fail _ -> true | _ -> false)
180
-
results)
181
-
in
182
-
let skip_count =
183
-
List.length (List.filter (fun r -> r.status = `Skip) results)
184
-
in
185
-
let total = List.length results in
186
-
let json_pass_count =
187
-
List.length (List.filter (fun r -> r.json_status = `Pass) results)
188
-
in
189
-
let json_fail_count =
190
-
List.length
191
-
(List.filter
192
-
(fun r -> match r.json_status with `Fail _ -> true | _ -> false)
193
-
results)
194
-
in
195
-
let json_skip_count =
196
-
List.length (List.filter (fun r -> r.json_status = `Skip) results)
197
-
in
198
-
199
-
Printf.fprintf oc
200
-
{|<!DOCTYPE html>
164
+
let page_css_1 =
165
+
{|<!DOCTYPE html>
201
166
<html lang="en">
202
167
<head>
203
168
<meta charset="UTF-8">
···
205
170
<title>Yamlrw Test Results</title>
206
171
<style>
207
172
:root {
208
-
--pass-color: #22c55e;
209
-
--fail-color: #ef4444;
210
-
--skip-color: #f59e0b;
211
-
--bg-color: #1a1a2e;
212
-
--card-bg: #16213e;
213
-
--text-color: #e2e8f0;
214
-
--border-color: #334155;
173
+
--pass-color: #22c55e; --fail-color: #ef4444; --skip-color: #f59e0b;
174
+
--bg-color: #1a1a2e; --card-bg: #16213e;
175
+
--text-color: #e2e8f0; --border-color: #334155;
215
176
}
216
177
* { box-sizing: border-box; margin: 0; padding: 0; }
217
178
body {
218
179
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif;
219
-
background: var(--bg-color);
220
-
color: var(--text-color);
221
-
line-height: 1.6;
222
-
padding: 2rem;
180
+
background: var(--bg-color); color: var(--text-color);
181
+
line-height: 1.6; padding: 2rem;
223
182
}
224
183
.container { max-width: 1400px; margin: 0 auto; }
225
184
h1 { margin-bottom: 1.5rem; font-size: 2rem; }
226
-
.summary {
227
-
display: flex;
228
-
gap: 1rem;
229
-
margin-bottom: 2rem;
230
-
flex-wrap: wrap;
231
-
}
185
+
.summary { display: flex; gap: 1rem; margin-bottom: 2rem; flex-wrap: wrap; }
232
186
.stat {
233
-
background: var(--card-bg);
234
-
padding: 1rem 1.5rem;
235
-
border-radius: 8px;
236
-
border-left: 4px solid var(--border-color);
187
+
background: var(--card-bg); padding: 1rem 1.5rem;
188
+
border-radius: 8px; border-left: 4px solid var(--border-color);
237
189
}
238
190
.stat.pass { border-left-color: var(--pass-color); }
239
191
.stat.fail { border-left-color: var(--fail-color); }
240
192
.stat.skip { border-left-color: var(--skip-color); }
241
193
.stat-value { font-size: 2rem; font-weight: bold; }
242
194
.stat-label { font-size: 0.875rem; opacity: 0.8; }
243
-
.filters {
244
-
margin-bottom: 1.5rem;
245
-
display: flex;
246
-
gap: 0.5rem;
247
-
flex-wrap: wrap;
248
-
}
195
+
.filters { margin-bottom: 1.5rem; display: flex; gap: 0.5rem; flex-wrap: wrap; }
249
196
.filter-btn {
250
-
padding: 0.5rem 1rem;
251
-
border: 1px solid var(--border-color);
252
-
background: var(--card-bg);
253
-
color: var(--text-color);
254
-
border-radius: 4px;
255
-
cursor: pointer;
256
-
transition: all 0.2s;
257
-
}
197
+
padding: 0.5rem 1rem; border: 1px solid var(--border-color);
198
+
background: var(--card-bg); color: var(--text-color);
199
+
border-radius: 4px; cursor: pointer; transition: all 0.2s;
200
+
}|}
201
+
202
+
let page_css_2 =
203
+
{|
258
204
.filter-btn:hover { border-color: var(--text-color); }
259
205
.filter-btn.active { background: var(--text-color); color: var(--bg-color); }
260
206
.search {
261
-
padding: 0.5rem 1rem;
262
-
border: 1px solid var(--border-color);
263
-
background: var(--card-bg);
264
-
color: var(--text-color);
265
-
border-radius: 4px;
266
-
width: 200px;
207
+
padding: 0.5rem 1rem; border: 1px solid var(--border-color);
208
+
background: var(--card-bg); color: var(--text-color);
209
+
border-radius: 4px; width: 200px;
267
210
}
268
211
.tests { display: flex; flex-direction: column; gap: 1rem; }
269
212
.test {
270
-
background: var(--card-bg);
271
-
border-radius: 8px;
272
-
border: 1px solid var(--border-color);
273
-
overflow: hidden;
213
+
background: var(--card-bg); border-radius: 8px;
214
+
border: 1px solid var(--border-color); overflow: hidden;
274
215
}
275
216
.test-header {
276
-
padding: 1rem;
277
-
display: flex;
278
-
align-items: center;
279
-
gap: 1rem;
280
-
cursor: pointer;
281
-
border-bottom: 1px solid var(--border-color);
217
+
padding: 1rem; display: flex; align-items: center; gap: 1rem;
218
+
cursor: pointer; border-bottom: 1px solid var(--border-color);
282
219
}
283
220
.test-header:hover { background: rgba(255,255,255,0.05); }
284
221
.badge {
285
-
padding: 0.25rem 0.5rem;
286
-
border-radius: 4px;
287
-
font-size: 0.75rem;
288
-
font-weight: bold;
289
-
text-transform: uppercase;
222
+
padding: 0.25rem 0.5rem; border-radius: 4px;
223
+
font-size: 0.75rem; font-weight: bold; text-transform: uppercase;
290
224
}
291
225
.badge.pass { background: var(--pass-color); color: #000; }
292
226
.badge.fail { background: var(--fail-color); color: #fff; }
···
298
232
.test.expanded .test-content { display: block; }
299
233
.section { margin-bottom: 1rem; }
300
234
.section-title {
301
-
font-size: 0.875rem;
302
-
text-transform: uppercase;
303
-
opacity: 0.6;
304
-
margin-bottom: 0.5rem;
305
-
letter-spacing: 0.05em;
235
+
font-size: 0.875rem; text-transform: uppercase; opacity: 0.6;
236
+
margin-bottom: 0.5rem; letter-spacing: 0.05em;
306
237
}
307
238
pre {
308
-
background: #0f172a;
309
-
padding: 1rem;
310
-
border-radius: 4px;
311
-
overflow-x: auto;
312
-
font-size: 0.875rem;
313
-
white-space: pre-wrap;
314
-
word-break: break-all;
239
+
background: #0f172a; padding: 1rem; border-radius: 4px;
240
+
overflow-x: auto; font-size: 0.875rem;
241
+
white-space: pre-wrap; word-break: break-all;
315
242
}
316
243
.expand-icon { transition: transform 0.2s; }
317
244
.test.expanded .expand-icon { transform: rotate(90deg); }
···
319
246
</head>
320
247
<body>
321
248
<div class="container">
322
-
<h1>Yamlrw Test Results</h1>
249
+
<h1>Yamlrw Test Results</h1>|}
250
+
251
+
let page_css = page_css_1 ^ page_css_2
252
+
253
+
let html_stats_section pass_count fail_count skip_count total json_pass
254
+
json_fail json_skip =
255
+
Fmt.str
256
+
{|
323
257
<div class="summary">
324
258
<div class="stat pass">
325
259
<div class="stat-value">%d</div>
···
362
296
</div>
363
297
<div class="tests">
364
298
|}
365
-
pass_count fail_count skip_count total json_pass_count json_fail_count
366
-
json_skip_count;
299
+
pass_count fail_count skip_count total json_pass json_fail json_skip
367
300
368
-
List.iter
369
-
(fun result ->
370
-
let error_badge =
371
-
if result.is_error_test then
372
-
{|<span class="badge error-test">Error Test</span>|}
373
-
else ""
374
-
in
375
-
let json_badge =
376
-
Printf.sprintf
377
-
{|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|}
378
-
(status_class result.json_status)
379
-
(status_text result.json_status)
380
-
in
381
-
let json_section =
382
-
if result.json_expected <> "" || result.json_actual <> "" then
383
-
Printf.sprintf
384
-
{|
301
+
let html_test_row result =
302
+
let error_badge =
303
+
if result.is_error_test then
304
+
{|<span class="badge error-test">Error Test</span>|}
305
+
else ""
306
+
in
307
+
let json_badge =
308
+
Fmt.str {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|}
309
+
(status_class result.json_status)
310
+
(status_text result.json_status)
311
+
in
312
+
let json_section =
313
+
if result.json_expected <> "" || result.json_actual <> "" then
314
+
Fmt.str
315
+
{|
385
316
<div class="section">
386
317
<div class="section-title">Expected JSON</div>
387
318
<pre>%s</pre>
···
390
321
<div class="section-title">Actual JSON</div>
391
322
<pre>%s</pre>
392
323
</div>|}
393
-
(html_escape result.json_expected)
394
-
(html_escape result.json_actual)
395
-
else ""
396
-
in
397
-
Printf.fprintf oc
398
-
{| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s">
324
+
(html_escape result.json_expected)
325
+
(html_escape result.json_actual)
326
+
else ""
327
+
in
328
+
Fmt.str
329
+
{| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s">
399
330
<div class="test-header" onclick="this.parentElement.classList.toggle('expanded')">
400
331
<span class="expand-icon">▶</span>
401
332
<span class="badge %s">%s</span>
···
416
347
</div>
417
348
</div>
418
349
|}
419
-
(status_class result.status)
420
-
(status_class result.json_status)
421
-
(html_escape result.id)
422
-
(html_escape (String.lowercase_ascii result.name))
423
-
(status_class result.status)
424
-
(status_text result.status)
425
-
json_badge (html_escape result.id) (html_escape result.name) error_badge
426
-
(html_escape result.yaml)
427
-
(html_escape result.output)
428
-
json_section)
429
-
results;
350
+
(status_class result.status)
351
+
(status_class result.json_status)
352
+
(html_escape result.id)
353
+
(html_escape (String.lowercase_ascii result.name))
354
+
(status_class result.status)
355
+
(status_text result.status)
356
+
json_badge (html_escape result.id) (html_escape result.name) error_badge
357
+
(html_escape result.yaml)
358
+
(html_escape result.output)
359
+
json_section
430
360
431
-
Printf.fprintf oc
432
-
{| </div>
361
+
let html_footer =
362
+
{| </div>
433
363
</div>
434
364
<script>
435
365
document.querySelectorAll('.filter-btn').forEach(btn => {
···
455
385
</script>
456
386
</body>
457
387
</html>
458
-
|};
388
+
|}
389
+
390
+
let generate_html results output_file =
391
+
let oc = open_out output_file in
392
+
let pass_count =
393
+
List.length (List.filter (fun r -> r.status = `Pass) results)
394
+
in
395
+
let fail_count =
396
+
List.length
397
+
(List.filter
398
+
(fun r -> match r.status with `Fail _ -> true | _ -> false)
399
+
results)
400
+
in
401
+
let skip_count =
402
+
List.length (List.filter (fun r -> r.status = `Skip) results)
403
+
in
404
+
let total = List.length results in
405
+
let json_pass_count =
406
+
List.length (List.filter (fun r -> r.json_status = `Pass) results)
407
+
in
408
+
let json_fail_count =
409
+
List.length
410
+
(List.filter
411
+
(fun r -> match r.json_status with `Fail _ -> true | _ -> false)
412
+
results)
413
+
in
414
+
let json_skip_count =
415
+
List.length (List.filter (fun r -> r.json_status = `Skip) results)
416
+
in
417
+
output_string oc page_css;
418
+
output_string oc
419
+
(html_stats_section pass_count fail_count skip_count total json_pass_count
420
+
json_fail_count json_skip_count);
421
+
List.iter (fun result -> output_string oc (html_test_row result)) results;
422
+
output_string oc html_footer;
459
423
close_out oc
460
424
461
425
let () =
···
479
443
<path>]";
480
444
481
445
let all_tests = TL.load_directory !test_suite_path_ref in
482
-
Printf.printf "Total tests loaded: %d\n%!" (List.length all_tests);
446
+
Fmt.pr "Total tests loaded: %d\n%!" (List.length all_tests);
483
447
484
448
let results = List.map run_test all_tests in
485
449
···
509
473
List.length (List.filter (fun r -> r.json_status = `Skip) results)
510
474
in
511
475
512
-
Printf.printf
513
-
"\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" pass_count
514
-
fail_count skip_count
476
+
Fmt.pr "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!"
477
+
pass_count fail_count skip_count
515
478
(pass_count + fail_count + skip_count);
516
479
517
-
Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count
480
+
Fmt.pr "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count
518
481
json_fail_count json_skip_count;
519
482
520
483
if fail_count > 0 then begin
521
-
Printf.printf "\nFailing event tree tests:\n";
484
+
Fmt.pr "\nFailing event tree tests:\n";
522
485
List.iter
523
486
(fun r ->
524
487
match r.status with
525
-
| `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
488
+
| `Fail msg -> Fmt.pr " %s: %s - %s\n" r.id r.name msg
526
489
| _ -> ())
527
490
results
528
491
end;
529
492
530
493
if json_fail_count > 0 then begin
531
-
Printf.printf "\nFailing JSON tests:\n";
494
+
Fmt.pr "\nFailing JSON tests:\n";
532
495
List.iter
533
496
(fun r ->
534
497
match r.json_status with
535
-
| `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
498
+
| `Fail msg -> Fmt.pr " %s: %s - %s\n" r.id r.name msg
536
499
| _ -> ())
537
500
results
538
501
end;
539
502
540
503
if !show_skipped && skip_count > 0 then begin
541
-
Printf.printf "\nSkipped tests (no expected tree):\n";
504
+
Fmt.pr "\nSkipped tests (no expected tree):\n";
542
505
List.iter
543
506
(fun r ->
544
507
if r.status = `Skip then begin
545
-
Printf.printf " %s: %s\n" r.id r.name;
546
-
Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml)
508
+
Fmt.pr " %s: %s\n" r.id r.name;
509
+
Fmt.pr " YAML (%d chars): %S\n" (String.length r.yaml)
547
510
(if String.length r.yaml <= 60 then r.yaml
548
511
else String.sub r.yaml 0 60 ^ "...")
549
512
end)
···
553
516
(match !html_output with
554
517
| Some file ->
555
518
generate_html results file;
556
-
Printf.printf "\nHTML report generated: %s\n" file
519
+
Fmt.pr "\nHTML report generated: %s\n" file
557
520
| None -> ());
558
521
559
522
(* Exit with non-zero code if any tests failed *)
+184
-221
tests/run_all_tests_eio.ml
+184
-221
tests/run_all_tests_eio.ml
···
72
72
if compare_json expected_json actual_json then (`Pass, actual_json)
73
73
else (`Fail "JSON mismatch", actual_json)
74
74
with
75
-
| Yamlrw_error e ->
76
-
(`Fail (Format.asprintf "Parse error: %a" Error.pp e), "")
77
-
| exn ->
78
-
(`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)), "")
79
-
)
75
+
| Yamlrw_error e -> (`Fail (Fmt.str "Parse error: %a" Error.pp e), "")
76
+
| exn -> (`Fail (Fmt.str "Exception: %s" (Printexc.to_string exn)), ""))
77
+
78
+
let run_error_test base yaml =
79
+
try
80
+
let parser = Parser.of_string yaml in
81
+
let events = Parser.to_list parser in
82
+
let tree = TF.of_spanned_events events in
83
+
{ base with status = `Fail "Expected parsing to fail"; output = tree }
84
+
with
85
+
| Yamlrw_error e ->
86
+
{ base with status = `Pass; output = Fmt.str "%a" Error.pp e }
87
+
| exn -> { base with status = `Pass; output = Printexc.to_string exn }
88
+
89
+
let run_tree_test base yaml expected =
90
+
try
91
+
let parser = Parser.of_string yaml in
92
+
let events = Parser.to_list parser in
93
+
let actual = TF.of_spanned_events events in
94
+
let expected_norm = normalize_tree expected in
95
+
let actual_norm = normalize_tree actual in
96
+
if expected_norm = actual_norm then
97
+
{ base with status = `Pass; output = actual }
98
+
else
99
+
{
100
+
base with
101
+
status = `Fail (Fmt.str "Tree mismatch");
102
+
output =
103
+
Fmt.str "Expected:\n%s\n\nActual:\n%s" expected_norm actual_norm;
104
+
}
105
+
with exn ->
106
+
{
107
+
base with
108
+
status = `Fail (Fmt.str "Exception: %s" (Printexc.to_string exn));
109
+
output = Printexc.to_string exn;
110
+
}
111
+
112
+
let run_no_tree_test base yaml json =
113
+
match json with
114
+
| Some _ -> (
115
+
try
116
+
let parser = Parser.of_string yaml in
117
+
let events = Parser.to_list parser in
118
+
let tree = TF.of_spanned_events events in
119
+
{ base with status = `Pass; output = tree }
120
+
with exn ->
121
+
{
122
+
base with
123
+
status =
124
+
`Fail (Fmt.str "Should parse but got: %s" (Printexc.to_string exn));
125
+
output = Printexc.to_string exn;
126
+
})
127
+
| None -> { base with status = `Skip; output = "(no expected tree or json)" }
80
128
81
129
let run_test (test : TL.test_case) : test_result =
82
130
let json_status, json_actual = run_json_test test in
···
93
141
json_actual;
94
142
}
95
143
in
96
-
if test.fail then begin
97
-
try
98
-
let parser = Parser.of_string test.yaml in
99
-
let events = Parser.to_list parser in
100
-
let tree = TF.of_spanned_events events in
101
-
{ base with status = `Fail "Expected parsing to fail"; output = tree }
102
-
with
103
-
| Yamlrw_error e ->
104
-
{ base with status = `Pass; output = Format.asprintf "%a" Error.pp e }
105
-
| exn -> { base with status = `Pass; output = Printexc.to_string exn }
106
-
end
107
-
else begin
144
+
if test.fail then run_error_test base test.yaml
145
+
else
108
146
match test.tree with
109
-
| None -> (
110
-
match test.json with
111
-
| Some _ -> (
112
-
try
113
-
let parser = Parser.of_string test.yaml in
114
-
let events = Parser.to_list parser in
115
-
let tree = TF.of_spanned_events events in
116
-
{ base with status = `Pass; output = tree }
117
-
with exn ->
118
-
{
119
-
base with
120
-
status =
121
-
`Fail
122
-
(Printf.sprintf "Should parse but got: %s"
123
-
(Printexc.to_string exn));
124
-
output = Printexc.to_string exn;
125
-
})
126
-
| None ->
127
-
{ base with status = `Skip; output = "(no expected tree or json)" })
128
-
| Some expected -> (
129
-
try
130
-
let parser = Parser.of_string test.yaml in
131
-
let events = Parser.to_list parser in
132
-
let actual = TF.of_spanned_events events in
133
-
let expected_norm = normalize_tree expected in
134
-
let actual_norm = normalize_tree actual in
135
-
if expected_norm = actual_norm then
136
-
{ base with status = `Pass; output = actual }
137
-
else
138
-
{
139
-
base with
140
-
status = `Fail (Printf.sprintf "Tree mismatch");
141
-
output =
142
-
Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm
143
-
actual_norm;
144
-
}
145
-
with exn ->
146
-
{
147
-
base with
148
-
status =
149
-
`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn));
150
-
output = Printexc.to_string exn;
151
-
})
152
-
end
147
+
| None -> run_no_tree_test base test.yaml test.json
148
+
| Some expected -> run_tree_test base test.yaml expected
153
149
154
150
(* Run tests in parallel using Eio fibers *)
155
151
let run_tests_parallel tests = Eio.Fiber.List.map run_test tests
···
164
160
| `Fail _ -> "FAIL"
165
161
| `Skip -> "SKIP"
166
162
167
-
let generate_html ~fs results output_file =
168
-
let pass_count =
169
-
List.length (List.filter (fun r -> r.status = `Pass) results)
170
-
in
171
-
let fail_count =
172
-
List.length
173
-
(List.filter
174
-
(fun r -> match r.status with `Fail _ -> true | _ -> false)
175
-
results)
176
-
in
177
-
let skip_count =
178
-
List.length (List.filter (fun r -> r.status = `Skip) results)
179
-
in
180
-
let total = List.length results in
181
-
let json_pass_count =
182
-
List.length (List.filter (fun r -> r.json_status = `Pass) results)
183
-
in
184
-
let json_fail_count =
185
-
List.length
186
-
(List.filter
187
-
(fun r -> match r.json_status with `Fail _ -> true | _ -> false)
188
-
results)
189
-
in
190
-
let json_skip_count =
191
-
List.length (List.filter (fun r -> r.json_status = `Skip) results)
192
-
in
193
-
194
-
let buf = Buffer.create 65536 in
195
-
Printf.bprintf buf
196
-
{|<!DOCTYPE html>
163
+
let page_css_eio_1 =
164
+
{|<!DOCTYPE html>
197
165
<html lang="en">
198
166
<head>
199
167
<meta charset="UTF-8">
···
201
169
<title>Yamlrw Test Results (Eio)</title>
202
170
<style>
203
171
:root {
204
-
--pass-color: #22c55e;
205
-
--fail-color: #ef4444;
206
-
--skip-color: #f59e0b;
207
-
--bg-color: #1a1a2e;
208
-
--card-bg: #16213e;
209
-
--text-color: #e2e8f0;
210
-
--border-color: #334155;
172
+
--pass-color: #22c55e; --fail-color: #ef4444; --skip-color: #f59e0b;
173
+
--bg-color: #1a1a2e; --card-bg: #16213e;
174
+
--text-color: #e2e8f0; --border-color: #334155;
211
175
}
212
176
* { box-sizing: border-box; margin: 0; padding: 0; }
213
177
body {
214
178
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif;
215
-
background: var(--bg-color);
216
-
color: var(--text-color);
217
-
line-height: 1.6;
218
-
padding: 2rem;
179
+
background: var(--bg-color); color: var(--text-color);
180
+
line-height: 1.6; padding: 2rem;
219
181
}
220
182
.container { max-width: 1400px; margin: 0 auto; }
221
183
h1 { margin-bottom: 1.5rem; font-size: 2rem; }
222
184
.eio-badge {
223
185
display: inline-block;
224
-
background: linear-gradient(135deg, #667eea 0%%, #764ba2 100%%);
225
-
color: white;
226
-
padding: 0.25rem 0.75rem;
227
-
border-radius: 999px;
228
-
font-size: 0.875rem;
229
-
margin-left: 1rem;
230
-
vertical-align: middle;
231
-
}
232
-
.summary {
233
-
display: flex;
234
-
gap: 1rem;
235
-
margin-bottom: 2rem;
236
-
flex-wrap: wrap;
186
+
background: linear-gradient(135deg, #667eea 0%, #764ba2 100%);
187
+
color: white; padding: 0.25rem 0.75rem; border-radius: 999px;
188
+
font-size: 0.875rem; margin-left: 1rem; vertical-align: middle;
237
189
}
190
+
.summary { display: flex; gap: 1rem; margin-bottom: 2rem; flex-wrap: wrap; }
238
191
.stat {
239
-
background: var(--card-bg);
240
-
padding: 1rem 1.5rem;
241
-
border-radius: 8px;
242
-
border-left: 4px solid var(--border-color);
192
+
background: var(--card-bg); padding: 1rem 1.5rem;
193
+
border-radius: 8px; border-left: 4px solid var(--border-color);
243
194
}
244
195
.stat.pass { border-left-color: var(--pass-color); }
245
196
.stat.fail { border-left-color: var(--fail-color); }
246
197
.stat.skip { border-left-color: var(--skip-color); }
247
198
.stat-value { font-size: 2rem; font-weight: bold; }
248
199
.stat-label { font-size: 0.875rem; opacity: 0.8; }
249
-
.filters {
250
-
margin-bottom: 1.5rem;
251
-
display: flex;
252
-
gap: 0.5rem;
253
-
flex-wrap: wrap;
254
-
}
200
+
.filters { margin-bottom: 1.5rem; display: flex; gap: 0.5rem; flex-wrap: wrap; }
255
201
.filter-btn {
256
-
padding: 0.5rem 1rem;
257
-
border: 1px solid var(--border-color);
258
-
background: var(--card-bg);
259
-
color: var(--text-color);
260
-
border-radius: 4px;
261
-
cursor: pointer;
262
-
transition: all 0.2s;
263
-
}
202
+
padding: 0.5rem 1rem; border: 1px solid var(--border-color);
203
+
background: var(--card-bg); color: var(--text-color);
204
+
border-radius: 4px; cursor: pointer; transition: all 0.2s;
205
+
}|}
206
+
207
+
let page_css_eio_2 =
208
+
{|
264
209
.filter-btn:hover { border-color: var(--text-color); }
265
210
.filter-btn.active { background: var(--text-color); color: var(--bg-color); }
266
211
.search {
267
-
padding: 0.5rem 1rem;
268
-
border: 1px solid var(--border-color);
269
-
background: var(--card-bg);
270
-
color: var(--text-color);
271
-
border-radius: 4px;
272
-
width: 200px;
212
+
padding: 0.5rem 1rem; border: 1px solid var(--border-color);
213
+
background: var(--card-bg); color: var(--text-color);
214
+
border-radius: 4px; width: 200px;
273
215
}
274
216
.tests { display: flex; flex-direction: column; gap: 1rem; }
275
217
.test {
276
-
background: var(--card-bg);
277
-
border-radius: 8px;
278
-
border: 1px solid var(--border-color);
279
-
overflow: hidden;
218
+
background: var(--card-bg); border-radius: 8px;
219
+
border: 1px solid var(--border-color); overflow: hidden;
280
220
}
281
221
.test-header {
282
-
padding: 1rem;
283
-
display: flex;
284
-
align-items: center;
285
-
gap: 1rem;
286
-
cursor: pointer;
287
-
border-bottom: 1px solid var(--border-color);
222
+
padding: 1rem; display: flex; align-items: center; gap: 1rem;
223
+
cursor: pointer; border-bottom: 1px solid var(--border-color);
288
224
}
289
225
.test-header:hover { background: rgba(255,255,255,0.05); }
290
226
.badge {
291
-
padding: 0.25rem 0.5rem;
292
-
border-radius: 4px;
293
-
font-size: 0.75rem;
294
-
font-weight: bold;
295
-
text-transform: uppercase;
227
+
padding: 0.25rem 0.5rem; border-radius: 4px;
228
+
font-size: 0.75rem; font-weight: bold; text-transform: uppercase;
296
229
}
297
230
.badge.pass { background: var(--pass-color); color: #000; }
298
231
.badge.fail { background: var(--fail-color); color: #fff; }
···
304
237
.test.expanded .test-content { display: block; }
305
238
.section { margin-bottom: 1rem; }
306
239
.section-title {
307
-
font-size: 0.875rem;
308
-
text-transform: uppercase;
309
-
opacity: 0.6;
310
-
margin-bottom: 0.5rem;
311
-
letter-spacing: 0.05em;
240
+
font-size: 0.875rem; text-transform: uppercase; opacity: 0.6;
241
+
margin-bottom: 0.5rem; letter-spacing: 0.05em;
312
242
}
313
243
pre {
314
-
background: #0f172a;
315
-
padding: 1rem;
316
-
border-radius: 4px;
317
-
overflow-x: auto;
318
-
font-size: 0.875rem;
319
-
white-space: pre-wrap;
320
-
word-break: break-all;
244
+
background: #0f172a; padding: 1rem; border-radius: 4px;
245
+
overflow-x: auto; font-size: 0.875rem;
246
+
white-space: pre-wrap; word-break: break-all;
321
247
}
322
248
.expand-icon { transition: transform 0.2s; }
323
249
.test.expanded .expand-icon { transform: rotate(90deg); }
···
325
251
</head>
326
252
<body>
327
253
<div class="container">
328
-
<h1>Yamlrw Test Results <span class="eio-badge">Eio Parallel</span></h1>
254
+
<h1>Yamlrw Test Results <span class="eio-badge">Eio Parallel</span></h1>|}
255
+
256
+
let page_css_eio = page_css_eio_1 ^ page_css_eio_2
257
+
258
+
let html_stats_section_eio pass_count fail_count skip_count total json_pass
259
+
json_fail json_skip =
260
+
Fmt.str
261
+
{|
329
262
<div class="summary">
330
263
<div class="stat pass">
331
264
<div class="stat-value">%d</div>
···
368
301
</div>
369
302
<div class="tests">
370
303
|}
371
-
pass_count fail_count skip_count total json_pass_count json_fail_count
372
-
json_skip_count;
304
+
pass_count fail_count skip_count total json_pass json_fail json_skip
373
305
374
-
List.iter
375
-
(fun result ->
376
-
let error_badge =
377
-
if result.is_error_test then
378
-
{|<span class="badge error-test">Error Test</span>|}
379
-
else ""
380
-
in
381
-
let json_badge =
382
-
Printf.sprintf
383
-
{|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|}
384
-
(status_class result.json_status)
385
-
(status_text result.json_status)
386
-
in
387
-
let json_section =
388
-
if result.json_expected <> "" || result.json_actual <> "" then
389
-
Printf.sprintf
390
-
{|
306
+
let html_test_row_eio result =
307
+
let error_badge =
308
+
if result.is_error_test then
309
+
{|<span class="badge error-test">Error Test</span>|}
310
+
else ""
311
+
in
312
+
let json_badge =
313
+
Fmt.str {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|}
314
+
(status_class result.json_status)
315
+
(status_text result.json_status)
316
+
in
317
+
let json_section =
318
+
if result.json_expected <> "" || result.json_actual <> "" then
319
+
Fmt.str
320
+
{|
391
321
<div class="section">
392
322
<div class="section-title">Expected JSON</div>
393
323
<pre>%s</pre>
···
396
326
<div class="section-title">Actual JSON</div>
397
327
<pre>%s</pre>
398
328
</div>|}
399
-
(html_escape result.json_expected)
400
-
(html_escape result.json_actual)
401
-
else ""
402
-
in
403
-
Printf.bprintf buf
404
-
{| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s">
329
+
(html_escape result.json_expected)
330
+
(html_escape result.json_actual)
331
+
else ""
332
+
in
333
+
Fmt.str
334
+
{| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s">
405
335
<div class="test-header" onclick="this.parentElement.classList.toggle('expanded')">
406
336
<span class="expand-icon">▶</span>
407
337
<span class="badge %s">%s</span>
···
422
352
</div>
423
353
</div>
424
354
|}
425
-
(status_class result.status)
426
-
(status_class result.json_status)
427
-
(html_escape result.id)
428
-
(html_escape (String.lowercase_ascii result.name))
429
-
(status_class result.status)
430
-
(status_text result.status)
431
-
json_badge (html_escape result.id) (html_escape result.name) error_badge
432
-
(html_escape result.yaml)
433
-
(html_escape result.output)
434
-
json_section)
435
-
results;
355
+
(status_class result.status)
356
+
(status_class result.json_status)
357
+
(html_escape result.id)
358
+
(html_escape (String.lowercase_ascii result.name))
359
+
(status_class result.status)
360
+
(status_text result.status)
361
+
json_badge (html_escape result.id) (html_escape result.name) error_badge
362
+
(html_escape result.yaml)
363
+
(html_escape result.output)
364
+
json_section
436
365
437
-
Printf.bprintf buf
438
-
{| </div>
366
+
let html_footer_eio =
367
+
{| </div>
439
368
</div>
440
369
<script>
441
370
document.querySelectorAll('.filter-btn').forEach(btn => {
···
461
390
</script>
462
391
</body>
463
392
</html>
464
-
|};
393
+
|}
465
394
395
+
let generate_html ~fs results output_file =
396
+
let pass_count =
397
+
List.length (List.filter (fun r -> r.status = `Pass) results)
398
+
in
399
+
let fail_count =
400
+
List.length
401
+
(List.filter
402
+
(fun r -> match r.status with `Fail _ -> true | _ -> false)
403
+
results)
404
+
in
405
+
let skip_count =
406
+
List.length (List.filter (fun r -> r.status = `Skip) results)
407
+
in
408
+
let total = List.length results in
409
+
let json_pass_count =
410
+
List.length (List.filter (fun r -> r.json_status = `Pass) results)
411
+
in
412
+
let json_fail_count =
413
+
List.length
414
+
(List.filter
415
+
(fun r -> match r.json_status with `Fail _ -> true | _ -> false)
416
+
results)
417
+
in
418
+
let json_skip_count =
419
+
List.length (List.filter (fun r -> r.json_status = `Skip) results)
420
+
in
421
+
let buf = Buffer.create 65536 in
422
+
Buffer.add_string buf page_css_eio;
423
+
Buffer.add_string buf
424
+
(html_stats_section_eio pass_count fail_count skip_count total
425
+
json_pass_count json_fail_count json_skip_count);
426
+
List.iter
427
+
(fun result -> Buffer.add_string buf (html_test_row_eio result))
428
+
results;
429
+
Buffer.add_string buf html_footer_eio;
466
430
Eio.Path.save ~create:(`Or_truncate 0o644)
467
431
Eio.Path.(fs / output_file)
468
432
(Buffer.contents buf)
···
509
473
else TL.load_directory_parallel ~fs test_suite_abs
510
474
in
511
475
let load_time = Unix.gettimeofday () in
512
-
Printf.printf "Loaded %d tests in %.3fs\n%!" (List.length all_tests)
476
+
Fmt.pr "Loaded %d tests in %.3fs\n%!" (List.length all_tests)
513
477
(load_time -. start_time);
514
478
515
479
(* Run tests (parallel or sequential based on flag) *)
···
518
482
else run_tests_parallel all_tests
519
483
in
520
484
let run_time = Unix.gettimeofday () in
521
-
Printf.printf "Ran tests in %.3fs\n%!" (run_time -. load_time);
485
+
Fmt.pr "Ran tests in %.3fs\n%!" (run_time -. load_time);
522
486
523
487
let pass_count =
524
488
List.length (List.filter (fun r -> r.status = `Pass) results)
···
546
510
List.length (List.filter (fun r -> r.json_status = `Skip) results)
547
511
in
548
512
549
-
Printf.printf
550
-
"\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" pass_count
551
-
fail_count skip_count
513
+
Fmt.pr "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!"
514
+
pass_count fail_count skip_count
552
515
(pass_count + fail_count + skip_count);
553
516
554
-
Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count
517
+
Fmt.pr "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count
555
518
json_fail_count json_skip_count;
556
519
557
520
if fail_count > 0 then begin
558
-
Printf.printf "\nFailing event tree tests:\n";
521
+
Fmt.pr "\nFailing event tree tests:\n";
559
522
List.iter
560
523
(fun r ->
561
524
match r.status with
562
-
| `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
525
+
| `Fail msg -> Fmt.pr " %s: %s - %s\n" r.id r.name msg
563
526
| _ -> ())
564
527
results
565
528
end;
566
529
567
530
if json_fail_count > 0 then begin
568
-
Printf.printf "\nFailing JSON tests:\n";
531
+
Fmt.pr "\nFailing JSON tests:\n";
569
532
List.iter
570
533
(fun r ->
571
534
match r.json_status with
572
-
| `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
535
+
| `Fail msg -> Fmt.pr " %s: %s - %s\n" r.id r.name msg
573
536
| _ -> ())
574
537
results
575
538
end;
576
539
577
540
if !show_skipped && skip_count > 0 then begin
578
-
Printf.printf "\nSkipped tests (no expected tree):\n";
541
+
Fmt.pr "\nSkipped tests (no expected tree):\n";
579
542
List.iter
580
543
(fun r ->
581
544
if r.status = `Skip then begin
582
-
Printf.printf " %s: %s\n" r.id r.name;
583
-
Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml)
545
+
Fmt.pr " %s: %s\n" r.id r.name;
546
+
Fmt.pr " YAML (%d chars): %S\n" (String.length r.yaml)
584
547
(if String.length r.yaml <= 60 then r.yaml
585
548
else String.sub r.yaml 0 60 ^ "...")
586
549
end)
···
588
551
end;
589
552
590
553
let total_time = Unix.gettimeofday () in
591
-
Printf.printf "\nTotal time: %.3fs\n%!" (total_time -. start_time);
554
+
Fmt.pr "\nTotal time: %.3fs\n%!" (total_time -. start_time);
592
555
593
556
(match !html_output with
594
557
| Some file ->
595
558
generate_html ~fs results file;
596
-
Printf.printf "HTML report generated: %s\n" file
559
+
Fmt.pr "HTML report generated: %s\n" file
597
560
| None -> ());
598
561
599
562
(* Exit with non-zero code if any tests failed *)
+1
-1
tests/test_suite_lib/dune
+1
-1
tests/test_suite_lib/dune
+6
-4
tests/test_suite_lib/json_compare.ml
+6
-4
tests/test_suite_lib/json_compare.ml
···
34
34
sorted_a sorted_b
35
35
| _ -> false
36
36
37
+
let err_json e = Error (Fmt.str "%a" Jsonm.pp_error e)
38
+
37
39
(* Parse JSON string using jsonm *)
38
40
let parse_json s =
39
41
let decoder = Jsonm.decoder (`String s) in
···
46
48
| `Lexeme `As -> parse_array []
47
49
| `Lexeme `Os -> parse_object []
48
50
| `Lexeme _ -> Error "unexpected lexeme"
49
-
| `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e)
51
+
| `Error e -> err_json e
50
52
| `End -> Error "unexpected end"
51
53
| `Await -> Error "unexpected await"
52
54
and parse_array acc =
···
56
58
(* Push back and parse value *)
57
59
let result = parse_value_with_lex lex in
58
60
match result with Ok v -> parse_array (v :: acc) | Error _ as e -> e)
59
-
| `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e)
61
+
| `Error e -> err_json e
60
62
| `End -> Error "unexpected end in array"
61
63
| `Await -> Error "unexpected await"
62
64
and parse_object acc =
···
67
69
| Ok v -> parse_object ((key, v) :: acc)
68
70
| Error _ as e -> e)
69
71
| `Lexeme _ -> Error "expected object key"
70
-
| `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e)
72
+
| `Error e -> err_json e
71
73
| `End -> Error "unexpected end in object"
72
74
| `Await -> Error "unexpected await"
73
75
and parse_value_with_lex lex =
···
79
81
| `Lexeme `As -> parse_array []
80
82
| `Lexeme `Os -> parse_object []
81
83
| `Lexeme _ -> Error "unexpected lexeme"
82
-
| `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e)
84
+
| `Error e -> err_json e
83
85
| `End -> Error "unexpected end"
84
86
| `Await -> Error "unexpected await"
85
87
in
+3
-4
tests/test_suite_lib/json_format.ml
+3
-4
tests/test_suite_lib/json_format.ml
···
21
21
| '\x08' -> Buffer.add_string buf "\\b"
22
22
| '\x0c' -> Buffer.add_string buf "\\f"
23
23
| c when Char.code c < 32 ->
24
-
Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c))
24
+
Buffer.add_string buf (Fmt.str "\\u%04x" (Char.code c))
25
25
| c -> Buffer.add_char buf c)
26
26
s;
27
27
Buffer.add_char buf '"';
···
37
37
if Float.is_nan f then "null" (* JSON doesn't support NaN *)
38
38
else if f = Float.infinity || f = Float.neg_infinity then "null"
39
39
(* JSON doesn't support Inf *)
40
-
else if Float.is_integer f && Float.abs f < 1e15 then
41
-
Printf.sprintf "%.0f" f
40
+
else if Float.is_integer f && Float.abs f < 1e15 then Fmt.str "%.0f" f
42
41
else
43
42
(* Try to match yaml-test-suite's number formatting *)
44
-
let s = Printf.sprintf "%g" f in
43
+
let s = Fmt.str "%g" f in
45
44
(* Ensure we have a decimal point for floats *)
46
45
if
47
46
String.contains s '.' || String.contains s 'e'
+1
-1
tests/test_suite_lib/test_suite_loader.ml
+1
-1
tests/test_suite_lib/test_suite_loader.ml
+2
-1
tests/test_suite_lib/test_suite_loader_eio.ml
+2
-1
tests/test_suite_lib/test_suite_loader_eio.ml
···
13
13
type ctx = Eio.Fs.dir_ty Eio.Path.t
14
14
15
15
let read_file fs path =
16
-
try Some (Eio.Path.load Eio.Path.(fs / path)) with _ -> None
16
+
try Some (Eio.Path.load Eio.Path.(fs / path))
17
+
with Eio.Io _ | Not_found -> None
17
18
18
19
let file_exists fs path =
19
20
match Eio.Path.kind ~follow:true Eio.Path.(fs / path) with
+1
-1
tests/test_suite_lib/test_suite_loader_generic.ml
+1
-1
tests/test_suite_lib/test_suite_loader_generic.ml
···
103
103
List.filter_map
104
104
(fun variant ->
105
105
let variant_path = Filename.concat dir_path variant in
106
-
let variant_id = Printf.sprintf "%s:%s" test_id variant in
106
+
let variant_id = Fmt.str "%s:%s" test_id variant in
107
107
load_test_dir ctx variant_id variant_path)
108
108
variants
109
109
else
+4
-5
tests/test_suite_lib/tree_format.ml
+4
-5
tests/test_suite_lib/tree_format.ml
···
46
46
let anchor_str = match anchor with Some a -> " &" ^ a | None -> "" in
47
47
let tag_str = match tag with Some t -> " <" ^ t ^ ">" | None -> "" in
48
48
let flow_str = match style with `Flow -> " {}" | _ -> "" in
49
-
Printf.sprintf "+MAP%s%s%s" flow_str anchor_str tag_str
49
+
Fmt.str "+MAP%s%s%s" flow_str anchor_str tag_str
50
50
| Event.Mapping_end -> "-MAP"
51
51
| Event.Sequence_start { anchor; tag; style; _ } ->
52
52
let anchor_str = match anchor with Some a -> " &" ^ a | None -> "" in
53
53
let tag_str = match tag with Some t -> " <" ^ t ^ ">" | None -> "" in
54
54
let flow_str = match style with `Flow -> " []" | _ -> "" in
55
-
Printf.sprintf "+SEQ%s%s%s" flow_str anchor_str tag_str
55
+
Fmt.str "+SEQ%s%s%s" flow_str anchor_str tag_str
56
56
| Event.Sequence_end -> "-SEQ"
57
57
| Event.Scalar { anchor; tag; value; style; _ } ->
58
58
let anchor_str = match anchor with Some a -> " &" ^ a | None -> "" in
59
59
let tag_str = match tag with Some t -> " <" ^ t ^ ">" | None -> "" in
60
60
let style_c = style_char style in
61
-
Printf.sprintf "=VAL%s%s %c%s" anchor_str tag_str style_c
62
-
(escape_string value)
63
-
| Event.Alias { anchor } -> Printf.sprintf "=ALI *%s" anchor
61
+
Fmt.str "=VAL%s%s %c%s" anchor_str tag_str style_c (escape_string value)
62
+
| Event.Alias { anchor } -> Fmt.str "=ALI *%s" anchor
64
63
65
64
let of_spanned_events events =
66
65
let buf = Buffer.create 256 in
+25
-32
tests/test_yamlrw.ml
+25
-32
tests/test_yamlrw.ml
···
153
153
| `O [ ("a", `Float 1.0); ("b", `Float 2.0) ] -> ()
154
154
| _ -> Alcotest.fail "expected flow mapping {a: 1, b: 2}"
155
155
156
-
let test_parse_flow_mapping_trailing_comma () =
156
+
let test_flow_map_trailing_comma () =
157
157
let result = of_string "{ a: 1, }" in
158
158
match result with
159
159
| `O [ ("a", `Float 1.0) ] -> ()
···
175
175
("parse nested", `Quick, test_parse_nested);
176
176
("parse flow sequence", `Quick, test_parse_flow_sequence);
177
177
("parse flow mapping", `Quick, test_parse_flow_mapping);
178
-
( "flow mapping trailing comma",
179
-
`Quick,
180
-
test_parse_flow_mapping_trailing_comma );
178
+
("flow mapping trailing comma", `Quick, test_flow_map_trailing_comma);
181
179
]
182
180
183
181
(** Emitter tests *)
···
279
277
This was a bug where write_scalar would add a trailing newline for block
280
278
scalars, and then the caller would also add a newline, creating a blank line
281
279
between the value and the next key. *)
282
-
let test_block_scalar_no_double_newline () =
280
+
let test_block_scalar_no_newline () =
283
281
(* Create a value that will use folded style due to length > 80 chars,
284
282
or explicitly use events to force block scalar style *)
285
-
let emitter = Emitter.create () in
283
+
let emitter = Emitter.v () in
286
284
Emitter.emit emitter (Event.Stream_start { encoding = `Utf8 });
287
285
Emitter.emit emitter
288
286
(Event.Document_start { version = None; implicit = true });
···
354
352
| _ ->
355
353
Alcotest.fail ("expected mapping with url and next keys, got: " ^ result)
356
354
357
-
let test_literal_block_no_double_newline () =
358
-
let emitter = Emitter.create () in
355
+
let test_literal_block_no_newline () =
356
+
let emitter = Emitter.v () in
359
357
Emitter.emit emitter (Event.Stream_start { encoding = `Utf8 });
360
358
Emitter.emit emitter
361
359
(Event.Document_start { version = None; implicit = true });
···
417
415
[
418
416
("literal block", `Quick, test_literal_block);
419
417
("folded block", `Quick, test_folded_block);
420
-
( "folded block no double newline",
421
-
`Quick,
422
-
test_block_scalar_no_double_newline );
423
-
( "literal block no double newline",
424
-
`Quick,
425
-
test_literal_block_no_double_newline );
418
+
("folded block no double newline", `Quick, test_block_scalar_no_newline);
419
+
("literal block no double newline", `Quick, test_literal_block_no_newline);
426
420
]
427
421
428
422
(** Error handling tests *)
···
545
539
match result with
546
540
| `O map -> (
547
541
let pairs = Mapping.members map in
548
-
match List.assoc_opt (`Scalar (Scalar.make "b")) pairs with
542
+
match List.assoc_opt (`Scalar (Scalar.v "b")) pairs with
549
543
| Some (`Alias "anchor") -> ()
550
544
| _ -> Alcotest.fail "expected alias to be preserved")
551
545
| _ -> Alcotest.fail "expected mapping"
···
643
637
644
638
(* Test that bare "inf", "nan", "infinity" are NOT parsed as floats
645
639
(ocaml-yaml issue - OCaml's Float.of_string accepts these but YAML doesn't) *)
646
-
let test_bare_inf_nan_are_strings () =
640
+
let test_bare_inf_nan_strings () =
647
641
let inf_result = of_string "inf" in
648
642
(match inf_result with
649
643
| `String "inf" -> ()
···
701
695
( "parse special floats (.inf, -.inf, .nan)",
702
696
`Quick,
703
697
test_parse_special_floats );
704
-
("bare inf/nan/infinity are strings", `Quick, test_bare_inf_nan_are_strings);
698
+
("bare inf/nan/infinity are strings", `Quick, test_bare_inf_nan_strings);
705
699
("quoted scalars preserved as strings", `Quick, test_quoted_scalar_preserved);
706
700
("complex roundtrip preserves types", `Quick, test_complex_roundtrip);
707
701
]
708
702
709
-
(** Run all tests *)
710
-
711
-
let () =
712
-
Alcotest.run "yamlrw"
713
-
[
714
-
("scanner", scanner_tests);
715
-
("parser", parser_tests);
716
-
("value", value_tests);
717
-
("emitter", emitter_tests);
718
-
("yaml", yaml_tests);
719
-
("multiline", multiline_tests);
720
-
("errors", error_tests);
721
-
("alias_limits", alias_limit_tests);
722
-
("bugfix_regression", bugfix_regression_tests);
723
-
]
703
+
let suite =
704
+
( "yamlrw",
705
+
List.concat
706
+
[
707
+
scanner_tests;
708
+
parser_tests;
709
+
value_tests;
710
+
emitter_tests;
711
+
yaml_tests;
712
+
multiline_tests;
713
+
error_tests;
714
+
alias_limit_tests;
715
+
bugfix_regression_tests;
716
+
] )