Source file Cmd.ml

(*
   Command-line interface generated for a test program.
*)

open Printf
open Testo_util
open Fpath_.Operators
open Cmdliner

(* Record that groups configuration options known before parsing the command
   line. *)
type ocaml_conf = {
  argv : string array;
  project_name : string;
  expectation_workspace_root : Fpath.t option;
  status_workspace_root : Fpath.t option;
}

(*
   Configuration object type that is used for all subcommands although
   not all of them use all the fields.

   This configuration is obtained after evaluating the command line.
*)
type conf = {
  (* All subcommands *)
  chdir : Fpath.t option;
  debug : bool;
  filter_by_substring : string list option;
  filter_by_tag : Tag_query.t option;
  env : (string * string) list;
  ocaml_conf : ocaml_conf;
  (* Run and Status *)
  intro : string;
  show_output : bool;
  autoclean : bool;
  max_inline_log_bytes : int option;
  (* Status *)
  status_output_style : Run.status_output_style;
  (* Run *)
  lazy_ : bool;
  slice : Slice.t list;
  is_worker : bool;
  jobs : int option;
  strict : bool;
  test_list_checksum : string option;
}

let default_max_inline_log_bytes = 1_000_000

let default_ocaml_conf =
  {
    argv = Sys.argv;
    project_name = "";
    expectation_workspace_root = None;
    status_workspace_root = None;
  }

let default_conf =
  {
    ocaml_conf = default_ocaml_conf;
    chdir = None;
    debug = false;
    filter_by_substring = None;
    filter_by_tag = None;
    env = [];
    show_output = false;
    autoclean = false;
    max_inline_log_bytes = Some default_max_inline_log_bytes;
    status_output_style = Compact_important;
    intro = Run.introduction_text;
    lazy_ = false;
    slice = [];
    is_worker = false;
    jobs = None;
    strict = false;
    test_list_checksum = None;
  }

(*
   Subcommands:
   - run
   - status
   - approve
*)
type cmd_conf =
  | Run_tests of conf
  | Status of conf
  | Approve of conf
  | Show_tags of ocaml_conf

type subcommand_result =
  | Run_result of Types.test_with_status list
  | Status_result of Types.test_with_status list
  | Approve_result

type 'continuation_result test_spec =
  ((string * string) list -> Types.test list)
  * (int -> subcommand_result -> 'continuation_result)

(****************************************************************************)
(* Dispatch subcommands to do real work *)
(****************************************************************************)

let show_tags () =
  Tag.list () |> List.iter (fun tag -> printf "%s\n" (Tag.to_string tag))

let init_cwd_sensitive ~chdir:cwd ocaml_conf =
  let orig_cwd = Option.map (fun _ -> Fpath.v (Sys.getcwd ())) cwd in
  Option.iter Helpers.chdir cwd;
  Store.init_settings
    ?expectation_workspace_root:ocaml_conf.expectation_workspace_root
    ?status_workspace_root:ocaml_conf.status_workspace_root
    ~project_name:ocaml_conf.project_name ();
  orig_cwd

let run_with_conf ((get_tests, handle_subcommand_result) : _ test_spec)
    (cmd_conf : cmd_conf) : unit =
  (*
     The creation of tests can take a while so it's delayed until we
     really need the tests. This makes '--help' fast.
  *)
  match cmd_conf with
  | Run_tests conf ->
      let orig_cwd = init_cwd_sensitive ~chdir:conf.chdir conf.ocaml_conf in
      Debug.debug := conf.debug;
      (* Make sure to communicate over the pipe in binary mode to avoid
         CRLF<->LF conversions.
         We do this before running the user function 'get_tests' in case
         it prints messages to stdout that ends up as junk in the pipe. *)
      set_binary_mode_in stdin true;
      set_binary_mode_out stdout true;
      let tests = get_tests conf.env in
      Run.cmd_run
        ~always_show_unchecked_output:
          (conf.show_output, conf.max_inline_log_bytes)
        ~argv:conf.ocaml_conf.argv ~autoclean:conf.autoclean
        ~filter_by_substring:conf.filter_by_substring
        ~filter_by_tag:conf.filter_by_tag ~intro:conf.intro
        ~is_worker:conf.is_worker ~jobs:conf.jobs ~lazy_:conf.lazy_ ~orig_cwd
        ~slice:conf.slice ~strict:conf.strict
        ~test_list_checksum:conf.test_list_checksum tests
        (fun exit_code tests_with_status ->
          handle_subcommand_result exit_code (Run_result tests_with_status))
      |>
      (* TODO: ignoring this promise doesn't make sense.
            The whole Lwt support needs testing and probably doesn't
            work as is. If someone really needs it, please provide a test
            environment where it's justified i.e. where we can't
            call 'Lwt_main.run' so we can make this work. *)
      ignore
  | Status conf ->
      let _orig_cwd = init_cwd_sensitive ~chdir:conf.chdir conf.ocaml_conf in
      Debug.debug := conf.debug;
      let exit_code, tests_with_status =
        Run.cmd_status
          ~always_show_unchecked_output:
            (conf.show_output, conf.max_inline_log_bytes)
          ~autoclean:conf.autoclean
          ~filter_by_substring:conf.filter_by_substring
          ~filter_by_tag:conf.filter_by_tag ~intro:conf.intro
          ~output_style:conf.status_output_style ~strict:conf.strict
          (get_tests conf.env)
      in
      handle_subcommand_result exit_code (Status_result tests_with_status)
  | Approve conf ->
      let _orig_cwd = init_cwd_sensitive ~chdir:conf.chdir conf.ocaml_conf in
      Debug.debug := conf.debug;
      let exit_code =
        Run.cmd_approve ~filter_by_substring:conf.filter_by_substring
          ~filter_by_tag:conf.filter_by_tag (get_tests conf.env)
      in
      handle_subcommand_result exit_code Approve_result
  | Show_tags ocaml_conf ->
      let _orig_cwd = init_cwd_sensitive ~chdir:None ocaml_conf in
      show_tags ()

(****************************************************************************)
(* Command-line options *)
(****************************************************************************)
(*
   Some of the command-line options are shared among subcommands.
*)

let autoclean_term : bool Term.t =
  let info =
    Arg.info [ "autoclean" ]
      ~doc:"Remove test snapshots that don't match any test."
  in
  Arg.value (Arg.flag info)

let debug_term : bool Term.t =
  let info =
    Arg.info [ "debug" ]
      ~doc:"Log information that can be useful for debugging the Testo library."
  in
  Arg.value (Arg.flag info)

let chdir_term : string option Term.t =
  let info =
    Arg.info [ "C"; "chdir" ] ~docv:"DIR"
      ~doc:
        "Change the current working directory to $(docv) before doing any work."
  in
  Arg.value (Arg.opt (Arg.some Arg.string) None info)

let expert_term : bool Term.t =
  let info =
    Arg.info [ "expert" ]
      ~doc:
        "Assume the user is familiar with Testo and don't show non-essential\n\
         messages or tips targeted at new users."
  in
  Arg.value (Arg.flag info)

let filter_by_substring_term : string list Term.t =
  let info =
    Arg.info
      [ "s"; "filter-substring" ]
      ~docv:"SUBSTRING"
      ~doc:
        {|Select tests whose description
contains $(docv).
Multiple '-s' search queries can be specified in which case only one
of them needs to match.|}
  in
  Arg.value (Arg.opt_all Arg.string [] info)

let tag_query_conv =
  let parse str =
    match Tag_query.parse str with
    | Ok x -> Ok x
    | Error msg -> Error (`Msg msg)
  in
  Cmdliner.Arg.conv ~docv:"QUERY" (parse, Tag_query.pp)

(* This option currently supports only one tag. In the future, we might
   want to support boolean queries e.g. '-t "lang.python and not todo"' *)
let filter_by_tag_term : Tag_query.t option Term.t =
  let info =
    Arg.info [ "t"; "filter-tag" ] ~docv:"QUERY"
      ~doc:
        (sprintf
           "Select tests whose tags match $(docv). Filtering by tag is \
            generally more robust than selecting tests by text contained in \
            their name with '-s'. $(docv) is a boolean query combining tags \
            with 'and', 'or', 'not', and parentheses using the usual \
            precedence rules. Tag-like selectors 'all' and 'none' are also \
            supported. For example, '(foo or bar) and not e2e' will select any \
            test with the tag 'foo' or the tag 'bar' but not if it has the tag \
            'e2e'. Run '%s show-tags' to see the list of tags defined for the \
            current test suite."
           Sys.argv.(0))
  in
  Arg.value (Arg.opt (Arg.some tag_query_conv) None info)

let show_output_term : bool Term.t =
  let info =
    Arg.info [ "w"; "show-output" ]
      ~doc:
        "Show the output of all tests rather than only showing the output of \
         the failed tests. This excludes the output (stdout, stderr, or both) \
         that may be captured explicitly to be compared against expectations."
  in
  Arg.value (Arg.flag info)

let nonnegative_int_limit =
  let parse_nonnegative_int_limit str =
    match str with
    | "unlimited" -> Ok None
    | _ -> (
        match int_of_string_opt str with
        | None ->
            Error
              (`Msg
                 (Printf.sprintf "not a nonnegative int or 'unlimited': %s" str))
        | Some n ->
            if n < 0 then
              Error
                (`Msg
                   (Printf.sprintf
                      "A negative integer is not a valid upper limit for a \
                       nonnegative int: %s. To suppress the default limit, use \
                       'unlimited'"
                      str))
            else Ok (Some n))
  in
  let print_nonnegative_int_limit ppf opt_int =
    match opt_int with
    | None -> Format.fprintf ppf "unlimited"
    | Some n -> Format.fprintf ppf "%d" n
  in
  Cmdliner.Arg.conv ~docv:"LIMIT"
    (parse_nonnegative_int_limit, print_nonnegative_int_limit)

let max_inline_log_bytes_term : int option Term.t =
  let info =
    Arg.info [ "max-inline-log-bytes" ] ~docv:"LIMIT"
      ~doc:
        (sprintf
           "When displaying logs (unchecked stdout or stderr output), show at \
            most that many bytes for each test.\n\
           \               The default limit is %d bytes. To remove the \
            default limit, specify 'unlimited'."
           default_max_inline_log_bytes)
  in
  Arg.value
    (Arg.opt nonnegative_int_limit (Some default_max_inline_log_bytes) info)

let strict_term : bool Term.t =
  let info =
    Arg.info [ "strict" ]
      ~doc:
        "Treat flaky tests as ordinary tests. This disables the default \
         behavior of ignoring failing tests that were marked as flaky by the \
         programmer when determining the overall success of the test run."
  in
  Arg.value (Arg.flag info)

let verbose_run_term : bool Term.t =
  let info =
    Arg.info [ "v"; "verbose" ]
      ~doc:
        "Print more details than by default. Currently, this is equivalent to \
         '--show-output' but it may be extended in the future to bundle up \
         more options."
  in
  Arg.value (Arg.flag info)

(* Converter for arguments of the form KEY=VALUE *)
let env_conv =
  let key_re = Re.Pcre.regexp {|\A[A-Za-z_][A-Za-z_0-9]*\z|} in
  let error str = Error (sprintf "Malformed KEY=VALUE pair: %s" str) in
  let parse str =
    match String.index_opt str '=' with
    | None -> error str
    | Some pos ->
        let key = String.sub str 0 pos in
        if not (Re.Pcre.pmatch ~rex:key_re key) then error str
        else
          let value = String.sub str (pos + 1) (String.length str - pos - 1) in
          Ok (key, value)
  in
  let print fmt (key, value) = Format.fprintf fmt "%s=%s" key value in
  Arg.conv' ~docv:"KEY=VALUE" (parse, print)

let env_term : (string * string) list Term.t =
  let info =
    Arg.info [ "e"; "env" ] ~docv:"KEY=VALUE"
      ~doc:
        "Pass a key/value pair to the function that creates the test suite. \
         KEY must be an alphanumeric identifier of the form \
         [A-Za-z_][A-Za-z_0-9]*. VALUE can be any string. This mechanism for \
         passing arbitrary runtime settings to the test suite is offered as a \
         safer alternative to environment variables. Multiple -e/--env options \
         are supported in the same command, each defining one key/value pair."
  in
  Arg.value (Arg.opt_all env_conv [] info)

(****************************************************************************)
(* Subcommand: run (replaces alcotest's 'test') *)
(****************************************************************************)

let jobs_term ~default_workers : int option Term.t =
  let default_str =
    match default_workers with
    | None -> "set to the number of CPUs detected on the machine"
    | Some n -> string_of_int n
  in
  let info =
    Arg.info [ "j"; "jobs" ] ~docv:"NUM"
      ~doc:
        (sprintf
           "Specify the number of jobs to run in parallel. By default, this \
            value is %s. Both '-j0' and '-j1' ensure sequential, \
            non-overlapping execution of the tests. Unlike '-j1', '-j0' will \
            not create a separate worker process to run the tests. The default \
            can be changed by passing '~default_workers' to the OCaml function \
            'Testo.interpret_argv'. NOTE: Parallel executation of tests is not \
            stable on Windows."
           default_str)
  in
  Arg.value (Arg.opt (Arg.some Arg.int) None info)

let lazy_term : bool Term.t =
  let info =
    Arg.info [ "lazy" ]
      ~doc:"Run only the tests that were not previously successful."
  in
  Arg.value (Arg.flag info)

(* Converter for arguments of the form NUM/NUM_SLICES *)
let slice_conv =
  let parse str =
    match Slice.of_string str with
    | None -> Error (sprintf "Malformed slice: %s" str)
    | Some x -> Ok x
  in
  let print fmt slice = Format.pp_print_string fmt (Slice.to_string slice) in
  Arg.conv' ~docv:"NUM/NUM_SLICES" (parse, print)

let slice_term : Slice.t list Term.t =
  let info =
    Arg.info [ "slice" ] ~docv:"NUM/NUM_SLICES"
      ~doc:
        "Divide the test suite into NUM_SLICES and work on slice NUM only \
         (1-based). For example, '1/4' is the first of four slices and '4/4' \
         is the last one. If multiple '--slice' options are specified, they \
         are applied sequentially from left to right. If the original suite \
         defines 23 tests, '--slice 2/4' selects tests [7,8,9,10,11,12] \
         (1-based). If additionally '--slice 1/3' is specified after it on the \
         same command line, the remaining tests will be [7,8]. This filter is \
         meant for running tests in parallel, possibly across multiple hosts. \
         It is applied after any other filters to as to divide the work more \
         evenly."
  in
  Arg.value (Arg.opt_all slice_conv [] info)

let test_list_checksum_term : string option Term.t =
  let info =
    Arg.info [ "test-list-checksum" ] ~docv:"STR"
      ~doc:
        "Internal use only. This is a checksum used to check that the list of \
         tests generated in a worker is the same as the list of tests \
         generated by the master."
  in
  Arg.value (Arg.opt (Arg.some Arg.string) None info)

let worker_term : bool Term.t =
  let info =
    Arg.info [ "worker" ]
      ~doc:"Internal option used to launch a parallel worker."
  in
  Arg.value (Arg.flag info)

let run_doc = "run the tests"

let run_man : Manpage.block list =
  [
    `S Manpage.s_description;
    `P
      {|Run all or only some of the tests. By default, the status
of each test is reported as they are executed. Here's the legend for test
statuses:|};
    `Pre
      "• [PASS]: a successful test that was expected to succeed (good);\n\
       • [FAIL]: a failing test that was expected to succeed (needs fixing);\n\
       • [XFAIL]: a failing test that was expected to fail (tolerated failure);\n\
       • [XPASS]: a successful test that was expected to fail (progress?).\n\
       • [MISS]: a test that never ran;\n\
       • [SKIP]: a test that is always skipped but kept around for some reason;\n\
       • [xxxx*]: a new test for which there's no expected output yet.\n\
      \  In this case, you should review the test output and run the 'approve'\n\
      \  subcommand once you're satisfied with the output.\n";
    `P
      {|To review the status of the tests without rerunning them,
use the 'status' subcommand.|};
  ]

let optional_nonempty_list xs =
  match xs with
  | [] -> None
  | or_terms -> Some or_terms

let subcmd_run_term ~default_workers ocaml_conf (test_spec : _ test_spec) :
    unit Term.t =
  let combine autoclean chdir debug env expert filter_by_substring filter_by_tag
      jobs lazy_ max_inline_log_bytes show_output slice strict
      test_list_checksum verbose worker =
    let filter_by_substring = optional_nonempty_list filter_by_substring in
    let intro = if expert then "" else default_conf.intro in
    let show_output = show_output || verbose in
    let jobs =
      match jobs with
      | None -> default_workers
      | Some _ -> jobs
    in
    Run_tests
      {
        default_conf with
        autoclean;
        chdir = Option.map Fpath.v chdir;
        debug;
        env;
        filter_by_substring;
        filter_by_tag;
        intro;
        is_worker = worker;
        jobs;
        lazy_;
        max_inline_log_bytes;
        ocaml_conf;
        show_output;
        slice;
        strict;
        test_list_checksum;
      }
    |> run_with_conf test_spec
  in
  Term.(
    const combine $ autoclean_term $ chdir_term $ debug_term $ env_term
    $ expert_term $ filter_by_substring_term $ filter_by_tag_term
    $ jobs_term ~default_workers $ lazy_term $ max_inline_log_bytes_term
    $ show_output_term $ slice_term $ strict_term $ test_list_checksum_term
    $ verbose_run_term $ worker_term)

let subcmd_run ~default_workers ocaml_conf test_spec =
  let info = Cmd.info "run" ~doc:run_doc ~man:run_man in
  Cmd.v info (subcmd_run_term ~default_workers ocaml_conf test_spec)

(****************************************************************************)
(* Subcommand: status (replaces alcotest's 'list') *)
(****************************************************************************)

(*
   Design: the options '-l' and '-a' were chosen for two reasons:
   - make the status output compact by default;
   - adopt a similar behavior as the '-l' and '-a' options of 'ls'.
*)
let long_term : bool Term.t =
  let info =
    Arg.info [ "l"; "long" ]
      ~doc:"Print details instead of just a one-line summary for each test."
  in
  Arg.value (Arg.flag info)

let all_term : bool Term.t =
  let info =
    Arg.info [ "a"; "all" ]
      ~doc:
        "Report tests in all statuses instead of only the tests that\n\
        \            need attention."
  in
  Arg.value (Arg.flag info)

let verbose_status_term : bool Term.t =
  let info =
    Arg.info [ "v"; "verbose" ]
      ~doc:
        "Report the status of the tests with maximum verbosity.\n\
        \            This is currently equivalent to '-alw'."
  in
  Arg.value (Arg.flag info)

let status_doc = "show test status"

let subcmd_status_term ocaml_conf tests : unit Term.t =
  let combine all autoclean chdir debug env expert filter_by_substring
      filter_by_tag long max_inline_log_bytes show_output strict verbose =
    let filter_by_substring = optional_nonempty_list filter_by_substring in
    let intro = if expert then "" else default_conf.intro in
    let status_output_style : Run.status_output_style =
      if verbose then Long_all
      else
        match (long, all) with
        | true, true -> Long_all
        | false, true -> Compact_all
        | true, false -> Long_important
        | false, false -> Compact_important
    in
    let show_output = show_output || verbose in
    Status
      {
        default_conf with
        autoclean;
        chdir = Option.map Fpath.v chdir;
        debug;
        env;
        filter_by_substring;
        filter_by_tag;
        intro;
        max_inline_log_bytes;
        ocaml_conf;
        show_output;
        status_output_style;
        strict;
      }
    |> run_with_conf tests
  in
  Term.(
    const combine $ all_term $ autoclean_term $ chdir_term $ debug_term
    $ env_term $ expert_term $ filter_by_substring_term $ filter_by_tag_term
    $ long_term $ max_inline_log_bytes_term $ show_output_term $ strict_term
    $ verbose_status_term)

let subcmd_status ocaml_conf tests =
  let info = Cmd.info "status" ~doc:status_doc in
  Cmd.v info (subcmd_status_term ocaml_conf tests)

(****************************************************************************)
(* Subcommand: approve *)
(****************************************************************************)

let approve_doc = "approve new test output"

let subcmd_approve_term ocaml_conf tests : unit Term.t =
  let combine chdir debug env filter_by_substring filter_by_tag =
    let filter_by_substring = optional_nonempty_list filter_by_substring in
    Approve
      {
        default_conf with
        chdir = Option.map Fpath.v chdir;
        debug;
        env;
        filter_by_substring;
        filter_by_tag;
        ocaml_conf;
      }
    |> run_with_conf tests
  in
  Term.(
    const combine $ chdir_term $ debug_term $ env_term
    $ filter_by_substring_term $ filter_by_tag_term)

let subcmd_approve ocaml_conf tests =
  let info = Cmd.info "approve" ~doc:approve_doc in
  Cmd.v info (subcmd_approve_term ocaml_conf tests)

(****************************************************************************)
(* Subcommand: show-tags *)
(****************************************************************************)

let show_tags_doc = "show the list of valid tags for this test suite"

let subcmd_show_tags_term ocaml_conf tests : unit Term.t =
  let combine () = run_with_conf tests (Show_tags ocaml_conf) in
  Term.(const combine $ const ())

let subcmd_show_tags ocaml_conf tests =
  let info = Cmd.info "show-tags" ~doc:show_tags_doc in
  Cmd.v info (subcmd_show_tags_term ocaml_conf tests)

(****************************************************************************)
(* Main command *)
(****************************************************************************)

let root_doc ocaml_conf = sprintf "run tests for %s" ocaml_conf.project_name

let root_man ocaml_conf : Manpage.block list =
  [
    `S Manpage.s_description;
    `P
      (sprintf
         {|This is the program built for running and managing the tests for this project,
%s. It revolves around 3 main subcommands: 'run', 'status', and 'approve'.
Use the 'status' subcommand to check the status of each test without having
to re-run them. 'approve' must be used on tests whose output is captured
so as to make their latest output the new reference.
|}
         ocaml_conf.project_name);
    `P
      (sprintf
         (* NOTE: We use quoted string paths via %S to avoid conflicts with
            Cmdliner's markup (this occurs, e.g., with `\` in Windows paths). *)
         {|This test program was configured to store the temporary results in
%S and the expected test output in the persistent folder %S.
The latter should be kept under version control (git or similar).
|}
         !!(Option.value ocaml_conf.status_workspace_root
              ~default:Store.default_status_workspace_root)
         !!(Option.value ocaml_conf.status_workspace_root
              ~default:Store.default_expectation_workspace_root));
    `P
      {|Visit https://testocaml.net/ to learn how to
create and manage test suites with Testo.|};
  ]

let root_info ocaml_conf =
  let name = Filename.basename Sys.argv.(0) in
  Cmd.info name ~doc:(root_doc ocaml_conf) ~man:(root_man ocaml_conf)

let root_term ~default_workers ocaml_conf test_spec =
  (*
  Term.ret (Term.const (`Help (`Pager, None)))
*)
  subcmd_run_term ~default_workers ocaml_conf test_spec

let subcommands ~default_workers ~ocaml_conf test_spec =
  [
    subcmd_run ~default_workers ocaml_conf test_spec;
    subcmd_status ocaml_conf test_spec;
    subcmd_approve ocaml_conf test_spec;
    subcmd_show_tags ocaml_conf test_spec;
  ]

let with_record_backtrace func =
  let original_state = Printexc.backtrace_status () in
  Printexc.record_backtrace true;
  Fun.protect ~finally:(fun () -> Printexc.record_backtrace original_state) func

(*
     $ cmdliner-demo-subcmd           -> parsed as root subcommand
     $ cmdliner-demo-subcmd --help    -> also parsed as root subcommand
     $ cmdliner-demo-subcmd subcmd1   -> parsed as 'subcmd1' subcommand

   If there is a request to display the help page, it displayed at this point,
   returning '`Help'.

   Otherwise, 'conf' is returned to the application.
*)
let interpret_argv ?(argv = Sys.argv) ?(default_workers = None)
    ?expectation_workspace_root
    ?(handle_subcommand_result = fun exit_code _ -> exit exit_code)
    ?status_workspace_root ~project_name
    (get_tests : (string * string) list -> Types.test list) =
  let ocaml_conf =
    { argv; project_name; expectation_workspace_root; status_workspace_root }
  in
  let test_spec = (get_tests, handle_subcommand_result) in
  (* TODO: is there any reason why we shouldn't always record a stack
     backtrace when running tests? *)
  with_record_backtrace (fun () ->
      Cmd.group
        ~default:(root_term ~default_workers ocaml_conf test_spec)
        (root_info ocaml_conf)
        (subcommands ~ocaml_conf ~default_workers test_spec)
      |> Cmd.eval ~argv
      |>
      (* does not reach this point by default *)
      exit)