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