unikernel/duniverse/dune_/bin/runtest.ml

@@ -0,0 +1,164 @@
+open Import
+
+let runtest_info =
+  let doc = "Run tests." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P "Run the given tests. The [TEST] argument can be either:"
+    ; `I
+        ( "-"
+        , "A directory: If a directory is provided, dune will recursively run all tests \
+           within that directory." )
+    ; `I
+        ( "-"
+        , "A file name: If a specific file name is provided, dune will run the tests \
+           with that name." )
+    ; `P
+        "If no [TEST] is provided, dune will run all tests in the current directory and \
+         its subdirectories."
+    ; `P "See EXAMPLES below for additional information on use cases."
+    ; `Blocks Common.help_secs
+    ; Common.examples
+        [ "Run all tests in a given directory", "dune runtest path/to/dir/"
+        ; "Run a specific cram test", "dune runtest path/to/mytest.t"
+        ; ( "Run all tests in the current source tree (including those that passed on \
+             the last run)"
+          , "dune runtest --force" )
+        ; ( "Run tests sequentially without output buffering"
+          , "dune runtest --no-buffer -j 1" )
+        ; "Run tests in a specific build context", "dune runtest _build/my_context/"
+        ]
+    ]
+  in
+  Cmd.info "runtest" ~doc ~man ~envs:Common.envs
+;;
+
+let find_cram_test path ~parent_dir =
+  let open Memo.O in
+  Source_tree.nearest_dir parent_dir
+  >>= Dune_rules.Cram_rules.cram_tests
+  (* We ignore the errors we get when searching for cram tests as they will
+     be reported during building anyway. We are only interested in the
+     presence of cram tests. *)
+  >>| List.filter_map ~f:Result.to_option
+  (* We search our list of known cram tests for the test we are looking
+     for. *)
+  >>| List.find ~f:(fun (test : Source.Cram_test.t) ->
+    let src =
+      match test with
+      | File src -> src
+      | Dir { dir = src; _ } -> src
+    in
+    Path.Source.equal path src)
+;;
+
+let explain_unsuccessful_search path ~parent_dir =
+  let open Memo.O in
+  (* If the user misspelled the test name, we give them a hint. *)
+  let+ hints =
+    (* We search for all files and directories in the parent directory and
+       suggest them as possible candidates. *)
+    let+ candidates =
+      let+ file_candidates =
+        let+ files = Source_tree.files_of parent_dir in
+        Path.Source.Set.to_list_map files ~f:Path.Source.to_string
+      and+ dir_candidates =
+        let* parent_source_dir = Source_tree.find_dir parent_dir in
+        match parent_source_dir with
+        | None -> Memo.return []
+        | Some parent_source_dir ->
+          let dirs = Source_tree.Dir.sub_dirs parent_source_dir in
+          String.Map.to_list dirs
+          |> 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 [ file_candidates; dir_candidates ]
+    in
+    User_message.did_you_mean (Path.Source.to_string path) ~candidates
+  in
+  User_error.raise
+    ~hints
+    [ 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
+   run tests in. *)
+let disambiguate_test_name path =
+  match Path.Source.parent path with
+  | None -> Memo.return @@ `Runtest (Path.source Path.Source.root)
+  | Some parent_dir ->
+    let open Memo.O in
+    find_cram_test path ~parent_dir
+    >>= (function
+     | Some test ->
+       (* If we find the cram test, then we request that is run. *)
+       Memo.return (`Test (parent_dir, Source.Cram_test.name 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
+       >>= (function
+        (* We need to make sure that this directory or file exists. *)
+        | Some _ -> Memo.return (`Runtest (Path.source path))
+        | None -> explain_unsuccessful_search path ~parent_dir))
+;;
+
+let runtest_term =
+  let name = Arg.info [] ~docv:"TEST" in
+  let+ builder = Common.Builder.term
+  and+ dirs = Arg.(value & pos_all string [ "." ] name) in
+  let common, config = Common.init builder in
+  let request (setup : Import.Main.build_system) =
+    let contexts = setup.contexts in
+    List.map dirs ~f:(fun dir ->
+      let dir = Path.of_string dir |> Path.Expert.try_localize_external in
+      let open Action_builder.O in
+      let* contexts, alias_kind =
+        match (Util.check_path contexts dir : Util.checked) with
+        | In_build_dir (context, dir) ->
+          let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
+          [ context ], res
+        | In_source_dir dir ->
+          (* We need to adjust the path here to make up for the current working directory. *)
+          let { Workspace_root.to_cwd; _ } = Common.root common in
+          let dir =
+            Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir)
+          in
+          let+ res = Action_builder.of_memo (disambiguate_test_name dir) in
+          contexts, res
+        | In_private_context _ | In_install_dir _ ->
+          User_error.raise
+            [ Pp.textf
+                "This path is internal to dune: %s"
+                (Path.to_string_maybe_quoted dir)
+            ]
+        | External _ ->
+          User_error.raise
+            [ Pp.textf
+                "This path is outside the workspace: %s"
+                (Path.to_string_maybe_quoted dir)
+            ]
+      in
+      Alias.request
+      @@
+      match alias_kind with
+      | `Test (dir, alias_name) ->
+        Alias.in_dir
+          ~name:(Dune_engine.Alias.Name.of_string alias_name)
+          ~recursive:false
+          ~contexts
+          (Path.source dir)
+      | `Runtest dir ->
+        Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir)
+    |> Action_builder.all_unit
+  in
+  Build.run_build_command ~common ~config ~request
+;;
+
+let commands =
+  let command = Cmd.v runtest_info runtest_term in
+  [ command; command_alias command runtest_term "test" ]
+;;