Pure OCaml Yaml 1.2 reader and writer using Bytesrw
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Yamlrw
7module TL = Test_suite_lib.Test_suite_loader
8module TF = Test_suite_lib.Tree_format
9module JF = Test_suite_lib.Json_format
10module JC = Test_suite_lib.Json_compare
11
12let test_suite_path = "yaml-test-suite"
13
14(* HTML escape function *)
15let html_escape s =
16 let buf = Buffer.create (String.length s) in
17 String.iter
18 (function
19 | '<' -> Buffer.add_string buf "<"
20 | '>' -> Buffer.add_string buf ">"
21 | '&' -> Buffer.add_string buf "&"
22 | '"' -> Buffer.add_string buf """
23 | c -> Buffer.add_char buf c)
24 s;
25 Buffer.contents buf
26
27let normalize_tree s =
28 let lines = String.split_on_char '\n' s in
29 let lines = List.filter (fun l -> String.trim l <> "") lines in
30 String.concat "\n" lines
31
32type test_result = {
33 id : string;
34 name : string;
35 yaml : string;
36 is_error_test : bool;
37 status : [ `Pass | `Fail of string | `Skip ];
38 output : string;
39 json_status : [ `Pass | `Fail of string | `Skip ];
40 json_expected : string;
41 json_actual : string;
42}
43
44let compare_json expected actual =
45 (* Parse both JSON strings and compare the resulting structures.
46 This handles formatting differences and object key ordering. *)
47 JC.compare_json_strings expected actual
48
49let run_json_test (test : TL.test_case) :
50 [ `Pass | `Fail of string | `Skip ] * string =
51 match test.json with
52 | None -> (`Skip, "")
53 | Some expected_json -> (
54 if test.fail then
55 (* Error tests shouldn't have JSON comparison *)
56 (`Skip, "")
57 else
58 try
59 (* Handle multi-document YAML by using documents_of_string *)
60 let docs = Loader.documents_of_string test.yaml in
61 let values =
62 List.filter_map
63 (fun doc ->
64 match Document.root doc with
65 | None -> None
66 | Some yaml ->
67 Some (Yaml.to_value ~resolve_aliases_first:true yaml))
68 docs
69 in
70 let actual_json =
71 match values with
72 | [] -> "" (* Empty document produces empty JSON *)
73 | [ v ] -> JF.to_json v
74 | vs -> JF.documents_to_json vs
75 in
76 if compare_json expected_json actual_json then (`Pass, actual_json)
77 else (`Fail "JSON mismatch", actual_json)
78 with
79 | Yamlrw_error e ->
80 (`Fail (Format.asprintf "Parse error: %a" Error.pp e), "")
81 | exn ->
82 (`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)), "")
83 )
84
85let run_test (test : TL.test_case) : test_result =
86 let json_status, json_actual = run_json_test test in
87 let base =
88 {
89 id = test.id;
90 name = test.name;
91 yaml = test.yaml;
92 is_error_test = test.fail;
93 status = `Skip;
94 output = "";
95 json_status;
96 json_expected = Option.value ~default:"" test.json;
97 json_actual;
98 }
99 in
100 if test.fail then begin
101 try
102 let parser = Parser.of_string test.yaml in
103 let events = Parser.to_list parser in
104 let tree = TF.of_spanned_events events in
105 { base with status = `Fail "Expected parsing to fail"; output = tree }
106 with
107 | Yamlrw_error e ->
108 { base with status = `Pass; output = Format.asprintf "%a" Error.pp e }
109 | exn -> { base with status = `Pass; output = Printexc.to_string exn }
110 end
111 else begin
112 match test.tree with
113 | None -> (
114 (* No expected tree - check if json indicates expected success *)
115 match test.json with
116 | Some _ -> (
117 (* Has json output, so should parse successfully *)
118 try
119 let parser = Parser.of_string test.yaml in
120 let events = Parser.to_list parser in
121 let tree = TF.of_spanned_events events in
122 { base with status = `Pass; output = tree }
123 with exn ->
124 {
125 base with
126 status =
127 `Fail
128 (Printf.sprintf "Should parse but got: %s"
129 (Printexc.to_string exn));
130 output = Printexc.to_string exn;
131 })
132 | None ->
133 (* No tree, no json, no fail - ambiguous edge case, skip *)
134 { base with status = `Skip; output = "(no expected tree or json)" })
135 | Some expected -> (
136 try
137 let parser = Parser.of_string test.yaml in
138 let events = Parser.to_list parser in
139 let actual = TF.of_spanned_events events in
140 let expected_norm = normalize_tree expected in
141 let actual_norm = normalize_tree actual in
142 if expected_norm = actual_norm then
143 { base with status = `Pass; output = actual }
144 else
145 {
146 base with
147 status = `Fail (Printf.sprintf "Tree mismatch");
148 output =
149 Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm
150 actual_norm;
151 }
152 with exn ->
153 {
154 base with
155 status =
156 `Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn));
157 output = Printexc.to_string exn;
158 })
159 end
160
161let status_class = function
162 | `Pass -> "pass"
163 | `Fail _ -> "fail"
164 | `Skip -> "skip"
165
166let status_text = function
167 | `Pass -> "PASS"
168 | `Fail _ -> "FAIL"
169 | `Skip -> "SKIP"
170
171let generate_html results output_file =
172 let oc = open_out output_file in
173 let pass_count =
174 List.length (List.filter (fun r -> r.status = `Pass) results)
175 in
176 let fail_count =
177 List.length
178 (List.filter
179 (fun r -> match r.status with `Fail _ -> true | _ -> false)
180 results)
181 in
182 let skip_count =
183 List.length (List.filter (fun r -> r.status = `Skip) results)
184 in
185 let total = List.length results in
186 let json_pass_count =
187 List.length (List.filter (fun r -> r.json_status = `Pass) results)
188 in
189 let json_fail_count =
190 List.length
191 (List.filter
192 (fun r -> match r.json_status with `Fail _ -> true | _ -> false)
193 results)
194 in
195 let json_skip_count =
196 List.length (List.filter (fun r -> r.json_status = `Skip) results)
197 in
198
199 Printf.fprintf oc
200 {|<!DOCTYPE html>
201<html lang="en">
202<head>
203 <meta charset="UTF-8">
204 <meta name="viewport" content="width=device-width, initial-scale=1.0">
205 <title>Yamlrw Test Results</title>
206 <style>
207 :root {
208 --pass-color: #22c55e;
209 --fail-color: #ef4444;
210 --skip-color: #f59e0b;
211 --bg-color: #1a1a2e;
212 --card-bg: #16213e;
213 --text-color: #e2e8f0;
214 --border-color: #334155;
215 }
216 * { box-sizing: border-box; margin: 0; padding: 0; }
217 body {
218 font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif;
219 background: var(--bg-color);
220 color: var(--text-color);
221 line-height: 1.6;
222 padding: 2rem;
223 }
224 .container { max-width: 1400px; margin: 0 auto; }
225 h1 { margin-bottom: 1.5rem; font-size: 2rem; }
226 .summary {
227 display: flex;
228 gap: 1rem;
229 margin-bottom: 2rem;
230 flex-wrap: wrap;
231 }
232 .stat {
233 background: var(--card-bg);
234 padding: 1rem 1.5rem;
235 border-radius: 8px;
236 border-left: 4px solid var(--border-color);
237 }
238 .stat.pass { border-left-color: var(--pass-color); }
239 .stat.fail { border-left-color: var(--fail-color); }
240 .stat.skip { border-left-color: var(--skip-color); }
241 .stat-value { font-size: 2rem; font-weight: bold; }
242 .stat-label { font-size: 0.875rem; opacity: 0.8; }
243 .filters {
244 margin-bottom: 1.5rem;
245 display: flex;
246 gap: 0.5rem;
247 flex-wrap: wrap;
248 }
249 .filter-btn {
250 padding: 0.5rem 1rem;
251 border: 1px solid var(--border-color);
252 background: var(--card-bg);
253 color: var(--text-color);
254 border-radius: 4px;
255 cursor: pointer;
256 transition: all 0.2s;
257 }
258 .filter-btn:hover { border-color: var(--text-color); }
259 .filter-btn.active { background: var(--text-color); color: var(--bg-color); }
260 .search {
261 padding: 0.5rem 1rem;
262 border: 1px solid var(--border-color);
263 background: var(--card-bg);
264 color: var(--text-color);
265 border-radius: 4px;
266 width: 200px;
267 }
268 .tests { display: flex; flex-direction: column; gap: 1rem; }
269 .test {
270 background: var(--card-bg);
271 border-radius: 8px;
272 border: 1px solid var(--border-color);
273 overflow: hidden;
274 }
275 .test-header {
276 padding: 1rem;
277 display: flex;
278 align-items: center;
279 gap: 1rem;
280 cursor: pointer;
281 border-bottom: 1px solid var(--border-color);
282 }
283 .test-header:hover { background: rgba(255,255,255,0.05); }
284 .badge {
285 padding: 0.25rem 0.5rem;
286 border-radius: 4px;
287 font-size: 0.75rem;
288 font-weight: bold;
289 text-transform: uppercase;
290 }
291 .badge.pass { background: var(--pass-color); color: #000; }
292 .badge.fail { background: var(--fail-color); color: #fff; }
293 .badge.skip { background: var(--skip-color); color: #000; }
294 .badge.error-test { background: #8b5cf6; color: #fff; margin-left: auto; }
295 .test-id { font-family: monospace; font-weight: bold; }
296 .test-name { opacity: 0.8; flex: 1; }
297 .test-content { display: none; padding: 1rem; }
298 .test.expanded .test-content { display: block; }
299 .section { margin-bottom: 1rem; }
300 .section-title {
301 font-size: 0.875rem;
302 text-transform: uppercase;
303 opacity: 0.6;
304 margin-bottom: 0.5rem;
305 letter-spacing: 0.05em;
306 }
307 pre {
308 background: #0f172a;
309 padding: 1rem;
310 border-radius: 4px;
311 overflow-x: auto;
312 font-size: 0.875rem;
313 white-space: pre-wrap;
314 word-break: break-all;
315 }
316 .expand-icon { transition: transform 0.2s; }
317 .test.expanded .expand-icon { transform: rotate(90deg); }
318 </style>
319</head>
320<body>
321 <div class="container">
322 <h1>Yamlrw Test Results</h1>
323 <div class="summary">
324 <div class="stat pass">
325 <div class="stat-value">%d</div>
326 <div class="stat-label">Passed</div>
327 </div>
328 <div class="stat fail">
329 <div class="stat-value">%d</div>
330 <div class="stat-label">Failed</div>
331 </div>
332 <div class="stat skip">
333 <div class="stat-value">%d</div>
334 <div class="stat-label">Skipped</div>
335 </div>
336 <div class="stat">
337 <div class="stat-value">%d</div>
338 <div class="stat-label">Total</div>
339 </div>
340 </div>
341 <h2 style="margin: 1.5rem 0 1rem;">JSON Output Comparison</h2>
342 <div class="summary">
343 <div class="stat pass">
344 <div class="stat-value">%d</div>
345 <div class="stat-label">JSON Pass</div>
346 </div>
347 <div class="stat fail">
348 <div class="stat-value">%d</div>
349 <div class="stat-label">JSON Fail</div>
350 </div>
351 <div class="stat skip">
352 <div class="stat-value">%d</div>
353 <div class="stat-label">JSON Skip</div>
354 </div>
355 </div>
356 <div class="filters">
357 <button class="filter-btn active" data-filter="all">All</button>
358 <button class="filter-btn" data-filter="pass">Pass</button>
359 <button class="filter-btn" data-filter="fail">Fail</button>
360 <button class="filter-btn" data-filter="skip">Skip</button>
361 <input type="text" class="search" placeholder="Search by ID or name...">
362 </div>
363 <div class="tests">
364|}
365 pass_count fail_count skip_count total json_pass_count json_fail_count
366 json_skip_count;
367
368 List.iter
369 (fun result ->
370 let error_badge =
371 if result.is_error_test then
372 {|<span class="badge error-test">Error Test</span>|}
373 else ""
374 in
375 let json_badge =
376 Printf.sprintf
377 {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|}
378 (status_class result.json_status)
379 (status_text result.json_status)
380 in
381 let json_section =
382 if result.json_expected <> "" || result.json_actual <> "" then
383 Printf.sprintf
384 {|
385 <div class="section">
386 <div class="section-title">Expected JSON</div>
387 <pre>%s</pre>
388 </div>
389 <div class="section">
390 <div class="section-title">Actual JSON</div>
391 <pre>%s</pre>
392 </div>|}
393 (html_escape result.json_expected)
394 (html_escape result.json_actual)
395 else ""
396 in
397 Printf.fprintf oc
398 {| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s">
399 <div class="test-header" onclick="this.parentElement.classList.toggle('expanded')">
400 <span class="expand-icon">▶</span>
401 <span class="badge %s">%s</span>
402 %s
403 <span class="test-id">%s</span>
404 <span class="test-name">%s</span>
405 %s
406 </div>
407 <div class="test-content">
408 <div class="section">
409 <div class="section-title">YAML Input</div>
410 <pre>%s</pre>
411 </div>
412 <div class="section">
413 <div class="section-title">Event Tree Output</div>
414 <pre>%s</pre>
415 </div>%s
416 </div>
417 </div>
418|}
419 (status_class result.status)
420 (status_class result.json_status)
421 (html_escape result.id)
422 (html_escape (String.lowercase_ascii result.name))
423 (status_class result.status)
424 (status_text result.status)
425 json_badge (html_escape result.id) (html_escape result.name) error_badge
426 (html_escape result.yaml)
427 (html_escape result.output)
428 json_section)
429 results;
430
431 Printf.fprintf oc
432 {| </div>
433 </div>
434 <script>
435 document.querySelectorAll('.filter-btn').forEach(btn => {
436 btn.addEventListener('click', () => {
437 document.querySelectorAll('.filter-btn').forEach(b => b.classList.remove('active'));
438 btn.classList.add('active');
439 filterTests();
440 });
441 });
442 document.querySelector('.search').addEventListener('input', filterTests);
443 function filterTests() {
444 const filter = document.querySelector('.filter-btn.active').dataset.filter;
445 const search = document.querySelector('.search').value.toLowerCase();
446 document.querySelectorAll('.test').forEach(test => {
447 const status = test.dataset.status;
448 const id = test.dataset.id.toLowerCase();
449 const name = test.dataset.name;
450 const matchesFilter = filter === 'all' || status === filter;
451 const matchesSearch = !search || id.includes(search) || name.includes(search);
452 test.style.display = matchesFilter && matchesSearch ? '' : 'none';
453 });
454 }
455 </script>
456</body>
457</html>
458|};
459 close_out oc
460
461let () =
462 let html_output = ref None in
463 let show_skipped = ref false in
464 let test_suite_path_ref = ref test_suite_path in
465 let args =
466 [
467 ( "--html",
468 Arg.String (fun s -> html_output := Some s),
469 "<file> Generate HTML report to file" );
470 ("--show-skipped", Arg.Set show_skipped, " Show details of skipped tests");
471 ( "--test-suite-path",
472 Arg.Set_string test_suite_path_ref,
473 "<path> Path to yaml-test-suite directory" );
474 ]
475 in
476 Arg.parse args
477 (fun _ -> ())
478 "Usage: run_all_tests [--html <file>] [--show-skipped] [--test-suite-path \
479 <path>]";
480
481 let all_tests = TL.load_directory !test_suite_path_ref in
482 Printf.printf "Total tests loaded: %d\n%!" (List.length all_tests);
483
484 let results = List.map run_test all_tests in
485
486 let pass_count =
487 List.length (List.filter (fun r -> r.status = `Pass) results)
488 in
489 let fail_count =
490 List.length
491 (List.filter
492 (fun r -> match r.status with `Fail _ -> true | _ -> false)
493 results)
494 in
495 let skip_count =
496 List.length (List.filter (fun r -> r.status = `Skip) results)
497 in
498
499 let json_pass_count =
500 List.length (List.filter (fun r -> r.json_status = `Pass) results)
501 in
502 let json_fail_count =
503 List.length
504 (List.filter
505 (fun r -> match r.json_status with `Fail _ -> true | _ -> false)
506 results)
507 in
508 let json_skip_count =
509 List.length (List.filter (fun r -> r.json_status = `Skip) results)
510 in
511
512 Printf.printf
513 "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" pass_count
514 fail_count skip_count
515 (pass_count + fail_count + skip_count);
516
517 Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count
518 json_fail_count json_skip_count;
519
520 if fail_count > 0 then begin
521 Printf.printf "\nFailing event tree tests:\n";
522 List.iter
523 (fun r ->
524 match r.status with
525 | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
526 | _ -> ())
527 results
528 end;
529
530 if json_fail_count > 0 then begin
531 Printf.printf "\nFailing JSON tests:\n";
532 List.iter
533 (fun r ->
534 match r.json_status with
535 | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg
536 | _ -> ())
537 results
538 end;
539
540 if !show_skipped && skip_count > 0 then begin
541 Printf.printf "\nSkipped tests (no expected tree):\n";
542 List.iter
543 (fun r ->
544 if r.status = `Skip then begin
545 Printf.printf " %s: %s\n" r.id r.name;
546 Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml)
547 (if String.length r.yaml <= 60 then r.yaml
548 else String.sub r.yaml 0 60 ^ "...")
549 end)
550 results
551 end;
552
553 (match !html_output with
554 | Some file ->
555 generate_html results file;
556 Printf.printf "\nHTML report generated: %s\n" file
557 | None -> ());
558
559 (* Exit with non-zero code if any tests failed *)
560 if fail_count > 0 || json_fail_count > 0 then exit 1