upstream: https://github.com/stedolan/crowbar
refactor(crowbar): Alcotest-style API with suite exports and grouped run
- Change `run` signature to `string -> (string * test_case list) list -> unit`
matching Alcotest's grouping convention
- Fix `_name` bug: pass the name through to Alcotest.run_with_args
- Each fuzz module now exports `let suite = ("name", [test_case ...])`
- Entry points (fuzz.ml) collect suites: `Crowbar.run "pkg" [Fuzz_X.suite]`
- Remove stale `add_test`/`suite` API, keep only `test_case`/`run`
- Remove `let run () = ()` from fuzz_common.ml files
- Update merlint E725 rule to match new `let suite = ("name", ...)` pattern
- Update E725 test fixtures and expected output
+122
-94
+8
-4
examples/calendar/test_calendar.ml
+8
-4
examples/calendar/test_calendar.ml
···
22
22
let period =
23
23
map [const 0;const 0;int8;int8;int8;int8] C.Period.make
24
24
25
+
let suite =
26
+
("crowbar",
27
+
[
28
+
test_case "calendar" [time; time] @@ fun t1 t2 ->
29
+
guard (C.compare t1 t2 < 0);
30
+
check_eq ~pp:pp_time ~eq:C.equal (C.add t1 (C.precise_sub t2 t1)) t2;
31
+
])
25
32
26
-
let () =
27
-
add_test ~name:"calendar" [time; time] @@ fun t1 t2 ->
28
-
guard (C.compare t1 t2 < 0);
29
-
check_eq ~pp:pp_time ~eq:C.equal (C.add t1 (C.precise_sub t2 t1)) t2
33
+
let () = run "crowbar" [ suite ]
+11
-7
examples/fpath/test_fpath.ml
+11
-7
examples/fpath/test_fpath.ml
···
8
8
with
9
9
Invalid_argument _ -> bad_test ())
10
10
11
+
let suite =
12
+
("crowbar",
13
+
[
14
+
test_case "segs" [fpath] @@ fun p ->
15
+
let np = normalize p in
16
+
assert (is_dir_path p = is_dir_path np);
17
+
assert (is_file_path p = is_file_path np);
18
+
assert (filename p = filename np);
19
+
check_eq ~eq:equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~sep:dir_sep (segs p)));
20
+
])
11
21
12
-
let () =
13
-
add_test ~name:"segs" [fpath] @@ fun p ->
14
-
let np = normalize p in
15
-
assert (is_dir_path p = is_dir_path np);
16
-
assert (is_file_path p = is_file_path np);
17
-
assert (filename p = filename np);
18
-
check_eq ~eq:equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~sep:dir_sep (segs p)))
22
+
let () = run "crowbar" [ suite ]
+8
-3
examples/map/test_map.ml
+8
-3
examples/map/test_map.ml
···
42
42
(l' @ List.map (fun (k,v) -> k,v+42) r',
43
43
Map.union (fun k a b -> assert false) l (Map.map (fun v -> v + 42) r)))])
44
44
45
-
let () =
46
-
add_test ~name:"map" [map_gen] @@ fun m ->
47
-
check (check_map m)
45
+
let suite =
46
+
("crowbar",
47
+
[
48
+
test_case "map" [map_gen] @@ fun m ->
49
+
check (check_map m);
50
+
])
51
+
52
+
let () = run "crowbar" [ suite ]
+7
-2
examples/pprint/test_pprint.ml
+7
-2
examples/pprint/test_pprint.ml
+7
-1
examples/serializer/test_serializer.ml
+7
-1
examples/serializer/test_serializer.ml
···
44
44
| exception _ -> fail "incorrect deserialization"
45
45
| v' -> check_eq ~pp:(printer_of_ty t) v v'
46
46
47
-
let () = add_test ~name:"pairs" [pair_gen] check_pair
47
+
let suite =
48
+
("serializer",
49
+
[
50
+
test_case "pairs" [pair_gen] check_pair;
51
+
])
52
+
53
+
let () = run "serializer" [ suite ]
+35
-38
examples/uunf/test_uunf.ml
+35
-38
examples/uunf/test_uunf.ml
···
34
34
35
35
let unicode = with_printer pp_unicode unicode
36
36
37
-
let () =
38
-
add_test ~name:"uunf" [unicode] @@ fun s ->
39
-
let nfc = norm `NFC s in
40
-
let nfd = norm `NFD s in
41
-
let nfkc = norm `NFKC s in
42
-
let nfkd = norm `NFKD s in
43
-
(* [s; nfc; nfd; nfkc; nfkd] |> List.iter (fun s ->
44
-
Printf.printf "[%s]\n" (unicode_to_string s));
45
-
Printf.printf "\n%!";*)
37
+
let suite =
38
+
("crowbar",
39
+
[
40
+
test_case "uunf" [unicode] @@ fun s ->
41
+
let nfc = norm `NFC s in
42
+
let nfd = norm `NFD s in
43
+
let nfkc = norm `NFKC s in
44
+
let nfkd = norm `NFKD s in
45
+
let tests =
46
+
[
47
+
nfc, [
48
+
norm `NFC nfc;
49
+
norm `NFC nfd];
50
+
nfd, [
51
+
norm `NFD nfc;
52
+
norm `NFD nfd];
53
+
nfkc, [
54
+
norm `NFC nfkc;
55
+
norm `NFC nfkd;
56
+
norm `NFKC nfc;
57
+
norm `NFKC nfd;
58
+
norm `NFKC nfkc;
59
+
norm `NFKC nfkd];
60
+
nfkd, [
61
+
norm `NFD nfkc;
62
+
norm `NFD nfkd;
63
+
norm `NFKD nfc;
64
+
norm `NFKD nfd;
65
+
norm `NFKD nfkc;
66
+
norm `NFKD nfkd]
67
+
] in
68
+
tests |> List.iter (fun (s, eqs) ->
69
+
List.iter (fun s' -> check_eq ~pp:pp_unicode s s') eqs);
70
+
])
46
71
47
-
let tests =
48
-
[
49
-
nfc, [
50
-
norm `NFC nfc;
51
-
norm `NFC nfd];
52
-
53
-
nfd, [
54
-
norm `NFD nfc;
55
-
norm `NFD nfd];
56
-
57
-
nfkc, [
58
-
norm `NFC nfkc;
59
-
norm `NFC nfkd;
60
-
norm `NFKC nfc;
61
-
norm `NFKC nfd;
62
-
norm `NFKC nfkc;
63
-
norm `NFKC nfkd];
64
-
65
-
nfkd, [
66
-
norm `NFD nfkc;
67
-
norm `NFD nfkd;
68
-
norm `NFKD nfc;
69
-
norm `NFKD nfd;
70
-
norm `NFKD nfkc;
71
-
norm `NFKD nfkd]
72
-
] in
73
-
tests |> List.iter (fun (s, eqs) ->
74
-
List.iter (fun s' -> check_eq ~pp:pp_unicode s s') eqs)
75
-
72
+
let () = run "crowbar" [ suite ]
+8
-4
examples/xmldiff/test_xmldiff.ml
+8
-4
examples/xmldiff/test_xmldiff.ml
···
35
35
pp ppf "%s" (Xmldiff.string_of_xml xml)
36
36
let xml = with_printer pp_xml xml
37
37
38
+
let suite =
39
+
("crowbar",
40
+
[
41
+
test_case "xmldiff" [xml; xml] @@ fun xml1 xml2 ->
42
+
let (patch, xml3) = Xmldiff.diff_with_final_tree xml1 xml2 in
43
+
check_eq ~pp:pp_xml xml2 xml3;
44
+
])
38
45
39
-
let () =
40
-
add_test ~name:"xmldiff" [xml; xml] @@ fun xml1 xml2 ->
41
-
let (patch, xml3) = Xmldiff.diff_with_final_tree xml1 xml2 in
42
-
check_eq ~pp:pp_xml xml2 xml3
46
+
let () = run "crowbar" [ suite ]
+28
-29
src/crowbar.ml
+28
-29
src/crowbar.ml
···
390
390
391
391
let () = Printexc.record_backtrace true
392
392
393
-
type test = Test : string * ('f, unit) gens * 'f -> test
393
+
type test =
394
+
| Test : { suite : string; name : string; gens : ('f, unit) gens; f : 'f } -> test
394
395
395
396
type test_status =
396
397
| TestPass of unit printer
···
508
509
) f
509
510
end
510
511
511
-
let run_property_test (Test (_name, gens, f)) config =
512
+
let run_property_test (Test { gens; f; _ }) config =
512
513
let seed = match config.seed with
513
514
| Some s -> s
514
515
| None -> Random.int64 Int64.max_int in
···
544
545
| Some status ->
545
546
Alcotest.fail (Format.asprintf "%a" print_status status)
546
547
547
-
let run_with_alcotest tests =
548
-
let split_name name =
549
-
match String.index_opt name ':' with
550
-
| Some i ->
551
-
let group = String.trim (String.sub name 0 i) in
552
-
let rest = String.trim (String.sub name (i + 1) (String.length name - i - 1)) in
553
-
(group, rest)
554
-
| None -> ("crowbar", name)
555
-
in
548
+
let run_with_alcotest name tests =
556
549
let groups = Hashtbl.create 16 in
557
-
List.iter (fun (Test (name, _, _) as test) ->
558
-
let group, short = split_name name in
559
-
let tc = Alcotest.test_case short `Quick (run_property_test test) in
560
-
let prev = try Hashtbl.find groups group with Not_found -> [] in
561
-
Hashtbl.replace groups group (tc :: prev)
550
+
List.iter (fun (Test { suite; name; _ } as test) ->
551
+
let tc = Alcotest.test_case name `Quick (run_property_test test) in
552
+
let prev = try Hashtbl.find groups suite with Not_found -> [] in
553
+
Hashtbl.replace groups suite (tc :: prev)
562
554
) tests;
563
555
let suites = Hashtbl.fold (fun group tcs acc ->
564
556
(group, List.rev tcs) :: acc
565
557
) groups [] in
566
558
let suites = List.sort (fun (a, _) (b, _) -> String.compare a b) suites in
567
-
Alcotest.run_with_args "crowbar" config_term suites
559
+
Alcotest.run_with_args name config_term suites
568
560
569
561
(* {1 AFL runner} *)
570
562
···
578
570
let status =
579
571
try
580
572
let test = List.nth tests (choose_int (List.length tests) state) in
581
-
let (Test (_, gens, f)) = test in
573
+
let (Test { gens; f; _ }) = test in
582
574
run_once gens f state
583
575
with
584
576
| BadTest s -> BadInput s
···
598
590
else None
599
591
else None
600
592
601
-
let last_generated_name = ref 0
602
-
let generate_name () =
603
-
incr last_generated_name;
604
-
"test" ^ string_of_int !last_generated_name
593
+
let registered_name = ref "crowbar"
594
+
let registered_tests = ref []
605
595
606
-
let registered_tests = ref []
596
+
type test_case =
597
+
| TC : { name : string; gens : ('f, unit) gens; f : 'f } -> test_case
607
598
608
-
let add_test ?name gens f =
609
-
let name = match name with
610
-
| None -> generate_name ()
611
-
| Some name -> name in
612
-
registered_tests := Test (name, gens, f) :: !registered_tests
599
+
let test_case name gens f = TC { name; gens; f }
600
+
601
+
let run name suites =
602
+
registered_name := name;
603
+
List.iter
604
+
(fun (suite_name, tests) ->
605
+
List.iter
606
+
(fun (TC { name; gens; f }) ->
607
+
registered_tests :=
608
+
Test { suite = suite_name; name; gens; f } :: !registered_tests)
609
+
tests)
610
+
suites
613
611
614
612
let () =
615
613
at_exit (fun () ->
614
+
let name = !registered_name in
616
615
let t = !registered_tests in
617
616
registered_tests := [];
618
617
match t with
···
621
620
let tests = List.rev t in
622
621
match detect_afl_file () with
623
622
| Some file -> run_afl tests file
624
-
| None -> run_with_alcotest tests
623
+
| None -> run_with_alcotest name tests
625
624
)
626
625
627
626
module Syntax = struct
+10
-6
src/crowbar.mli
+10
-6
src/crowbar.mli
···
205
205
206
206
(** {1:testing Testing} *)
207
207
208
-
val add_test :
209
-
?name:string -> ('f, unit) gens -> 'f -> unit
210
-
(** [add_test name generators test_fn] adds [test_fn] to the list of eligible
211
-
tests to be run when the program is invoked. At runtime, random data will
212
-
be sent to [generators] to create the input necessary to run [test_fn]. Any
213
-
failures will be printed annotated with [name]. *)
208
+
type test_case
209
+
(** An opaque test case. *)
210
+
211
+
val test_case : string -> ('f, unit) gens -> 'f -> test_case
212
+
(** [test_case name generators test_fn] creates a test case. *)
213
+
214
+
val run : string -> (string * test_case list) list -> unit
215
+
(** [run name suites] registers [suites] for execution at program exit.
216
+
Each suite is a pair [(suite_name, test_cases)].
217
+
Mirrors {!Alcotest.run}. *)
214
218
215
219
(** {2:aborting Aborting Tests} *)
216
220