refactor internal common modules

src/ast-check/ast_check.ml

@@ -1,14 +1,4 @@
-(* open struct
-  module R = Result
-  module S = Common.Internal.Syntax
-  module C = Common.Error_context
-end *)
-
-(* open Parsetree *)
-
-(* module _ = Astlib.Parse *)
-
-open Common.Internal.Util
+open Common.Util
 open Ppxlib
 
 module Messages = struct
@@ -226,6 +216,7 @@ let path_violations ?(follow = FileUtil.Follow) ?prohibited ?limit
 let pp_violation ppf vio =
   let open Ocaml_common.Location in
   let report =
+    let open Common.Pp_util in
     errorf ~loc:vio.location "@[<v>%a%a@]"
       (pp_of pp_flow Feature.to_message) vio.feature
       Fmt.(option (cut ++ pp_flow)) vio.message

src/ast-check/ast_check_bin.ml

@@ -18,4 +18,4 @@ let main (_cmd : string) args =
   args |> List.iter (path_violations k);
   !status
 
-let _ = Common.Internal.Util.run_main main
+let _ = Common.Util.run_main main

src/common/README.md

@@ -0,0 +1,5 @@
+# Common Internal Functionality
+
+[Online Docs](https://just-max.github.io/less-power/main/less-power/Common/index.html).
+
+**Note**: this library is exposed only as an implementation detail. It may change at any time.

src/common/common.ml

@@ -1,11 +1,13 @@
 (** Functionality common to multiple components. *)
 
-module Error_context = Error_context
+[@@@alert lp_internal "This module is internal and has an unstable interface!"]
 
-module Internal = struct
-  [@@@alert lp_internal "This module is internal and has an unstable interface!"]
+module Util = Util
+module Pp_util = Pp_util
+module Path_util = Path_util
+module Ctx_util = Ctx_util
+module P_run = P_run
 
-  module Util = Util
-  module Path_util = Path_util
-  module Syntax = Syntax
-end
+(* module Syntax = Syntax *)
+
+(* {!modules: Util Pp_util Path_util Ctx_util P_run} *)

src/common/ctx_util.ml

@@ -0,0 +1,54 @@
+(** Context managers, loosely inspired by Python *)
+
+(** A context manager of type [('a, 'b, 'c) t] takes a continuation, and
+    should feed the continuation a value of type ['a]. Once the continuation
+    returns with either a [Ok of 'b] or an exception, the continuation should
+    perform cleanup, and may suppress the exception by producing a suitable
+    result (of type ['c]) instead. Typically, ['b = 'c].
+
+    This representation has the advantage that some existing functions library
+    already implement this type (e.g. {!In_channel.with_open_text}). *)
+type ('a, 'b, 'c) t = ('a -> ('b, exn) result) -> ('c, exn) result
+
+(** [with_context cm f] runs [f] in the context manager [cm] *)
+let with_context (cm : _ t) f =
+  let k x =
+    try Ok (f x)
+    with e -> Error e
+  in
+  match cm k with
+  | Ok x -> x
+  | Error e -> raise e
+
+(** Let-syntax for {!with_context} *)
+let ( let< ) = with_context
+
+(* {1 Context managers} *)
+
+(** As per {!Filename.temp_file}. Removes the temporary file upon completion. *)
+let temp_file ?temp_dir prefix suffix : _ t = fun k ->
+  let path = Filename.temp_file ?temp_dir prefix suffix in
+  let result = k path in
+  Sys.remove path;
+  result
+
+(** As per {!Unix.openfile}. Closes the file descriptor upon completion. *)
+let openfile path flags perm : _ t = fun k ->
+  let fd = Unix.openfile path flags perm in
+  let result = k fd in
+  Unix.close fd;
+  result
+
+(** As per {!Sys.set_signal}. Restores the previous signal behavior on completion. *)
+let set_signal signal behavior : _ t = fun k ->
+  let prev_behavior = Sys.signal signal behavior in
+  let result = k () in
+  Sys.set_signal signal prev_behavior;
+  result
+
+(** As per {!Unix.sigprocmask}. Restores the previous mask on completion. *)
+let sigprocmask mode sigs : _ t = fun k ->
+  let prev_mask = Unix.sigprocmask mode sigs in
+  let result = k () in
+  Unix.sigprocmask Unix.SIG_SETMASK prev_mask |> (ignore : int list -> _);
+  result

src/common/dune

@@ -1,4 +1,4 @@
 (library
  (name common)
  (public_name less-power.common)
- (libraries unix fmt fileutils))
+ (libraries unix fmt fileutils mtime mtime.clock.os))

src/common/p_run.ml

@@ -0,0 +1,135 @@
+(** Even higher-level wrapper around [Unix.open_process]. *)
+
+(** Waits for the given process or times out. *)
+let wait_pid_timeout t pid =
+  let open Ctx_util in
+  let< () = sigprocmask Unix.SIG_BLOCK [Sys.sigchld] in
+
+  let exception Sigchld in
+  let< () = set_signal Sys.sigchld (Sys.Signal_handle (fun _ -> raise Sigchld)) in
+  let t0 = Mtime_clock.counter () in
+  let rec task () =
+    let pidw, status = Unix.(waitpid [WNOHANG] pid) in
+    if pidw <> 0 then Some status
+    else
+      try
+        let< () = sigprocmask Unix.SIG_UNBLOCK [Sys.sigchld] in
+        let elapsed = Mtime_clock.count t0 in
+        if Mtime.Span.compare elapsed t < 0 then
+          Unix.sleepf @@ Util.span_to_float_s @@ Mtime.Span.abs_diff elapsed t;
+        None
+      with
+        Sigchld -> task ()
+  in
+  task ()
+
+(** Timeout after [duration], sending [signal]. If [kill_after] is [Some t],
+    then send [SIGKILL] after waiting an additional [t]. *)
+type timeout_description =
+  { duration : Mtime.span; signal : int; kill_after : Mtime.span option }
+
+let timeout ?(signal = Sys.sigterm) ?kill_after duration =
+  { duration; signal; kill_after }
+
+type phase = Completed | TimedOut | Killed
+(** Whether the process is running normally, has received
+    the first signal, or has received a SIGKILL. *)
+
+type result = {
+    phase : phase (** What phase was the process in when it completed? *);
+    status : Unix.process_status;
+    stdout : string;
+    stderr : string;
+    elapsed : Mtime.span;
+  }
+
+let pp_result ?(hide_stdout = false) ?(hide_stderr = false) ?command_line ppf r =
+  let open Fmt in
+  let open Pp_util in
+  let pp_status ppf = function
+    | TimedOut, _ -> string ppf "timed out"
+    | Killed, _ -> string ppf "timed out and was killed"
+    | Completed, Unix.WEXITED st -> pf ppf "exited with status %d" st
+    | Completed, Unix.WSIGNALED si -> pf ppf "exited on signal %a" Dump.signal si
+    | Completed, Unix.WSTOPPED si -> pf ppf "stopped on signal %a" Dump.signal si
+  in
+  let pp_output name ppf body =
+    let w = 40 in
+    let wn = String.length name + 2 in
+    let we1 = (w - wn) / 2 in
+    let we2 = w - we1 - wn in
+    pf ppf "@[<v>%a %s %a@,%a%a@]"
+      (pp_repeat we1 char) '=' name (pp_repeat we2 char) '='
+      pp_text_ body
+      (pp_repeat w char) '='
+  in
+  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)))
+    command_line
+    pp_status (r.phase, r.status)
+    Mtime.Span.pp r.elapsed
+    (option (cut ++ pp_output "STDOUT"))
+    (if hide_stdout then None else Some r.stdout)
+    (option (cut ++ pp_output "STDERR"))
+    (if hide_stderr then None else Some r.stderr)
+
+(** Send the [input] to [command] with the given [args].
+    Note: uses temporary files provided by {!Filename}. *)
+let p_run ?timeout:timeout_desc ?input ?(args = []) command =
+  let open Ctx_util in
+
+  let< stdout_path = temp_file command "stdout" in
+  let< stderr_path = temp_file command "stderr" in
+
+  let phase, status, elapsed =
+    let< stdin_path = temp_file command "stdin" in
+    input |> Option.iter (fun inp ->
+        let< stdin_ch = Out_channel.with_open_text stdin_path in
+        let ppf = Format.formatter_of_out_channel stdin_ch in
+        Format.fprintf ppf "%t" inp;
+        Format.pp_print_flush ppf ());
+
+    let< stdin_fd  = openfile stdin_path  Unix.[O_RDONLY] 0o000 in (* ; O_CLOEXEC? *)
+    let< stdout_fd = openfile stdout_path Unix.[O_WRONLY] 0o000 in
+    let< stderr_fd = openfile stderr_path Unix.[O_WRONLY] 0o000 in
+
+    let t0 = Mtime_clock.counter () in
+
+    let pid =
+      Unix.create_process command
+        (Array.of_list (command :: args))
+        stdin_fd stdout_fd stderr_fd
+    in
+
+    let rec timeouts phase = function
+      | [] -> phase, snd (Unix.waitpid [] pid)
+      | (t, signal, phase') :: ts ->
+          match wait_pid_timeout t pid with
+          | Some status -> phase, status
+          | None ->
+              Unix.kill pid signal;
+              timeouts phase' ts
+    in
+    let phase, status =
+      timeouts Completed @@
+      match timeout_desc with
+      | None -> []
+      | Some { duration; signal; kill_after = None } ->
+          [(duration, signal, TimedOut)]
+      | Some { duration; signal; kill_after = Some t } ->
+          [(duration, signal, TimedOut); (t, Sys.sigkill, Killed)]
+    in
+    let elapsed = Mtime_clock.count t0 in
+    phase, status, elapsed
+  in
+
+  let input_all path =
+    let< ch = In_channel.with_open_text path in
+    In_channel.input_all ch
+  in
+  let stdout = input_all stdout_path in
+  let stderr = input_all stderr_path in
+
+  { phase; status; stdout; stderr; elapsed }

src/common/path_util.ml

@@ -1,53 +1,5 @@
 (** Path and file-related utility functions. *)
 
-open struct
-  module C = Error_context
-  module S = Syntax
-end
-
-open Unix
-open Util
-
-type walk_order = BottomUp | TopDown
-
-let walk ?max_depth ?(walk_order = TopDown) ?(follow_symlinks = false)
-  : string -> (string, Util.access_file_error) C.Many.t =
-
-  (* whether we should descend recursively, or just yield p *)
-  let should_read p =
-    let open S.Result in
-    let* sym_ok =
-      if follow_symlinks then C.One.ok true
-      else
-        let+ stat = Util.lstat p in
-        stat.st_kind <> Unix.S_LNK
-    in
-    let+ dir = Util.is_directory p in (* TODO: don't check is_directory if sym_ok is false *)
-    sym_ok && dir
-  in
-
-  let rec impl depth p () =
-    let open S.Error_context.Many in
-    ~$() @@
-    match max_depth with
-    | Some md when depth >= md -> C.Many.return p
-    | _ ->
-        let* read_p = C.Many.of_one @@ should_read p in
-        if read_p then
-          let walk_entries () =
-            ~$() @@
-            let* dir_entry = C.Many.of_one_seq @@ Util.readdir p in
-            let p' = Filename.concat p dir_entry in
-            impl (depth + 1) p'
-          in
-          match walk_order with
-          | BottomUp -> Seq.append walk_entries (C.Many.return p)
-          | TopDown -> Seq.append (C.Many.return p) walk_entries
-        else C.Many.return p
-  in
-
-  impl 0
-
 (* TODO: make this fail or do something sensible if the second path is absolute...
    the standard library just concatenates *)
 let ( / ) = Filename.concat

src/common/pp_util.ml

@@ -0,0 +1,22 @@
+(** More pretty-printing combinators. *)
+
+let pp_of pp f : _ Fmt.t = fun ppf x -> pp ppf @@ f x
+
+let pp_repeat ?(sep = Fmt.nop) n0 (pp : 'a Fmt.t) : 'a Fmt.t = fun ppf x ->
+  let rec loop n =
+    if n = 0 then ()
+    else if n = 1 then pp ppf x
+    else (pp ppf x; sep ppf (); loop (n - 1))
+  in
+  loop n0
+
+let pp_text ?(line = Fmt.string) : string Fmt.t =
+  let open Fmt in
+  vbox @@ pp_of (list line) (String.split_on_char '\n')
+
+let pp_flow ?(word = Fmt.string) : string Fmt.t =
+  let open Fmt in
+  pp_text ~line:(box @@ pp_of (list ~sep:sp word) (String.split_on_char ' '))
+
+let pp_text_ = pp_text ?line:None
+let pp_flow_ = pp_flow ?word:None

src/common/syntax.ml

@@ -1,5 +1,7 @@
 (** [let*] and [let+] syntax *)
 
+(* currently unused, TODO: remove *)
+
 module type Monad1 = sig
   type 'a t
 
@@ -49,7 +51,3 @@ module Seq =
   MkSyntaxMonad1 (struct  include Seq  let bind x f = Seq.flat_map f x  end)
 module List =
   MkSyntaxMonad1 (struct  include List let bind x f = concat_map f x  let return x = [x]  end)
-
-module Error_context = struct
-  module Many = MkSyntaxMonad2 (Error_context.Many)
-end