diff --git a/bin/build.ml b/bin/build.ml index 542a4d7a4c4..179b5d00077 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -100,7 +100,7 @@ let poll_handling_rpc_build_requests ~(common : Common.t) ~config = Target.interpret_targets (Common.root common) config setup targets | Runtest test_paths -> Runtest_common.make_request - ~contexts:setup.contexts + ~scontexts:setup.scontexts ~to_cwd:root.to_cwd ~test_paths in diff --git a/bin/import.ml b/bin/import.ml index ba78f7e9fe0..9d4f4a00c40 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -39,6 +39,7 @@ include struct module Library = Library module Melange = Melange module Executables = Executables + module Dir_contents = Dir_contents end include struct diff --git a/bin/runtest.ml b/bin/runtest.ml index d4126611c96..4ebf46323c5 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -43,7 +43,7 @@ let runtest_term = | Ok () -> Build.run_build_command ~common ~config ~request:(fun setup -> Runtest_common.make_request - ~contexts:setup.contexts + ~scontexts:setup.scontexts ~to_cwd:(Common.root common).to_cwd ~test_paths) | Error lock_held_by -> diff --git a/bin/runtest_common.ml b/bin/runtest_common.ml index 22d7777c5a8..18a7a94788d 100644 --- a/bin/runtest_common.ml +++ b/bin/runtest_common.ml @@ -4,11 +4,20 @@ module Test_kind = struct type t = | Runtest of Path.t | Cram of Path.t * Source.Cram_test.t + | Test_executable of + { dir : Path.t + ; exe_name : string + } let alias ~contexts = function | Cram (dir, cram) -> let name = Dune_engine.Alias.Name.of_string (Source.Cram_test.name cram) in Alias.in_dir ~name ~recursive:false ~contexts dir + | Test_executable { dir; exe_name } -> + (* CR-someday Alizter: get the proper alias, also check js_of_ocaml + runtst aliases? *) + let name = Dune_engine.Alias.Name.of_string ("runtest-" ^ exe_name) in + Alias.in_dir ~name ~recursive:false ~contexts dir | Runtest dir -> Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir ;; @@ -34,44 +43,92 @@ let find_cram_test cram_tests path = | Error (Dune_rules.Cram_rules.Missing_run_t _) | Ok _ -> None) ;; -let all_tests_of_dir parent_dir = +(** [find_test_executable ~sctx ~dir ~ml_file] looks up whether [ml_file] is part + of a (tests) stanza in [dir] and returns: + - [Ok exe_name] if the file is a test entry point, or if the file belongs to + a tests stanza with a single entry point (in which case that entry point is + returned) + - [Error `Not_an_entry_point] if the file belongs to a tests stanza with + multiple entry points but is not itself an entry point + - [Error `Not_a_test] if the file is not part of any tests stanza *) +let find_test_executable ~sctx ~dir ~ml_file = + let open Memo.O in + let ml_file_no_ext = Filename.remove_extension ml_file in + match Dune_lang.Module_name.of_string_opt ml_file_no_ext with + | None -> Memo.return (Error `Not_a_test) + | Some module_name -> + let* dir_contents = + let dir = + Path.Build.append_source (Super_context.context sctx |> Context.build_dir) dir + in + Dir_contents.get sctx ~dir + in + let* ml_sources = Dir_contents.ocaml dir_contents + and* scope = Dir_contents.dir dir_contents |> Dune_rules.Scope.DB.find_by_dir in + Dune_rules.Ml_sources.find_origin + ml_sources + ~libs:(Dune_rules.Scope.libs scope) + [ module_name ] + >>| (function + | Some (Library _ | Executables _ | Melange _) | None -> Error `Not_a_test + | Some (Tests { exes; _ }) -> + let exe_names = Nonempty_list.to_list exes.names |> List.map ~f:snd in + if List.mem exe_names ml_file_no_ext ~equal:String.equal + then Ok ml_file_no_ext + else ( + match exe_names with + | [ single_exe ] -> Ok single_exe + | _ -> Error `Not_an_entry_point)) +;; + +let all_tests_of_dir ~sctx parent_dir = let open Memo.O in let+ cram_candidates = cram_tests_of_dir parent_dir >>| List.filter_map ~f:(fun res -> Result.to_option res |> Option.map ~f:(fun test -> Source.Cram_test.path test |> Path.Source.to_string)) + and+ test_executables_candidates = + let dir = + Path.Build.append_source + (Super_context.context sctx |> Context.build_dir) + parent_dir + in + Dir_contents.get sctx ~dir + >>= Dir_contents.ocaml + >>| Dune_rules.Ml_sources.test_entry_points + >>| List.map ~f:(fun name -> name ^ ".ml") and+ dir_candidates = - let* parent_source_dir = Source_tree.find_dir parent_dir in - match parent_source_dir with + Source_tree.find_dir parent_dir + >>= function | None -> Memo.return [] | Some parent_source_dir -> - let dirs = Source_tree.Dir.sub_dirs parent_source_dir in - String.Map.to_list dirs + Source_tree.Dir.sub_dirs parent_source_dir + |> String.Map.to_list |> Memo.List.map ~f:(fun (_candidate, candidate_path) -> Source_tree.Dir.sub_dir_as_t candidate_path >>| Source_tree.Dir.path >>| Path.Source.to_string) in - List.concat [ cram_candidates; dir_candidates ] + List.concat [ cram_candidates; test_executables_candidates; dir_candidates ] |> String.Set.of_list |> String.Set.to_list ;; -let explain_unsuccessful_search path ~parent_dir = +let explain_unsuccessful_search ~sctx path ~parent_dir = let open Memo.O in - let+ candidates = all_tests_of_dir parent_dir in + let+ candidates = all_tests_of_dir ~sctx parent_dir in User_error.raise ~hints:(User_message.did_you_mean (Path.Source.to_string path) ~candidates) [ Pp.textf "%S does not match any known test." (Path.Source.to_string path) ] ;; -(* [disambiguate_test_name path] is a function that takes in a - directory [path] and classifies it as either a cram test or a directory to +(* [disambiguate_test_name path] is a function that takes in a directory [path] + and classifies it as either a cram test, test executable, or a directory to run tests in. *) -let disambiguate_test_name path = +let disambiguate_test_name ~sctx path = match Path.Source.parent path with - | None -> Memo.return @@ Test_kind.Runtest (Path.source Path.Source.root) + | None -> Memo.return (Test_kind.Runtest (Path.source Path.Source.root)) | Some parent_dir -> let open Memo.O in let* cram_tests = cram_tests_of_dir parent_dir in @@ -80,27 +137,45 @@ let disambiguate_test_name path = (* If we find the cram test, then we request that is run. *) Memo.return (Test_kind.Cram (Path.source parent_dir, test)) | None -> - (* If we don't find it, then we assume the user intended a directory for - @runtest to be used. *) - Source_tree.find_dir path + (* Check for test executables *) + let filename = Path.Source.basename path in + find_test_executable ~sctx ~dir:parent_dir ~ml_file:filename >>= (function - (* We need to make sure that this directory or file exists. *) - | Some _ -> Memo.return (Test_kind.Runtest (Path.source path)) - | None -> explain_unsuccessful_search path ~parent_dir)) + | Ok exe_name -> + Memo.return + (Test_kind.Test_executable { dir = Path.source parent_dir; exe_name }) + | Error `Not_an_entry_point -> + User_error.raise + [ Pp.textf + "%S is used by multiple test executables and cannot be run directly." + filename + ] + | Error `Not_a_test -> + (* If we don't find it, then we assume the user intended a directory for + @runtest to be used. *) + Source_tree.find_dir path + >>= (function + (* We need to make sure that this directory or file exists. *) + | Some _ -> Memo.return (Test_kind.Runtest (Path.source path)) + | None -> explain_unsuccessful_search ~sctx path ~parent_dir))) ;; -let make_request ~contexts ~to_cwd ~test_paths = +let make_request ~scontexts ~to_cwd ~test_paths = + let contexts = + Context_name.Map.to_list_map scontexts ~f:(fun _ -> Super_context.context) + in List.map test_paths ~f:(fun dir -> let dir = Path.of_string dir |> Path.Expert.try_localize_external in - let contexts, src_dir = + let sctx, contexts, src_dir = match (Util.check_path contexts dir : Util.checked) with - | In_build_dir (context, dir) -> [ context ], dir + | In_build_dir (context, dir) -> + Context_name.Map.find_exn scontexts (Context.name context), [ context ], dir | In_source_dir dir -> (* We need to adjust the path here to make up for the current working directory. *) let dir = Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir) in - contexts, dir + Context_name.Map.find_exn scontexts Context_name.default, contexts, dir | In_private_context _ | In_install_dir _ -> User_error.raise [ Pp.textf "This path is internal to dune: %s" (Path.to_string_maybe_quoted dir) @@ -113,7 +188,7 @@ let make_request ~contexts ~to_cwd ~test_paths = ] in let open Action_builder.O in - Action_builder.of_memo (disambiguate_test_name src_dir) + Action_builder.of_memo (disambiguate_test_name ~sctx src_dir) >>| Test_kind.alias ~contexts >>= Alias.request) |> Action_builder.all_unit diff --git a/bin/runtest_common.mli b/bin/runtest_common.mli index 877d2cde0fe..c1bbd84ba3a 100644 --- a/bin/runtest_common.mli +++ b/bin/runtest_common.mli @@ -1,7 +1,7 @@ open Import val make_request - : contexts:Context.t list + : scontexts:Super_context.t Context_name.Map.t -> to_cwd:string list -> test_paths:string list -> unit Action_builder.t diff --git a/doc/changes/added/12785.md b/doc/changes/added/12785.md new file mode 100644 index 00000000000..7d54dcacf0b --- /dev/null +++ b/doc/changes/added/12785.md @@ -0,0 +1,3 @@ +- `dune runtest` can now run individual test executables from `(tests)` stanzas + by providing their source files as arguments. (#12785, partially addresses + #870, @Alizter) diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 15a6636af8f..f59e184d4dc 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -5,23 +5,27 @@ module Origin = struct type t = | Library of Library.t | Executables of Executables.t + | Tests of Tests.t | Melange of Melange_stanzas.Emit.t let loc = function | Library l -> l.buildable.loc | Executables e -> e.buildable.loc + | Tests t -> t.exes.buildable.loc | Melange mel -> mel.loc ;; let preprocess = function | Library l -> l.buildable.preprocess | Executables e -> e.buildable.preprocess + | Tests t -> t.exes.buildable.preprocess | Melange mel -> mel.preprocess ;; let to_dyn = function | Library _ -> Dyn.variant "Library" [ Dyn.Opaque ] | Executables _ -> Dyn.variant "Executables" [ Dyn.Opaque ] + | Tests _ -> Dyn.variant "Tests" [ Dyn.Opaque ] | Melange _ -> Dyn.variant "Melange" [ Dyn.Opaque ] ;; end @@ -58,10 +62,11 @@ module Per_stanza = struct type groups = { libraries : Library.t group_part list ; executables : Executables.t group_part list + ; tests : Tests.t group_part list ; melange_emits : Melange_stanzas.Emit.t group_part list } - let make { libraries = libs; executables = exes; melange_emits = emits } = + let make { libraries = libs; executables = exes; tests; melange_emits = emits } = let libraries, libraries_by_obj_dir = List.fold_left libs @@ -84,16 +89,26 @@ module Per_stanza = struct by_id, by_obj_dir) in let executables = - match - String.Map.of_list_map exes ~f:(fun (part : Executables.t group_part) -> - let first_exe = snd (Nonempty_list.hd part.stanza.names) in - let origin : Origin.t = Executables part.stanza in - first_exe, (origin, part.modules, part.obj_dir)) - with - | Ok x -> x - | Error (name, _, part) -> + let entries = + List.concat + [ List.map exes ~f:(fun (part : Executables.t group_part) -> + let first_exe = snd (Nonempty_list.hd part.stanza.names) in + let origin : Origin.t = Executables part.stanza in + first_exe, (origin, part.modules, part.obj_dir, part.stanza.buildable.loc)) + ; List.map tests ~f:(fun (part : Tests.t group_part) -> + let first_exe = snd (Nonempty_list.hd part.stanza.exes.names) in + let origin : Origin.t = Tests part.stanza in + ( first_exe + , (origin, part.modules, part.obj_dir, part.stanza.exes.buildable.loc) )) + ] + in + match String.Map.of_list entries with + | Ok map -> + String.Map.map map ~f:(fun (origin, modules, obj_dir, _loc) -> + origin, modules, obj_dir) + | Error (name, (_, _, _, loc1), (_, _, _, _loc2)) -> User_error.raise - ~loc:part.stanza.buildable.loc + ~loc:loc1 [ Pp.textf "Executable %S appears for the second time in this directory" name ] in let melange_emits = @@ -118,6 +133,8 @@ module Per_stanza = struct by_path (Library part.stanza, part.dir) part.sources) ; List.rev_concat_map exes ~f:(fun part -> by_path (Executables part.stanza, part.dir) part.sources) + ; List.rev_concat_map tests ~f:(fun part -> + by_path (Tests part.stanza, part.dir) part.sources) ; List.rev_concat_map emits ~f:(fun part -> by_path (Melange part.stanza, part.dir) part.sources) ] @@ -252,7 +269,7 @@ let find_origin (t : t) ~libs path = | Some origins -> Memo.List.filter_map origins ~f:(fun (origin, dir) -> match origin with - | Executables _ | Melange _ -> Memo.return (Some origin) + | Executables _ | Tests _ | Melange _ -> Memo.return (Some origin) | Library lib -> let src_dir = Path.drop_optional_build_context_src_exn (Path.build dir) in Lib.DB.available_by_lib_id libs (Local (Library.to_lib_id ~src_dir lib)) @@ -265,6 +282,18 @@ let find_origin (t : t) ~libs path = | origins -> raise_module_conflict_error origins ~module_path:path) ;; +let test_entry_points t = + String.Map.fold + t.modules.executables + ~init:[] + ~f:(fun (origin, _modules, _obj_dir) acc -> + match origin with + | Origin.Tests tests -> + let names = Nonempty_list.to_list tests.exes.names |> List.map ~f:snd in + names @ acc + | Origin.Library _ | Origin.Executables _ | Origin.Melange _ -> acc) +;; + let modules_and_obj_dir t ~libs ~for_ = match match for_ with @@ -469,14 +498,18 @@ let modules_of_stanzas = | `Skip -> loop l acc | `Library y -> loop l { acc with libraries = y :: acc.libraries } | `Executables y -> loop l { acc with executables = y :: acc.executables } + | `Tests y -> loop l { acc with tests = y :: acc.tests } | `Melange_emit y -> loop l { acc with melange_emits = y :: acc.melange_emits }) in - fun l -> loop l { libraries = []; executables = []; melange_emits = [] } + fun l -> loop l { libraries = []; executables = []; tests = []; melange_emits = [] } in fun l -> - let { Per_stanza.libraries; executables; melange_emits } = rev_filter_partition l in + let { Per_stanza.libraries; executables; tests; melange_emits } = + rev_filter_partition l + in { Per_stanza.libraries = List.rev libraries ; executables = List.rev executables + ; tests = List.rev tests ; melange_emits = List.rev melange_emits } in @@ -505,6 +538,11 @@ let modules_of_stanzas = in `Executables { Per_stanza.stanza = exes; sources; modules; obj_dir; dir } in + let make_tests ~dir ~expander ~modules ~project tests = + let+ result = make_executables ~dir ~expander ~modules ~project tests.Tests.exes in + match result with + | `Executables group_part -> `Tests { group_part with stanza = tests } + in fun stanzas ~expander ~project ~dir ~libs ~lookup_vlib ~modules ~include_subdirs -> Memo.parallel_map stanzas ~f:(fun stanza -> let enabled_if = @@ -541,7 +579,7 @@ let modules_of_stanzas = let obj_dir = Library.obj_dir lib ~dir in `Library { Per_stanza.stanza = lib; sources; modules; dir; obj_dir } | Executables.T exes -> make_executables ~dir ~expander ~modules ~project exes - | Tests.T { exes; _ } -> make_executables ~dir ~expander ~modules ~project exes + | Tests.T tests -> make_tests ~dir ~expander ~modules ~project tests | Melange_stanzas.Emit.T mel -> let obj_dir = Obj_dir.make_melange_emit ~dir ~name:mel.target in let+ sources, modules = @@ -665,9 +703,11 @@ let make part.stanza, part.modules, part.obj_dir) in let exes = - List.map - modules_of_stanzas.executables - ~f:(fun (part : _ Per_stanza.group_part) -> part.modules, part.obj_dir) + let modules_and_obj_dir { Per_stanza.modules; obj_dir; _ } = modules, obj_dir in + List.concat + [ List.map modules_of_stanzas.executables ~f:modules_and_obj_dir + ; List.map modules_of_stanzas.tests ~f:modules_and_obj_dir + ] in Artifacts_obj.make ~dir diff --git a/src/dune_rules/ml_sources.mli b/src/dune_rules/ml_sources.mli index 7b08c4388f3..cebb63d034f 100644 --- a/src/dune_rules/ml_sources.mli +++ b/src/dune_rules/ml_sources.mli @@ -8,6 +8,7 @@ module Origin : sig type t = | Library of Library.t | Executables of Executables.t + | Tests of Tests.t | Melange of Melange_stanzas.Emit.t val preprocess : t -> Preprocess.With_instrumentation.t Preprocess.Per_module.t @@ -38,6 +39,9 @@ val modules : t -> libs:Lib.DB.t -> for_:for_ -> Modules.t Memo.t (** Find out the origin of the stanza for a given module *) val find_origin : t -> libs:Lib.DB.t -> Module_name.Path.t -> Origin.t option Memo.t +(** Returns the entry point names for all Tests stanzas in this directory *) +val test_entry_points : t -> string list + val empty : t (** This [lookup_vlib] argument is required for constructing the collection of modules for diff --git a/src/dune_rules/top_module.ml b/src/dune_rules/top_module.ml index aeed5582f97..3915455f4ca 100644 --- a/src/dune_rules/top_module.ml +++ b/src/dune_rules/top_module.ml @@ -42,6 +42,7 @@ let find_module sctx src = @@ fun () -> match origin with | Executables exes -> Exe_rules.rules ~sctx ~dir_contents ~scope ~expander exes + | Tests tests -> Exe_rules.rules ~sctx ~dir_contents ~scope ~expander tests.exes | Library lib -> Lib_rules.rules lib ~sctx ~dir_contents ~expander ~scope | Melange mel -> Melange_rules.setup_emit_cmj_rules ~sctx ~dir_contents ~expander ~scope mel diff --git a/test/blackbox-tests/test-cases/runtest-cmd-tests.t b/test/blackbox-tests/test-cases/runtest-cmd-tests.t new file mode 100644 index 00000000000..dbe6c13b44d --- /dev/null +++ b/test/blackbox-tests/test-cases/runtest-cmd-tests.t @@ -0,0 +1,208 @@ +Test running tests by specifying ML source files directly. + + $ cat > dune-project < (lang dune 3.21) + > EOF + +Set up a simple test with multiple test executables: + + $ cat > dune < (tests + > (names test1 test2) + > (modules test1 test2 test_lib)) + > EOF + + $ cat > test_lib.ml < let run_test name = + > Printf.printf "Running %s\n" name + > EOF + + $ cat > test1.ml < let () = + > Test_lib.run_test "test1"; + > assert true + > EOF + + $ cat > test2.ml < let () = + > Test_lib.run_test "test2"; + > exit 1 (* This test fails *) + > EOF + +Running tests by specifying ML files directly: + + $ dune test test1.ml + Running test1 + + $ dune test test2.ml + File "dune", line 2, characters 14-19: + 2 | (names test1 test2) + ^^^^^ + Running test2 + [1] + +Error when specifying a non-test ML file: + + $ cat > lib.ml < let x = 42 + > EOF + + $ cat > dune < (library + > (name mylib) + > (modules lib)) + > (tests + > (names test1 test2) + > (modules test1 test2 test_lib)) + > EOF + + $ dune test lib.ml + Error: "lib.ml" does not match any known test. + [1] + +Error when specifying a non-existent ML file: + + $ dune test nonexistent.ml + Error: "nonexistent.ml" does not match any known test. + [1] + + $ dune test test3.ml + Error: "test3.ml" does not match any known test. + Hint: did you mean test1.ml or test2.ml? + [1] + +Can run tests from _build directory: + + $ rm -rf _build + $ dune test _build/default/test1.ml + Running test1 + +Can specify multiple ML files: + + $ rm -rf _build + $ dune test test1.ml test2.ml + Running test1 + File "dune", line 5, characters 14-19: + 5 | (names test1 test2) + ^^^^^ + Running test2 + [1] + +-------------------------------------------------------------------------------- + +Test with a single test executable and multiple modules. + + $ cat > dune < (test + > (name single_test) + > (modules single_test helper1 helper2)) + > EOF + + $ cat > helper1.ml < let value = "from helper1" + > EOF + + $ cat > helper2.ml < let value = Helper1.value ^ " and helper2" + > EOF + + $ cat > single_test.ml < let () = + > Printf.printf "Test: %s\n" Helper2.value; + > exit 1 + > EOF + +Targeting the entry point: + + $ dune test single_test.ml + File "dune", line 2, characters 7-18: + 2 | (name single_test) + ^^^^^^^^^^^ + Test: from helper1 and helper2 + [1] + +Targeting helper modules should also run the test: + + $ dune test helper1.ml + File "dune", line 2, characters 7-18: + 2 | (name single_test) + ^^^^^^^^^^^ + Test: from helper1 and helper2 + [1] + + $ dune test helper2.ml + File "dune", line 2, characters 7-18: + 2 | (name single_test) + ^^^^^^^^^^^ + Test: from helper1 and helper2 + [1] + +-------------------------------------------------------------------------------- + +Test with more complex module dependencies. +Set up: A <- B <- C -> D -> E where A and E are entry points. + + $ cat > dune < (tests + > (names a e) + > (modules a b c d e)) + > EOF + + $ cat > c.ml < let shared = "shared by both" + > EOF + + $ cat > b.ml < let helper = "used only by A via " ^ C.shared + > EOF + + $ cat > d.ml < let helper = "used only by E via " ^ C.shared + > EOF + + $ cat > a.ml < let () = + > Printf.printf "A using %s\n" B.helper; + > exit 1 + > EOF + + $ cat > e.ml < let () = + > Printf.printf "E using %s\n" D.helper; + > exit 1 + > EOF + +Targeting entry points A and E should run those specific tests: + + $ dune test a.ml + File "dune", line 2, characters 8-9: + 2 | (names a e) + ^ + A using used only by A via shared by both + [1] + + $ dune test e.ml + File "dune", line 2, characters 10-11: + 2 | (names a e) + ^ + E using used only by E via shared by both + [1] + +Targeting non-entry-point modules in a stanza with multiple tests errors. +Currently B, D, and C all error even though only C is actually shared: + + $ dune test b.ml + Error: "b.ml" is used by multiple test executables and cannot be run + directly. + [1] + + $ dune test d.ml + Error: "d.ml" is used by multiple test executables and cannot be run + directly. + [1] + + $ dune test c.ml + Error: "c.ml" is used by multiple test executables and cannot be run + directly. + [1] +