polish test runners

dune-project

@@ -22,6 +22,7 @@
   (fmt (and (>= 0.9) (< 0.10)))
   (ppxlib (and (>= 0.30) (< 0.31)))
   (ocaml-compiler-libs (and (>= v0.12) (< v0.13)))
+  (cmdliner (and (>= 1.2) (< 1.3)))
  )
 )
 

less-power.opam

@@ -21,6 +21,7 @@ depends: [
   "fmt" {>= "0.9" & < "0.10"}
   "ppxlib" {>= "0.30" & < "0.31"}
   "ocaml-compiler-libs" {>= "v0.12" & < "v0.13"}
+  "cmdliner" {>= "1.2" & < "1.3"}
   "odoc" {with-doc}
 ]
 build: [

src/common/ctx_util.ml

@@ -18,7 +18,7 @@ let with_context (cm : _ t) f =
   in
   match cm k with
   | Ok x -> x
-  | Error e -> raise e
+  | Error e -> raise e (* TODO: better backtraces? *)
 
 (** Let-syntax for {!with_context} *)
 let ( let< ) = with_context
@@ -52,3 +52,29 @@ let sigprocmask mode sigs : _ t = fun k ->
   let result = k () in
   Unix.sigprocmask Unix.SIG_SETMASK prev_mask |> (ignore : int list -> _);
   result
+
+let timeout_unix ?timer t : _ t = fun k ->
+  match Util.timeout_unix ?timer t k () with
+  | None -> Ok None
+  | Some r -> Result.map Option.some r
+
+let timed : _ t = fun k ->
+  match Util.timed k () with
+  | Error _ as e, _ -> e
+  | Ok r, t -> Ok (r, t)
+
+let capture_exceptions ?(filter = Fun.const true) () : _ t = fun k ->
+  match k () with
+  | Ok x -> Ok (Ok x)
+  | Error e when filter e -> Ok (Error e)
+  | Error e -> Error e
+
+let empty_context x f : _ t = fun k -> Result.map f (k x)
+let empty_context' x : _ t = empty_context x Fun.id
+
+let optional_context ~some x_empty f_empty = function
+  | None -> empty_context x_empty f_empty
+  | Some x -> some x
+
+let optional_timeout_unix ?timeout =
+  optional_context ~some:timeout_unix () Option.some timeout

src/common/p_run.ml

@@ -37,12 +37,19 @@ type phase = Completed | TimedOut | Killed
 
 type result = {
     phase : phase (** What phase was the process in when it completed? *);
-    status : Unix.process_status;
+    status : Unix.process_status (** What status did the process exit with? *);
     stdout : string;
     stderr : string;
     elapsed : Mtime.span;
   }
 
+(** Did the subprocess exit normally? If [check_status] is [false], ignore
+    the exit code and check only for a timeout. *)
+let result_is_ok ?(check_status = true) = function[@warning "-4"]
+  | { phase = Completed; _ } when not check_status -> true
+  | { phase = Completed; status = Unix.WEXITED 0; _ } -> true
+  | _ -> false
+
 let pp_result ?(hide_stdout = false) ?(hide_stderr = false) ?command_line ppf r =
   let open Fmt in
   let open Pp_util in
@@ -66,7 +73,7 @@ let pp_result ?(hide_stdout = false) ?(hide_stderr = false) ?command_line ppf r
   pf ppf "@[<v>@[%a@ %a@ after %a@]%a%a@]"
     (option
       ~none:(const string "A command")
-      (fun ppf -> pf ppf "@[<2>The command @[<2>%a@]@]" (list ~sep:sp @@ pp_of string (* Filename.quote *) Fun.id)))
+      (fun ppf -> pf ppf "@[<2>The command `@[<2>%a@]`@]" (list ~sep:sp @@ pp_of string (* Filename.quote *) Fun.id)))
     command_line
     pp_status (r.phase, r.status)
     Mtime.Span.pp r.elapsed

src/common/path_util.ml

@@ -14,3 +14,7 @@ let is_code ?(condition = FileUtil.True) p =
   if test Is_link p
   then test condition p && test Is_file (Unix.readlink p)
   else test (And (Is_file, condition)) p
+
+let mkdir ?(mode = 0o777) ?(exist_ok = false) p =
+  let open Unix in
+  try mkdir p mode with Unix_error (EEXIST, _, _) when exist_ok -> ()

src/common/util.ml

@@ -12,8 +12,18 @@ let peek f x = f x; x
 (** One-element list. *)
 let singleton x = [x]
 
+let null = function [] -> true | _ -> false
+
+let uncons = function [] -> None | x :: xs -> Some (x, xs)
+
+let unsnoc xs = uncons (List.rev xs) |> Option.map (fun (x, xs) -> List.rev xs, x)
+
 let or_option o1 o2 = o1 |> Option.(fold ~some ~none:o2)
 
+let filter_option f = function Some x as o when f x -> o | _ -> None
+
+let if_option b x = if b then Some x else None
+
 (** [string_contains ~needle haystack]:
     does [needle] exist as a substring of [haystack]?
     Naive {m \mathcal{O}(nm) } implementation. *)

src/test-runner/dune

@@ -1,14 +1,13 @@
 (library
  (name test_runner)
  (public_name less-power.test-runner)
- (modules (:standard \ test_runner_bin))
  (libraries
-  common ast_check
-  fileutils unix mtime mtime.clock.os threads fmt))
+  common
+  ast_check
 
-; temporary: TODO, remove this
-(executable
- (name test_runner_bin)
- (public_name lp-test-runner)
- (modules test_runner_bin)
- (libraries common test_runner fmt fileutils))
+  unix
+
+  cmdliner
+  fileutils
+  fmt
+  mtime))