mte/unikernel/duniverse/dune_/bin/runtest.ml

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" ]
;;