this repo has no description
sync
+5093
+43
yaml/ocaml-yamle/TODO.md
+43
yaml/ocaml-yamle/TODO.md
···
1
+
# Yamle Implementation Progress
2
+
3
+
## Phase 1: Foundation
4
+
- [x] Project structure and dune files
5
+
- [ ] Position module - location tracking
6
+
- [ ] Span module - source ranges
7
+
- [ ] Error module - exception with position info
8
+
- [ ] Encoding module - UTF-8/16 detection
9
+
10
+
## Phase 2: Styles and Input
11
+
- [ ] Scalar_style module
12
+
- [ ] Layout_style module
13
+
- [ ] Chomping module
14
+
- [ ] Input module - character source abstraction
15
+
16
+
## Phase 3: Scanner (Lexer)
17
+
- [ ] Token module - token types
18
+
- [ ] Scanner module - tokenizer with lookahead
19
+
20
+
## Phase 4: Parser
21
+
- [ ] Event module - parser events
22
+
- [ ] Parser module - state machine
23
+
24
+
## Phase 5: Data Structures
25
+
- [ ] Value module - JSON-compatible representation
26
+
- [ ] Tag module - YAML tags
27
+
- [ ] Scalar module - scalar with metadata
28
+
- [ ] Sequence module - sequence with metadata
29
+
- [ ] Mapping module - mapping with metadata
30
+
- [ ] Yaml module - full YAML representation
31
+
- [ ] Document module - document wrapper
32
+
33
+
## Phase 6: Loader and Emitter
34
+
- [ ] Loader module - events to data structures
35
+
- [ ] Emitter module - data structures to YAML string
36
+
37
+
## Phase 7: Top-Level API
38
+
- [ ] Yamle module - main API
39
+
- [ ] Stream submodule - streaming interface
40
+
41
+
## Phase 8: Testing
42
+
- [ ] Unit tests for each module
43
+
- [ ] Integration tests with YAML test suite
+8
yaml/ocaml-yamle/bin/dune
+8
yaml/ocaml-yamle/bin/dune
+14
yaml/ocaml-yamle/bin/test_emit.ml
+14
yaml/ocaml-yamle/bin/test_emit.ml
···
1
+
let () =
2
+
let yaml = {|
3
+
name: Alice
4
+
age: 30
5
+
hobbies:
6
+
- reading
7
+
- coding
8
+
|} in
9
+
let v = Yamle.of_string yaml in
10
+
print_endline "=== Using to_string (YAML output) ===";
11
+
print_endline (Yamle.to_string v);
12
+
print_endline "";
13
+
print_endline "=== Using pp (JSON-like) ===";
14
+
Format.printf "%a@." Yamle.pp v
+105
yaml/ocaml-yamle/bin/yamlcat.ml
+105
yaml/ocaml-yamle/bin/yamlcat.ml
···
1
+
(** yamlcat - parse and reprint YAML files *)
2
+
3
+
let usage () =
4
+
Printf.eprintf "Usage: %s [OPTIONS] [FILE...]\n" Sys.argv.(0);
5
+
Printf.eprintf "\n";
6
+
Printf.eprintf "Parse YAML files and reprint them.\n";
7
+
Printf.eprintf "If no files are given, reads from stdin.\n";
8
+
Printf.eprintf "\n";
9
+
Printf.eprintf "Options:\n";
10
+
Printf.eprintf " --json Output as JSON format\n";
11
+
Printf.eprintf " --flow Output YAML in flow style\n";
12
+
Printf.eprintf " --debug Output internal representation (for debugging)\n";
13
+
Printf.eprintf " --help Show this help message\n";
14
+
exit 1
15
+
16
+
type output_format = Yaml | Json | Flow | Debug
17
+
18
+
let rec json_to_string buf (v : Yamle.value) =
19
+
match v with
20
+
| `Null -> Buffer.add_string buf "null"
21
+
| `Bool b -> Buffer.add_string buf (if b then "true" else "false")
22
+
| `Float f ->
23
+
if Float.is_integer f && Float.abs f < 1e15 then
24
+
Buffer.add_string buf (Printf.sprintf "%.0f" f)
25
+
else
26
+
Buffer.add_string buf (Printf.sprintf "%g" f)
27
+
| `String s -> Buffer.add_string buf (Printf.sprintf "%S" s)
28
+
| `A items ->
29
+
Buffer.add_char buf '[';
30
+
List.iteri (fun i item ->
31
+
if i > 0 then Buffer.add_string buf ", ";
32
+
json_to_string buf item
33
+
) items;
34
+
Buffer.add_char buf ']'
35
+
| `O pairs ->
36
+
Buffer.add_char buf '{';
37
+
List.iteri (fun i (k, v) ->
38
+
if i > 0 then Buffer.add_string buf ", ";
39
+
Buffer.add_string buf (Printf.sprintf "%S: " k);
40
+
json_to_string buf v
41
+
) pairs;
42
+
Buffer.add_char buf '}'
43
+
44
+
let value_to_json v =
45
+
let buf = Buffer.create 256 in
46
+
json_to_string buf v;
47
+
Buffer.contents buf
48
+
49
+
let process_string ~format content =
50
+
try
51
+
match format with
52
+
| Yaml ->
53
+
let value = Yamle.of_string content in
54
+
print_string (Yamle.to_string value)
55
+
| Flow ->
56
+
let value = Yamle.of_string content in
57
+
print_string (Yamle.to_string ~layout_style:Yamle.Layout_style.Flow value)
58
+
| Json ->
59
+
let value = Yamle.of_string content in
60
+
print_endline (value_to_json value)
61
+
| Debug ->
62
+
let yaml = Yamle.yaml_of_string content in
63
+
Format.printf "%a@." Yamle.pp_yaml yaml
64
+
with
65
+
| Yamle.Yamle_error e ->
66
+
Printf.eprintf "Error: %s\n" (Yamle.Error.to_string e);
67
+
exit 1
68
+
69
+
let process_file ~format filename =
70
+
let content =
71
+
if filename = "-" then
72
+
In_channel.input_all In_channel.stdin
73
+
else
74
+
In_channel.with_open_text filename In_channel.input_all
75
+
in
76
+
process_string ~format content
77
+
78
+
let () =
79
+
let files = ref [] in
80
+
let format = ref Yaml in
81
+
let show_help = ref false in
82
+
83
+
(* Parse arguments *)
84
+
let args = Array.to_list Sys.argv |> List.tl in
85
+
List.iter (fun arg ->
86
+
match arg with
87
+
| "--help" | "-h" -> show_help := true
88
+
| "--json" -> format := Json
89
+
| "--flow" -> format := Flow
90
+
| "--debug" -> format := Debug
91
+
| s when String.length s > 0 && s.[0] = '-' ->
92
+
Printf.eprintf "Unknown option: %s\n" s;
93
+
usage ()
94
+
| filename -> files := filename :: !files
95
+
) args;
96
+
97
+
if !show_help then usage ();
98
+
99
+
let files = List.rev !files in
100
+
101
+
if files = [] then
102
+
(* Read from stdin *)
103
+
process_file ~format:!format "-"
104
+
else
105
+
List.iter (process_file ~format:!format) files
+19
yaml/ocaml-yamle/dune-project
+19
yaml/ocaml-yamle/dune-project
···
1
+
(lang dune 3.0)
2
+
(name yamle)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source (github ocaml/yamle))
8
+
(license ISC)
9
+
(authors "Yamle Authors")
10
+
(maintainers "yamle@example.com")
11
+
12
+
(package
13
+
(name yamle)
14
+
(synopsis "Pure OCaml YAML 1.2 parser and emitter")
15
+
(description "A pure OCaml implementation of YAML 1.2 parsing and emission, with no C dependencies.")
16
+
(depends
17
+
(ocaml (>= 4.14.0))
18
+
(dune (>= 3.0))
19
+
(alcotest :with-test)))
+26
yaml/ocaml-yamle/lib/chomping.ml
+26
yaml/ocaml-yamle/lib/chomping.ml
···
1
+
(** Block scalar chomping indicators *)
2
+
3
+
type t =
4
+
| Strip (** Remove final line break and trailing empty lines *)
5
+
| Clip (** Keep final line break, remove trailing empty lines (default) *)
6
+
| Keep (** Keep final line break and trailing empty lines *)
7
+
8
+
let to_string = function
9
+
| Strip -> "strip"
10
+
| Clip -> "clip"
11
+
| Keep -> "keep"
12
+
13
+
let pp fmt t =
14
+
Format.pp_print_string fmt (to_string t)
15
+
16
+
let of_char = function
17
+
| '-' -> Some Strip
18
+
| '+' -> Some Keep
19
+
| _ -> None
20
+
21
+
let to_char = function
22
+
| Strip -> Some '-'
23
+
| Clip -> None
24
+
| Keep -> Some '+'
25
+
26
+
let equal a b = a = b
+54
yaml/ocaml-yamle/lib/document.ml
+54
yaml/ocaml-yamle/lib/document.ml
···
1
+
(** YAML document with directives and content *)
2
+
3
+
type t = {
4
+
version : (int * int) option;
5
+
tags : (string * string) list;
6
+
root : Yaml.t option;
7
+
implicit_start : bool;
8
+
implicit_end : bool;
9
+
}
10
+
11
+
let make
12
+
?(version : (int * int) option)
13
+
?(tags : (string * string) list = [])
14
+
?(implicit_start = true)
15
+
?(implicit_end = true)
16
+
root =
17
+
{ version; tags; root; implicit_start; implicit_end }
18
+
19
+
let version t = t.version
20
+
let tags t = t.tags
21
+
let root t = t.root
22
+
let implicit_start t = t.implicit_start
23
+
let implicit_end t = t.implicit_end
24
+
25
+
let with_version version t = { t with version = Some version }
26
+
let with_tags tags t = { t with tags }
27
+
let with_root root t = { t with root = Some root }
28
+
29
+
let pp fmt t =
30
+
Format.fprintf fmt "@[<v 2>document(@,";
31
+
(match t.version with
32
+
| Some (maj, min) -> Format.fprintf fmt "version=%d.%d,@ " maj min
33
+
| None -> ());
34
+
if t.tags <> [] then begin
35
+
Format.fprintf fmt "tags=[";
36
+
List.iteri (fun i (h, p) ->
37
+
if i > 0 then Format.fprintf fmt ", ";
38
+
Format.fprintf fmt "%s -> %s" h p
39
+
) t.tags;
40
+
Format.fprintf fmt "],@ "
41
+
end;
42
+
Format.fprintf fmt "implicit_start=%b,@ " t.implicit_start;
43
+
Format.fprintf fmt "implicit_end=%b,@ " t.implicit_end;
44
+
(match t.root with
45
+
| Some root -> Format.fprintf fmt "root=%a" Yaml.pp root
46
+
| None -> Format.fprintf fmt "root=<empty>");
47
+
Format.fprintf fmt "@]@,)"
48
+
49
+
let equal a b =
50
+
Option.equal (fun (a1, a2) (b1, b2) -> a1 = b1 && a2 = b2) a.version b.version &&
51
+
List.equal (fun (h1, p1) (h2, p2) -> h1 = h2 && p1 = p2) a.tags b.tags &&
52
+
Option.equal Yaml.equal a.root b.root &&
53
+
a.implicit_start = b.implicit_start &&
54
+
a.implicit_end = b.implicit_end
+26
yaml/ocaml-yamle/lib/dune
+26
yaml/ocaml-yamle/lib/dune
···
1
+
(library
2
+
(name yamle)
3
+
(public_name yamle)
4
+
(modules
5
+
position
6
+
span
7
+
error
8
+
encoding
9
+
scalar_style
10
+
layout_style
11
+
chomping
12
+
input
13
+
token
14
+
scanner
15
+
event
16
+
parser
17
+
value
18
+
tag
19
+
scalar
20
+
sequence
21
+
mapping
22
+
yaml
23
+
document
24
+
loader
25
+
emitter
26
+
yamle))
+701
yaml/ocaml-yamle/lib/emitter.ml
+701
yaml/ocaml-yamle/lib/emitter.ml
···
1
+
(** Emitter - converts YAML data structures to string output *)
2
+
3
+
type config = {
4
+
encoding : Encoding.t;
5
+
scalar_style : Scalar_style.t;
6
+
layout_style : Layout_style.t;
7
+
indent : int;
8
+
width : int;
9
+
canonical : bool;
10
+
}
11
+
12
+
let default_config = {
13
+
encoding = Encoding.Utf8;
14
+
scalar_style = Scalar_style.Any;
15
+
layout_style = Layout_style.Any;
16
+
indent = 2;
17
+
width = 80;
18
+
canonical = false;
19
+
}
20
+
21
+
type state =
22
+
| Initial
23
+
| Stream_started
24
+
| Document_started
25
+
| In_block_sequence of int (* indent level *)
26
+
| In_block_mapping_key of int
27
+
| In_block_mapping_value of int
28
+
| In_block_mapping_first_key of int (* first key after "- ", no indent needed *)
29
+
| In_flow_sequence
30
+
| In_flow_mapping_key
31
+
| In_flow_mapping_value
32
+
| Document_ended
33
+
| Stream_ended
34
+
35
+
type t = {
36
+
config : config;
37
+
buffer : Buffer.t;
38
+
mutable state : state;
39
+
mutable states : state list;
40
+
mutable indent : int;
41
+
mutable flow_level : int;
42
+
mutable need_separator : bool;
43
+
}
44
+
45
+
let create ?(config = default_config) () = {
46
+
config;
47
+
buffer = Buffer.create 1024;
48
+
state = Initial;
49
+
states = [];
50
+
indent = 0;
51
+
flow_level = 0;
52
+
need_separator = false;
53
+
}
54
+
55
+
let contents t = Buffer.contents t.buffer
56
+
57
+
let reset t =
58
+
Buffer.clear t.buffer;
59
+
t.state <- Initial;
60
+
t.states <- [];
61
+
t.indent <- 0;
62
+
t.flow_level <- 0;
63
+
t.need_separator <- false
64
+
65
+
(** Output helpers *)
66
+
67
+
let write t s = Buffer.add_string t.buffer s
68
+
let write_char t c = Buffer.add_char t.buffer c
69
+
70
+
let write_indent t =
71
+
for _ = 1 to t.indent do
72
+
write_char t ' '
73
+
done
74
+
75
+
let write_newline t =
76
+
write_char t '\n'
77
+
78
+
let push_state t s =
79
+
t.states <- t.state :: t.states;
80
+
t.state <- s
81
+
82
+
let pop_state t =
83
+
match t.states with
84
+
| s :: rest ->
85
+
t.state <- s;
86
+
t.states <- rest
87
+
| [] ->
88
+
t.state <- Stream_ended
89
+
90
+
(** Check if string needs quoting *)
91
+
let needs_quoting s =
92
+
if String.length s = 0 then true
93
+
else
94
+
let first = s.[0] in
95
+
(* Check first character *)
96
+
if first = '-' || first = '?' || first = ':' || first = ',' ||
97
+
first = '[' || first = ']' || first = '{' || first = '}' ||
98
+
first = '#' || first = '&' || first = '*' || first = '!' ||
99
+
first = '|' || first = '>' || first = '\'' || first = '"' ||
100
+
first = '%' || first = '@' || first = '`' || first = ' ' then
101
+
true
102
+
else
103
+
(* Check for special values *)
104
+
let lower = String.lowercase_ascii s in
105
+
if lower = "null" || lower = "true" || lower = "false" ||
106
+
lower = "yes" || lower = "no" || lower = "on" || lower = "off" ||
107
+
lower = "~" || lower = ".inf" || lower = "-.inf" || lower = ".nan" then
108
+
true
109
+
else
110
+
(* Check for characters that need quoting *)
111
+
try
112
+
String.iter (fun c ->
113
+
if c = ':' || c = '#' || c = '\n' || c = '\r' then
114
+
raise Exit
115
+
) s;
116
+
(* Check if it looks like a number *)
117
+
(try ignore (Float.of_string s); true with _ -> false)
118
+
with Exit -> true
119
+
120
+
(** Check if string contains characters requiring double quotes *)
121
+
let needs_double_quotes s =
122
+
try
123
+
String.iter (fun c ->
124
+
if c = '\n' || c = '\r' || c = '\t' || c = '\\' ||
125
+
c < ' ' || c = '"' then
126
+
raise Exit
127
+
) s;
128
+
false
129
+
with Exit -> true
130
+
131
+
(** Write scalar with appropriate quoting *)
132
+
let write_scalar t ?(style = Scalar_style.Any) value =
133
+
let effective_style =
134
+
if style = Scalar_style.Any then
135
+
if needs_double_quotes value then Scalar_style.Double_quoted
136
+
else if needs_quoting value then Scalar_style.Single_quoted
137
+
else Scalar_style.Plain
138
+
else style
139
+
in
140
+
match effective_style with
141
+
| Scalar_style.Plain | Scalar_style.Any ->
142
+
write t value
143
+
144
+
| Scalar_style.Single_quoted ->
145
+
write_char t '\'';
146
+
String.iter (fun c ->
147
+
if c = '\'' then write t "''"
148
+
else write_char t c
149
+
) value;
150
+
write_char t '\''
151
+
152
+
| Scalar_style.Double_quoted ->
153
+
write_char t '"';
154
+
String.iter (fun c ->
155
+
match c with
156
+
| '"' -> write t "\\\""
157
+
| '\\' -> write t "\\\\"
158
+
| '\n' -> write t "\\n"
159
+
| '\r' -> write t "\\r"
160
+
| '\t' -> write t "\\t"
161
+
| c when c < ' ' -> write t (Printf.sprintf "\\x%02x" (Char.code c))
162
+
| c -> write_char t c
163
+
) value;
164
+
write_char t '"'
165
+
166
+
| Scalar_style.Literal ->
167
+
write t "|";
168
+
write_newline t;
169
+
let lines = String.split_on_char '\n' value in
170
+
List.iter (fun line ->
171
+
write_indent t;
172
+
write t line;
173
+
write_newline t
174
+
) lines
175
+
176
+
| Scalar_style.Folded ->
177
+
write t ">";
178
+
write_newline t;
179
+
let lines = String.split_on_char '\n' value in
180
+
List.iter (fun line ->
181
+
write_indent t;
182
+
write t line;
183
+
write_newline t
184
+
) lines
185
+
186
+
(** Write anchor if present *)
187
+
let write_anchor t anchor =
188
+
match anchor with
189
+
| Some name ->
190
+
write_char t '&';
191
+
write t name;
192
+
write_char t ' '
193
+
| None -> ()
194
+
195
+
(** Write tag if present and not implicit *)
196
+
let write_tag t ~implicit tag =
197
+
if not implicit then
198
+
match tag with
199
+
| Some tag_str ->
200
+
write_char t '!';
201
+
write t tag_str;
202
+
write_char t ' '
203
+
| None -> ()
204
+
205
+
(** Emit events *)
206
+
207
+
let emit t (ev : Event.t) =
208
+
match ev with
209
+
| Event.Stream_start _ ->
210
+
t.state <- Stream_started
211
+
212
+
| Event.Stream_end ->
213
+
t.state <- Stream_ended
214
+
215
+
| Event.Document_start { version; implicit } ->
216
+
if not implicit then begin
217
+
(match version with
218
+
| Some (maj, min) ->
219
+
write t (Printf.sprintf "%%YAML %d.%d\n" maj min)
220
+
| None -> ());
221
+
write t "---";
222
+
write_newline t
223
+
end;
224
+
t.state <- Document_started
225
+
226
+
| Event.Document_end { implicit } ->
227
+
if not implicit then begin
228
+
write t "...";
229
+
write_newline t
230
+
end;
231
+
t.state <- Document_ended
232
+
233
+
| Event.Alias { anchor } ->
234
+
if t.flow_level > 0 then begin
235
+
if t.need_separator then write t ", ";
236
+
t.need_separator <- true;
237
+
write_char t '*';
238
+
write t anchor
239
+
end else begin
240
+
(match t.state with
241
+
| In_block_sequence _ ->
242
+
write_indent t;
243
+
write t "- *";
244
+
write t anchor;
245
+
write_newline t
246
+
| In_block_mapping_key _ ->
247
+
write_indent t;
248
+
write_char t '*';
249
+
write t anchor;
250
+
write t ": ";
251
+
t.state <- In_block_mapping_value t.indent
252
+
| In_block_mapping_value indent ->
253
+
write_char t '*';
254
+
write t anchor;
255
+
write_newline t;
256
+
t.state <- In_block_mapping_key indent
257
+
| _ ->
258
+
write_char t '*';
259
+
write t anchor;
260
+
write_newline t)
261
+
end
262
+
263
+
| Event.Scalar { anchor; tag; value; plain_implicit; style; _ } ->
264
+
if t.flow_level > 0 then begin
265
+
(match t.state with
266
+
| In_flow_mapping_key ->
267
+
if t.need_separator then write t ", ";
268
+
write_anchor t anchor;
269
+
write_tag t ~implicit:plain_implicit tag;
270
+
write_scalar t ~style value;
271
+
write t ": ";
272
+
t.need_separator <- false;
273
+
t.state <- In_flow_mapping_value
274
+
| In_flow_mapping_value ->
275
+
write_anchor t anchor;
276
+
write_tag t ~implicit:plain_implicit tag;
277
+
write_scalar t ~style value;
278
+
t.need_separator <- true;
279
+
t.state <- In_flow_mapping_key
280
+
| _ ->
281
+
if t.need_separator then write t ", ";
282
+
t.need_separator <- true;
283
+
write_anchor t anchor;
284
+
write_tag t ~implicit:plain_implicit tag;
285
+
write_scalar t ~style value)
286
+
end else begin
287
+
match t.state with
288
+
| In_block_sequence _ ->
289
+
write_indent t;
290
+
write t "- ";
291
+
write_anchor t anchor;
292
+
write_tag t ~implicit:plain_implicit tag;
293
+
write_scalar t ~style value;
294
+
write_newline t
295
+
| In_block_mapping_key indent ->
296
+
write_indent t;
297
+
write_anchor t anchor;
298
+
write_tag t ~implicit:plain_implicit tag;
299
+
write_scalar t ~style value;
300
+
write_char t ':';
301
+
t.state <- In_block_mapping_value indent
302
+
| In_block_mapping_first_key indent ->
303
+
(* First key after "- ", no indent needed *)
304
+
write_anchor t anchor;
305
+
write_tag t ~implicit:plain_implicit tag;
306
+
write_scalar t ~style value;
307
+
write_char t ':';
308
+
t.state <- In_block_mapping_value indent
309
+
| In_block_mapping_value indent ->
310
+
write_char t ' ';
311
+
write_anchor t anchor;
312
+
write_tag t ~implicit:plain_implicit tag;
313
+
write_scalar t ~style value;
314
+
write_newline t;
315
+
t.state <- In_block_mapping_key indent
316
+
| _ ->
317
+
write_anchor t anchor;
318
+
write_tag t ~implicit:plain_implicit tag;
319
+
write_scalar t ~style value;
320
+
write_newline t
321
+
end
322
+
323
+
| Event.Sequence_start { anchor; tag; implicit; style } ->
324
+
let use_flow = style = Layout_style.Flow || t.flow_level > 0 in
325
+
if t.flow_level > 0 then begin
326
+
(match t.state with
327
+
| In_flow_mapping_key ->
328
+
if t.need_separator then write t ", ";
329
+
write_anchor t anchor;
330
+
write_tag t ~implicit tag;
331
+
write_char t '[';
332
+
t.flow_level <- t.flow_level + 1;
333
+
t.need_separator <- false;
334
+
push_state t In_flow_mapping_value; (* After ] we'll be in value position but sequence handles it *)
335
+
t.state <- In_flow_sequence
336
+
| In_flow_mapping_value ->
337
+
write_anchor t anchor;
338
+
write_tag t ~implicit tag;
339
+
write_char t '[';
340
+
t.flow_level <- t.flow_level + 1;
341
+
t.need_separator <- false;
342
+
push_state t In_flow_mapping_key;
343
+
t.state <- In_flow_sequence
344
+
| _ ->
345
+
if t.need_separator then write t ", ";
346
+
write_anchor t anchor;
347
+
write_tag t ~implicit tag;
348
+
write_char t '[';
349
+
t.flow_level <- t.flow_level + 1;
350
+
t.need_separator <- false;
351
+
push_state t In_flow_sequence)
352
+
end else begin
353
+
match t.state with
354
+
| In_block_sequence _ ->
355
+
write_indent t;
356
+
write t "- ";
357
+
write_anchor t anchor;
358
+
write_tag t ~implicit tag;
359
+
if use_flow then begin
360
+
write_char t '[';
361
+
t.flow_level <- t.flow_level + 1;
362
+
t.need_separator <- false;
363
+
push_state t In_flow_sequence
364
+
end else begin
365
+
write_newline t;
366
+
push_state t (In_block_sequence t.indent);
367
+
t.indent <- t.indent + t.config.indent
368
+
end
369
+
| In_block_mapping_key indent ->
370
+
write_indent t;
371
+
write_anchor t anchor;
372
+
write_tag t ~implicit tag;
373
+
write t ":";
374
+
write_newline t;
375
+
push_state t (In_block_mapping_key indent);
376
+
t.indent <- t.indent + t.config.indent;
377
+
t.state <- In_block_sequence t.indent
378
+
| In_block_mapping_first_key indent ->
379
+
(* First key after "- " with sequence value - no indent *)
380
+
write_anchor t anchor;
381
+
write_tag t ~implicit tag;
382
+
write t ":";
383
+
write_newline t;
384
+
push_state t (In_block_mapping_key indent);
385
+
t.indent <- t.indent + t.config.indent;
386
+
t.state <- In_block_sequence t.indent
387
+
| In_block_mapping_value indent ->
388
+
write_anchor t anchor;
389
+
write_tag t ~implicit tag;
390
+
if use_flow then begin
391
+
write_char t '[';
392
+
t.flow_level <- t.flow_level + 1;
393
+
t.need_separator <- false;
394
+
(* Save key state to return to after flow sequence *)
395
+
t.state <- In_block_mapping_key indent;
396
+
push_state t In_flow_sequence
397
+
end else begin
398
+
write_newline t;
399
+
(* Save key state to return to after nested sequence *)
400
+
t.state <- In_block_mapping_key indent;
401
+
push_state t (In_block_sequence (t.indent + t.config.indent));
402
+
t.indent <- t.indent + t.config.indent
403
+
end
404
+
| _ ->
405
+
write_anchor t anchor;
406
+
write_tag t ~implicit tag;
407
+
if use_flow then begin
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
+
end else begin
413
+
push_state t (In_block_sequence t.indent);
414
+
t.state <- In_block_sequence t.indent
415
+
end
416
+
end
417
+
418
+
| Event.Sequence_end ->
419
+
if t.flow_level > 0 then begin
420
+
write_char t ']';
421
+
t.flow_level <- t.flow_level - 1;
422
+
t.need_separator <- true;
423
+
pop_state t
424
+
end else begin
425
+
t.indent <- t.indent - t.config.indent;
426
+
pop_state t
427
+
end
428
+
429
+
| Event.Mapping_start { anchor; tag; implicit; style } ->
430
+
let use_flow = style = Layout_style.Flow || t.flow_level > 0 in
431
+
if t.flow_level > 0 then begin
432
+
(match t.state with
433
+
| In_flow_mapping_key ->
434
+
if t.need_separator then write t ", ";
435
+
write_anchor t anchor;
436
+
write_tag t ~implicit tag;
437
+
write_char t '{';
438
+
t.flow_level <- t.flow_level + 1;
439
+
t.need_separator <- false;
440
+
push_state t In_flow_mapping_value;
441
+
t.state <- In_flow_mapping_key
442
+
| In_flow_mapping_value ->
443
+
write_anchor t anchor;
444
+
write_tag t ~implicit tag;
445
+
write_char t '{';
446
+
t.flow_level <- t.flow_level + 1;
447
+
t.need_separator <- false;
448
+
push_state t In_flow_mapping_key;
449
+
t.state <- In_flow_mapping_key
450
+
| _ ->
451
+
if t.need_separator then write t ", ";
452
+
write_anchor t anchor;
453
+
write_tag t ~implicit tag;
454
+
write_char t '{';
455
+
t.flow_level <- t.flow_level + 1;
456
+
t.need_separator <- false;
457
+
push_state t In_flow_mapping_key)
458
+
end else begin
459
+
match t.state with
460
+
| In_block_sequence _ ->
461
+
write_indent t;
462
+
write t "- ";
463
+
write_anchor t anchor;
464
+
write_tag t ~implicit tag;
465
+
if use_flow then begin
466
+
write_char t '{';
467
+
t.flow_level <- t.flow_level + 1;
468
+
t.need_separator <- false;
469
+
push_state t In_flow_mapping_key
470
+
end else begin
471
+
(* Don't write newline - first key goes on same line as "- " *)
472
+
push_state t (In_block_sequence t.indent);
473
+
t.indent <- t.indent + t.config.indent;
474
+
t.state <- In_block_mapping_first_key t.indent
475
+
end
476
+
| In_block_mapping_key indent ->
477
+
write_indent t;
478
+
write_anchor t anchor;
479
+
write_tag t ~implicit tag;
480
+
write t ":";
481
+
write_newline t;
482
+
push_state t (In_block_mapping_key indent);
483
+
t.indent <- t.indent + t.config.indent;
484
+
t.state <- In_block_mapping_key t.indent
485
+
| In_block_mapping_first_key indent ->
486
+
(* First key after "- " with mapping value - no indent *)
487
+
write_anchor t anchor;
488
+
write_tag t ~implicit tag;
489
+
write t ":";
490
+
write_newline t;
491
+
push_state t (In_block_mapping_key indent);
492
+
t.indent <- t.indent + t.config.indent;
493
+
t.state <- In_block_mapping_key t.indent
494
+
| In_block_mapping_value indent ->
495
+
write_anchor t anchor;
496
+
write_tag t ~implicit tag;
497
+
if use_flow then begin
498
+
write_char t '{';
499
+
t.flow_level <- t.flow_level + 1;
500
+
t.need_separator <- false;
501
+
(* Save key state to return to after flow mapping *)
502
+
t.state <- In_block_mapping_key indent;
503
+
push_state t In_flow_mapping_key
504
+
end else begin
505
+
write_newline t;
506
+
(* Save key state to return to after nested mapping *)
507
+
t.state <- In_block_mapping_key indent;
508
+
push_state t (In_block_mapping_key (t.indent + t.config.indent));
509
+
t.indent <- t.indent + t.config.indent
510
+
end
511
+
| _ ->
512
+
write_anchor t anchor;
513
+
write_tag t ~implicit tag;
514
+
if use_flow then begin
515
+
write_char t '{';
516
+
t.flow_level <- t.flow_level + 1;
517
+
t.need_separator <- false;
518
+
push_state t In_flow_mapping_key
519
+
end else begin
520
+
push_state t (In_block_mapping_key t.indent);
521
+
t.state <- In_block_mapping_key t.indent
522
+
end
523
+
end
524
+
525
+
| Event.Mapping_end ->
526
+
if t.flow_level > 0 then begin
527
+
write_char t '}';
528
+
t.flow_level <- t.flow_level - 1;
529
+
t.need_separator <- true;
530
+
pop_state t
531
+
end else begin
532
+
t.indent <- t.indent - t.config.indent;
533
+
pop_state t
534
+
end
535
+
536
+
(** High-level emission *)
537
+
538
+
let rec emit_yaml_node t (yaml : Yaml.t) =
539
+
match yaml with
540
+
| `Scalar s ->
541
+
emit t (Event.Scalar {
542
+
anchor = Scalar.anchor s;
543
+
tag = Scalar.tag s;
544
+
value = Scalar.value s;
545
+
plain_implicit = Scalar.plain_implicit s;
546
+
quoted_implicit = Scalar.quoted_implicit s;
547
+
style = Scalar.style s;
548
+
})
549
+
550
+
| `Alias name ->
551
+
emit t (Event.Alias { anchor = name })
552
+
553
+
| `A seq ->
554
+
emit t (Event.Sequence_start {
555
+
anchor = Sequence.anchor seq;
556
+
tag = Sequence.tag seq;
557
+
implicit = Sequence.implicit seq;
558
+
style = Sequence.style seq;
559
+
});
560
+
List.iter (emit_yaml_node t) (Sequence.members seq);
561
+
emit t Event.Sequence_end
562
+
563
+
| `O map ->
564
+
emit t (Event.Mapping_start {
565
+
anchor = Mapping.anchor map;
566
+
tag = Mapping.tag map;
567
+
implicit = Mapping.implicit map;
568
+
style = Mapping.style map;
569
+
});
570
+
List.iter (fun (k, v) ->
571
+
emit_yaml_node t k;
572
+
emit_yaml_node t v
573
+
) (Mapping.members map);
574
+
emit t Event.Mapping_end
575
+
576
+
let emit_yaml t yaml =
577
+
emit t (Event.Stream_start { encoding = t.config.encoding });
578
+
emit t (Event.Document_start { version = None; implicit = true });
579
+
emit_yaml_node t yaml;
580
+
emit t (Event.Document_end { implicit = true });
581
+
emit t Event.Stream_end
582
+
583
+
let rec emit_value_node t (value : Value.t) =
584
+
match value with
585
+
| `Null ->
586
+
emit t (Event.Scalar {
587
+
anchor = None; tag = None;
588
+
value = "null";
589
+
plain_implicit = true; quoted_implicit = false;
590
+
style = Scalar_style.Plain;
591
+
})
592
+
593
+
| `Bool b ->
594
+
emit t (Event.Scalar {
595
+
anchor = None; tag = None;
596
+
value = if b then "true" else "false";
597
+
plain_implicit = true; quoted_implicit = false;
598
+
style = Scalar_style.Plain;
599
+
})
600
+
601
+
| `Float f ->
602
+
let value =
603
+
match Float.classify_float f with
604
+
| FP_nan -> ".nan"
605
+
| FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
606
+
| _ ->
607
+
if Float.is_integer f && Float.abs f < 1e15 then
608
+
Printf.sprintf "%.0f" f
609
+
else
610
+
Printf.sprintf "%g" f
611
+
in
612
+
emit t (Event.Scalar {
613
+
anchor = None; tag = None;
614
+
value;
615
+
plain_implicit = true; quoted_implicit = false;
616
+
style = Scalar_style.Plain;
617
+
})
618
+
619
+
| `String s ->
620
+
let style =
621
+
if needs_double_quotes s then Scalar_style.Double_quoted
622
+
else if needs_quoting s then Scalar_style.Single_quoted
623
+
else Scalar_style.Plain
624
+
in
625
+
emit t (Event.Scalar {
626
+
anchor = None; tag = None;
627
+
value = s;
628
+
plain_implicit = style = Scalar_style.Plain;
629
+
quoted_implicit = style <> Scalar_style.Plain;
630
+
style;
631
+
})
632
+
633
+
| `A items ->
634
+
let style =
635
+
if t.config.layout_style = Layout_style.Flow then Layout_style.Flow
636
+
else Layout_style.Block
637
+
in
638
+
emit t (Event.Sequence_start {
639
+
anchor = None; tag = None;
640
+
implicit = true;
641
+
style;
642
+
});
643
+
List.iter (emit_value_node t) items;
644
+
emit t Event.Sequence_end
645
+
646
+
| `O pairs ->
647
+
let style =
648
+
if t.config.layout_style = Layout_style.Flow then Layout_style.Flow
649
+
else Layout_style.Block
650
+
in
651
+
emit t (Event.Mapping_start {
652
+
anchor = None; tag = None;
653
+
implicit = true;
654
+
style;
655
+
});
656
+
List.iter (fun (k, v) ->
657
+
emit t (Event.Scalar {
658
+
anchor = None; tag = None;
659
+
value = k;
660
+
plain_implicit = not (needs_quoting k);
661
+
quoted_implicit = needs_quoting k;
662
+
style = if needs_quoting k then Scalar_style.Double_quoted else Scalar_style.Plain;
663
+
});
664
+
emit_value_node t v
665
+
) pairs;
666
+
emit t Event.Mapping_end
667
+
668
+
let emit_value t value =
669
+
emit t (Event.Stream_start { encoding = t.config.encoding });
670
+
emit t (Event.Document_start { version = None; implicit = true });
671
+
emit_value_node t value;
672
+
emit t (Event.Document_end { implicit = true });
673
+
emit t Event.Stream_end
674
+
675
+
let emit_document t doc =
676
+
emit t (Event.Document_start {
677
+
version = Document.version doc;
678
+
implicit = Document.implicit_start doc;
679
+
});
680
+
(match Document.root doc with
681
+
| Some yaml -> emit_yaml_node t yaml
682
+
| None ->
683
+
emit t (Event.Scalar {
684
+
anchor = None; tag = None;
685
+
value = "";
686
+
plain_implicit = true; quoted_implicit = false;
687
+
style = Scalar_style.Plain;
688
+
}));
689
+
emit t (Event.Document_end { implicit = Document.implicit_end doc })
690
+
691
+
(** Convenience functions *)
692
+
693
+
let value_to_string ?(config = default_config) value =
694
+
let t = create ~config () in
695
+
emit_value t value;
696
+
contents t
697
+
698
+
let yaml_to_string ?(config = default_config) yaml =
699
+
let t = create ~config () in
700
+
emit_yaml t yaml;
701
+
contents t
+54
yaml/ocaml-yamle/lib/encoding.ml
+54
yaml/ocaml-yamle/lib/encoding.ml
···
1
+
(** Character encoding detection and handling *)
2
+
3
+
type t =
4
+
| Utf8
5
+
| Utf16be
6
+
| Utf16le
7
+
| Utf32be
8
+
| Utf32le
9
+
10
+
let to_string = function
11
+
| Utf8 -> "UTF-8"
12
+
| Utf16be -> "UTF-16BE"
13
+
| Utf16le -> "UTF-16LE"
14
+
| Utf32be -> "UTF-32BE"
15
+
| Utf32le -> "UTF-32LE"
16
+
17
+
let pp fmt t =
18
+
Format.pp_print_string fmt (to_string t)
19
+
20
+
(** Detect encoding from BOM or first bytes.
21
+
Returns (encoding, bom_length) *)
22
+
let detect s =
23
+
let len = String.length s in
24
+
if len = 0 then (Utf8, 0)
25
+
else
26
+
let b0 = Char.code s.[0] in
27
+
let b1 = if len > 1 then Char.code s.[1] else 0 in
28
+
let b2 = if len > 2 then Char.code s.[2] else 0 in
29
+
let b3 = if len > 3 then Char.code s.[3] else 0 in
30
+
(* Check for BOM first *)
31
+
if b0 = 0xEF && b1 = 0xBB && b2 = 0xBF then
32
+
(Utf8, 3)
33
+
else if b0 = 0xFE && b1 = 0xFF then
34
+
(Utf16be, 2)
35
+
else if b0 = 0xFF && b1 = 0xFE then
36
+
if b2 = 0x00 && b3 = 0x00 then
37
+
(Utf32le, 4)
38
+
else
39
+
(Utf16le, 2)
40
+
else if b0 = 0x00 && b1 = 0x00 && b2 = 0xFE && b3 = 0xFF then
41
+
(Utf32be, 4)
42
+
(* No BOM - detect from content pattern *)
43
+
else if b0 = 0x00 && b1 = 0x00 && b2 = 0x00 && b3 <> 0x00 then
44
+
(Utf32be, 0)
45
+
else if b0 <> 0x00 && b1 = 0x00 && b2 = 0x00 && b3 = 0x00 then
46
+
(Utf32le, 0)
47
+
else if b0 = 0x00 && b1 <> 0x00 then
48
+
(Utf16be, 0)
49
+
else if b0 <> 0x00 && b1 = 0x00 then
50
+
(Utf16le, 0)
51
+
else
52
+
(Utf8, 0)
53
+
54
+
let equal a b = a = b
+179
yaml/ocaml-yamle/lib/error.ml
+179
yaml/ocaml-yamle/lib/error.ml
···
1
+
(** Error handling with position information *)
2
+
3
+
(** Error classification *)
4
+
type kind =
5
+
(* Scanner errors *)
6
+
| Unexpected_character of char
7
+
| Unexpected_eof
8
+
| Invalid_escape_sequence of string
9
+
| Invalid_unicode_escape of string
10
+
| Invalid_hex_escape of string
11
+
| Invalid_tag of string
12
+
| Invalid_anchor of string
13
+
| Invalid_alias of string
14
+
| Unclosed_single_quote
15
+
| Unclosed_double_quote
16
+
| Unclosed_flow_sequence
17
+
| Unclosed_flow_mapping
18
+
| Invalid_indentation of int * int (** expected, got *)
19
+
| Tab_in_indentation
20
+
| Invalid_block_scalar_header of string
21
+
| Invalid_directive of string
22
+
| Invalid_yaml_version of string
23
+
| Invalid_tag_directive of string
24
+
| Reserved_directive of string
25
+
26
+
(* Parser errors *)
27
+
| Unexpected_token of string
28
+
| Expected_document_start
29
+
| Expected_document_end
30
+
| Expected_block_entry
31
+
| Expected_key
32
+
| Expected_value
33
+
| Expected_node
34
+
| Expected_scalar
35
+
| Expected_sequence_end
36
+
| Expected_mapping_end
37
+
| Duplicate_anchor of string
38
+
| Undefined_alias of string
39
+
| Alias_cycle of string
40
+
| Multiple_documents
41
+
| Mapping_key_too_long
42
+
43
+
(* Loader errors *)
44
+
| Invalid_scalar_conversion of string * string (** value, target type *)
45
+
| Type_mismatch of string * string (** expected, got *)
46
+
| Unresolved_alias of string
47
+
| Key_not_found of string
48
+
49
+
(* Emitter errors *)
50
+
| Invalid_encoding of string
51
+
| Scalar_contains_invalid_chars of string
52
+
| Anchor_not_set
53
+
| Invalid_state of string
54
+
55
+
(* Generic *)
56
+
| Custom of string
57
+
58
+
(** Full error with location *)
59
+
type t = {
60
+
kind : kind;
61
+
span : Span.t option;
62
+
context : string list;
63
+
source : string option;
64
+
}
65
+
66
+
(** The exception raised by yamle *)
67
+
exception Yamle_error of t
68
+
69
+
let () =
70
+
Printexc.register_printer (function
71
+
| Yamle_error e ->
72
+
let loc = match e.span with
73
+
| None -> ""
74
+
| Some span -> " at " ^ Span.to_string span
75
+
in
76
+
Some (Printf.sprintf "Yamle_error: %s%s"
77
+
(match e.kind with Custom s -> s | _ -> "error") loc)
78
+
| _ -> None)
79
+
80
+
let make ?span ?(context=[]) ?source kind =
81
+
{ kind; span; context; source }
82
+
83
+
let raise ?span ?context ?source kind =
84
+
Stdlib.raise (Yamle_error (make ?span ?context ?source kind))
85
+
86
+
let raise_at pos kind =
87
+
let span = Span.point pos in
88
+
raise ~span kind
89
+
90
+
let raise_span span kind =
91
+
raise ~span kind
92
+
93
+
let with_context ctx f =
94
+
try f () with
95
+
| Yamle_error e ->
96
+
Stdlib.raise (Yamle_error { e with context = ctx :: e.context })
97
+
98
+
let kind_to_string = function
99
+
| Unexpected_character c -> Printf.sprintf "unexpected character %C" c
100
+
| Unexpected_eof -> "unexpected end of input"
101
+
| Invalid_escape_sequence s -> Printf.sprintf "invalid escape sequence: %s" s
102
+
| Invalid_unicode_escape s -> Printf.sprintf "invalid unicode escape: %s" s
103
+
| Invalid_hex_escape s -> Printf.sprintf "invalid hex escape: %s" s
104
+
| Invalid_tag s -> Printf.sprintf "invalid tag: %s" s
105
+
| Invalid_anchor s -> Printf.sprintf "invalid anchor: %s" s
106
+
| Invalid_alias s -> Printf.sprintf "invalid alias: %s" s
107
+
| Unclosed_single_quote -> "unclosed single quote"
108
+
| Unclosed_double_quote -> "unclosed double quote"
109
+
| Unclosed_flow_sequence -> "unclosed flow sequence '['"
110
+
| Unclosed_flow_mapping -> "unclosed flow mapping '{'"
111
+
| Invalid_indentation (expected, got) ->
112
+
Printf.sprintf "invalid indentation: expected %d, got %d" expected got
113
+
| Tab_in_indentation -> "tab character in indentation"
114
+
| Invalid_block_scalar_header s ->
115
+
Printf.sprintf "invalid block scalar header: %s" s
116
+
| Invalid_directive s -> Printf.sprintf "invalid directive: %s" s
117
+
| Invalid_yaml_version s -> Printf.sprintf "invalid YAML version: %s" s
118
+
| Invalid_tag_directive s -> Printf.sprintf "invalid TAG directive: %s" s
119
+
| Reserved_directive s -> Printf.sprintf "reserved directive: %s" s
120
+
| Unexpected_token s -> Printf.sprintf "unexpected token: %s" s
121
+
| Expected_document_start -> "expected document start '---'"
122
+
| Expected_document_end -> "expected document end '...'"
123
+
| Expected_block_entry -> "expected block entry '-'"
124
+
| Expected_key -> "expected mapping key"
125
+
| Expected_value -> "expected mapping value"
126
+
| Expected_node -> "expected node"
127
+
| Expected_scalar -> "expected scalar"
128
+
| Expected_sequence_end -> "expected sequence end ']'"
129
+
| Expected_mapping_end -> "expected mapping end '}'"
130
+
| Duplicate_anchor s -> Printf.sprintf "duplicate anchor: &%s" s
131
+
| Undefined_alias s -> Printf.sprintf "undefined alias: *%s" s
132
+
| Alias_cycle s -> Printf.sprintf "alias cycle detected: *%s" s
133
+
| Multiple_documents -> "multiple documents found when single expected"
134
+
| Mapping_key_too_long -> "mapping key too long (max 1024 characters)"
135
+
| Invalid_scalar_conversion (value, typ) ->
136
+
Printf.sprintf "cannot convert %S to %s" value typ
137
+
| Type_mismatch (expected, got) ->
138
+
Printf.sprintf "type mismatch: expected %s, got %s" expected got
139
+
| Unresolved_alias s -> Printf.sprintf "unresolved alias: *%s" s
140
+
| Key_not_found s -> Printf.sprintf "key not found: %s" s
141
+
| Invalid_encoding s -> Printf.sprintf "invalid encoding: %s" s
142
+
| Scalar_contains_invalid_chars s ->
143
+
Printf.sprintf "scalar contains invalid characters: %s" s
144
+
| Anchor_not_set -> "anchor not set"
145
+
| Invalid_state s -> Printf.sprintf "invalid state: %s" s
146
+
| Custom s -> s
147
+
148
+
let to_string t =
149
+
let loc = match t.span with
150
+
| None -> ""
151
+
| Some span -> " at " ^ Span.to_string span
152
+
in
153
+
let ctx = match t.context with
154
+
| [] -> ""
155
+
| ctxs -> " (in " ^ String.concat " > " (List.rev ctxs) ^ ")"
156
+
in
157
+
kind_to_string t.kind ^ loc ^ ctx
158
+
159
+
let pp fmt t =
160
+
Format.fprintf fmt "Yamle error: %s" (to_string t)
161
+
162
+
let extract_line source line_num =
163
+
let lines = String.split_on_char '\n' source in
164
+
if line_num >= 1 && line_num <= List.length lines then
165
+
Some (List.nth lines (line_num - 1))
166
+
else
167
+
None
168
+
169
+
let pp_with_source ~source fmt t =
170
+
pp fmt t;
171
+
match t.span with
172
+
| None -> ()
173
+
| Some span ->
174
+
match extract_line source span.start.line with
175
+
| None -> ()
176
+
| Some line ->
177
+
Format.fprintf fmt "\n %d | %s\n" span.start.line line;
178
+
let padding = String.make (span.start.column - 1) ' ' in
179
+
Format.fprintf fmt " | %s^" padding
+77
yaml/ocaml-yamle/lib/event.ml
+77
yaml/ocaml-yamle/lib/event.ml
···
1
+
(** YAML parser events *)
2
+
3
+
type t =
4
+
| Stream_start of { encoding : Encoding.t }
5
+
| Stream_end
6
+
| Document_start of {
7
+
version : (int * int) option;
8
+
implicit : bool;
9
+
}
10
+
| Document_end of { implicit : bool }
11
+
| Alias of { anchor : string }
12
+
| Scalar of {
13
+
anchor : string option;
14
+
tag : string option;
15
+
value : string;
16
+
plain_implicit : bool;
17
+
quoted_implicit : bool;
18
+
style : Scalar_style.t;
19
+
}
20
+
| Sequence_start of {
21
+
anchor : string option;
22
+
tag : string option;
23
+
implicit : bool;
24
+
style : Layout_style.t;
25
+
}
26
+
| Sequence_end
27
+
| Mapping_start of {
28
+
anchor : string option;
29
+
tag : string option;
30
+
implicit : bool;
31
+
style : Layout_style.t;
32
+
}
33
+
| Mapping_end
34
+
35
+
type spanned = {
36
+
event : t;
37
+
span : Span.t;
38
+
}
39
+
40
+
let pp fmt = function
41
+
| Stream_start { encoding } ->
42
+
Format.fprintf fmt "stream-start(%a)" Encoding.pp encoding
43
+
| Stream_end ->
44
+
Format.fprintf fmt "stream-end"
45
+
| Document_start { version; implicit } ->
46
+
Format.fprintf fmt "document-start(version=%s, implicit=%b)"
47
+
(match version with None -> "none" | Some (maj, min) -> Printf.sprintf "%d.%d" maj min)
48
+
implicit
49
+
| Document_end { implicit } ->
50
+
Format.fprintf fmt "document-end(implicit=%b)" implicit
51
+
| Alias { anchor } ->
52
+
Format.fprintf fmt "alias(%s)" anchor
53
+
| Scalar { anchor; tag; value; style; _ } ->
54
+
Format.fprintf fmt "scalar(anchor=%s, tag=%s, style=%a, value=%S)"
55
+
(Option.value anchor ~default:"none")
56
+
(Option.value tag ~default:"none")
57
+
Scalar_style.pp style
58
+
value
59
+
| Sequence_start { anchor; tag; implicit; style } ->
60
+
Format.fprintf fmt "sequence-start(anchor=%s, tag=%s, implicit=%b, style=%a)"
61
+
(Option.value anchor ~default:"none")
62
+
(Option.value tag ~default:"none")
63
+
implicit
64
+
Layout_style.pp style
65
+
| Sequence_end ->
66
+
Format.fprintf fmt "sequence-end"
67
+
| Mapping_start { anchor; tag; implicit; style } ->
68
+
Format.fprintf fmt "mapping-start(anchor=%s, tag=%s, implicit=%b, style=%a)"
69
+
(Option.value anchor ~default:"none")
70
+
(Option.value tag ~default:"none")
71
+
implicit
72
+
Layout_style.pp style
73
+
| Mapping_end ->
74
+
Format.fprintf fmt "mapping-end"
75
+
76
+
let pp_spanned fmt { event; span } =
77
+
Format.fprintf fmt "%a at %a" pp event Span.pp span
+146
yaml/ocaml-yamle/lib/input.ml
+146
yaml/ocaml-yamle/lib/input.ml
···
1
+
(** Character input source with lookahead *)
2
+
3
+
type t = {
4
+
source : string;
5
+
mutable pos : int; (** Current byte position *)
6
+
mutable position : Position.t; (** Line/column tracking *)
7
+
length : int;
8
+
}
9
+
10
+
let of_string source =
11
+
let encoding, bom_len = Encoding.detect source in
12
+
(* For now, we only support UTF-8. Skip BOM if present. *)
13
+
ignore encoding;
14
+
{
15
+
source;
16
+
pos = bom_len;
17
+
position = Position.initial;
18
+
length = String.length source;
19
+
}
20
+
21
+
let position t = t.position
22
+
23
+
let is_eof t = t.pos >= t.length
24
+
25
+
let peek t =
26
+
if t.pos >= t.length then None
27
+
else Some t.source.[t.pos]
28
+
29
+
let peek_exn t =
30
+
if t.pos >= t.length then
31
+
Error.raise_at t.position Unexpected_eof
32
+
else
33
+
t.source.[t.pos]
34
+
35
+
let peek_nth t n =
36
+
let idx = t.pos + n in
37
+
if idx >= t.length then None
38
+
else Some t.source.[idx]
39
+
40
+
let peek_string t n =
41
+
if t.pos + n > t.length then
42
+
String.sub t.source t.pos (t.length - t.pos)
43
+
else
44
+
String.sub t.source t.pos n
45
+
46
+
let next t =
47
+
if t.pos >= t.length then None
48
+
else begin
49
+
let c = t.source.[t.pos] in
50
+
t.pos <- t.pos + 1;
51
+
t.position <- Position.advance_char c t.position;
52
+
Some c
53
+
end
54
+
55
+
let next_exn t =
56
+
match next t with
57
+
| Some c -> c
58
+
| None -> Error.raise_at t.position Unexpected_eof
59
+
60
+
let skip t n =
61
+
for _ = 1 to n do
62
+
ignore (next t)
63
+
done
64
+
65
+
let skip_while t pred =
66
+
while not (is_eof t) && pred (Option.get (peek t)) do
67
+
ignore (next t)
68
+
done
69
+
70
+
(** Character classification *)
71
+
72
+
let is_break c = c = '\n' || c = '\r'
73
+
74
+
let is_blank c = c = ' ' || c = '\t'
75
+
76
+
let is_whitespace c = is_break c || is_blank c
77
+
78
+
let is_digit c = c >= '0' && c <= '9'
79
+
80
+
let is_hex c =
81
+
(c >= '0' && c <= '9') ||
82
+
(c >= 'a' && c <= 'f') ||
83
+
(c >= 'A' && c <= 'F')
84
+
85
+
let is_alpha c =
86
+
(c >= 'a' && c <= 'z') ||
87
+
(c >= 'A' && c <= 'Z')
88
+
89
+
let is_alnum c = is_alpha c || is_digit c
90
+
91
+
(** YAML indicator characters *)
92
+
let is_indicator c =
93
+
match c with
94
+
| '-' | '?' | ':' | ',' | '[' | ']' | '{' | '}'
95
+
| '#' | '&' | '*' | '!' | '|' | '>' | '\'' | '"'
96
+
| '%' | '@' | '`' -> true
97
+
| _ -> false
98
+
99
+
(** Characters that cannot start a plain scalar *)
100
+
let is_flow_indicator c =
101
+
match c with
102
+
| ',' | '[' | ']' | '{' | '}' -> true
103
+
| _ -> false
104
+
105
+
(** Check if next char satisfies predicate *)
106
+
let next_is pred t =
107
+
match peek t with
108
+
| None -> false
109
+
| Some c -> pred c
110
+
111
+
let next_is_break t = next_is is_break t
112
+
let next_is_blank t = next_is is_blank t
113
+
let next_is_whitespace t = next_is is_whitespace t
114
+
let next_is_digit t = next_is is_digit t
115
+
let next_is_hex t = next_is is_hex t
116
+
let next_is_alpha t = next_is is_alpha t
117
+
let next_is_indicator t = next_is is_indicator t
118
+
119
+
(** Check if at document boundary (--- or ...) *)
120
+
let at_document_boundary t =
121
+
if t.position.column <> 1 then false
122
+
else
123
+
let s = peek_string t 4 in
124
+
let prefix = String.sub s 0 (min 3 (String.length s)) in
125
+
(prefix = "---" || prefix = "...") &&
126
+
(String.length s < 4 || is_whitespace s.[3] || String.length s = 3)
127
+
128
+
(** Consume line break, handling \r\n as single break *)
129
+
let consume_break t =
130
+
match peek t with
131
+
| Some '\r' ->
132
+
ignore (next t);
133
+
(match peek t with
134
+
| Some '\n' -> ignore (next t)
135
+
| _ -> ())
136
+
| Some '\n' ->
137
+
ignore (next t)
138
+
| _ -> ()
139
+
140
+
(** Get remaining content from current position *)
141
+
let remaining t =
142
+
if t.pos >= t.length then ""
143
+
else String.sub t.source t.pos (t.length - t.pos)
144
+
145
+
(** Mark current position for span creation *)
146
+
let mark t = t.position
+24
yaml/ocaml-yamle/lib/layout_style.ml
+24
yaml/ocaml-yamle/lib/layout_style.ml
···
1
+
(** Collection layout styles *)
2
+
3
+
type t =
4
+
| Any (** Let emitter choose *)
5
+
| Block (** Indentation-based *)
6
+
| Flow (** Inline with brackets *)
7
+
8
+
let to_string = function
9
+
| Any -> "any"
10
+
| Block -> "block"
11
+
| Flow -> "flow"
12
+
13
+
let pp fmt t =
14
+
Format.pp_print_string fmt (to_string t)
15
+
16
+
let equal a b = a = b
17
+
18
+
let compare a b =
19
+
let to_int = function
20
+
| Any -> 0
21
+
| Block -> 1
22
+
| Flow -> 2
23
+
in
24
+
Int.compare (to_int a) (to_int b)
+243
yaml/ocaml-yamle/lib/loader.ml
+243
yaml/ocaml-yamle/lib/loader.ml
···
1
+
(** Loader - converts parser events to YAML data structures *)
2
+
3
+
(** Stack frame for building nested structures *)
4
+
type frame =
5
+
| Sequence_frame of {
6
+
anchor : string option;
7
+
tag : string option;
8
+
implicit : bool;
9
+
style : Layout_style.t;
10
+
items : Yaml.t list;
11
+
}
12
+
| Mapping_frame of {
13
+
anchor : string option;
14
+
tag : string option;
15
+
implicit : bool;
16
+
style : Layout_style.t;
17
+
pairs : (Yaml.t * Yaml.t) list;
18
+
pending_key : Yaml.t option;
19
+
}
20
+
21
+
type state = {
22
+
mutable stack : frame list;
23
+
mutable current : Yaml.t option;
24
+
mutable documents : Document.t list;
25
+
mutable doc_version : (int * int) option;
26
+
mutable doc_implicit_start : bool;
27
+
}
28
+
29
+
let create_state () = {
30
+
stack = [];
31
+
current = None;
32
+
documents = [];
33
+
doc_version = None;
34
+
doc_implicit_start = true;
35
+
}
36
+
37
+
(** Process a single event *)
38
+
let rec process_event state (ev : Event.spanned) =
39
+
match ev.event with
40
+
| Event.Stream_start _ -> ()
41
+
42
+
| Event.Stream_end -> ()
43
+
44
+
| Event.Document_start { version; implicit } ->
45
+
state.doc_version <- version;
46
+
state.doc_implicit_start <- implicit
47
+
48
+
| Event.Document_end { implicit } ->
49
+
let doc = Document.make
50
+
?version:state.doc_version
51
+
~implicit_start:state.doc_implicit_start
52
+
~implicit_end:implicit
53
+
state.current
54
+
in
55
+
state.documents <- doc :: state.documents;
56
+
state.current <- None;
57
+
state.doc_version <- None;
58
+
state.doc_implicit_start <- true
59
+
60
+
| Event.Alias { anchor } ->
61
+
let node : Yaml.t = `Alias anchor in
62
+
add_node state node
63
+
64
+
| Event.Scalar { anchor; tag; value; plain_implicit; quoted_implicit; style } ->
65
+
let scalar = Scalar.make
66
+
?anchor ?tag
67
+
~plain_implicit ~quoted_implicit
68
+
~style value
69
+
in
70
+
let node : Yaml.t = `Scalar scalar in
71
+
add_node state node
72
+
73
+
| Event.Sequence_start { anchor; tag; implicit; style } ->
74
+
let frame = Sequence_frame {
75
+
anchor; tag; implicit; style;
76
+
items = [];
77
+
} in
78
+
state.stack <- frame :: state.stack
79
+
80
+
| Event.Sequence_end ->
81
+
(match state.stack with
82
+
| Sequence_frame { anchor; tag; implicit; style; items } :: rest ->
83
+
let seq = Sequence.make ?anchor ?tag ~implicit ~style (List.rev items) in
84
+
let node : Yaml.t = `A seq in
85
+
state.stack <- rest;
86
+
add_node state node
87
+
| _ -> Error.raise (Invalid_state "unexpected sequence end"))
88
+
89
+
| Event.Mapping_start { anchor; tag; implicit; style } ->
90
+
let frame = Mapping_frame {
91
+
anchor; tag; implicit; style;
92
+
pairs = [];
93
+
pending_key = None;
94
+
} in
95
+
state.stack <- frame :: state.stack
96
+
97
+
| Event.Mapping_end ->
98
+
(match state.stack with
99
+
| Mapping_frame { anchor; tag; implicit; style; pairs; pending_key = None } :: rest ->
100
+
let map = Mapping.make ?anchor ?tag ~implicit ~style (List.rev pairs) in
101
+
let node : Yaml.t = `O map in
102
+
state.stack <- rest;
103
+
add_node state node
104
+
| Mapping_frame { pending_key = Some _; _ } :: _ ->
105
+
Error.raise (Invalid_state "mapping ended with pending key")
106
+
| _ -> Error.raise (Invalid_state "unexpected mapping end"))
107
+
108
+
(** Add a node to current context *)
109
+
and add_node state node =
110
+
match state.stack with
111
+
| [] ->
112
+
state.current <- Some node
113
+
114
+
| Sequence_frame f :: rest ->
115
+
state.stack <- Sequence_frame { f with items = node :: f.items } :: rest
116
+
117
+
| Mapping_frame f :: rest ->
118
+
(match f.pending_key with
119
+
| None ->
120
+
(* This is a key *)
121
+
state.stack <- Mapping_frame { f with pending_key = Some node } :: rest
122
+
| Some key ->
123
+
(* This is a value *)
124
+
state.stack <- Mapping_frame {
125
+
f with
126
+
pairs = (key, node) :: f.pairs;
127
+
pending_key = None;
128
+
} :: rest)
129
+
130
+
(** Load single document as Value *)
131
+
let value_of_string s =
132
+
let parser = Parser.of_string s in
133
+
let state = create_state () in
134
+
Parser.iter (process_event state) parser;
135
+
match state.documents with
136
+
| [] -> `Null
137
+
| [doc] ->
138
+
(match Document.root doc with
139
+
| None -> `Null
140
+
| Some yaml -> Yaml.to_value yaml)
141
+
| _ -> Error.raise Multiple_documents
142
+
143
+
(** Load single document as Yaml *)
144
+
let yaml_of_string s =
145
+
let parser = Parser.of_string s in
146
+
let state = create_state () in
147
+
Parser.iter (process_event state) parser;
148
+
match state.documents with
149
+
| [] -> `Scalar (Scalar.make "")
150
+
| [doc] ->
151
+
(match Document.root doc with
152
+
| None -> `Scalar (Scalar.make "")
153
+
| Some yaml -> yaml)
154
+
| _ -> Error.raise Multiple_documents
155
+
156
+
(** Load all documents *)
157
+
let documents_of_string s =
158
+
let parser = Parser.of_string s in
159
+
let state = create_state () in
160
+
Parser.iter (process_event state) parser;
161
+
List.rev state.documents
162
+
163
+
(** Load single Value from parser *)
164
+
let load_value parser =
165
+
let state = create_state () in
166
+
let rec loop () =
167
+
match Parser.next parser with
168
+
| None -> None
169
+
| Some ev ->
170
+
process_event state ev;
171
+
match ev.event with
172
+
| Event.Document_end _ ->
173
+
(match state.documents with
174
+
| doc :: _ ->
175
+
state.documents <- [];
176
+
Some (match Document.root doc with
177
+
| None -> `Null
178
+
| Some yaml -> Yaml.to_value yaml)
179
+
| [] -> None)
180
+
| Event.Stream_end -> None
181
+
| _ -> loop ()
182
+
in
183
+
loop ()
184
+
185
+
(** Load single Yaml from parser *)
186
+
let load_yaml parser =
187
+
let state = create_state () in
188
+
let rec loop () =
189
+
match Parser.next parser with
190
+
| None -> None
191
+
| Some ev ->
192
+
process_event state ev;
193
+
match ev.event with
194
+
| Event.Document_end _ ->
195
+
(match state.documents with
196
+
| doc :: _ ->
197
+
state.documents <- [];
198
+
Some (match Document.root doc with
199
+
| None -> `Scalar (Scalar.make "")
200
+
| Some yaml -> yaml)
201
+
| [] -> None)
202
+
| Event.Stream_end -> None
203
+
| _ -> loop ()
204
+
in
205
+
loop ()
206
+
207
+
(** Load single Document from parser *)
208
+
let load_document parser =
209
+
let state = create_state () in
210
+
let rec loop () =
211
+
match Parser.next parser with
212
+
| None -> None
213
+
| Some ev ->
214
+
process_event state ev;
215
+
match ev.event with
216
+
| Event.Document_end _ ->
217
+
(match state.documents with
218
+
| doc :: _ ->
219
+
state.documents <- [];
220
+
Some doc
221
+
| [] -> None)
222
+
| Event.Stream_end -> None
223
+
| _ -> loop ()
224
+
in
225
+
loop ()
226
+
227
+
(** Iterate over documents *)
228
+
let iter_documents f parser =
229
+
let rec loop () =
230
+
match load_document parser with
231
+
| None -> ()
232
+
| Some doc -> f doc; loop ()
233
+
in
234
+
loop ()
235
+
236
+
(** Fold over documents *)
237
+
let fold_documents f init parser =
238
+
let rec loop acc =
239
+
match load_document parser with
240
+
| None -> acc
241
+
| Some doc -> loop (f acc doc)
242
+
in
243
+
loop init
+92
yaml/ocaml-yamle/lib/mapping.ml
+92
yaml/ocaml-yamle/lib/mapping.ml
···
1
+
(** YAML mapping (object) values with metadata *)
2
+
3
+
type ('k, 'v) t = {
4
+
anchor : string option;
5
+
tag : string option;
6
+
implicit : bool;
7
+
style : Layout_style.t;
8
+
members : ('k * 'v) list;
9
+
}
10
+
11
+
let make
12
+
?(anchor : string option)
13
+
?(tag : string option)
14
+
?(implicit = true)
15
+
?(style = Layout_style.Any)
16
+
members =
17
+
{ anchor; tag; implicit; style; members }
18
+
19
+
let members t = t.members
20
+
let anchor t = t.anchor
21
+
let tag t = t.tag
22
+
let implicit t = t.implicit
23
+
let style t = t.style
24
+
25
+
let with_anchor anchor t = { t with anchor = Some anchor }
26
+
let with_tag tag t = { t with tag = Some tag }
27
+
let with_style style t = { t with style }
28
+
29
+
let map_keys f t = { t with members = List.map (fun (k, v) -> (f k, v)) t.members }
30
+
let map_values f t = { t with members = List.map (fun (k, v) -> (k, f v)) t.members }
31
+
let map f t = { t with members = List.map (fun (k, v) -> f k v) t.members }
32
+
33
+
let length t = List.length t.members
34
+
35
+
let is_empty t = t.members = []
36
+
37
+
let find pred t =
38
+
match List.find_opt (fun (k, _) -> pred k) t.members with
39
+
| Some (_, v) -> Some v
40
+
| None -> None
41
+
42
+
let find_key pred t =
43
+
List.find_opt (fun (k, _) -> pred k) t.members
44
+
45
+
let mem pred t =
46
+
List.exists (fun (k, _) -> pred k) t.members
47
+
48
+
let keys t = List.map fst t.members
49
+
50
+
let values t = List.map snd t.members
51
+
52
+
let iter f t = List.iter (fun (k, v) -> f k v) t.members
53
+
54
+
let fold f init t = List.fold_left (fun acc (k, v) -> f acc k v) init t.members
55
+
56
+
let pp pp_key pp_val fmt t =
57
+
Format.fprintf fmt "@[<hv 2>mapping(@,";
58
+
(match t.anchor with
59
+
| Some a -> Format.fprintf fmt "anchor=%s,@ " a
60
+
| None -> ());
61
+
(match t.tag with
62
+
| Some tag -> Format.fprintf fmt "tag=%s,@ " tag
63
+
| None -> ());
64
+
Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style;
65
+
Format.fprintf fmt "members={@,";
66
+
List.iteri (fun i (k, v) ->
67
+
if i > 0 then Format.fprintf fmt ",@ ";
68
+
Format.fprintf fmt "@[<hv 2>%a:@ %a@]" pp_key k pp_val v
69
+
) t.members;
70
+
Format.fprintf fmt "@]@,})"
71
+
72
+
let equal eq_k eq_v a b =
73
+
Option.equal String.equal a.anchor b.anchor &&
74
+
Option.equal String.equal a.tag b.tag &&
75
+
a.implicit = b.implicit &&
76
+
Layout_style.equal a.style b.style &&
77
+
List.equal (fun (k1, v1) (k2, v2) -> eq_k k1 k2 && eq_v v1 v2) a.members b.members
78
+
79
+
let compare cmp_k cmp_v a b =
80
+
let c = Option.compare String.compare a.anchor b.anchor in
81
+
if c <> 0 then c else
82
+
let c = Option.compare String.compare a.tag b.tag in
83
+
if c <> 0 then c else
84
+
let c = Bool.compare a.implicit b.implicit in
85
+
if c <> 0 then c else
86
+
let c = Layout_style.compare a.style b.style in
87
+
if c <> 0 then c else
88
+
let cmp_pair (k1, v1) (k2, v2) =
89
+
let c = cmp_k k1 k2 in
90
+
if c <> 0 then c else cmp_v v1 v2
91
+
in
92
+
List.compare cmp_pair a.members b.members
+711
yaml/ocaml-yamle/lib/parser.ml
+711
yaml/ocaml-yamle/lib/parser.ml
···
1
+
(** YAML parser - converts tokens to semantic events via state machine *)
2
+
3
+
(** Parser states *)
4
+
type state =
5
+
| Stream_start
6
+
| Implicit_document_start
7
+
| Document_start
8
+
| Document_content
9
+
| Document_end
10
+
| Block_node
11
+
| Block_node_or_indentless_sequence
12
+
| Flow_node
13
+
| Block_sequence_first_entry
14
+
| Block_sequence_entry
15
+
| Indentless_sequence_entry
16
+
| Block_mapping_first_key
17
+
| Block_mapping_key
18
+
| Block_mapping_value
19
+
| Flow_sequence_first_entry
20
+
| Flow_sequence_entry
21
+
| Flow_sequence_entry_mapping_key
22
+
| Flow_sequence_entry_mapping_value
23
+
| Flow_sequence_entry_mapping_end
24
+
| Flow_mapping_first_key
25
+
| Flow_mapping_key
26
+
| Flow_mapping_value
27
+
| Flow_mapping_empty_value
28
+
| End
29
+
30
+
type t = {
31
+
scanner : Scanner.t;
32
+
mutable state : state;
33
+
mutable states : state list; (** State stack *)
34
+
mutable marks : Span.t list; (** Mark stack for span tracking *)
35
+
mutable version : (int * int) option;
36
+
mutable tag_directives : (string * string) list;
37
+
mutable current_token : Token.spanned option;
38
+
mutable finished : bool;
39
+
}
40
+
41
+
let create scanner = {
42
+
scanner;
43
+
state = Stream_start;
44
+
states = [];
45
+
marks = [];
46
+
version = None;
47
+
tag_directives = [
48
+
("!", "!");
49
+
("!!", "tag:yaml.org,2002:");
50
+
];
51
+
current_token = None;
52
+
finished = false;
53
+
}
54
+
55
+
let of_string s = create (Scanner.of_string s)
56
+
57
+
(** Get current token, fetching if needed *)
58
+
let current_token t =
59
+
match t.current_token with
60
+
| Some tok -> tok
61
+
| None ->
62
+
let tok = Scanner.next t.scanner in
63
+
t.current_token <- tok;
64
+
match tok with
65
+
| Some tok -> tok
66
+
| None -> Error.raise Unexpected_eof
67
+
68
+
(** Peek at current token *)
69
+
let peek_token t =
70
+
match t.current_token with
71
+
| Some _ -> t.current_token
72
+
| None ->
73
+
t.current_token <- Scanner.next t.scanner;
74
+
t.current_token
75
+
76
+
(** Skip current token *)
77
+
let skip_token t =
78
+
t.current_token <- None
79
+
80
+
(** Check if current token matches *)
81
+
let check t pred =
82
+
match peek_token t with
83
+
| Some tok -> pred tok.token
84
+
| None -> false
85
+
86
+
(** Check for specific token *)
87
+
let check_token t token_match =
88
+
check t token_match
89
+
90
+
(** Push state onto stack *)
91
+
let push_state t s =
92
+
t.states <- s :: t.states
93
+
94
+
(** Pop state from stack *)
95
+
let pop_state t =
96
+
match t.states with
97
+
| s :: rest ->
98
+
t.states <- rest;
99
+
s
100
+
| [] -> End
101
+
102
+
(** Resolve a tag *)
103
+
let resolve_tag t ~handle ~suffix =
104
+
match List.assoc_opt handle t.tag_directives with
105
+
| Some prefix -> prefix ^ suffix
106
+
| None when handle = "!" -> "!" ^ suffix
107
+
| None -> Error.raise (Invalid_tag (handle ^ suffix))
108
+
109
+
(** Process directives at document start *)
110
+
let process_directives t =
111
+
t.version <- None;
112
+
t.tag_directives <- [("!", "!"); ("!!", "tag:yaml.org,2002:")];
113
+
114
+
while check t (function
115
+
| Token.Version_directive _ | Token.Tag_directive _ -> true
116
+
| _ -> false)
117
+
do
118
+
let tok = current_token t in
119
+
skip_token t;
120
+
match tok.token with
121
+
| Token.Version_directive { major; minor } ->
122
+
if t.version <> None then
123
+
Error.raise_span tok.span (Invalid_yaml_version "duplicate YAML directive");
124
+
t.version <- Some (major, minor)
125
+
| Token.Tag_directive { handle; prefix } ->
126
+
if List.mem_assoc handle t.tag_directives &&
127
+
handle <> "!" && handle <> "!!" then
128
+
Error.raise_span tok.span (Invalid_tag_directive ("duplicate tag handle: " ^ handle));
129
+
t.tag_directives <- (handle, prefix) :: t.tag_directives
130
+
| _ -> ()
131
+
done
132
+
133
+
(** Parse anchor and/or tag properties *)
134
+
let parse_properties t =
135
+
let anchor = ref None in
136
+
let tag = ref None in
137
+
138
+
while check t (function
139
+
| Token.Anchor _ | Token.Tag _ -> true
140
+
| _ -> false)
141
+
do
142
+
let tok = current_token t in
143
+
skip_token t;
144
+
match tok.token with
145
+
| Token.Anchor name ->
146
+
if !anchor <> None then
147
+
Error.raise_span tok.span (Duplicate_anchor name);
148
+
anchor := Some name
149
+
| Token.Tag { handle; suffix } ->
150
+
if !tag <> None then
151
+
Error.raise_span tok.span (Invalid_tag "duplicate tag");
152
+
let resolved =
153
+
if handle = "" && suffix = "" then None
154
+
else if handle = "!" && suffix = "" then Some "!"
155
+
else Some (resolve_tag t ~handle ~suffix)
156
+
in
157
+
tag := resolved
158
+
| _ -> ()
159
+
done;
160
+
(!anchor, !tag)
161
+
162
+
(** Empty scalar event *)
163
+
let empty_scalar_event ~anchor ~tag span =
164
+
Event.Scalar {
165
+
anchor;
166
+
tag;
167
+
value = "";
168
+
plain_implicit = tag = None;
169
+
quoted_implicit = false;
170
+
style = Scalar_style.Plain;
171
+
}, span
172
+
173
+
(** Parse stream start *)
174
+
let parse_stream_start t =
175
+
let tok = current_token t in
176
+
skip_token t;
177
+
match tok.token with
178
+
| Token.Stream_start encoding ->
179
+
t.state <- Implicit_document_start;
180
+
Event.Stream_start { encoding }, tok.span
181
+
| _ ->
182
+
Error.raise_span tok.span (Unexpected_token "expected stream start")
183
+
184
+
(** Parse document start (implicit or explicit) *)
185
+
let parse_document_start t ~implicit =
186
+
process_directives t;
187
+
188
+
if not implicit then begin
189
+
let tok = current_token t in
190
+
match tok.token with
191
+
| Token.Document_start ->
192
+
skip_token t
193
+
| _ ->
194
+
Error.raise_span tok.span Expected_document_start
195
+
end;
196
+
197
+
let span = match peek_token t with
198
+
| Some tok -> tok.span
199
+
| None -> Span.point Position.initial
200
+
in
201
+
202
+
push_state t Document_end;
203
+
t.state <- Document_content;
204
+
Event.Document_start { version = t.version; implicit }, span
205
+
206
+
(** Parse document end *)
207
+
let parse_document_end t =
208
+
let implicit = not (check t (function Token.Document_end -> true | _ -> false)) in
209
+
let span = match peek_token t with
210
+
| Some tok -> tok.span
211
+
| None -> Span.point Position.initial
212
+
in
213
+
214
+
if not implicit then skip_token t;
215
+
216
+
t.state <- Implicit_document_start;
217
+
Event.Document_end { implicit }, span
218
+
219
+
(** Parse node in various contexts *)
220
+
let parse_node t ~block ~indentless =
221
+
let tok = current_token t in
222
+
match tok.token with
223
+
| Token.Alias name ->
224
+
skip_token t;
225
+
t.state <- pop_state t;
226
+
Event.Alias { anchor = name }, tok.span
227
+
228
+
| Token.Anchor _ | Token.Tag _ ->
229
+
let anchor, tag = parse_properties t in
230
+
let tok = current_token t in
231
+
(match tok.token with
232
+
| Token.Block_entry when indentless ->
233
+
t.state <- Indentless_sequence_entry;
234
+
Event.Sequence_start {
235
+
anchor; tag;
236
+
implicit = tag = None;
237
+
style = Layout_style.Block;
238
+
}, tok.span
239
+
240
+
| Token.Block_sequence_start when block ->
241
+
t.state <- Block_sequence_first_entry;
242
+
skip_token t;
243
+
Event.Sequence_start {
244
+
anchor; tag;
245
+
implicit = tag = None;
246
+
style = Layout_style.Block;
247
+
}, tok.span
248
+
249
+
| Token.Block_mapping_start when block ->
250
+
t.state <- Block_mapping_first_key;
251
+
skip_token t;
252
+
Event.Mapping_start {
253
+
anchor; tag;
254
+
implicit = tag = None;
255
+
style = Layout_style.Block;
256
+
}, tok.span
257
+
258
+
| Token.Flow_sequence_start ->
259
+
t.state <- Flow_sequence_first_entry;
260
+
skip_token t;
261
+
Event.Sequence_start {
262
+
anchor; tag;
263
+
implicit = tag = None;
264
+
style = Layout_style.Flow;
265
+
}, tok.span
266
+
267
+
| Token.Flow_mapping_start ->
268
+
t.state <- Flow_mapping_first_key;
269
+
skip_token t;
270
+
Event.Mapping_start {
271
+
anchor; tag;
272
+
implicit = tag = None;
273
+
style = Layout_style.Flow;
274
+
}, tok.span
275
+
276
+
| Token.Scalar { style; value } ->
277
+
skip_token t;
278
+
t.state <- pop_state t;
279
+
let plain_implicit = tag = None && style = Scalar_style.Plain in
280
+
let quoted_implicit = tag = None && style <> Scalar_style.Plain in
281
+
Event.Scalar {
282
+
anchor; tag; value;
283
+
plain_implicit; quoted_implicit; style;
284
+
}, tok.span
285
+
286
+
| _ ->
287
+
(* Empty node *)
288
+
t.state <- pop_state t;
289
+
empty_scalar_event ~anchor ~tag tok.span)
290
+
291
+
| Token.Block_sequence_start when block ->
292
+
t.state <- Block_sequence_first_entry;
293
+
skip_token t;
294
+
Event.Sequence_start {
295
+
anchor = None; tag = None;
296
+
implicit = true;
297
+
style = Layout_style.Block;
298
+
}, tok.span
299
+
300
+
| Token.Block_mapping_start when block ->
301
+
t.state <- Block_mapping_first_key;
302
+
skip_token t;
303
+
Event.Mapping_start {
304
+
anchor = None; tag = None;
305
+
implicit = true;
306
+
style = Layout_style.Block;
307
+
}, tok.span
308
+
309
+
| Token.Flow_sequence_start ->
310
+
t.state <- Flow_sequence_first_entry;
311
+
skip_token t;
312
+
Event.Sequence_start {
313
+
anchor = None; tag = None;
314
+
implicit = true;
315
+
style = Layout_style.Flow;
316
+
}, tok.span
317
+
318
+
| Token.Flow_mapping_start ->
319
+
t.state <- Flow_mapping_first_key;
320
+
skip_token t;
321
+
Event.Mapping_start {
322
+
anchor = None; tag = None;
323
+
implicit = true;
324
+
style = Layout_style.Flow;
325
+
}, tok.span
326
+
327
+
| Token.Block_entry when indentless ->
328
+
t.state <- Indentless_sequence_entry;
329
+
Event.Sequence_start {
330
+
anchor = None; tag = None;
331
+
implicit = true;
332
+
style = Layout_style.Block;
333
+
}, tok.span
334
+
335
+
| Token.Scalar { style; value } ->
336
+
skip_token t;
337
+
t.state <- pop_state t;
338
+
let plain_implicit = style = Scalar_style.Plain in
339
+
let quoted_implicit = style <> Scalar_style.Plain in
340
+
Event.Scalar {
341
+
anchor = None; tag = None; value;
342
+
plain_implicit; quoted_implicit; style;
343
+
}, tok.span
344
+
345
+
| _ ->
346
+
(* Empty node *)
347
+
t.state <- pop_state t;
348
+
empty_scalar_event ~anchor:None ~tag:None tok.span
349
+
350
+
(** Parse block sequence entry *)
351
+
let parse_block_sequence_entry t =
352
+
let tok = current_token t in
353
+
match tok.token with
354
+
| Token.Block_entry ->
355
+
skip_token t;
356
+
if check t (function
357
+
| Token.Block_entry | Token.Block_end -> true
358
+
| _ -> false)
359
+
then begin
360
+
t.state <- Block_sequence_entry;
361
+
empty_scalar_event ~anchor:None ~tag:None tok.span
362
+
end else begin
363
+
push_state t Block_sequence_entry;
364
+
parse_node t ~block:true ~indentless:false
365
+
end
366
+
| Token.Block_end ->
367
+
skip_token t;
368
+
t.state <- pop_state t;
369
+
Event.Sequence_end, tok.span
370
+
| _ ->
371
+
Error.raise_span tok.span Expected_block_entry
372
+
373
+
(** Parse block mapping key *)
374
+
let parse_block_mapping_key t =
375
+
let tok = current_token t in
376
+
match tok.token with
377
+
| Token.Key ->
378
+
skip_token t;
379
+
if check t (function
380
+
| Token.Key | Token.Value | Token.Block_end -> true
381
+
| _ -> false)
382
+
then begin
383
+
t.state <- Block_mapping_value;
384
+
empty_scalar_event ~anchor:None ~tag:None tok.span
385
+
end else begin
386
+
push_state t Block_mapping_value;
387
+
parse_node t ~block:true ~indentless:true
388
+
end
389
+
| Token.Block_end ->
390
+
skip_token t;
391
+
t.state <- pop_state t;
392
+
Event.Mapping_end, tok.span
393
+
| _ ->
394
+
Error.raise_span tok.span Expected_key
395
+
396
+
(** Parse block mapping value *)
397
+
let parse_block_mapping_value t =
398
+
let tok = current_token t in
399
+
match tok.token with
400
+
| Token.Value ->
401
+
skip_token t;
402
+
if check t (function
403
+
| Token.Key | Token.Value | Token.Block_end -> true
404
+
| _ -> false)
405
+
then begin
406
+
t.state <- Block_mapping_key;
407
+
empty_scalar_event ~anchor:None ~tag:None tok.span
408
+
end else begin
409
+
push_state t Block_mapping_key;
410
+
parse_node t ~block:true ~indentless:true
411
+
end
412
+
| _ ->
413
+
(* Implicit empty value *)
414
+
t.state <- Block_mapping_key;
415
+
empty_scalar_event ~anchor:None ~tag:None tok.span
416
+
417
+
(** Parse indentless sequence entry *)
418
+
let parse_indentless_sequence_entry t =
419
+
let tok = current_token t in
420
+
match tok.token with
421
+
| Token.Block_entry ->
422
+
skip_token t;
423
+
if check t (function
424
+
| Token.Block_entry | Token.Key | Token.Value | Token.Block_end -> true
425
+
| _ -> false)
426
+
then begin
427
+
t.state <- Indentless_sequence_entry;
428
+
empty_scalar_event ~anchor:None ~tag:None tok.span
429
+
end else begin
430
+
push_state t Indentless_sequence_entry;
431
+
parse_node t ~block:true ~indentless:false
432
+
end
433
+
| _ ->
434
+
t.state <- pop_state t;
435
+
Event.Sequence_end, tok.span
436
+
437
+
(** Parse flow sequence *)
438
+
let rec parse_flow_sequence_entry t ~first =
439
+
let tok = current_token t in
440
+
match tok.token with
441
+
| Token.Flow_sequence_end ->
442
+
skip_token t;
443
+
t.state <- pop_state t;
444
+
Event.Sequence_end, tok.span
445
+
| Token.Flow_entry when not first ->
446
+
skip_token t;
447
+
parse_flow_sequence_entry_internal t
448
+
| _ when first ->
449
+
parse_flow_sequence_entry_internal t
450
+
| _ ->
451
+
Error.raise_span tok.span Expected_sequence_end
452
+
453
+
and parse_flow_sequence_entry_internal t =
454
+
let tok = current_token t in
455
+
match tok.token with
456
+
| Token.Flow_sequence_end ->
457
+
t.state <- Flow_sequence_entry;
458
+
empty_scalar_event ~anchor:None ~tag:None tok.span
459
+
| Token.Key ->
460
+
skip_token t;
461
+
push_state t Flow_sequence_entry_mapping_end;
462
+
t.state <- Flow_sequence_entry_mapping_key;
463
+
Event.Mapping_start {
464
+
anchor = None; tag = None;
465
+
implicit = true;
466
+
style = Layout_style.Flow;
467
+
}, tok.span
468
+
| _ ->
469
+
push_state t Flow_sequence_entry;
470
+
parse_node t ~block:false ~indentless:false
471
+
472
+
(** Parse flow sequence entry mapping *)
473
+
let parse_flow_sequence_entry_mapping_key t =
474
+
let tok = current_token t in
475
+
if check t (function
476
+
| Token.Value | Token.Flow_entry | Token.Flow_sequence_end -> true
477
+
| _ -> false)
478
+
then begin
479
+
t.state <- Flow_sequence_entry_mapping_value;
480
+
empty_scalar_event ~anchor:None ~tag:None tok.span
481
+
end else begin
482
+
push_state t Flow_sequence_entry_mapping_value;
483
+
parse_node t ~block:false ~indentless:false
484
+
end
485
+
486
+
let parse_flow_sequence_entry_mapping_value t =
487
+
let tok = current_token t in
488
+
match tok.token with
489
+
| Token.Value ->
490
+
skip_token t;
491
+
if check t (function
492
+
| Token.Flow_entry | Token.Flow_sequence_end -> true
493
+
| _ -> false)
494
+
then begin
495
+
t.state <- Flow_sequence_entry_mapping_end;
496
+
empty_scalar_event ~anchor:None ~tag:None tok.span
497
+
end else begin
498
+
push_state t Flow_sequence_entry_mapping_end;
499
+
parse_node t ~block:false ~indentless:false
500
+
end
501
+
| _ ->
502
+
t.state <- Flow_sequence_entry_mapping_end;
503
+
empty_scalar_event ~anchor:None ~tag:None tok.span
504
+
505
+
let parse_flow_sequence_entry_mapping_end t =
506
+
let tok = current_token t in
507
+
t.state <- Flow_sequence_entry;
508
+
Event.Mapping_end, tok.span
509
+
510
+
(** Parse flow mapping *)
511
+
let rec parse_flow_mapping_key t ~first =
512
+
let tok = current_token t in
513
+
match tok.token with
514
+
| Token.Flow_mapping_end ->
515
+
skip_token t;
516
+
t.state <- pop_state t;
517
+
Event.Mapping_end, tok.span
518
+
| Token.Flow_entry when not first ->
519
+
skip_token t;
520
+
parse_flow_mapping_key_internal t
521
+
| _ when first ->
522
+
parse_flow_mapping_key_internal t
523
+
| _ ->
524
+
Error.raise_span tok.span Expected_mapping_end
525
+
526
+
and parse_flow_mapping_key_internal t =
527
+
let tok = current_token t in
528
+
match tok.token with
529
+
| Token.Flow_mapping_end ->
530
+
t.state <- Flow_mapping_key;
531
+
empty_scalar_event ~anchor:None ~tag:None tok.span
532
+
| Token.Key ->
533
+
skip_token t;
534
+
if check t (function
535
+
| Token.Value | Token.Flow_entry | Token.Flow_mapping_end -> true
536
+
| _ -> false)
537
+
then begin
538
+
t.state <- Flow_mapping_value;
539
+
empty_scalar_event ~anchor:None ~tag:None tok.span
540
+
end else begin
541
+
push_state t Flow_mapping_value;
542
+
parse_node t ~block:false ~indentless:false
543
+
end
544
+
| _ ->
545
+
push_state t Flow_mapping_value;
546
+
parse_node t ~block:false ~indentless:false
547
+
548
+
let parse_flow_mapping_value t ~empty =
549
+
let tok = current_token t in
550
+
if empty then begin
551
+
t.state <- Flow_mapping_key;
552
+
empty_scalar_event ~anchor:None ~tag:None tok.span
553
+
end else
554
+
match tok.token with
555
+
| Token.Value ->
556
+
skip_token t;
557
+
if check t (function
558
+
| Token.Flow_entry | Token.Flow_mapping_end -> true
559
+
| _ -> false)
560
+
then begin
561
+
t.state <- Flow_mapping_key;
562
+
empty_scalar_event ~anchor:None ~tag:None tok.span
563
+
end else begin
564
+
push_state t Flow_mapping_key;
565
+
parse_node t ~block:false ~indentless:false
566
+
end
567
+
| _ ->
568
+
t.state <- Flow_mapping_key;
569
+
empty_scalar_event ~anchor:None ~tag:None tok.span
570
+
571
+
(** Main state machine dispatcher *)
572
+
let parse t =
573
+
match t.state with
574
+
| Stream_start ->
575
+
parse_stream_start t
576
+
577
+
| Implicit_document_start ->
578
+
if check t (function
579
+
| Token.Version_directive _ | Token.Tag_directive _
580
+
| Token.Document_start | Token.Stream_end -> true
581
+
| _ -> false)
582
+
then begin
583
+
if check t (function Token.Stream_end -> true | _ -> false) then begin
584
+
let tok = current_token t in
585
+
skip_token t;
586
+
t.state <- End;
587
+
t.finished <- true;
588
+
Event.Stream_end, tok.span
589
+
end else begin
590
+
parse_document_start t ~implicit:false
591
+
end
592
+
end else
593
+
parse_document_start t ~implicit:true
594
+
595
+
| Document_start ->
596
+
parse_document_start t ~implicit:false
597
+
598
+
| Document_content ->
599
+
if check t (function
600
+
| Token.Version_directive _ | Token.Tag_directive _
601
+
| Token.Document_start | Token.Document_end | Token.Stream_end -> true
602
+
| _ -> false)
603
+
then begin
604
+
let tok = current_token t in
605
+
t.state <- pop_state t;
606
+
empty_scalar_event ~anchor:None ~tag:None tok.span
607
+
end else
608
+
parse_node t ~block:true ~indentless:false
609
+
610
+
| Document_end ->
611
+
parse_document_end t
612
+
613
+
| Block_node ->
614
+
parse_node t ~block:true ~indentless:false
615
+
616
+
| Block_node_or_indentless_sequence ->
617
+
parse_node t ~block:true ~indentless:true
618
+
619
+
| Flow_node ->
620
+
parse_node t ~block:false ~indentless:false
621
+
622
+
| Block_sequence_first_entry ->
623
+
t.state <- Block_sequence_entry;
624
+
parse_block_sequence_entry t
625
+
626
+
| Block_sequence_entry ->
627
+
parse_block_sequence_entry t
628
+
629
+
| Indentless_sequence_entry ->
630
+
parse_indentless_sequence_entry t
631
+
632
+
| Block_mapping_first_key ->
633
+
t.state <- Block_mapping_key;
634
+
parse_block_mapping_key t
635
+
636
+
| Block_mapping_key ->
637
+
parse_block_mapping_key t
638
+
639
+
| Block_mapping_value ->
640
+
parse_block_mapping_value t
641
+
642
+
| Flow_sequence_first_entry ->
643
+
parse_flow_sequence_entry t ~first:true
644
+
645
+
| Flow_sequence_entry ->
646
+
parse_flow_sequence_entry t ~first:false
647
+
648
+
| Flow_sequence_entry_mapping_key ->
649
+
parse_flow_sequence_entry_mapping_key t
650
+
651
+
| Flow_sequence_entry_mapping_value ->
652
+
parse_flow_sequence_entry_mapping_value t
653
+
654
+
| Flow_sequence_entry_mapping_end ->
655
+
parse_flow_sequence_entry_mapping_end t
656
+
657
+
| Flow_mapping_first_key ->
658
+
parse_flow_mapping_key t ~first:true
659
+
660
+
| Flow_mapping_key ->
661
+
parse_flow_mapping_key t ~first:false
662
+
663
+
| Flow_mapping_value ->
664
+
parse_flow_mapping_value t ~empty:false
665
+
666
+
| Flow_mapping_empty_value ->
667
+
parse_flow_mapping_value t ~empty:true
668
+
669
+
| End ->
670
+
let span = Span.point Position.initial in
671
+
t.finished <- true;
672
+
Event.Stream_end, span
673
+
674
+
(** Get next event *)
675
+
let next t =
676
+
if t.finished then None
677
+
else begin
678
+
let event, span = parse t in
679
+
Some { Event.event; span }
680
+
end
681
+
682
+
(** Peek at next event *)
683
+
let peek t =
684
+
(* Parser is not easily peekable without full state save/restore *)
685
+
(* For now, we don't support peek - could add caching if needed *)
686
+
if t.finished then None
687
+
else
688
+
(* Just call next and the caller will have to deal with it *)
689
+
next t
690
+
691
+
(** Iterate over all events *)
692
+
let iter f t =
693
+
let rec loop () =
694
+
match next t with
695
+
| None -> ()
696
+
| Some ev -> f ev; loop ()
697
+
in
698
+
loop ()
699
+
700
+
(** Fold over all events *)
701
+
let fold f init t =
702
+
let rec loop acc =
703
+
match next t with
704
+
| None -> acc
705
+
| Some ev -> loop (f acc ev)
706
+
in
707
+
loop init
708
+
709
+
(** Convert to list *)
710
+
let to_list t =
711
+
fold (fun acc ev -> ev :: acc) [] t |> List.rev
+42
yaml/ocaml-yamle/lib/position.ml
+42
yaml/ocaml-yamle/lib/position.ml
···
1
+
(** Position tracking for source locations *)
2
+
3
+
type t = {
4
+
index : int; (** Byte offset from start *)
5
+
line : int; (** 1-indexed line number *)
6
+
column : int; (** 1-indexed column number *)
7
+
}
8
+
9
+
let initial = { index = 0; line = 1; column = 1 }
10
+
11
+
let advance_byte t =
12
+
{ t with index = t.index + 1; column = t.column + 1 }
13
+
14
+
let advance_line t =
15
+
{ index = t.index + 1; line = t.line + 1; column = 1 }
16
+
17
+
let advance_char c t =
18
+
if c = '\n' then advance_line t
19
+
else advance_byte t
20
+
21
+
let advance_utf8 uchar t =
22
+
let len = Uchar.utf_8_byte_length uchar in
23
+
let code = Uchar.to_int uchar in
24
+
if code = 0x0A (* LF *) then
25
+
{ index = t.index + len; line = t.line + 1; column = 1 }
26
+
else
27
+
{ t with index = t.index + len; column = t.column + 1 }
28
+
29
+
let advance_bytes n t =
30
+
{ t with index = t.index + n; column = t.column + n }
31
+
32
+
let pp fmt t =
33
+
Format.fprintf fmt "line %d, column %d" t.line t.column
34
+
35
+
let to_string t =
36
+
Format.asprintf "%a" pp t
37
+
38
+
let compare a b =
39
+
Int.compare a.index b.index
40
+
41
+
let equal a b =
42
+
a.index = b.index
+61
yaml/ocaml-yamle/lib/scalar.ml
+61
yaml/ocaml-yamle/lib/scalar.ml
···
1
+
(** YAML scalar values with metadata *)
2
+
3
+
type t = {
4
+
anchor : string option;
5
+
tag : string option;
6
+
value : string;
7
+
plain_implicit : bool;
8
+
quoted_implicit : bool;
9
+
style : Scalar_style.t;
10
+
}
11
+
12
+
let make
13
+
?(anchor : string option)
14
+
?(tag : string option)
15
+
?(plain_implicit = true)
16
+
?(quoted_implicit = false)
17
+
?(style = Scalar_style.Plain)
18
+
value =
19
+
{ anchor; tag; value; plain_implicit; quoted_implicit; style }
20
+
21
+
let value t = t.value
22
+
let anchor t = t.anchor
23
+
let tag t = t.tag
24
+
let style t = t.style
25
+
let plain_implicit t = t.plain_implicit
26
+
let quoted_implicit t = t.quoted_implicit
27
+
28
+
let with_anchor anchor t = { t with anchor = Some anchor }
29
+
let with_tag tag t = { t with tag = Some tag }
30
+
let with_style style t = { t with style }
31
+
32
+
let pp fmt t =
33
+
Format.fprintf fmt "scalar(%S" t.value;
34
+
(match t.anchor with
35
+
| Some a -> Format.fprintf fmt ", anchor=%s" a
36
+
| None -> ());
37
+
(match t.tag with
38
+
| Some tag -> Format.fprintf fmt ", tag=%s" tag
39
+
| None -> ());
40
+
Format.fprintf fmt ", style=%a)" Scalar_style.pp t.style
41
+
42
+
let equal a b =
43
+
Option.equal String.equal a.anchor b.anchor &&
44
+
Option.equal String.equal a.tag b.tag &&
45
+
String.equal a.value b.value &&
46
+
a.plain_implicit = b.plain_implicit &&
47
+
a.quoted_implicit = b.quoted_implicit &&
48
+
Scalar_style.equal a.style b.style
49
+
50
+
let compare a b =
51
+
let c = Option.compare String.compare a.anchor b.anchor in
52
+
if c <> 0 then c else
53
+
let c = Option.compare String.compare a.tag b.tag in
54
+
if c <> 0 then c else
55
+
let c = String.compare a.value b.value in
56
+
if c <> 0 then c else
57
+
let c = Bool.compare a.plain_implicit b.plain_implicit in
58
+
if c <> 0 then c else
59
+
let c = Bool.compare a.quoted_implicit b.quoted_implicit in
60
+
if c <> 0 then c else
61
+
Scalar_style.compare a.style b.style
+33
yaml/ocaml-yamle/lib/scalar_style.ml
+33
yaml/ocaml-yamle/lib/scalar_style.ml
···
1
+
(** Scalar formatting styles *)
2
+
3
+
type t =
4
+
| Any (** Let emitter choose *)
5
+
| Plain (** Unquoted: foo *)
6
+
| Single_quoted (** 'foo' *)
7
+
| Double_quoted (** "foo" *)
8
+
| Literal (** | block *)
9
+
| Folded (** > block *)
10
+
11
+
let to_string = function
12
+
| Any -> "any"
13
+
| Plain -> "plain"
14
+
| Single_quoted -> "single-quoted"
15
+
| Double_quoted -> "double-quoted"
16
+
| Literal -> "literal"
17
+
| Folded -> "folded"
18
+
19
+
let pp fmt t =
20
+
Format.pp_print_string fmt (to_string t)
21
+
22
+
let equal a b = a = b
23
+
24
+
let compare a b =
25
+
let to_int = function
26
+
| Any -> 0
27
+
| Plain -> 1
28
+
| Single_quoted -> 2
29
+
| Double_quoted -> 3
30
+
| Literal -> 4
31
+
| Folded -> 5
32
+
in
33
+
Int.compare (to_int a) (to_int b)
+1046
yaml/ocaml-yamle/lib/scanner.ml
+1046
yaml/ocaml-yamle/lib/scanner.ml
···
1
+
(** YAML tokenizer/scanner with lookahead for ambiguity resolution *)
2
+
3
+
(** Simple key tracking for mapping key disambiguation *)
4
+
type simple_key = {
5
+
sk_possible : bool;
6
+
sk_required : bool;
7
+
sk_token_number : int;
8
+
sk_position : Position.t;
9
+
}
10
+
11
+
(** Indent level tracking *)
12
+
type indent = {
13
+
indent : int;
14
+
needs_block_end : bool;
15
+
sequence : bool; (** true if this is a sequence indent *)
16
+
}
17
+
18
+
type t = {
19
+
input : Input.t;
20
+
mutable tokens : Token.spanned Queue.t;
21
+
mutable token_number : int;
22
+
mutable tokens_taken : int;
23
+
mutable stream_started : bool;
24
+
mutable stream_ended : bool;
25
+
mutable indent_stack : indent list; (** Stack of indentation levels *)
26
+
mutable flow_level : int; (** Nesting depth in [] or {} *)
27
+
mutable simple_keys : simple_key option list; (** Per flow-level simple key tracking *)
28
+
mutable allow_simple_key : bool;
29
+
}
30
+
31
+
let create input =
32
+
{
33
+
input;
34
+
tokens = Queue.create ();
35
+
token_number = 0;
36
+
tokens_taken = 0;
37
+
stream_started = false;
38
+
stream_ended = false;
39
+
indent_stack = [];
40
+
flow_level = 0;
41
+
simple_keys = [None]; (* One entry for the base level *)
42
+
allow_simple_key = true;
43
+
}
44
+
45
+
let of_string s = create (Input.of_string s)
46
+
47
+
let position t = Input.position t.input
48
+
49
+
(** Add a token to the queue *)
50
+
let emit t span token =
51
+
Queue.add { Token.token; span } t.tokens;
52
+
t.token_number <- t.token_number + 1
53
+
54
+
(** Get current column (1-indexed) *)
55
+
let column t = (Input.position t.input).column
56
+
57
+
(** Get current indent level *)
58
+
let current_indent t =
59
+
match t.indent_stack with
60
+
| [] -> 0
61
+
| { indent; _ } :: _ -> indent
62
+
63
+
(** Skip whitespace and comments, return true if at newline *)
64
+
let rec skip_to_next_token t =
65
+
(* Skip blanks *)
66
+
while Input.next_is_blank t.input do
67
+
ignore (Input.next t.input)
68
+
done;
69
+
(* Skip comment *)
70
+
if Input.next_is (( = ) '#') t.input then begin
71
+
while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do
72
+
ignore (Input.next t.input)
73
+
done
74
+
end;
75
+
(* Skip line break in block context *)
76
+
if t.flow_level = 0 && Input.next_is_break t.input then begin
77
+
Input.consume_break t.input;
78
+
t.allow_simple_key <- true;
79
+
skip_to_next_token t
80
+
end
81
+
else if t.flow_level > 0 && Input.next_is_whitespace t.input then begin
82
+
ignore (Input.next t.input);
83
+
skip_to_next_token t
84
+
end
85
+
86
+
(** Roll the indentation level *)
87
+
let roll_indent t col ~sequence =
88
+
if t.flow_level = 0 && col > current_indent t then begin
89
+
t.indent_stack <- { indent = col; needs_block_end = true; sequence } :: t.indent_stack;
90
+
true
91
+
end else
92
+
false
93
+
94
+
(** Unroll indentation to given column *)
95
+
let unroll_indent t col =
96
+
while t.flow_level = 0 &&
97
+
match t.indent_stack with
98
+
| { indent; needs_block_end = true; _ } :: _ when indent > col -> true
99
+
| _ -> false
100
+
do
101
+
match t.indent_stack with
102
+
| { indent = _; needs_block_end = true; _ } :: rest ->
103
+
let pos = Input.position t.input in
104
+
let span = Span.point pos in
105
+
emit t span Token.Block_end;
106
+
t.indent_stack <- rest
107
+
| _ -> ()
108
+
done
109
+
110
+
(** Save a potential simple key *)
111
+
let save_simple_key t =
112
+
if t.allow_simple_key then begin
113
+
(* A simple key is required only if we're in a block context,
114
+
at the current indentation level, AND we have an active indent *)
115
+
let required = t.flow_level = 0 &&
116
+
t.indent_stack <> [] &&
117
+
current_indent t = column t - 1 in
118
+
let sk = {
119
+
sk_possible = true;
120
+
sk_required = required;
121
+
sk_token_number = t.token_number;
122
+
sk_position = Input.position t.input;
123
+
} in
124
+
(* Remove any existing simple key at current level *)
125
+
t.simple_keys <- (
126
+
match t.simple_keys with
127
+
| _ :: rest -> Some sk :: rest
128
+
| [] -> [Some sk]
129
+
)
130
+
end
131
+
132
+
(** Remove simple key at current level *)
133
+
let remove_simple_key t =
134
+
match t.simple_keys with
135
+
| Some sk :: _rest when sk.sk_required ->
136
+
Error.raise_at sk.sk_position Expected_key
137
+
| _ :: rest -> t.simple_keys <- None :: rest
138
+
| [] -> ()
139
+
140
+
(** Stale simple keys that span too many tokens *)
141
+
let stale_simple_keys t =
142
+
t.simple_keys <- List.map (fun sk_opt ->
143
+
match sk_opt with
144
+
| Some sk when sk.sk_possible &&
145
+
(Input.position t.input).line > sk.sk_position.line &&
146
+
t.flow_level = 0 ->
147
+
if sk.sk_required then
148
+
Error.raise_at sk.sk_position Expected_key;
149
+
None
150
+
| _ -> sk_opt
151
+
) t.simple_keys
152
+
153
+
(** Read anchor or alias name *)
154
+
let scan_anchor_alias t =
155
+
let start = Input.mark t.input in
156
+
let buf = Buffer.create 16 in
157
+
while
158
+
match Input.peek t.input with
159
+
| Some c when Input.is_alnum c || c = '_' || c = '-' ->
160
+
Buffer.add_char buf c;
161
+
ignore (Input.next t.input);
162
+
true
163
+
| _ -> false
164
+
do () done;
165
+
let name = Buffer.contents buf in
166
+
if String.length name = 0 then
167
+
Error.raise_at start (Invalid_anchor "empty anchor name");
168
+
(name, Span.make ~start ~stop:(Input.mark t.input))
169
+
170
+
(** Scan tag handle *)
171
+
let scan_tag_handle t =
172
+
let start = Input.mark t.input in
173
+
let buf = Buffer.create 16 in
174
+
(* Expect ! *)
175
+
(match Input.peek t.input with
176
+
| Some '!' ->
177
+
Buffer.add_char buf '!';
178
+
ignore (Input.next t.input)
179
+
| _ -> Error.raise_at start (Invalid_tag "expected '!'"));
180
+
(* Read word chars *)
181
+
while
182
+
match Input.peek t.input with
183
+
| Some c when Input.is_alnum c || c = '-' ->
184
+
Buffer.add_char buf c;
185
+
ignore (Input.next t.input);
186
+
true
187
+
| _ -> false
188
+
do () done;
189
+
(* Check for secondary ! *)
190
+
(match Input.peek t.input with
191
+
| Some '!' ->
192
+
Buffer.add_char buf '!';
193
+
ignore (Input.next t.input)
194
+
| _ -> ());
195
+
Buffer.contents buf
196
+
197
+
(** Scan tag suffix (after handle) *)
198
+
let scan_tag_suffix t =
199
+
let buf = Buffer.create 32 in
200
+
while
201
+
match Input.peek t.input with
202
+
| Some c when not (Input.is_whitespace c) &&
203
+
not (Input.is_flow_indicator c) ->
204
+
Buffer.add_char buf c;
205
+
ignore (Input.next t.input);
206
+
true
207
+
| _ -> false
208
+
do () done;
209
+
Buffer.contents buf
210
+
211
+
(** Scan a tag *)
212
+
let scan_tag t =
213
+
let start = Input.mark t.input in
214
+
ignore (Input.next t.input); (* consume ! *)
215
+
let handle, suffix =
216
+
match Input.peek t.input with
217
+
| Some '<' ->
218
+
(* Verbatim tag: !<...> *)
219
+
ignore (Input.next t.input);
220
+
let buf = Buffer.create 32 in
221
+
while
222
+
match Input.peek t.input with
223
+
| Some '>' -> false
224
+
| Some c ->
225
+
Buffer.add_char buf c;
226
+
ignore (Input.next t.input);
227
+
true
228
+
| None -> Error.raise_at (Input.mark t.input) (Invalid_tag "unclosed verbatim tag")
229
+
do () done;
230
+
ignore (Input.next t.input); (* consume > *)
231
+
("!", Buffer.contents buf)
232
+
| Some c when Input.is_whitespace c || Input.is_flow_indicator c ->
233
+
(* Non-specific tag: ! *)
234
+
("!", "")
235
+
| Some '!' ->
236
+
(* Secondary handle *)
237
+
let handle = scan_tag_handle t in
238
+
let suffix = scan_tag_suffix t in
239
+
(handle, suffix)
240
+
| _ ->
241
+
(* Primary handle or just suffix *)
242
+
let first_part = scan_tag_suffix t in
243
+
if String.length first_part > 0 && first_part.[String.length first_part - 1] = '!' then
244
+
let suffix = scan_tag_suffix t in
245
+
(first_part, suffix)
246
+
else
247
+
("!", first_part)
248
+
in
249
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
250
+
(handle, suffix, span)
251
+
252
+
(** Scan single-quoted scalar *)
253
+
let scan_single_quoted t =
254
+
let start = Input.mark t.input in
255
+
ignore (Input.next t.input); (* consume opening single-quote *)
256
+
let buf = Buffer.create 64 in
257
+
let rec loop () =
258
+
match Input.peek t.input with
259
+
| None -> Error.raise_at start Unclosed_single_quote
260
+
| Some '\'' ->
261
+
ignore (Input.next t.input);
262
+
(* Check for escaped quote ('') *)
263
+
(match Input.peek t.input with
264
+
| Some '\'' ->
265
+
Buffer.add_char buf '\'';
266
+
ignore (Input.next t.input);
267
+
loop ()
268
+
| _ -> ())
269
+
| Some '\n' | Some '\r' ->
270
+
Input.consume_break t.input;
271
+
(* Fold line break to space unless at start of content *)
272
+
if Buffer.length buf > 0 then
273
+
Buffer.add_char buf ' ';
274
+
(* Skip leading whitespace on next line *)
275
+
while Input.next_is_blank t.input do
276
+
ignore (Input.next t.input)
277
+
done;
278
+
loop ()
279
+
| Some c ->
280
+
Buffer.add_char buf c;
281
+
ignore (Input.next t.input);
282
+
loop ()
283
+
in
284
+
loop ();
285
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
286
+
(Buffer.contents buf, span)
287
+
288
+
(** Decode hex escape of given length *)
289
+
let decode_hex t len =
290
+
let start = Input.mark t.input in
291
+
let buf = Buffer.create len in
292
+
for _ = 1 to len do
293
+
match Input.peek t.input with
294
+
| Some c when Input.is_hex c ->
295
+
Buffer.add_char buf c;
296
+
ignore (Input.next t.input)
297
+
| _ ->
298
+
Error.raise_at start (Invalid_hex_escape (Buffer.contents buf))
299
+
done;
300
+
let code = int_of_string ("0x" ^ Buffer.contents buf) in
301
+
if code <= 0x7F then
302
+
String.make 1 (Char.chr code)
303
+
else if code <= 0x7FF then
304
+
let b1 = 0xC0 lor (code lsr 6) in
305
+
let b2 = 0x80 lor (code land 0x3F) in
306
+
String.init 2 (fun i -> Char.chr (if i = 0 then b1 else b2))
307
+
else if code <= 0xFFFF then
308
+
let b1 = 0xE0 lor (code lsr 12) in
309
+
let b2 = 0x80 lor ((code lsr 6) land 0x3F) in
310
+
let b3 = 0x80 lor (code land 0x3F) in
311
+
String.init 3 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | _ -> b3))
312
+
else
313
+
let b1 = 0xF0 lor (code lsr 18) in
314
+
let b2 = 0x80 lor ((code lsr 12) land 0x3F) in
315
+
let b3 = 0x80 lor ((code lsr 6) land 0x3F) in
316
+
let b4 = 0x80 lor (code land 0x3F) in
317
+
String.init 4 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | 2 -> b3 | _ -> b4))
318
+
319
+
(** Scan double-quoted scalar *)
320
+
let scan_double_quoted t =
321
+
let start = Input.mark t.input in
322
+
ignore (Input.next t.input); (* consume opening double-quote *)
323
+
let buf = Buffer.create 64 in
324
+
let rec loop () =
325
+
match Input.peek t.input with
326
+
| None -> Error.raise_at start Unclosed_double_quote
327
+
| Some '"' ->
328
+
ignore (Input.next t.input)
329
+
| Some '\\' ->
330
+
ignore (Input.next t.input);
331
+
(match Input.peek t.input with
332
+
| None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>")
333
+
| Some '0' -> Buffer.add_char buf '\x00'; ignore (Input.next t.input)
334
+
| Some 'a' -> Buffer.add_char buf '\x07'; ignore (Input.next t.input)
335
+
| Some 'b' -> Buffer.add_char buf '\x08'; ignore (Input.next t.input)
336
+
| Some 't' | Some '\t' -> Buffer.add_char buf '\t'; ignore (Input.next t.input)
337
+
| Some 'n' -> Buffer.add_char buf '\n'; ignore (Input.next t.input)
338
+
| Some 'v' -> Buffer.add_char buf '\x0B'; ignore (Input.next t.input)
339
+
| Some 'f' -> Buffer.add_char buf '\x0C'; ignore (Input.next t.input)
340
+
| Some 'r' -> Buffer.add_char buf '\r'; ignore (Input.next t.input)
341
+
| Some 'e' -> Buffer.add_char buf '\x1B'; ignore (Input.next t.input)
342
+
| Some ' ' -> Buffer.add_char buf ' '; ignore (Input.next t.input)
343
+
| Some '"' -> Buffer.add_char buf '"'; ignore (Input.next t.input)
344
+
| Some '/' -> Buffer.add_char buf '/'; ignore (Input.next t.input)
345
+
| Some '\\' -> Buffer.add_char buf '\\'; ignore (Input.next t.input)
346
+
| Some 'N' -> Buffer.add_string buf "\xC2\x85"; ignore (Input.next t.input) (* NEL *)
347
+
| Some '_' -> Buffer.add_string buf "\xC2\xA0"; ignore (Input.next t.input) (* NBSP *)
348
+
| Some 'L' -> Buffer.add_string buf "\xE2\x80\xA8"; ignore (Input.next t.input) (* LS *)
349
+
| Some 'P' -> Buffer.add_string buf "\xE2\x80\xA9"; ignore (Input.next t.input) (* PS *)
350
+
| Some 'x' ->
351
+
ignore (Input.next t.input);
352
+
Buffer.add_string buf (decode_hex t 2)
353
+
| Some 'u' ->
354
+
ignore (Input.next t.input);
355
+
Buffer.add_string buf (decode_hex t 4)
356
+
| Some 'U' ->
357
+
ignore (Input.next t.input);
358
+
Buffer.add_string buf (decode_hex t 8)
359
+
| Some '\n' | Some '\r' ->
360
+
(* Line continuation *)
361
+
Input.consume_break t.input;
362
+
while Input.next_is_blank t.input do
363
+
ignore (Input.next t.input)
364
+
done
365
+
| Some c ->
366
+
Error.raise_at (Input.mark t.input)
367
+
(Invalid_escape_sequence (Printf.sprintf "\\%c" c)));
368
+
loop ()
369
+
| Some '\n' | Some '\r' ->
370
+
Input.consume_break t.input;
371
+
(* Fold to space *)
372
+
Buffer.add_char buf ' ';
373
+
(* Skip leading whitespace *)
374
+
while Input.next_is_blank t.input do
375
+
ignore (Input.next t.input)
376
+
done;
377
+
loop ()
378
+
| Some c ->
379
+
Buffer.add_char buf c;
380
+
ignore (Input.next t.input);
381
+
loop ()
382
+
in
383
+
loop ();
384
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
385
+
(Buffer.contents buf, span)
386
+
387
+
(** Check if character can appear in plain scalar at this position *)
388
+
let can_continue_plain t c ~in_flow =
389
+
match c with
390
+
| ':' ->
391
+
(* : is OK if not followed by whitespace or flow indicator *)
392
+
(match Input.peek_nth t.input 1 with
393
+
| None -> true
394
+
| Some c2 when Input.is_whitespace c2 -> false
395
+
| Some c2 when in_flow && Input.is_flow_indicator c2 -> false
396
+
| _ -> true)
397
+
| '#' ->
398
+
(* # is OK if not preceded by whitespace (checked at call site) *)
399
+
false
400
+
| c when in_flow && Input.is_flow_indicator c -> false
401
+
| _ when Input.is_break c -> false
402
+
| _ -> true
403
+
404
+
(** Scan plain scalar *)
405
+
let scan_plain_scalar t =
406
+
let start = Input.mark t.input in
407
+
let in_flow = t.flow_level > 0 in
408
+
let indent = current_indent t in
409
+
let buf = Buffer.create 64 in
410
+
let spaces = Buffer.create 16 in
411
+
let leading_blanks = ref false in
412
+
413
+
let rec scan_line () =
414
+
match Input.peek t.input with
415
+
| None -> ()
416
+
| Some c when can_continue_plain t c ~in_flow ->
417
+
(* Check for # preceded by space *)
418
+
if c = '#' && Buffer.length buf > 0 then
419
+
() (* Stop - # after content *)
420
+
else begin
421
+
if Buffer.length spaces > 0 then begin
422
+
if !leading_blanks then begin
423
+
(* Fold line break *)
424
+
if Buffer.contents spaces = "\n" then
425
+
Buffer.add_char buf ' '
426
+
else begin
427
+
(* Multiple breaks - preserve all but first *)
428
+
let s = Buffer.contents spaces in
429
+
Buffer.add_substring buf s 1 (String.length s - 1)
430
+
end
431
+
end else
432
+
Buffer.add_buffer buf spaces;
433
+
Buffer.clear spaces
434
+
end;
435
+
Buffer.add_char buf c;
436
+
ignore (Input.next t.input);
437
+
leading_blanks := false;
438
+
scan_line ()
439
+
end
440
+
| _ -> ()
441
+
in
442
+
443
+
let rec scan_lines () =
444
+
scan_line ();
445
+
(* Check for line continuation *)
446
+
if not in_flow && Input.next_is_break t.input then begin
447
+
(* Save whitespace *)
448
+
Buffer.clear spaces;
449
+
Buffer.add_char spaces '\n';
450
+
Input.consume_break t.input;
451
+
(* Line break in block context allows simple key *)
452
+
t.allow_simple_key <- true;
453
+
(* Skip leading blanks *)
454
+
while Input.next_is_blank t.input do
455
+
Buffer.add_char spaces (Option.get (Input.next t.input))
456
+
done;
457
+
let col = (Input.position t.input).column in
458
+
(* Check indentation - stop if we're at or before the containing block's indent *)
459
+
if not in_flow && col <= indent then
460
+
() (* Stop - dedented or at parent level *)
461
+
else if Input.at_document_boundary t.input then
462
+
() (* Stop - document boundary *)
463
+
else begin
464
+
leading_blanks := true;
465
+
scan_lines ()
466
+
end
467
+
end
468
+
in
469
+
470
+
scan_lines ();
471
+
let value = Buffer.contents buf in
472
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
473
+
(value, span)
474
+
475
+
(** Scan block scalar (literal | or folded >) *)
476
+
let scan_block_scalar t literal =
477
+
let start = Input.mark t.input in
478
+
ignore (Input.next t.input); (* consume | or > *)
479
+
480
+
(* Parse header: optional indentation indicator and chomping *)
481
+
let explicit_indent = ref None in
482
+
let chomping = ref Chomping.Clip in
483
+
484
+
(* First character of header *)
485
+
(match Input.peek t.input with
486
+
| Some c when Input.is_digit c && c <> '0' ->
487
+
explicit_indent := Some (Char.code c - Char.code '0');
488
+
ignore (Input.next t.input)
489
+
| Some '-' -> chomping := Chomping.Strip; ignore (Input.next t.input)
490
+
| Some '+' -> chomping := Chomping.Keep; ignore (Input.next t.input)
491
+
| _ -> ());
492
+
493
+
(* Second character of header *)
494
+
(match Input.peek t.input with
495
+
| Some c when Input.is_digit c && c <> '0' && !explicit_indent = None ->
496
+
explicit_indent := Some (Char.code c - Char.code '0');
497
+
ignore (Input.next t.input)
498
+
| Some '-' when !chomping = Chomping.Clip ->
499
+
chomping := Chomping.Strip; ignore (Input.next t.input)
500
+
| Some '+' when !chomping = Chomping.Clip ->
501
+
chomping := Chomping.Keep; ignore (Input.next t.input)
502
+
| _ -> ());
503
+
504
+
(* Skip to end of line *)
505
+
while Input.next_is_blank t.input do
506
+
ignore (Input.next t.input)
507
+
done;
508
+
509
+
(* Optional comment *)
510
+
if Input.next_is (( = ) '#') t.input then begin
511
+
while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do
512
+
ignore (Input.next t.input)
513
+
done
514
+
end;
515
+
516
+
(* Consume line break *)
517
+
if Input.next_is_break t.input then
518
+
Input.consume_break t.input
519
+
else if not (Input.is_eof t.input) then
520
+
Error.raise_at (Input.mark t.input)
521
+
(Invalid_block_scalar_header "expected newline after header");
522
+
523
+
let base_indent = current_indent t in
524
+
let content_indent = ref (
525
+
match !explicit_indent with
526
+
| Some n -> base_indent + n
527
+
| None -> 0 (* Will be determined by first non-empty line *)
528
+
) in
529
+
530
+
let buf = Buffer.create 256 in
531
+
let trailing_breaks = Buffer.create 16 in
532
+
533
+
(* Read content *)
534
+
let rec read_lines () =
535
+
(* Skip empty lines, collecting breaks *)
536
+
while Input.next_is_break t.input ||
537
+
(Input.next_is_blank t.input &&
538
+
match Input.peek_nth t.input 1 with
539
+
| Some c when Input.is_break c -> true
540
+
| None -> true
541
+
| _ -> false)
542
+
do
543
+
if Input.next_is_blank t.input then begin
544
+
while Input.next_is_blank t.input do
545
+
ignore (Input.next t.input)
546
+
done
547
+
end;
548
+
if Input.next_is_break t.input then begin
549
+
Buffer.add_char trailing_breaks '\n';
550
+
Input.consume_break t.input
551
+
end
552
+
done;
553
+
554
+
(* Check if we're at content *)
555
+
if Input.is_eof t.input then ()
556
+
else if Input.at_document_boundary t.input then ()
557
+
else begin
558
+
(* Count leading spaces *)
559
+
let line_indent = ref 0 in
560
+
while Input.next_is (( = ) ' ') t.input do
561
+
incr line_indent;
562
+
ignore (Input.next t.input)
563
+
done;
564
+
565
+
(* Determine content indent from first content line *)
566
+
if !content_indent = 0 then begin
567
+
if !line_indent <= base_indent then begin
568
+
(* No content - restore position conceptually *)
569
+
()
570
+
end else
571
+
content_indent := !line_indent
572
+
end;
573
+
574
+
if !line_indent < !content_indent then begin
575
+
(* Dedented - done with content *)
576
+
()
577
+
end else begin
578
+
(* Add trailing breaks to buffer *)
579
+
if Buffer.length buf > 0 then begin
580
+
if Buffer.length trailing_breaks > 0 then begin
581
+
if literal then
582
+
Buffer.add_buffer buf trailing_breaks
583
+
else begin
584
+
let breaks = Buffer.contents trailing_breaks in
585
+
if String.length breaks = 1 then
586
+
Buffer.add_char buf ' '
587
+
else
588
+
Buffer.add_substring buf breaks 1 (String.length breaks - 1)
589
+
end
590
+
end else if not literal then
591
+
Buffer.add_char buf ' '
592
+
end else
593
+
Buffer.add_buffer buf trailing_breaks;
594
+
Buffer.clear trailing_breaks;
595
+
596
+
(* Add extra indentation for literal *)
597
+
if literal then begin
598
+
for _ = !content_indent + 1 to !line_indent do
599
+
Buffer.add_char buf ' '
600
+
done
601
+
end;
602
+
603
+
(* Read line content *)
604
+
while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do
605
+
Buffer.add_char buf (Input.next_exn t.input)
606
+
done;
607
+
608
+
(* Record trailing break *)
609
+
if Input.next_is_break t.input then begin
610
+
Buffer.add_char trailing_breaks '\n';
611
+
Input.consume_break t.input
612
+
end;
613
+
614
+
read_lines ()
615
+
end
616
+
end
617
+
in
618
+
619
+
read_lines ();
620
+
621
+
(* Apply chomping *)
622
+
let value =
623
+
let content = Buffer.contents buf in
624
+
match !chomping with
625
+
| Chomping.Strip -> content
626
+
| Chomping.Clip ->
627
+
if String.length content > 0 then content ^ "\n" else content
628
+
| Chomping.Keep ->
629
+
content ^ Buffer.contents trailing_breaks
630
+
in
631
+
632
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
633
+
let style = if literal then Scalar_style.Literal else Scalar_style.Folded in
634
+
(value, style, span)
635
+
636
+
(** Scan directive (after %) *)
637
+
let scan_directive t =
638
+
let start = Input.mark t.input in
639
+
ignore (Input.next t.input); (* consume % *)
640
+
641
+
(* Read directive name *)
642
+
let name_buf = Buffer.create 16 in
643
+
while
644
+
match Input.peek t.input with
645
+
| Some c when Input.is_alnum c || c = '-' ->
646
+
Buffer.add_char name_buf c;
647
+
ignore (Input.next t.input);
648
+
true
649
+
| _ -> false
650
+
do () done;
651
+
let name = Buffer.contents name_buf in
652
+
653
+
(* Skip blanks *)
654
+
while Input.next_is_blank t.input do
655
+
ignore (Input.next t.input)
656
+
done;
657
+
658
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
659
+
660
+
match name with
661
+
| "YAML" ->
662
+
(* Version directive: %YAML 1.2 *)
663
+
let major = ref 0 in
664
+
let minor = ref 0 in
665
+
(* Read major version *)
666
+
while Input.next_is_digit t.input do
667
+
major := !major * 10 + (Char.code (Input.next_exn t.input) - Char.code '0')
668
+
done;
669
+
(* Expect . *)
670
+
(match Input.peek t.input with
671
+
| Some '.' -> ignore (Input.next t.input)
672
+
| _ -> Error.raise_at (Input.mark t.input) (Invalid_yaml_version "expected '.'"));
673
+
(* Read minor version *)
674
+
while Input.next_is_digit t.input do
675
+
minor := !minor * 10 + (Char.code (Input.next_exn t.input) - Char.code '0')
676
+
done;
677
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
678
+
Token.Version_directive { major = !major; minor = !minor }, span
679
+
680
+
| "TAG" ->
681
+
(* Tag directive: %TAG !foo! tag:example.com,2000: *)
682
+
let handle = scan_tag_handle t in
683
+
(* Skip blanks *)
684
+
while Input.next_is_blank t.input do
685
+
ignore (Input.next t.input)
686
+
done;
687
+
(* Read prefix *)
688
+
let prefix_buf = Buffer.create 32 in
689
+
while
690
+
match Input.peek t.input with
691
+
| Some c when not (Input.is_whitespace c) ->
692
+
Buffer.add_char prefix_buf c;
693
+
ignore (Input.next t.input);
694
+
true
695
+
| _ -> false
696
+
do () done;
697
+
let prefix = Buffer.contents prefix_buf in
698
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
699
+
Token.Tag_directive { handle; prefix }, span
700
+
701
+
| _ when String.length name > 0 && name.[0] >= 'A' && name.[0] <= 'Z' ->
702
+
(* Reserved directive *)
703
+
Error.raise_span span (Reserved_directive name)
704
+
705
+
| _ ->
706
+
(* Unknown directive - skip to end of line *)
707
+
while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do
708
+
ignore (Input.next t.input)
709
+
done;
710
+
Error.raise_span span (Invalid_directive name)
711
+
712
+
(** Fetch the next token(s) into the queue *)
713
+
let rec fetch_next_token t =
714
+
skip_to_next_token t;
715
+
stale_simple_keys t;
716
+
let col = column t in
717
+
(* Unroll indents that are deeper than current column.
718
+
Note: we use col, not col-1, to allow entries at the same level. *)
719
+
unroll_indent t col;
720
+
721
+
if Input.is_eof t.input then
722
+
fetch_stream_end t
723
+
else if Input.at_document_boundary t.input then
724
+
fetch_document_indicator t
725
+
else begin
726
+
match Input.peek t.input with
727
+
| None -> fetch_stream_end t
728
+
| Some '%' when (Input.position t.input).column = 1 ->
729
+
fetch_directive t
730
+
| Some '[' -> fetch_flow_collection_start t Token.Flow_sequence_start
731
+
| Some '{' -> fetch_flow_collection_start t Token.Flow_mapping_start
732
+
| Some ']' -> fetch_flow_collection_end t Token.Flow_sequence_end
733
+
| Some '}' -> fetch_flow_collection_end t Token.Flow_mapping_end
734
+
| Some ',' -> fetch_flow_entry t
735
+
| Some '-' when t.flow_level = 0 && check_block_entry t ->
736
+
fetch_block_entry t
737
+
| Some '?' when t.flow_level = 0 && check_key t ->
738
+
fetch_key t
739
+
| Some ':' when check_value t ->
740
+
fetch_value t
741
+
| Some '*' -> fetch_alias t
742
+
| Some '&' -> fetch_anchor t
743
+
| Some '!' -> fetch_tag t
744
+
| Some '|' when t.flow_level = 0 -> fetch_block_scalar t true
745
+
| Some '>' when t.flow_level = 0 -> fetch_block_scalar t false
746
+
| Some '\'' -> fetch_single_quoted t
747
+
| Some '"' -> fetch_double_quoted t
748
+
| Some '-' when can_start_plain t ->
749
+
fetch_plain_scalar t
750
+
| Some '?' when can_start_plain t ->
751
+
fetch_plain_scalar t
752
+
| Some ':' when can_start_plain t ->
753
+
fetch_plain_scalar t
754
+
| Some c when can_start_plain_char c t ->
755
+
fetch_plain_scalar t
756
+
| Some c ->
757
+
Error.raise_at (Input.mark t.input) (Unexpected_character c)
758
+
end
759
+
760
+
and fetch_stream_end t =
761
+
if not t.stream_ended then begin
762
+
unroll_indent t (-1);
763
+
remove_simple_key t;
764
+
t.allow_simple_key <- false;
765
+
t.stream_ended <- true;
766
+
let span = Span.point (Input.mark t.input) in
767
+
emit t span Token.Stream_end
768
+
end
769
+
770
+
and fetch_document_indicator t =
771
+
unroll_indent t (-1);
772
+
remove_simple_key t;
773
+
t.allow_simple_key <- false;
774
+
let start = Input.mark t.input in
775
+
let indicator = Input.peek_string t.input 3 in
776
+
Input.skip t.input 3;
777
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
778
+
let token = if indicator = "---" then Token.Document_start else Token.Document_end in
779
+
emit t span token
780
+
781
+
and fetch_directive t =
782
+
unroll_indent t (-1);
783
+
remove_simple_key t;
784
+
t.allow_simple_key <- false;
785
+
let token, span = scan_directive t in
786
+
emit t span token
787
+
788
+
and fetch_flow_collection_start t token_type =
789
+
save_simple_key t;
790
+
t.flow_level <- t.flow_level + 1;
791
+
t.allow_simple_key <- true;
792
+
t.simple_keys <- None :: t.simple_keys;
793
+
let start = Input.mark t.input in
794
+
ignore (Input.next t.input);
795
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
796
+
emit t span token_type
797
+
798
+
and fetch_flow_collection_end t token_type =
799
+
remove_simple_key t;
800
+
t.flow_level <- t.flow_level - 1;
801
+
t.simple_keys <- (match t.simple_keys with _ :: rest -> rest | [] -> []);
802
+
t.allow_simple_key <- false;
803
+
let start = Input.mark t.input in
804
+
ignore (Input.next t.input);
805
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
806
+
emit t span token_type
807
+
808
+
and fetch_flow_entry t =
809
+
remove_simple_key t;
810
+
t.allow_simple_key <- true;
811
+
let start = Input.mark t.input in
812
+
ignore (Input.next t.input);
813
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
814
+
emit t span Token.Flow_entry
815
+
816
+
and check_block_entry t =
817
+
(* - followed by whitespace or EOF *)
818
+
match Input.peek_nth t.input 1 with
819
+
| None -> true
820
+
| Some c -> Input.is_whitespace c
821
+
822
+
and fetch_block_entry t =
823
+
if t.flow_level = 0 then begin
824
+
if not t.allow_simple_key then
825
+
Error.raise_at (Input.mark t.input) Expected_block_entry;
826
+
let col = column t in
827
+
if roll_indent t col ~sequence:true then begin
828
+
let span = Span.point (Input.mark t.input) in
829
+
emit t span Token.Block_sequence_start
830
+
end
831
+
end;
832
+
remove_simple_key t;
833
+
t.allow_simple_key <- true;
834
+
let start = Input.mark t.input in
835
+
ignore (Input.next t.input);
836
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
837
+
emit t span Token.Block_entry
838
+
839
+
and check_key t =
840
+
(* ? followed by whitespace in block, any in flow *)
841
+
if t.flow_level > 0 then true
842
+
else match Input.peek_nth t.input 1 with
843
+
| None -> true
844
+
| Some c -> Input.is_whitespace c
845
+
846
+
and fetch_key t =
847
+
if t.flow_level = 0 then begin
848
+
if not t.allow_simple_key then
849
+
Error.raise_at (Input.mark t.input) Expected_key;
850
+
let col = column t in
851
+
if roll_indent t col ~sequence:false then begin
852
+
let span = Span.point (Input.mark t.input) in
853
+
emit t span Token.Block_mapping_start
854
+
end
855
+
end;
856
+
remove_simple_key t;
857
+
t.allow_simple_key <- t.flow_level = 0;
858
+
let start = Input.mark t.input in
859
+
ignore (Input.next t.input);
860
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
861
+
emit t span Token.Key
862
+
863
+
and check_value t =
864
+
(* : followed by whitespace in block, or flow indicator in flow *)
865
+
if t.flow_level > 0 then true
866
+
else match Input.peek_nth t.input 1 with
867
+
| None -> true
868
+
| Some c -> Input.is_whitespace c
869
+
870
+
and fetch_value t =
871
+
(* Check for simple key *)
872
+
(match t.simple_keys with
873
+
| Some sk :: _ when sk.sk_possible ->
874
+
(* Insert KEY token before the simple key value *)
875
+
let key_span = Span.point sk.sk_position in
876
+
let key_token = { Token.token = Token.Key; span = key_span } in
877
+
(* We need to insert at the right position *)
878
+
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
879
+
Queue.clear t.tokens;
880
+
let insert_pos = sk.sk_token_number - t.tokens_taken in
881
+
Array.iteri (fun i tok ->
882
+
if i = insert_pos then Queue.add key_token t.tokens;
883
+
Queue.add tok t.tokens
884
+
) tokens;
885
+
if insert_pos >= Array.length tokens then
886
+
Queue.add key_token t.tokens;
887
+
t.token_number <- t.token_number + 1;
888
+
(* Roll indent for implicit block mapping *)
889
+
if t.flow_level = 0 then begin
890
+
let col = sk.sk_position.column in
891
+
if roll_indent t col ~sequence:false then begin
892
+
let span = Span.point sk.sk_position in
893
+
(* Insert block mapping start before key *)
894
+
let bm_token = { Token.token = Token.Block_mapping_start; span } in
895
+
let tokens = Queue.to_seq t.tokens |> Array.of_seq in
896
+
Queue.clear t.tokens;
897
+
Array.iteri (fun i tok ->
898
+
if i = insert_pos then Queue.add bm_token t.tokens;
899
+
Queue.add tok t.tokens
900
+
) tokens;
901
+
if insert_pos >= Array.length tokens then
902
+
Queue.add bm_token t.tokens;
903
+
t.token_number <- t.token_number + 1
904
+
end
905
+
end;
906
+
t.simple_keys <- None :: (List.tl t.simple_keys)
907
+
| _ ->
908
+
(* No simple key - this is a complex value *)
909
+
if t.flow_level = 0 then begin
910
+
if not t.allow_simple_key then
911
+
Error.raise_at (Input.mark t.input) Expected_key;
912
+
let col = column t in
913
+
if roll_indent t col ~sequence:false then begin
914
+
let span = Span.point (Input.mark t.input) in
915
+
emit t span Token.Block_mapping_start
916
+
end
917
+
end);
918
+
remove_simple_key t;
919
+
t.allow_simple_key <- t.flow_level = 0;
920
+
let start = Input.mark t.input in
921
+
ignore (Input.next t.input);
922
+
let span = Span.make ~start ~stop:(Input.mark t.input) in
923
+
emit t span Token.Value
924
+
925
+
and fetch_alias t =
926
+
save_simple_key t;
927
+
t.allow_simple_key <- false;
928
+
let start = Input.mark t.input in
929
+
ignore (Input.next t.input); (* consume * *)
930
+
let name, span = scan_anchor_alias t in
931
+
let span = Span.make ~start ~stop:span.stop in
932
+
emit t span (Token.Alias name)
933
+
934
+
and fetch_anchor t =
935
+
save_simple_key t;
936
+
t.allow_simple_key <- false;
937
+
let start = Input.mark t.input in
938
+
ignore (Input.next t.input); (* consume & *)
939
+
let name, span = scan_anchor_alias t in
940
+
let span = Span.make ~start ~stop:span.stop in
941
+
emit t span (Token.Anchor name)
942
+
943
+
and fetch_tag t =
944
+
save_simple_key t;
945
+
t.allow_simple_key <- false;
946
+
let handle, suffix, span = scan_tag t in
947
+
emit t span (Token.Tag { handle; suffix })
948
+
949
+
and fetch_block_scalar t literal =
950
+
remove_simple_key t;
951
+
t.allow_simple_key <- true;
952
+
let value, style, span = scan_block_scalar t literal in
953
+
emit t span (Token.Scalar { style; value })
954
+
955
+
and fetch_single_quoted t =
956
+
save_simple_key t;
957
+
t.allow_simple_key <- false;
958
+
let value, span = scan_single_quoted t in
959
+
emit t span (Token.Scalar { style = Scalar_style.Single_quoted; value })
960
+
961
+
and fetch_double_quoted t =
962
+
save_simple_key t;
963
+
t.allow_simple_key <- false;
964
+
let value, span = scan_double_quoted t in
965
+
emit t span (Token.Scalar { style = Scalar_style.Double_quoted; value })
966
+
967
+
and can_start_plain t =
968
+
(* Check if - ? : can start a plain scalar *)
969
+
match Input.peek_nth t.input 1 with
970
+
| None -> false
971
+
| Some c ->
972
+
not (Input.is_whitespace c) &&
973
+
(t.flow_level = 0 || not (Input.is_flow_indicator c))
974
+
975
+
and can_start_plain_char c _t =
976
+
(* Characters that can start a plain scalar *)
977
+
if Input.is_whitespace c then false
978
+
else if Input.is_indicator c then false
979
+
else true
980
+
981
+
and fetch_plain_scalar t =
982
+
save_simple_key t;
983
+
t.allow_simple_key <- false;
984
+
let value, span = scan_plain_scalar t in
985
+
emit t span (Token.Scalar { style = Scalar_style.Plain; value })
986
+
987
+
(** Check if we need more tokens to resolve simple keys *)
988
+
let need_more_tokens t =
989
+
if t.stream_ended then false
990
+
else if Queue.is_empty t.tokens then true
991
+
else
992
+
(* Check if any simple key could affect the first queued token *)
993
+
List.exists (function
994
+
| Some sk when sk.sk_possible ->
995
+
sk.sk_token_number >= t.tokens_taken
996
+
| _ -> false
997
+
) t.simple_keys
998
+
999
+
(** Ensure we have enough tokens to return one safely *)
1000
+
let ensure_tokens t =
1001
+
if not t.stream_started then begin
1002
+
t.stream_started <- true;
1003
+
let span = Span.point (Input.position t.input) in
1004
+
let encoding, _ = Encoding.detect t.input.source in
1005
+
emit t span (Token.Stream_start encoding)
1006
+
end;
1007
+
while need_more_tokens t do
1008
+
fetch_next_token t
1009
+
done
1010
+
1011
+
(** Get next token *)
1012
+
let next t =
1013
+
ensure_tokens t;
1014
+
if Queue.is_empty t.tokens then
1015
+
None
1016
+
else begin
1017
+
t.tokens_taken <- t.tokens_taken + 1;
1018
+
Some (Queue.pop t.tokens)
1019
+
end
1020
+
1021
+
(** Peek at next token *)
1022
+
let peek t =
1023
+
ensure_tokens t;
1024
+
Queue.peek_opt t.tokens
1025
+
1026
+
(** Iterate over all tokens *)
1027
+
let iter f t =
1028
+
let rec loop () =
1029
+
match next t with
1030
+
| None -> ()
1031
+
| Some tok -> f tok; loop ()
1032
+
in
1033
+
loop ()
1034
+
1035
+
(** Fold over all tokens *)
1036
+
let fold f init t =
1037
+
let rec loop acc =
1038
+
match next t with
1039
+
| None -> acc
1040
+
| Some tok -> loop (f acc tok)
1041
+
in
1042
+
loop init
1043
+
1044
+
(** Convert to list *)
1045
+
let to_list t =
1046
+
fold (fun acc tok -> tok :: acc) [] t |> List.rev
+72
yaml/ocaml-yamle/lib/sequence.ml
+72
yaml/ocaml-yamle/lib/sequence.ml
···
1
+
(** YAML sequence (array) values with metadata *)
2
+
3
+
type 'a t = {
4
+
anchor : string option;
5
+
tag : string option;
6
+
implicit : bool;
7
+
style : Layout_style.t;
8
+
members : 'a list;
9
+
}
10
+
11
+
let make
12
+
?(anchor : string option)
13
+
?(tag : string option)
14
+
?(implicit = true)
15
+
?(style = Layout_style.Any)
16
+
members =
17
+
{ anchor; tag; implicit; style; members }
18
+
19
+
let members t = t.members
20
+
let anchor t = t.anchor
21
+
let tag t = t.tag
22
+
let implicit t = t.implicit
23
+
let style t = t.style
24
+
25
+
let with_anchor anchor t = { t with anchor = Some anchor }
26
+
let with_tag tag t = { t with tag = Some tag }
27
+
let with_style style t = { t with style }
28
+
29
+
let map f t = { t with members = List.map f t.members }
30
+
31
+
let length t = List.length t.members
32
+
33
+
let is_empty t = t.members = []
34
+
35
+
let nth t n = List.nth t.members n
36
+
37
+
let nth_opt t n = List.nth_opt t.members n
38
+
39
+
let iter f t = List.iter f t.members
40
+
41
+
let fold f init t = List.fold_left f init t.members
42
+
43
+
let pp pp_elem fmt t =
44
+
Format.fprintf fmt "@[<hv 2>sequence(@,";
45
+
(match t.anchor with
46
+
| Some a -> Format.fprintf fmt "anchor=%s,@ " a
47
+
| None -> ());
48
+
(match t.tag with
49
+
| Some tag -> Format.fprintf fmt "tag=%s,@ " tag
50
+
| None -> ());
51
+
Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style;
52
+
Format.fprintf fmt "members=[@,%a@]@,)"
53
+
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp_elem)
54
+
t.members
55
+
56
+
let equal eq a b =
57
+
Option.equal String.equal a.anchor b.anchor &&
58
+
Option.equal String.equal a.tag b.tag &&
59
+
a.implicit = b.implicit &&
60
+
Layout_style.equal a.style b.style &&
61
+
List.equal eq a.members b.members
62
+
63
+
let compare cmp a b =
64
+
let c = Option.compare String.compare a.anchor b.anchor in
65
+
if c <> 0 then c else
66
+
let c = Option.compare String.compare a.tag b.tag in
67
+
if c <> 0 then c else
68
+
let c = Bool.compare a.implicit b.implicit in
69
+
if c <> 0 then c else
70
+
let c = Layout_style.compare a.style b.style in
71
+
if c <> 0 then c else
72
+
List.compare cmp a.members b.members
+35
yaml/ocaml-yamle/lib/span.ml
+35
yaml/ocaml-yamle/lib/span.ml
···
1
+
(** Source spans representing ranges in input *)
2
+
3
+
type t = {
4
+
start : Position.t;
5
+
stop : Position.t;
6
+
}
7
+
8
+
let make ~start ~stop = { start; stop }
9
+
10
+
let point pos = { start = pos; stop = pos }
11
+
12
+
let merge a b =
13
+
let start = if Position.compare a.start b.start <= 0 then a.start else b.start in
14
+
let stop = if Position.compare a.stop b.stop >= 0 then a.stop else b.stop in
15
+
{ start; stop }
16
+
17
+
let extend span pos =
18
+
{ span with stop = pos }
19
+
20
+
let pp fmt t =
21
+
if t.start.line = t.stop.line then
22
+
Format.fprintf fmt "line %d, columns %d-%d"
23
+
t.start.line t.start.column t.stop.column
24
+
else
25
+
Format.fprintf fmt "lines %d-%d" t.start.line t.stop.line
26
+
27
+
let to_string t =
28
+
Format.asprintf "%a" pp t
29
+
30
+
let compare a b =
31
+
let c = Position.compare a.start b.start in
32
+
if c <> 0 then c else Position.compare a.stop b.stop
33
+
34
+
let equal a b =
35
+
Position.equal a.start b.start && Position.equal a.stop b.stop
+70
yaml/ocaml-yamle/lib/tag.ml
+70
yaml/ocaml-yamle/lib/tag.ml
···
1
+
(** YAML tags for type information *)
2
+
3
+
type t = {
4
+
handle : string; (** e.g., "!" or "!!" or "!foo!" *)
5
+
suffix : string; (** e.g., "str", "int", "custom/type" *)
6
+
}
7
+
8
+
let make ~handle ~suffix = { handle; suffix }
9
+
10
+
let of_string s =
11
+
if String.length s = 0 then None
12
+
else if s.[0] <> '!' then None
13
+
else
14
+
(* Find the suffix after the handle *)
15
+
let len = String.length s in
16
+
if len = 1 then Some { handle = "!"; suffix = "" }
17
+
else if s.[1] = '!' then
18
+
(* !! handle *)
19
+
Some { handle = "!!"; suffix = String.sub s 2 (len - 2) }
20
+
else if s.[1] = '<' then
21
+
(* Verbatim tag !<...> *)
22
+
if len > 2 && s.[len - 1] = '>' then
23
+
Some { handle = "!"; suffix = String.sub s 2 (len - 3) }
24
+
else
25
+
None
26
+
else
27
+
(* Primary handle or local tag *)
28
+
Some { handle = "!"; suffix = String.sub s 1 (len - 1) }
29
+
30
+
let to_string t =
31
+
if t.handle = "!" && t.suffix = "" then "!"
32
+
else t.handle ^ t.suffix
33
+
34
+
let to_uri t =
35
+
match t.handle with
36
+
| "!!" -> "tag:yaml.org,2002:" ^ t.suffix
37
+
| "!" -> "!" ^ t.suffix
38
+
| h -> h ^ t.suffix
39
+
40
+
let pp fmt t =
41
+
Format.pp_print_string fmt (to_string t)
42
+
43
+
let equal a b =
44
+
String.equal a.handle b.handle && String.equal a.suffix b.suffix
45
+
46
+
let compare a b =
47
+
let c = String.compare a.handle b.handle in
48
+
if c <> 0 then c else String.compare a.suffix b.suffix
49
+
50
+
(** Standard tags *)
51
+
52
+
let null = { handle = "!!"; suffix = "null" }
53
+
let bool = { handle = "!!"; suffix = "bool" }
54
+
let int = { handle = "!!"; suffix = "int" }
55
+
let float = { handle = "!!"; suffix = "float" }
56
+
let str = { handle = "!!"; suffix = "str" }
57
+
let seq = { handle = "!!"; suffix = "seq" }
58
+
let map = { handle = "!!"; suffix = "map" }
59
+
let binary = { handle = "!!"; suffix = "binary" }
60
+
let timestamp = { handle = "!!"; suffix = "timestamp" }
61
+
62
+
(** Check if tag matches a standard type *)
63
+
64
+
let is_null t = equal t null || (t.handle = "!" && t.suffix = "")
65
+
let is_bool t = equal t bool
66
+
let is_int t = equal t int
67
+
let is_float t = equal t float
68
+
let is_str t = equal t str
69
+
let is_seq t = equal t seq
70
+
let is_map t = equal t map
+78
yaml/ocaml-yamle/lib/token.ml
+78
yaml/ocaml-yamle/lib/token.ml
···
1
+
(** YAML token types produced by the scanner *)
2
+
3
+
type t =
4
+
| Stream_start of Encoding.t
5
+
| Stream_end
6
+
| Version_directive of { major : int; minor : int }
7
+
| Tag_directive of { handle : string; prefix : string }
8
+
| Document_start (** --- *)
9
+
| Document_end (** ... *)
10
+
| Block_sequence_start
11
+
| Block_mapping_start
12
+
| Block_entry (** - *)
13
+
| Block_end (** implicit, from dedent *)
14
+
| Flow_sequence_start (** [ *)
15
+
| Flow_sequence_end (** ] *)
16
+
| Flow_mapping_start (** { *)
17
+
| Flow_mapping_end (** } *)
18
+
| Flow_entry (** , *)
19
+
| Key (** ? or implicit key *)
20
+
| Value (** : *)
21
+
| Anchor of string (** &name *)
22
+
| Alias of string (** *name *)
23
+
| Tag of { handle : string; suffix : string }
24
+
| Scalar of { style : Scalar_style.t; value : string }
25
+
26
+
type spanned = {
27
+
token : t;
28
+
span : Span.t;
29
+
}
30
+
31
+
let pp_token fmt = function
32
+
| Stream_start enc ->
33
+
Format.fprintf fmt "STREAM-START(%a)" Encoding.pp enc
34
+
| Stream_end ->
35
+
Format.fprintf fmt "STREAM-END"
36
+
| Version_directive { major; minor } ->
37
+
Format.fprintf fmt "VERSION-DIRECTIVE(%d.%d)" major minor
38
+
| Tag_directive { handle; prefix } ->
39
+
Format.fprintf fmt "TAG-DIRECTIVE(%s, %s)" handle prefix
40
+
| Document_start ->
41
+
Format.fprintf fmt "DOCUMENT-START"
42
+
| Document_end ->
43
+
Format.fprintf fmt "DOCUMENT-END"
44
+
| Block_sequence_start ->
45
+
Format.fprintf fmt "BLOCK-SEQUENCE-START"
46
+
| Block_mapping_start ->
47
+
Format.fprintf fmt "BLOCK-MAPPING-START"
48
+
| Block_entry ->
49
+
Format.fprintf fmt "BLOCK-ENTRY"
50
+
| Block_end ->
51
+
Format.fprintf fmt "BLOCK-END"
52
+
| Flow_sequence_start ->
53
+
Format.fprintf fmt "FLOW-SEQUENCE-START"
54
+
| Flow_sequence_end ->
55
+
Format.fprintf fmt "FLOW-SEQUENCE-END"
56
+
| Flow_mapping_start ->
57
+
Format.fprintf fmt "FLOW-MAPPING-START"
58
+
| Flow_mapping_end ->
59
+
Format.fprintf fmt "FLOW-MAPPING-END"
60
+
| Flow_entry ->
61
+
Format.fprintf fmt "FLOW-ENTRY"
62
+
| Key ->
63
+
Format.fprintf fmt "KEY"
64
+
| Value ->
65
+
Format.fprintf fmt "VALUE"
66
+
| Anchor name ->
67
+
Format.fprintf fmt "ANCHOR(%s)" name
68
+
| Alias name ->
69
+
Format.fprintf fmt "ALIAS(%s)" name
70
+
| Tag { handle; suffix } ->
71
+
Format.fprintf fmt "TAG(%s, %s)" handle suffix
72
+
| Scalar { style; value } ->
73
+
Format.fprintf fmt "SCALAR(%a, %S)" Scalar_style.pp style value
74
+
75
+
let pp fmt t = pp_token fmt t
76
+
77
+
let pp_spanned fmt { token; span } =
78
+
Format.fprintf fmt "%a at %a" pp_token token Span.pp span
+182
yaml/ocaml-yamle/lib/value.ml
+182
yaml/ocaml-yamle/lib/value.ml
···
1
+
(** JSON-compatible YAML value representation *)
2
+
3
+
type t = [
4
+
| `Null
5
+
| `Bool of bool
6
+
| `Float of float
7
+
| `String of string
8
+
| `A of t list
9
+
| `O of (string * t) list
10
+
]
11
+
12
+
(** Constructors *)
13
+
14
+
let null : t = `Null
15
+
let bool b : t = `Bool b
16
+
let int n : t = `Float (Float.of_int n)
17
+
let float f : t = `Float f
18
+
let string s : t = `String s
19
+
20
+
let list f xs : t = `A (List.map f xs)
21
+
let obj pairs : t = `O pairs
22
+
23
+
(** Type name for error messages *)
24
+
let type_name : t -> string = function
25
+
| `Null -> "null"
26
+
| `Bool _ -> "bool"
27
+
| `Float _ -> "float"
28
+
| `String _ -> "string"
29
+
| `A _ -> "array"
30
+
| `O _ -> "object"
31
+
32
+
(** Safe accessors (return option) *)
33
+
34
+
let as_null = function `Null -> Some () | _ -> None
35
+
let as_bool = function `Bool b -> Some b | _ -> None
36
+
let as_float = function `Float f -> Some f | _ -> None
37
+
let as_string = function `String s -> Some s | _ -> None
38
+
let as_list = function `A l -> Some l | _ -> None
39
+
let as_assoc = function `O o -> Some o | _ -> None
40
+
41
+
let as_int = function
42
+
| `Float f ->
43
+
let i = Float.to_int f in
44
+
if Float.equal (Float.of_int i) f then Some i else None
45
+
| _ -> None
46
+
47
+
(** Unsafe accessors (raise on type mismatch) *)
48
+
49
+
let to_null v =
50
+
match as_null v with
51
+
| Some () -> ()
52
+
| None -> Error.raise (Type_mismatch ("null", type_name v))
53
+
54
+
let to_bool v =
55
+
match as_bool v with
56
+
| Some b -> b
57
+
| None -> Error.raise (Type_mismatch ("bool", type_name v))
58
+
59
+
let to_float v =
60
+
match as_float v with
61
+
| Some f -> f
62
+
| None -> Error.raise (Type_mismatch ("float", type_name v))
63
+
64
+
let to_string v =
65
+
match as_string v with
66
+
| Some s -> s
67
+
| None -> Error.raise (Type_mismatch ("string", type_name v))
68
+
69
+
let to_list v =
70
+
match as_list v with
71
+
| Some l -> l
72
+
| None -> Error.raise (Type_mismatch ("array", type_name v))
73
+
74
+
let to_assoc v =
75
+
match as_assoc v with
76
+
| Some o -> o
77
+
| None -> Error.raise (Type_mismatch ("object", type_name v))
78
+
79
+
let to_int v =
80
+
match as_int v with
81
+
| Some i -> i
82
+
| None -> Error.raise (Type_mismatch ("int", type_name v))
83
+
84
+
(** Object access *)
85
+
86
+
let mem key = function
87
+
| `O pairs -> List.exists (fun (k, _) -> k = key) pairs
88
+
| _ -> false
89
+
90
+
let find key = function
91
+
| `O pairs -> List.assoc_opt key pairs
92
+
| _ -> None
93
+
94
+
let get key v =
95
+
match find key v with
96
+
| Some v -> v
97
+
| None -> Error.raise (Key_not_found key)
98
+
99
+
let keys = function
100
+
| `O pairs -> List.map fst pairs
101
+
| v -> Error.raise (Type_mismatch ("object", type_name v))
102
+
103
+
let values = function
104
+
| `O pairs -> List.map snd pairs
105
+
| v -> Error.raise (Type_mismatch ("object", type_name v))
106
+
107
+
(** Combinators *)
108
+
109
+
let combine v1 v2 =
110
+
match v1, v2 with
111
+
| `O o1, `O o2 -> `O (o1 @ o2)
112
+
| v1, _ -> Error.raise (Type_mismatch ("object", type_name v1))
113
+
114
+
let map f = function
115
+
| `A l -> `A (List.map f l)
116
+
| v -> Error.raise (Type_mismatch ("array", type_name v))
117
+
118
+
let filter pred = function
119
+
| `A l -> `A (List.filter pred l)
120
+
| v -> Error.raise (Type_mismatch ("array", type_name v))
121
+
122
+
(** Pretty printing *)
123
+
124
+
let rec pp fmt (v : t) =
125
+
match v with
126
+
| `Null -> Format.pp_print_string fmt "null"
127
+
| `Bool b -> Format.pp_print_bool fmt b
128
+
| `Float f ->
129
+
if Float.is_integer f && Float.abs f < 1e15 then
130
+
Format.fprintf fmt "%.0f" f
131
+
else
132
+
Format.fprintf fmt "%g" f
133
+
| `String s -> Format.fprintf fmt "%S" s
134
+
| `A [] -> Format.pp_print_string fmt "[]"
135
+
| `A items ->
136
+
Format.fprintf fmt "@[<hv 2>[@,%a@]@,]"
137
+
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp)
138
+
items
139
+
| `O [] -> Format.pp_print_string fmt "{}"
140
+
| `O pairs ->
141
+
Format.fprintf fmt "@[<hv 2>{@,%a@]@,}"
142
+
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
143
+
(fun fmt (k, v) -> Format.fprintf fmt "@[<hv 2>%S:@ %a@]" k pp v))
144
+
pairs
145
+
146
+
(** Equality and comparison *)
147
+
148
+
let rec equal (a : t) (b : t) =
149
+
match a, b with
150
+
| `Null, `Null -> true
151
+
| `Bool a, `Bool b -> a = b
152
+
| `Float a, `Float b -> Float.equal a b
153
+
| `String a, `String b -> String.equal a b
154
+
| `A a, `A b -> List.equal equal a b
155
+
| `O a, `O b ->
156
+
List.length a = List.length b &&
157
+
List.for_all2 (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) a b
158
+
| _ -> false
159
+
160
+
let rec compare (a : t) (b : t) =
161
+
match a, b with
162
+
| `Null, `Null -> 0
163
+
| `Null, _ -> -1
164
+
| _, `Null -> 1
165
+
| `Bool a, `Bool b -> Bool.compare a b
166
+
| `Bool _, _ -> -1
167
+
| _, `Bool _ -> 1
168
+
| `Float a, `Float b -> Float.compare a b
169
+
| `Float _, _ -> -1
170
+
| _, `Float _ -> 1
171
+
| `String a, `String b -> String.compare a b
172
+
| `String _, _ -> -1
173
+
| _, `String _ -> 1
174
+
| `A a, `A b -> List.compare compare a b
175
+
| `A _, _ -> -1
176
+
| _, `A _ -> 1
177
+
| `O a, `O b ->
178
+
let cmp_pair (k1, v1) (k2, v2) =
179
+
let c = String.compare k1 k2 in
180
+
if c <> 0 then c else compare v1 v2
181
+
in
182
+
List.compare cmp_pair a b
+224
yaml/ocaml-yamle/lib/yaml.ml
+224
yaml/ocaml-yamle/lib/yaml.ml
···
1
+
(** Full YAML representation with anchors, tags, and aliases *)
2
+
3
+
type t = [
4
+
| `Scalar of Scalar.t
5
+
| `Alias of string
6
+
| `A of t Sequence.t
7
+
| `O of (t, t) Mapping.t
8
+
]
9
+
10
+
(** Pretty printing *)
11
+
12
+
let rec pp fmt (v : t) =
13
+
match v with
14
+
| `Scalar s -> Scalar.pp fmt s
15
+
| `Alias name -> Format.fprintf fmt "*%s" name
16
+
| `A seq -> Sequence.pp pp fmt seq
17
+
| `O map -> Mapping.pp pp pp fmt map
18
+
19
+
(** Equality *)
20
+
21
+
let rec equal (a : t) (b : t) =
22
+
match a, b with
23
+
| `Scalar a, `Scalar b -> Scalar.equal a b
24
+
| `Alias a, `Alias b -> String.equal a b
25
+
| `A a, `A b -> Sequence.equal equal a b
26
+
| `O a, `O b -> Mapping.equal equal equal a b
27
+
| _ -> false
28
+
29
+
(** Construct from JSON-compatible Value *)
30
+
31
+
let rec of_value (v : Value.t) : t =
32
+
match v with
33
+
| `Null -> `Scalar (Scalar.make "null")
34
+
| `Bool true -> `Scalar (Scalar.make "true")
35
+
| `Bool false -> `Scalar (Scalar.make "false")
36
+
| `Float f ->
37
+
let s =
38
+
if Float.is_integer f && Float.abs f < 1e15 then
39
+
Printf.sprintf "%.0f" f
40
+
else
41
+
Printf.sprintf "%g" f
42
+
in
43
+
`Scalar (Scalar.make s)
44
+
| `String s ->
45
+
`Scalar (Scalar.make s ~style:Scalar_style.Double_quoted)
46
+
| `A items ->
47
+
`A (Sequence.make (List.map of_value items))
48
+
| `O pairs ->
49
+
`O (Mapping.make (List.map (fun (k, v) ->
50
+
(`Scalar (Scalar.make k), of_value v)
51
+
) pairs))
52
+
53
+
(** Convert to JSON-compatible Value *)
54
+
55
+
let rec to_value (v : t) : Value.t =
56
+
match v with
57
+
| `Scalar s -> scalar_to_value s
58
+
| `Alias name -> Error.raise (Unresolved_alias name)
59
+
| `A seq -> `A (List.map to_value (Sequence.members seq))
60
+
| `O map ->
61
+
`O (List.map (fun (k, v) ->
62
+
let key = match k with
63
+
| `Scalar s -> Scalar.value s
64
+
| _ -> Error.raise (Type_mismatch ("string key", "complex key"))
65
+
in
66
+
(key, to_value v)
67
+
) (Mapping.members map))
68
+
69
+
(** Convert scalar to JSON value based on content *)
70
+
and scalar_to_value s =
71
+
let value = Scalar.value s in
72
+
let tag = Scalar.tag s in
73
+
let style = Scalar.style s in
74
+
75
+
(* If explicitly tagged, respect the tag *)
76
+
match tag with
77
+
| Some "tag:yaml.org,2002:null" | Some "!!null" ->
78
+
`Null
79
+
| Some "tag:yaml.org,2002:bool" | Some "!!bool" ->
80
+
(match String.lowercase_ascii value with
81
+
| "true" | "yes" | "on" -> `Bool true
82
+
| "false" | "no" | "off" -> `Bool false
83
+
| _ -> Error.raise (Invalid_scalar_conversion (value, "bool")))
84
+
| Some "tag:yaml.org,2002:int" | Some "!!int" ->
85
+
(try `Float (Float.of_string value)
86
+
with _ -> Error.raise (Invalid_scalar_conversion (value, "int")))
87
+
| Some "tag:yaml.org,2002:float" | Some "!!float" ->
88
+
(try `Float (Float.of_string value)
89
+
with _ -> Error.raise (Invalid_scalar_conversion (value, "float")))
90
+
| Some "tag:yaml.org,2002:str" | Some "!!str" ->
91
+
`String value
92
+
| Some _ ->
93
+
(* Unknown tag - treat as string *)
94
+
`String value
95
+
| None ->
96
+
(* Implicit type resolution for plain scalars *)
97
+
if style <> Scalar_style.Plain then
98
+
`String value
99
+
else
100
+
infer_scalar_type value
101
+
102
+
(** Infer type from plain scalar value *)
103
+
and infer_scalar_type value =
104
+
let lower = String.lowercase_ascii value in
105
+
(* Null *)
106
+
if value = "" || lower = "null" || lower = "~" then
107
+
`Null
108
+
(* Boolean *)
109
+
else if lower = "true" || lower = "yes" || lower = "on" then
110
+
`Bool true
111
+
else if lower = "false" || lower = "no" || lower = "off" then
112
+
`Bool false
113
+
(* Special floats *)
114
+
else if lower = ".inf" || lower = "+.inf" then
115
+
`Float Float.infinity
116
+
else if lower = "-.inf" then
117
+
`Float Float.neg_infinity
118
+
else if lower = ".nan" then
119
+
`Float Float.nan
120
+
(* Try numeric *)
121
+
else
122
+
try_parse_number value
123
+
124
+
(** Try to parse as number *)
125
+
and try_parse_number value =
126
+
(* Try integer first *)
127
+
let try_int () =
128
+
if String.length value > 0 then
129
+
let first = value.[0] in
130
+
if first = '-' || first = '+' || (first >= '0' && first <= '9') then
131
+
try
132
+
(* Handle octal: 0o prefix or leading 0 *)
133
+
if String.length value > 2 && value.[0] = '0' then
134
+
match value.[1] with
135
+
| 'x' | 'X' ->
136
+
(* Hex *)
137
+
Some (`Float (Float.of_int (int_of_string value)))
138
+
| 'o' | 'O' ->
139
+
(* Octal *)
140
+
Some (`Float (Float.of_int (int_of_string value)))
141
+
| 'b' | 'B' ->
142
+
(* Binary *)
143
+
Some (`Float (Float.of_int (int_of_string value)))
144
+
| _ ->
145
+
(* Decimal with leading zero or octal in YAML 1.1 *)
146
+
Some (`Float (Float.of_string value))
147
+
else
148
+
Some (`Float (Float.of_string value))
149
+
with _ -> None
150
+
else None
151
+
else None
152
+
in
153
+
match try_int () with
154
+
| Some v -> v
155
+
| None ->
156
+
(* Try float *)
157
+
try
158
+
let f = Float.of_string value in
159
+
`Float f
160
+
with _ ->
161
+
(* Not a number - it's a string *)
162
+
`String value
163
+
164
+
(** Resolve aliases by replacing them with referenced nodes *)
165
+
166
+
let resolve_aliases (root : t) : t =
167
+
let anchors = Hashtbl.create 16 in
168
+
169
+
(* First pass: collect all anchors *)
170
+
let rec collect (v : t) =
171
+
match v with
172
+
| `Scalar s ->
173
+
(match Scalar.anchor s with
174
+
| Some name -> Hashtbl.replace anchors name v
175
+
| None -> ())
176
+
| `Alias _ -> ()
177
+
| `A seq ->
178
+
(match Sequence.anchor seq with
179
+
| Some name -> Hashtbl.replace anchors name v
180
+
| None -> ());
181
+
List.iter collect (Sequence.members seq)
182
+
| `O map ->
183
+
(match Mapping.anchor map with
184
+
| Some name -> Hashtbl.replace anchors name v
185
+
| None -> ());
186
+
List.iter (fun (k, v) -> collect k; collect v) (Mapping.members map)
187
+
in
188
+
collect root;
189
+
190
+
(* Second pass: resolve aliases *)
191
+
let rec resolve (v : t) : t =
192
+
match v with
193
+
| `Scalar _ -> v
194
+
| `Alias name ->
195
+
(match Hashtbl.find_opt anchors name with
196
+
| Some target -> resolve target
197
+
| None -> Error.raise (Undefined_alias name))
198
+
| `A seq ->
199
+
`A (Sequence.map resolve seq)
200
+
| `O map ->
201
+
`O (Mapping.make
202
+
?anchor:(Mapping.anchor map)
203
+
?tag:(Mapping.tag map)
204
+
~implicit:(Mapping.implicit map)
205
+
~style:(Mapping.style map)
206
+
(List.map (fun (k, v) -> (resolve k, resolve v)) (Mapping.members map)))
207
+
in
208
+
resolve root
209
+
210
+
(** Get anchor from any node *)
211
+
let anchor (v : t) =
212
+
match v with
213
+
| `Scalar s -> Scalar.anchor s
214
+
| `Alias _ -> None
215
+
| `A seq -> Sequence.anchor seq
216
+
| `O map -> Mapping.anchor map
217
+
218
+
(** Get tag from any node *)
219
+
let tag (v : t) =
220
+
match v with
221
+
| `Scalar s -> Scalar.tag s
222
+
| `Alias _ -> None
223
+
| `A seq -> Sequence.tag seq
224
+
| `O map -> Mapping.tag map
+149
yaml/ocaml-yamle/lib/yamle.ml
+149
yaml/ocaml-yamle/lib/yamle.ml
···
1
+
type value = Value.t
2
+
type yaml = Yaml.t
3
+
4
+
type version = [ `V1_1 | `V1_2 ]
5
+
6
+
type encoding = Encoding.t
7
+
type scalar_style = Scalar_style.t
8
+
type layout_style = Layout_style.t
9
+
10
+
(** {1 Error handling} *)
11
+
12
+
type error = Error.t
13
+
exception Yamle_error = Error.Yamle_error
14
+
15
+
(** {1 JSON-compatible parsing} *)
16
+
17
+
let of_string s = Loader.value_of_string s
18
+
19
+
(** {1 JSON-compatible emission} *)
20
+
21
+
let to_string
22
+
?(encoding = Encoding.Utf8)
23
+
?(scalar_style = Scalar_style.Any)
24
+
?(layout_style = Layout_style.Any)
25
+
value =
26
+
let config = {
27
+
Emitter.default_config with
28
+
encoding;
29
+
scalar_style;
30
+
layout_style;
31
+
} in
32
+
Emitter.value_to_string ~config value
33
+
34
+
(** {1 YAML-specific parsing} *)
35
+
36
+
let yaml_of_string s = Loader.yaml_of_string s
37
+
38
+
(** {1 YAML-specific emission} *)
39
+
40
+
let yaml_to_string
41
+
?(encoding = Encoding.Utf8)
42
+
?(scalar_style = Scalar_style.Any)
43
+
?(layout_style = Layout_style.Any)
44
+
yaml =
45
+
let config = {
46
+
Emitter.default_config with
47
+
encoding;
48
+
scalar_style;
49
+
layout_style;
50
+
} in
51
+
Emitter.yaml_to_string ~config yaml
52
+
53
+
(** {1 Conversion} *)
54
+
55
+
let to_json yaml = Yaml.to_value yaml
56
+
57
+
let of_json value = Yaml.of_value value
58
+
59
+
(** {1 Pretty printing} *)
60
+
61
+
let pp = Value.pp
62
+
let pp_yaml = Yaml.pp
63
+
let equal = Value.equal
64
+
let equal_yaml = Yaml.equal
65
+
66
+
(** {1 Nested modules} *)
67
+
68
+
module Error = Error
69
+
module Position = Position
70
+
module Span = Span
71
+
module Encoding = Encoding
72
+
module Input = Input
73
+
module Scalar_style = Scalar_style
74
+
module Layout_style = Layout_style
75
+
module Chomping = Chomping
76
+
module Token = Token
77
+
module Scanner = Scanner
78
+
module Event = Event
79
+
module Parser = Parser
80
+
module Tag = Tag
81
+
module Value = Value
82
+
module Scalar = Scalar
83
+
module Sequence = Sequence
84
+
module Mapping = Mapping
85
+
module Yaml = Yaml
86
+
module Document = Document
87
+
module Loader = Loader
88
+
module Emitter = Emitter
89
+
90
+
(** {1 Streaming interface} *)
91
+
92
+
module Stream = struct
93
+
type parser = Parser.t
94
+
type emitter = Emitter.t
95
+
96
+
let parser s = Parser.of_string s
97
+
98
+
let do_parse p = Parser.next p
99
+
100
+
let emitter ?len:_ () = Emitter.create ()
101
+
102
+
let emit e ev = Emitter.emit e ev
103
+
104
+
let emitter_buf e = Emitter.contents e
105
+
106
+
(** Convenience event emitters *)
107
+
108
+
let stream_start e enc =
109
+
Emitter.emit e (Event.Stream_start { encoding = enc })
110
+
111
+
let stream_end e =
112
+
Emitter.emit e Event.Stream_end
113
+
114
+
let document_start ?version ?(implicit = true) e =
115
+
let version = match version with
116
+
| Some `V1_1 -> Some (1, 1)
117
+
| Some `V1_2 -> Some (1, 2)
118
+
| None -> None
119
+
in
120
+
Emitter.emit e (Event.Document_start { version; implicit })
121
+
122
+
let document_end ?(implicit = true) e =
123
+
Emitter.emit e (Event.Document_end { implicit })
124
+
125
+
let scalar s e =
126
+
Emitter.emit e (Event.Scalar {
127
+
anchor = Scalar.anchor s;
128
+
tag = Scalar.tag s;
129
+
value = Scalar.value s;
130
+
plain_implicit = Scalar.plain_implicit s;
131
+
quoted_implicit = Scalar.quoted_implicit s;
132
+
style = Scalar.style s;
133
+
})
134
+
135
+
let alias e name =
136
+
Emitter.emit e (Event.Alias { anchor = name })
137
+
138
+
let sequence_start ?anchor ?tag ?(implicit = true) ?(style = Layout_style.Any) e =
139
+
Emitter.emit e (Event.Sequence_start { anchor; tag; implicit; style })
140
+
141
+
let sequence_end e =
142
+
Emitter.emit e Event.Sequence_end
143
+
144
+
let mapping_start ?anchor ?tag ?(implicit = true) ?(style = Layout_style.Any) e =
145
+
Emitter.emit e (Event.Mapping_start { anchor; tag; implicit; style })
146
+
147
+
let mapping_end e =
148
+
Emitter.emit e Event.Mapping_end
149
+
end
+7
yaml/ocaml-yamle/tests/cram/dune
+7
yaml/ocaml-yamle/tests/cram/dune
+161
yaml/ocaml-yamle/tests/cram/yamlcat.t
+161
yaml/ocaml-yamle/tests/cram/yamlcat.t
···
1
+
Test yamlcat with simple YAML
2
+
3
+
$ echo 'hello: world' | yamlcat
4
+
hello: world
5
+
6
+
$ echo 'name: Alice
7
+
> age: 30' | yamlcat
8
+
name: Alice
9
+
age: 30
10
+
11
+
Test nested mappings
12
+
13
+
$ echo 'server:
14
+
> host: localhost
15
+
> port: 8080
16
+
> database:
17
+
> name: mydb' | yamlcat
18
+
server:
19
+
host: localhost
20
+
port: 8080
21
+
database:
22
+
name: mydb
23
+
24
+
Test sequences
25
+
26
+
$ echo '- apple
27
+
> - banana
28
+
> - cherry' | yamlcat
29
+
- apple
30
+
- banana
31
+
- cherry
32
+
33
+
Test mapping with sequence value
34
+
35
+
$ echo 'fruits:
36
+
> - apple
37
+
> - banana' | yamlcat
38
+
fruits:
39
+
- apple
40
+
- banana
41
+
42
+
Test flow style output
43
+
44
+
$ echo 'name: Alice
45
+
> hobbies:
46
+
> - reading
47
+
> - coding' | yamlcat --flow
48
+
{name: Alice, hobbies: [reading, coding]}
49
+
50
+
Test JSON output
51
+
52
+
$ echo 'name: Alice
53
+
> age: 30' | yamlcat --json
54
+
{"name": "Alice", "age": 30}
55
+
56
+
Test seq.yml file (multiline plain scalar)
57
+
58
+
$ yamlcat ../yaml/seq.yml
59
+
- hello - whats - up
60
+
- foo
61
+
- bar
62
+
63
+
Test seq.yml roundtrip preserves data
64
+
65
+
$ yamlcat --json ../yaml/seq.yml
66
+
["hello - whats - up", "foo", "bar"]
67
+
68
+
Test cohttp.yml
69
+
70
+
$ yamlcat ../yaml/cohttp.yml
71
+
language: c
72
+
sudo: false
73
+
services:
74
+
- docker
75
+
install: 'wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh'
76
+
script: bash -ex ./.travis-docker.sh
77
+
env:
78
+
global:
79
+
- "EXTRA_REMOTES=\"https://github.com/mirage/mirage-dev.git\""
80
+
- "PINS=\"cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:.\""
81
+
matrix:
82
+
- "PACKAGE=\"cohttp\" DISTRO=\"alpine-3.5\" OCAML_VERSION=\"4.06.0\""
83
+
- "PACKAGE=\"cohttp-async\" DISTRO=\"alpine\" OCAML_VERSION=\"4.06.0\""
84
+
- "PACKAGE=\"cohttp-lwt\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""
85
+
- "PACKAGE=\"cohttp-mirage\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""
86
+
notifications:
87
+
webhooks:
88
+
urls:
89
+
- 'https://webhooks.gitter.im/e/6ee5059c7420709f4ad1'
90
+
on_success: change
91
+
on_failure: always
92
+
on_start: false
93
+
94
+
Test cohttp.yml roundtrip with JSON
95
+
96
+
$ yamlcat --json ../yaml/cohttp.yml
97
+
{"language": "c", "sudo": false, "services": ["docker"], "install": "wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh", "script": "bash -ex ./.travis-docker.sh", "env": {"global": ["EXTRA_REMOTES=\"https://github.com/mirage/mirage-dev.git\"", "PINS=\"cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:.\""], "matrix": ["PACKAGE=\"cohttp\" DISTRO=\"alpine-3.5\" OCAML_VERSION=\"4.06.0\"", "PACKAGE=\"cohttp-async\" DISTRO=\"alpine\" OCAML_VERSION=\"4.06.0\"", "PACKAGE=\"cohttp-lwt\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\"", "PACKAGE=\"cohttp-mirage\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""]}, "notifications": {"webhooks": {"urls": ["https://webhooks.gitter.im/e/6ee5059c7420709f4ad1"], "on_success": "change", "on_failure": "always", "on_start": false}}}
98
+
99
+
Test special values
100
+
101
+
$ echo 'null_val: null
102
+
> bool_true: true
103
+
> bool_false: false
104
+
> number: 42
105
+
> float: 3.14' | yamlcat --json
106
+
{"null_val": null, "bool_true": true, "bool_false": false, "number": 42, "float": 3.14}
107
+
108
+
Test quoted strings
109
+
110
+
$ echo 'single: '"'"'hello world'"'"'
111
+
> double: "hello world"' | yamlcat
112
+
single: hello world
113
+
double: hello world
114
+
115
+
Test literal block scalar
116
+
117
+
$ echo 'text: |
118
+
> line one
119
+
> line two' | yamlcat --json
120
+
{"text": "line one\nline two\n"}
121
+
122
+
Test folded block scalar
123
+
124
+
$ echo 'text: >
125
+
> line one
126
+
> line two' | yamlcat --json
127
+
{"text": "line one line two\n"}
128
+
129
+
Test linuxkit.yml (sequences of mappings)
130
+
131
+
$ yamlcat ../yaml/linuxkit.yml | head -30
132
+
kernel:
133
+
image: 'linuxkit/kernel:4.9.40'
134
+
cmdline: console=tty0 console=ttyS0
135
+
init:
136
+
- 'linuxkit/init:906e174b3f2e07f97d6fd693a2e8518e98dafa58'
137
+
- 'linuxkit/runc:90e45f13e1d0a0983f36ef854621e3eac91cf541'
138
+
- 'linuxkit/containerd:7c986fb7df33bea73b5c8097b46989e46f49d875'
139
+
- 'linuxkit/ca-certificates:e44b0a66df5a102c0e220f0066b0d904710dcb10'
140
+
onboot:
141
+
- name: sysctl
142
+
image: 'linuxkit/sysctl:184c914d23a017062d7b53d7fc1dfaf47764bef6'
143
+
- name: dhcpcd
144
+
image: 'linuxkit/dhcpcd:f3f5413abb78fae9020e35bd4788fa93df4530b7'
145
+
command:
146
+
- /sbin/dhcpcd
147
+
- '--nobackground'
148
+
- '-f'
149
+
- /dhcpcd.conf
150
+
- '-1'
151
+
onshutdown:
152
+
- name: shutdown
153
+
image: 'busybox:latest'
154
+
command:
155
+
- /bin/echo
156
+
- so long and thanks for all the fish
157
+
services:
158
+
- name: getty
159
+
image: 'linuxkit/getty:2c841cdc34396e3fa8f25b62d112808f63f16df6'
160
+
env:
161
+
- INSECURE=true
+262
yaml/ocaml-yamle/tests/test_yamle.ml
+262
yaml/ocaml-yamle/tests/test_yamle.ml
···
1
+
(** Tests for the Yamle library *)
2
+
3
+
open Yamle
4
+
5
+
(** Test helpers *)
6
+
7
+
let check_value msg expected actual =
8
+
Alcotest.(check bool) msg true (Value.equal expected actual)
9
+
10
+
let _check_string msg expected actual =
11
+
Alcotest.(check string) msg expected actual
12
+
13
+
(** Scanner tests *)
14
+
15
+
let test_scanner_simple () =
16
+
let scanner = Scanner.of_string "hello: world" in
17
+
let tokens = Scanner.to_list scanner in
18
+
let token_types = List.map (fun (t : Token.spanned) -> t.token) tokens in
19
+
Alcotest.(check int) "token count" 8 (List.length token_types);
20
+
(* Stream_start, Block_mapping_start, Key, Scalar, Value, Scalar, Block_end, Stream_end *)
21
+
match token_types with
22
+
| Token.Stream_start _ :: Token.Block_mapping_start :: Token.Key ::
23
+
Token.Scalar { value = "hello"; _ } :: Token.Value ::
24
+
Token.Scalar { value = "world"; _ } :: Token.Block_end :: Token.Stream_end :: [] ->
25
+
()
26
+
| _ ->
27
+
Alcotest.fail "unexpected token sequence"
28
+
29
+
let test_scanner_sequence () =
30
+
let scanner = Scanner.of_string "- one\n- two\n- three" in
31
+
let tokens = Scanner.to_list scanner in
32
+
Alcotest.(check bool) "has tokens" true (List.length tokens > 0)
33
+
34
+
let test_scanner_flow () =
35
+
let scanner = Scanner.of_string "[1, 2, 3]" in
36
+
let tokens = Scanner.to_list scanner in
37
+
let has_flow_start = List.exists (fun (t : Token.spanned) ->
38
+
match t.token with Token.Flow_sequence_start -> true | _ -> false
39
+
) tokens in
40
+
Alcotest.(check bool) "has flow sequence start" true has_flow_start
41
+
42
+
let scanner_tests = [
43
+
"simple mapping", `Quick, test_scanner_simple;
44
+
"sequence", `Quick, test_scanner_sequence;
45
+
"flow sequence", `Quick, test_scanner_flow;
46
+
]
47
+
48
+
(** Parser tests *)
49
+
50
+
let test_parser_events () =
51
+
let parser = Parser.of_string "key: value" in
52
+
let events = Parser.to_list parser in
53
+
Alcotest.(check bool) "has events" true (List.length events > 0);
54
+
let has_stream_start = List.exists (fun (e : Event.spanned) ->
55
+
match e.event with Event.Stream_start _ -> true | _ -> false
56
+
) events in
57
+
Alcotest.(check bool) "has stream start" true has_stream_start
58
+
59
+
let test_parser_sequence_events () =
60
+
let parser = Parser.of_string "- a\n- b" in
61
+
let events = Parser.to_list parser in
62
+
let has_seq_start = List.exists (fun (e : Event.spanned) ->
63
+
match e.event with Event.Sequence_start _ -> true | _ -> false
64
+
) events in
65
+
Alcotest.(check bool) "has sequence start" true has_seq_start
66
+
67
+
let parser_tests = [
68
+
"parse events", `Quick, test_parser_events;
69
+
"sequence events", `Quick, test_parser_sequence_events;
70
+
]
71
+
72
+
(** Value parsing tests *)
73
+
74
+
let test_parse_null () =
75
+
check_value "null" `Null (of_string "null");
76
+
check_value "~" `Null (of_string "~");
77
+
check_value "empty" `Null (of_string "")
78
+
79
+
let test_parse_bool () =
80
+
check_value "true" (`Bool true) (of_string "true");
81
+
check_value "false" (`Bool false) (of_string "false");
82
+
check_value "yes" (`Bool true) (of_string "yes");
83
+
check_value "no" (`Bool false) (of_string "no")
84
+
85
+
let test_parse_number () =
86
+
check_value "integer" (`Float 42.0) (of_string "42");
87
+
check_value "negative" (`Float (-17.0)) (of_string "-17");
88
+
check_value "float" (`Float 3.14) (of_string "3.14")
89
+
90
+
let test_parse_string () =
91
+
check_value "plain" (`String "hello") (of_string "hello world" |> function `String s -> `String (String.sub s 0 5) | v -> v);
92
+
check_value "quoted" (`String "hello") (of_string {|"hello"|})
93
+
94
+
let test_parse_sequence () =
95
+
let result = of_string "- one\n- two\n- three" in
96
+
match result with
97
+
| `A [_; _; _] -> ()
98
+
| _ -> Alcotest.fail "expected sequence with 3 elements"
99
+
100
+
let test_parse_mapping () =
101
+
let result = of_string "name: Alice\nage: 30" in
102
+
match result with
103
+
| `O pairs when List.length pairs = 2 -> ()
104
+
| _ -> Alcotest.fail "expected mapping with 2 pairs"
105
+
106
+
let test_parse_nested () =
107
+
let yaml = {|
108
+
person:
109
+
name: Bob
110
+
hobbies:
111
+
- reading
112
+
- coding
113
+
|} in
114
+
let result = of_string yaml in
115
+
match result with
116
+
| `O [("person", `O _)] -> ()
117
+
| _ -> Alcotest.fail "expected nested structure"
118
+
119
+
let test_parse_flow_sequence () =
120
+
let result = of_string "[1, 2, 3]" in
121
+
match result with
122
+
| `A [`Float 1.0; `Float 2.0; `Float 3.0] -> ()
123
+
| _ -> Alcotest.fail "expected flow sequence [1, 2, 3]"
124
+
125
+
let test_parse_flow_mapping () =
126
+
let result = of_string "{a: 1, b: 2}" in
127
+
match result with
128
+
| `O [("a", `Float 1.0); ("b", `Float 2.0)] -> ()
129
+
| _ -> Alcotest.fail "expected flow mapping {a: 1, b: 2}"
130
+
131
+
let value_tests = [
132
+
"parse null", `Quick, test_parse_null;
133
+
"parse bool", `Quick, test_parse_bool;
134
+
"parse number", `Quick, test_parse_number;
135
+
"parse string", `Quick, test_parse_string;
136
+
"parse sequence", `Quick, test_parse_sequence;
137
+
"parse mapping", `Quick, test_parse_mapping;
138
+
"parse nested", `Quick, test_parse_nested;
139
+
"parse flow sequence", `Quick, test_parse_flow_sequence;
140
+
"parse flow mapping", `Quick, test_parse_flow_mapping;
141
+
]
142
+
143
+
(** Emitter tests *)
144
+
145
+
let test_emit_null () =
146
+
let result = to_string `Null in
147
+
Alcotest.(check bool) "contains null" true (String.length result > 0)
148
+
149
+
let starts_with prefix s =
150
+
String.length s >= String.length prefix &&
151
+
String.sub s 0 (String.length prefix) = prefix
152
+
153
+
let test_emit_mapping () =
154
+
let value = `O [("name", `String "Alice"); ("age", `Float 30.0)] in
155
+
let result = to_string value in
156
+
let trimmed = String.trim result in
157
+
Alcotest.(check bool) "contains name" true (starts_with "name" trimmed || starts_with "\"name\"" trimmed)
158
+
159
+
let test_roundtrip_simple () =
160
+
let yaml = "name: Alice" in
161
+
let value = of_string yaml in
162
+
let _ = to_string value in
163
+
(* Just check it doesn't crash *)
164
+
()
165
+
166
+
let test_roundtrip_sequence () =
167
+
let yaml = "- one\n- two\n- three" in
168
+
let value = of_string yaml in
169
+
match value with
170
+
| `A items when List.length items = 3 ->
171
+
let _ = to_string value in
172
+
()
173
+
| _ -> Alcotest.fail "roundtrip failed"
174
+
175
+
let emitter_tests = [
176
+
"emit null", `Quick, test_emit_null;
177
+
"emit mapping", `Quick, test_emit_mapping;
178
+
"roundtrip simple", `Quick, test_roundtrip_simple;
179
+
"roundtrip sequence", `Quick, test_roundtrip_sequence;
180
+
]
181
+
182
+
(** YAML-specific tests *)
183
+
184
+
let test_yaml_anchor () =
185
+
let yaml = "&anchor hello" in
186
+
let result = yaml_of_string yaml in
187
+
match result with
188
+
| `Scalar s when Scalar.anchor s = Some "anchor" -> ()
189
+
| _ -> Alcotest.fail "expected scalar with anchor"
190
+
191
+
let test_yaml_alias () =
192
+
let yaml = {|
193
+
defaults: &defaults
194
+
timeout: 30
195
+
production:
196
+
<<: *defaults
197
+
port: 8080
198
+
|} in
199
+
(* Just check it parses without error *)
200
+
let _ = yaml_of_string yaml in
201
+
()
202
+
203
+
let yaml_tests = [
204
+
"yaml anchor", `Quick, test_yaml_anchor;
205
+
"yaml alias", `Quick, test_yaml_alias;
206
+
]
207
+
208
+
(** Multiline scalar tests *)
209
+
210
+
let test_literal_block () =
211
+
let yaml = {|description: |
212
+
This is a
213
+
multi-line
214
+
description
215
+
|} in
216
+
let result = of_string yaml in
217
+
match result with
218
+
| `O [("description", `String _)] -> ()
219
+
| _ -> Alcotest.fail "expected mapping with literal block"
220
+
221
+
let test_folded_block () =
222
+
let yaml = {|description: >
223
+
This is a
224
+
folded
225
+
description
226
+
|} in
227
+
let result = of_string yaml in
228
+
match result with
229
+
| `O [("description", `String _)] -> ()
230
+
| _ -> Alcotest.fail "expected mapping with folded block"
231
+
232
+
let multiline_tests = [
233
+
"literal block", `Quick, test_literal_block;
234
+
"folded block", `Quick, test_folded_block;
235
+
]
236
+
237
+
(** Error handling tests *)
238
+
239
+
let test_error_position () =
240
+
try
241
+
let _ = of_string "key: [unclosed" in
242
+
Alcotest.fail "expected error"
243
+
with
244
+
| Yamle_error e ->
245
+
Alcotest.(check bool) "has span" true (e.span <> None)
246
+
247
+
let error_tests = [
248
+
"error position", `Quick, test_error_position;
249
+
]
250
+
251
+
(** Run all tests *)
252
+
253
+
let () =
254
+
Alcotest.run "yamle" [
255
+
"scanner", scanner_tests;
256
+
"parser", parser_tests;
257
+
"value", value_tests;
258
+
"emitter", emitter_tests;
259
+
"yaml", yaml_tests;
260
+
"multiline", multiline_tests;
261
+
"errors", error_tests;
262
+
]
+24
yaml/ocaml-yamle/tests/yaml/anchor.yml
+24
yaml/ocaml-yamle/tests/yaml/anchor.yml
···
1
+
datetime: 2001-12-15T02:59:43.1Z
2
+
datetime_with_spaces: 2001-12-14 21:59:43.10 -5
3
+
date: 2002-12-14
4
+
5
+
# The !!binary tag indicates that a string is actually a base64-encoded
6
+
# representation of a binary blob.
7
+
gif_file: !!binary |
8
+
R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5
9
+
OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+
10
+
+f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC
11
+
AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=
12
+
13
+
# YAML also has a set type, which looks like this:
14
+
set:
15
+
? item1
16
+
? item2
17
+
? item3
18
+
19
+
# Like Python, sets are just maps with null values; the above is equivalent to:
20
+
set2:
21
+
item1: null
22
+
item2: null
23
+
item3: null
24
+
+23
yaml/ocaml-yamle/tests/yaml/cohttp.yml
+23
yaml/ocaml-yamle/tests/yaml/cohttp.yml
···
1
+
language: c
2
+
sudo: false
3
+
services:
4
+
- docker
5
+
install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh
6
+
script: bash -ex ./.travis-docker.sh
7
+
env:
8
+
global:
9
+
- EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git"
10
+
- PINS="cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:."
11
+
matrix:
12
+
- PACKAGE="cohttp" DISTRO="alpine-3.5" OCAML_VERSION="4.06.0"
13
+
- PACKAGE="cohttp-async" DISTRO="alpine" OCAML_VERSION="4.06.0"
14
+
- PACKAGE="cohttp-lwt" DISTRO="debian-unstable" OCAML_VERSION="4.03.0"
15
+
- PACKAGE="cohttp-mirage" DISTRO="debian-unstable" OCAML_VERSION="4.03.0"
16
+
notifications:
17
+
webhooks:
18
+
urls:
19
+
- https://webhooks.gitter.im/e/6ee5059c7420709f4ad1
20
+
on_success: change
21
+
on_failure: always
22
+
on_start: false
23
+
+59
yaml/ocaml-yamle/tests/yaml/linuxkit.yml
+59
yaml/ocaml-yamle/tests/yaml/linuxkit.yml
···
1
+
kernel:
2
+
image: linuxkit/kernel:4.9.40
3
+
cmdline: "console=tty0 console=ttyS0"
4
+
init:
5
+
- linuxkit/init:906e174b3f2e07f97d6fd693a2e8518e98dafa58
6
+
- linuxkit/runc:90e45f13e1d0a0983f36ef854621e3eac91cf541
7
+
- linuxkit/containerd:7c986fb7df33bea73b5c8097b46989e46f49d875
8
+
- linuxkit/ca-certificates:e44b0a66df5a102c0e220f0066b0d904710dcb10
9
+
onboot:
10
+
- name: sysctl
11
+
image: linuxkit/sysctl:184c914d23a017062d7b53d7fc1dfaf47764bef6
12
+
- name: dhcpcd
13
+
image: linuxkit/dhcpcd:f3f5413abb78fae9020e35bd4788fa93df4530b7
14
+
command: ["/sbin/dhcpcd", "--nobackground", "-f", "/dhcpcd.conf", "-1"]
15
+
onshutdown:
16
+
- name: shutdown
17
+
image: busybox:latest
18
+
command: ["/bin/echo", "so long and thanks for all the fish"]
19
+
services:
20
+
- name: getty
21
+
image: linuxkit/getty:2c841cdc34396e3fa8f25b62d112808f63f16df6
22
+
env:
23
+
- INSECURE=true
24
+
- name: rngd
25
+
image: linuxkit/rngd:b2f4bdcb55aa88a25c86733e294628614504f383
26
+
- name: nginx
27
+
image: nginx:alpine
28
+
capabilities:
29
+
- CAP_NET_BIND_SERVICE
30
+
- CAP_CHOWN
31
+
- CAP_SETUID
32
+
- CAP_SETGID
33
+
- CAP_DAC_OVERRIDE
34
+
files:
35
+
- path: etc/containerd/config.toml
36
+
contents: |
37
+
state = "/run/containerd"
38
+
root = "/var/lib/containerd"
39
+
snapshotter = "io.containerd.snapshotter.v1.overlayfs"
40
+
differ = "io.containerd.differ.v1.base-diff"
41
+
subreaper = false
42
+
43
+
[grpc]
44
+
address = "/run/containerd/containerd.sock"
45
+
uid = 0
46
+
gid = 0
47
+
48
+
[debug]
49
+
address = "/run/containerd/debug.sock"
50
+
level = "info"
51
+
52
+
[metrics]
53
+
address = ":13337"
54
+
- path: etc/linuxkit-config
55
+
metadata: yaml
56
+
trust:
57
+
org:
58
+
- linuxkit
59
+
- library
+3
yaml/ocaml-yamle/tests/yaml/yaml-1.2.yml
+3
yaml/ocaml-yamle/tests/yaml/yaml-1.2.yml
···
1
+
- {"when the key is quoted":"space after colon can be omitted."}
2
+
- "quoted slashes \/ are allowed."
3
+
- {?"a key can be looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooger": "than 1024 when parsing is unambiguous before seeing the colon."}
+32
yaml/ocaml-yamle/yamle.opam
+32
yaml/ocaml-yamle/yamle.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "Pure OCaml YAML 1.2 parser and emitter"
5
+
description:
6
+
"A pure OCaml implementation of YAML 1.2 parsing and emission, with no C dependencies."
7
+
maintainer: ["yamle@example.com"]
8
+
authors: ["Yamle Authors"]
9
+
license: "ISC"
10
+
homepage: "https://github.com/ocaml/yamle"
11
+
bug-reports: "https://github.com/ocaml/yamle/issues"
12
+
depends: [
13
+
"ocaml" {>= "4.14.0"}
14
+
"dune" {>= "3.0" & >= "3.0"}
15
+
"alcotest" {with-test}
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "git+https://github.com/ocaml/yamle.git"