From 5eba9060a75cab718896a37e46f56b29123ec07e Mon Sep 17 00:00:00 2001 From: Arvid Jakobsson Date: Mon, 20 Mar 2023 13:50:42 +0100 Subject: [PATCH 1/3] select files by suffix Co-authored-by: Romain --- CHANGES.md | 10 ++++ lib_core/cli.ml | 21 +++++---- lib_core/test.ml | 120 ++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 134 insertions(+), 17 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 6864de7..be6a78f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -25,6 +25,10 @@ - Skipping all tests with `--skip` or `--only` now results in an error. This makes those command-line arguments behave like other filters. +- Tests are now registered with the full value passed as + `~__FILE__` to `Test.register`, instead of just the + basename. + ### New Features - Added `?seed` to `Test.register` and the `--seed` command-line parameter @@ -41,6 +45,12 @@ - `--time` can now be passed along with `--from-record --list` to pretty-print timings from previous executions. +- `--file FILE` now selects all tests registered from a source file + that ends with `FILE`. + +- Added `--not-file FILE` to deselect tests registered from a source + file that ends with `FILE`. + ### Bug Fixes - Fixed a bug where the log file does not contain logs from tests in diff --git a/lib_core/cli.ml b/lib_core/cli.ml index 8c45a03..f791be9 100644 --- a/lib_core/cli.ml +++ b/lib_core/cli.ml @@ -310,8 +310,8 @@ let init ?args () = ( "--file", Arg.String (fun file -> options.files_to_run <- file :: options.files_to_run), - " Only run tests implemented in source file FILE (see \ - SELECTING TESTS)." ); + " Only run tests implemented in source files ending with FILE \ + (see SELECTING TESTS)." ); ( "-f", Arg.String (fun file -> options.files_to_run <- file :: options.files_to_run), @@ -320,8 +320,8 @@ let init ?args () = Arg.String (fun file -> options.files_not_to_run <- file :: options.files_not_to_run), - " Only run tests not implemented in source file FILE (see \ - SELECTING TESTS)." ); + " Only run tests not implemented in source files ending with \ + FILE (see SELECTING TESTS)." ); ( "--match", Arg.String (fun pattern -> @@ -342,8 +342,9 @@ let init ?args () = options.patterns_not_to_run <- Base.rex ~opts:[`Caseless] pattern :: options.patterns_not_to_run), - " Only run tests not matching PERL_REGEXP (case \ - insensitive) (see SELECTING TESTS)." ); + " Only run tests for which 'FILE: TITLE' does not match \ + PERL_REGEXP (case insensitive), where FILE is the source file of \ + the test and TITLE its title (see SELECTING TESTS)." ); ( "--title", Arg.String (fun title -> options.tests_to_run <- title :: options.tests_to_run), @@ -526,10 +527,10 @@ let init ?args () = title' matches one or several Perl regular expressions using --match \ (respectively --not-match).\n\n\ \ The file in which a test is implemented is specified by the ~__FILE__ \ - argument of Test.register. In other words, it is the name of the file \ - in which the test is defined, without directories. Use --file \ - (respectively --not-file) to select (respectively unselect) a test by \ - its filename on the command-line.\n\n\ + argument of Test.register. In other words, it is the path of the file \ + in which the test is defined. Use --file (respectively --not-file) to \ + select (respectively unselect) a test by its path (or a suffix thereof) \ + on the command-line.\n\n\ \ For instance:\n\n\ \ " ^ Sys.argv.(0) ^ " node bake /rpc --file bootstrap.ml --file sync.ml\n\n\ diff --git a/lib_core/test.ml b/lib_core/test.ml index 202a583..672314b 100644 --- a/lib_core/test.ml +++ b/lib_core/test.ml @@ -341,6 +341,97 @@ let run_one ~sleep ~clean_up ~temp_start ~temp_stop ~temp_clean_up test = Cli.options.retry test +(* Radix trees for string lists. + + Similar to [Set.Make (struct type t = string list end)], except that it provides + functions to work on prefixes. *) +module String_tree : sig + type t + + val empty : t + + val add : string list -> t -> t + + (* Test whether a tree contains a list that starts with a given prefix. + + [mem_prefix prefix tree] returns [true] if, and only if [tree] contains + a [list] of which [prefix] is a prefix. *) + val mem_prefix : string list -> t -> bool + + (* Test whether a tree contains a prefix of a given list. + + [mem_prefix_of list tree] returns [true] if a list that was added in [tree] + is a prefix of [list]. *) + val mem_prefix_of : string list -> t -> bool +end = struct + (* Note: [value] could actually have type [bool]. + But by storing the list we avoid having to build it again, so it's probably + more efficient that way, as long as we don't need to take a subtree of a tree + because we rely on the invariant that [value] is the path from the root. *) + type t = {subtrees : t String_map.t; value : string list option; count : int} + + let empty = {subtrees = String_map.empty; value = None; count = 0} + + let add path tree = + let rec add items tree = + match items with + | [] -> {tree with value = Some path; count = tree.count + 1} + | head :: tail -> + let dir = + match String_map.find_opt head tree.subtrees with + | None -> empty + | Some dir -> dir + in + let dir = add tail dir in + { + tree with + subtrees = String_map.add head dir tree.subtrees; + count = tree.count + 1; + } + in + add path tree + + let rec sub path tree = + match path with + | [] -> tree + | head :: tail -> ( + match String_map.find_opt head tree.subtrees with + | None -> empty + | Some tree -> sub tail tree) + + let mem_prefix path tree = (sub path tree).count > 0 + + let mem_prefix_of path tree = + let rec aux items tree = + if String_map.cardinal tree.subtrees = 0 then true + else + match items with + | [] -> false + | head :: tail -> ( + match String_map.find_opt head tree.subtrees with + | None -> false + | Some tree -> aux tail tree) + in + if tree.count = 0 then false else aux path tree +end + +let dir_sep = + if String.length Filename.dir_sep = 1 then Filename.dir_sep.[0] else '/' + +let split_file_rev file = String.split_on_char dir_sep file |> List.rev + +let files_to_run_tree = + List.fold_left + (fun tree file -> String_tree.add (split_file_rev file) tree) + String_tree.empty + Cli.options.files_to_run + +let files_not_to_run_tree = + List.fold_left + (fun tree file -> String_tree.add (split_file_rev file) tree) + String_tree.empty + Cli.options.files_not_to_run + let test_should_be_run ~file ~title ~tags = let uid = file ^ ": " ^ title in let match_uid pattern = uid =~ pattern in @@ -357,8 +448,13 @@ let test_should_be_run ~file ~title ~tags = && (not (List.exists match_uid Cli.options.patterns_not_to_run)) && (match Cli.options.files_to_run with | [] -> true - | files -> List.mem file files) - && not (List.mem file Cli.options.files_not_to_run) + | _ -> String_tree.mem_prefix_of (split_file_rev file) files_to_run_tree) + && + match Cli.options.files_not_to_run with + | [] -> true + | _ -> + not + @@ String_tree.mem_prefix_of (split_file_rev file) files_not_to_run_tree let tag_rex = rex "^[a-z0-9_]{1,32}$" @@ -372,13 +468,14 @@ let check_tags tags = be at most 32 character long.\n" ; exit 1 -let known_files = ref String_set.empty +let known_files = ref String_tree.empty let known_titles = ref String_set.empty let known_tags = ref String_set.empty -let register_file file = known_files := String_set.add file !known_files +let register_file file = + known_files := String_tree.add (split_file_rev file) !known_files let register_title title = known_titles := String_set.add title !known_titles @@ -390,6 +487,15 @@ let check_existence kind known specified = (Log.warn "Unknown %s: %s" kind) (String_set.diff (String_set.of_list specified) !known) +(* Check that all [suffixes] are suffixes of files that exist in [!known_files]. *) +let check_suffix_existence suffixes = + List.iter + (fun suffix -> + let suffix_split = split_file_rev suffix in + if String_tree.(not (mem_prefix suffix_split !known_files)) then + Log.warn "Unknown file or file suffix: %s" suffix) + suffixes + (* Tests added using [register] and that match command-line filters. *) let registered : test String_map.t ref = ref String_map.empty @@ -921,7 +1027,7 @@ let output_junit filename = let next_id = ref 0 let register ~__FILE__ ~title ~tags ?(seed = Fixed 0) body = - let file = Filename.basename __FILE__ in + let file = __FILE__ in (match String_map.find_opt title !registered with | None -> () | Some {file = other_file; tags = other_tags; _} -> @@ -995,8 +1101,8 @@ let run_with_scheduler scheduler = current_worker_id_ref := Scheduler.get_current_worker_id ; List.iter (fun f -> f ()) !before_test_run_functions ; (* Check command-line options. *) - check_existence "--file" known_files Cli.options.files_to_run ; - check_existence "--not-file" known_files Cli.options.files_not_to_run ; + check_suffix_existence Cli.options.files_to_run ; + check_suffix_existence Cli.options.files_not_to_run ; check_existence "--title" known_titles Cli.options.tests_to_run ; check_existence "--not-title" known_titles Cli.options.tests_not_to_run ; check_existence -- GitLab From c3fcba9e9b8d4ce403f1aa4037e6da22e8fd418c Mon Sep 17 00:00:00 2001 From: Arvid Jakobsson Date: Fri, 24 Mar 2023 10:50:00 +0100 Subject: [PATCH 2/3] add tests for String_tree --- lib_core/test.mli | 14 +++++++++++++ test/common/tests.ml | 48 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/lib_core/test.mli b/lib_core/test.mli index cd7eb78..7b2c7db 100644 --- a/lib_core/test.mli +++ b/lib_core/test.mli @@ -178,3 +178,17 @@ val run_one : temp_clean_up:(unit -> unit) -> t -> test_result Lwt.t + +module String_tree : sig + (** Radix trees for string lists. *) + + (** This module is only exposed so that it can be tested in test/common/tests.ml. *) + + type t + + val empty : t + + val add : string list -> t -> t + + val mem_prefix_of : string list -> t -> bool +end diff --git a/test/common/tests.ml b/test/common/tests.ml index 8eedfee..0421bb2 100644 --- a/test/common/tests.ml +++ b/test/common/tests.ml @@ -47,3 +47,51 @@ let () = ~error_msg: "expected x <> %R, got %L (there is a 1/2^63 chance that this happens)" ; unit + +let () = + Test.register + ~__FILE__ + ~title:"string_tree: mem_prefix_of" + ~tags:["string_tree"] + @@ fun () -> + let split file = String.split_on_char '/' file |> List.rev in + List.iter + (fun (suffixes, tests) -> + let suffix_tree = + List.fold_left + (fun tree s -> Test.String_tree.add (split s) tree) + Test.String_tree.empty + suffixes + in + List.iter + (fun (file, expected_res) -> + let res = Test.String_tree.mem_prefix_of (split file) suffix_tree in + Check.( + (res = expected_res) + bool + ~__LOC__ + ~error_msg: + (sf "mem_prefix_of(%s, %s) = " file (String.concat ";" suffixes) + ^ "%L, expected %R")) ; + Log.info + "mem_prefix_of(%s, %s) = %b" + file + (String.concat ";" suffixes) + res) + tests) + [ + (["c.ml"], [("c.ml", true); ("b/c.ml", true); ("d.ml", false)]); + ( ["b/c.ml"], + [("c.ml", false); ("b/c.ml", true); ("d.ml", false); ("a/b/c.ml", true)] + ); + ([], [("c.ml", false); ("b/c.ml", false)]); + ( ["b/x.ml"; "c/x.ml"; "y.ml"], + [ + ("b/x.ml", true); + ("c/x.ml", true); + ("y.ml", true); + ("z/x.ml", false); + ("z/b/x.ml", true); + ] ); + ] ; + unit -- GitLab From 104d0cada62c208720431322a12336ddf0a36cb9 Mon Sep 17 00:00:00 2001 From: Arvid Jakobsson Date: Fri, 24 Mar 2023 10:50:25 +0100 Subject: [PATCH 3/3] add tests for selection by file suffix --- test/cram/main.ml | 10 +++++ test/cram/test-basic.t | 2 +- test/cram/test-retry.t | 14 +++---- test/cram/test-selection.t | 83 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 101 insertions(+), 8 deletions(-) create mode 100644 test/cram/test-selection.t diff --git a/test/cram/main.ml b/test/cram/main.ml index 55d8648..0ea35c4 100644 --- a/test/cram/main.ml +++ b/test/cram/main.ml @@ -55,8 +55,18 @@ let test_fail_always () = ~tags:["retry"; "fail"; "always"] @@ fun () -> Test.fail "Always failing test" +(* Used to test selection of tests *) +let test_selection () = + let files = ["a/b/c.ml"; "a/b/g.ml"; "a/c.ml"; "d.ml"; "e.ml"] in + List.iter + (fun file -> + Test.register ~__FILE__:file ~title:file ~tags:["selection"] (fun () -> + unit)) + files + let () = test_success () ; test_fail_every_other_run () ; test_fail_always () ; + test_selection () ; Test.run () diff --git a/test/cram/test-basic.t b/test/cram/test-basic.t index 07d6386..d9b2257 100644 --- a/test/cram/test-basic.t +++ b/test/cram/test-basic.t @@ -4,5 +4,5 @@ Run a test that should fail: Starting test: Failing test [error] Always failing test [FAILURE] (1/1, 1 failed) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [1] diff --git a/test/cram/test-retry.t b/test/cram/test-retry.t index d0e2bed..2b7810a 100644 --- a/test/cram/test-retry.t +++ b/test/cram/test-retry.t @@ -5,7 +5,7 @@ Without --retry, we fail as usual. Starting test: Fail every other run test [error] Failing test on first try [FAILURE] (2/3, 1 failed) Fail every other run test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Fail every other run test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Fail every other run test' [1] With --keep-going but without --retry, we run all tests and fail as usual. @@ -15,11 +15,11 @@ With --keep-going but without --retry, we run all tests and fail as usual. Starting test: Fail every other run test [error] Failing test on first try [FAILURE] (2/3, 1 failed) Fail every other run test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Fail every other run test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Fail every other run test' Starting test: Failing test [error] Always failing test [FAILURE] (3/3, 2 failed) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [1] If we set --retry, then the "fail once" test will eventually @@ -37,7 +37,7 @@ succeed. However, the "fail always" test will fail the test suite. Starting test: Failing test [error] Always failing test [FAILURE] (3/3, 1 failed) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [1] @@ -64,7 +64,7 @@ With --keep-going, we still fail: Starting test: Failing test [error] Always failing test [FAILURE] (3/3, 1 failed) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [1] Looping is handled: @@ -81,7 +81,7 @@ Looping is handled: Starting test: Failing test [error] Always failing test [FAILURE] (3/3, 1 failed) (loop 1) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [SUCCESS] (1/3, 1 failed) (loop 2) Success Starting test: Fail every other run test [error] Failing test on first try @@ -93,7 +93,7 @@ Looping is handled: Starting test: Failing test [error] Always failing test [FAILURE] (3/3, 2 failed) (loop 2) Failing test - Try again with: _build/default/main.exe --verbose --file main.ml --title 'Failing test' + Try again with: _build/default/main.exe --verbose --file test/cram/main.ml --title 'Failing test' [1] Retries work with `-j`, but we don't know the order of the output. So diff --git a/test/cram/test-selection.t b/test/cram/test-selection.t new file mode 100644 index 0000000..e0a8de5 --- /dev/null +++ b/test/cram/test-selection.t @@ -0,0 +1,83 @@ +Test the '--file' filter. + + $ ./tezt.sh selection --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + | a/b/g.ml | a/b/g.ml | selection | + | a/c.ml | a/c.ml | selection | + | d.ml | d.ml | selection | + | e.ml | e.ml | selection | + +----------+----------+-----------+ + + $ ./tezt.sh selection --file 'a/b/c.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --file 'c.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + | a/c.ml | a/c.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --file 'b/c.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --file 'a/c.ml' --list + +--------+--------+-----------+ + | FILE | TITLE | TAGS | + +--------+--------+-----------+ + | a/c.ml | a/c.ml | selection | + +--------+--------+-----------+ + $ ./tezt.sh selection --file 'd.ml' --list + +------+-------+-----------+ + | FILE | TITLE | TAGS | + +------+-------+-----------+ + | d.ml | d.ml | selection | + +------+-------+-----------+ + $ ./tezt.sh selection --file '' --list + [warn] Unknown file or file suffix: + No test found for filters: --file selection + [3] + $ ./tezt.sh selection --file '.ml' --list + [warn] Unknown file or file suffix: .ml + No test found for filters: --file .ml selection + [3] + $ ./tezt.sh selection --file 'c.ml' --file 'd.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + | a/c.ml | a/c.ml | selection | + | d.ml | d.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --not-file 'c.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/g.ml | a/b/g.ml | selection | + | d.ml | d.ml | selection | + | e.ml | e.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --not-file 'b/g.ml' --list + +----------+----------+-----------+ + | FILE | TITLE | TAGS | + +----------+----------+-----------+ + | a/b/c.ml | a/b/c.ml | selection | + | a/c.ml | a/c.ml | selection | + | d.ml | d.ml | selection | + | e.ml | e.ml | selection | + +----------+----------+-----------+ + $ ./tezt.sh selection --file 'c.ml' --not-file 'b/c.ml' --list + +--------+--------+-----------+ + | FILE | TITLE | TAGS | + +--------+--------+-----------+ + | a/c.ml | a/c.ml | selection | + +--------+--------+-----------+ -- GitLab