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