Windows-inspired tweaks to the UI

src/core/dune

@@ -3,7 +3,7 @@
   (public_name opam-core)
   (synopsis    "OCaml Package Manager core internal stdlib")
   ; TODO: Remove (re_export ...) when CI uses the OCaml version that includes https://github.com/ocaml/ocaml/pull/11989
-  (libraries   re (re_export ocamlgraph) unix sha jsonm swhid_core uutf
+  (libraries   re (re_export ocamlgraph) unix sha jsonm swhid_core uutf threads
                (select opamACL.ml from
                        (opam-core.libacl -> opamACL.libacl.ml)
                        (                 -> opamACL.dummy.ml))

src/core/opamParallel.ml

@@ -98,42 +98,80 @@ module Make (G : G) = struct
       raise (Cyclic sccs)
     );
 
+    let rec limit_width acc rem_cols = function
+      | [] -> List.rev acc
+      | t::ts ->
+        let len = OpamStd.Format.visual_length t in
+        if ts = [] && len < rem_cols then List.rev (t::acc)
+        else if len > rem_cols - 5 then
+          List.rev
+            (Printf.sprintf "%s+%2d"
+               (String.make (rem_cols - 4) ' ') (List.length ts + 1)
+             :: acc)
+        else
+          limit_width (t::acc) (rem_cols - len - 1) ts in
+
+    let abs_start = Unix.gettimeofday () in
+    let start = ref abs_start in (* XXX start is more "last_change" - i.e. when the status information naturally updated because a job was added/completed *)
+    let running_title = ref "" in
+    let disp_running = ref M.empty in
+    let last_status = ref "" in
+
+    let update_status () =
+      let running = !disp_running in
+      let texts =
+        let now = Unix.gettimeofday () in
+        (* Display the spinners after 5 seconds on the _current_ status bar *)
+        let with_status = now -. !start >= 5.0 in
+        (* XXX Needs fallback, re-coding to use \x format, moving to OpamConsole, etc. *)
+        let spinner_chars = [| "⠋"; "⠙"; "⠹"; "⠸"; "⠼"; "⠴"; "⠦"; "⠧"; "⠇"; "⠏" |] in
+        let f (p, last, _, t) =
+          let size_stdout = Option.map (fun f -> Unix.(try (stat f).st_size with Unix_error _ -> 0)) p.OpamProcess.p_stdout in
+          let size_stderr = Option.map (fun f -> Unix.(try (stat f).st_size with Unix_error _ -> 0)) p.OpamProcess.p_stderr in
+          let current = Option.value ~default:0 size_stdout + Option.value ~default:0 size_stderr in
+          let () =
+            if current <> !last then begin
+              last := current;
+              p.OpamProcess.p_cycle <- p.OpamProcess.p_cycle + 1;
+            end in
+          let stamp = p.OpamProcess.p_time in
+          let c = spinner_chars.(p.OpamProcess.p_cycle mod Array.length spinner_chars) in
+          (* Only display a job at all after 2 seconds *)
+          if now -. stamp < 2.0 then None else Option.map (fun s -> if !last = 0 || not with_status || s = "" then s else if s.[String.length s - 1] = ']' then String.sub s 0 (String.length s - 1) ^ Printf.sprintf " %s]" c else s) t  (* XXX This should be done with a richer type indicator that spinners can be used and where to put them *)
+        in
+        OpamStd.List.filter_map f (M.values running)
+      in
+      let texts =
+        limit_width [] (OpamStd.Sys.terminal_columns ()) (!running_title :: texts) in
+      let status = String.concat " " texts in
+      if status <> !last_status then begin
+        last_status := status;
+        OpamConsole.status_line "%s" status
+      end
+    in
+
     let print_status
         (finished: int)
-        (running: (OpamProcess.t * 'a * string option) M.t) =
+        (running: (OpamProcess.t * int ref * 'a * string option) M.t) =
+      disp_running := running;
       let texts =
-        OpamStd.List.filter_map (fun (_,_,t) -> t) (M.values running) in
-      let rec limit_width acc rem_cols = function
-        | [] -> List.rev acc
-        | t::ts ->
-          let len = OpamStd.Format.visual_length t in
-          if ts = [] && len < rem_cols then List.rev (t::acc)
-          else if len > rem_cols - 5 then
-            List.rev
-              (Printf.sprintf "%s+%2d"
-                 (String.make (rem_cols - 4) ' ') (List.length ts + 1)
-               :: acc)
-          else
-            limit_width (t::acc) (rem_cols - len - 1) ts
-      in
+        OpamStd.List.filter_map (fun (_,_,_,t) -> t) (M.values running) in
       let title =
         Printf.sprintf "Processing %2d/%d:"
           (finished + M.cardinal running) njobs
       in
-      let texts =
-        if OpamConsole.disp_status_line () then
-          limit_width [] (OpamStd.Sys.terminal_columns ()) (title::texts)
-        else if OpamConsole.verbose () then title::texts
-        else []
-      in
-      if texts <> [] then OpamConsole.status_line "%s" (String.concat " " texts)
+      if OpamConsole.disp_status_line () then begin
+        running_title := title;
+        update_status ()
+      end else if OpamConsole.verbose () then
+        OpamConsole.status_line "%s %s" title (String.concat " " texts)
     in
 
     (* nslots is the number of free slots *)
     let rec loop
         (nslots: (S.t * int) list) (* number of free slots *)
         (results: 'b M.t)
-        (running: (OpamProcess.t * 'a * string option) M.t)
+        (running: (OpamProcess.t * int ref * 'a * string option) M.t)
         (ready: S.t)
       =
       let get_slots nslots n =
@@ -151,7 +189,9 @@ module Make (G : G) = struct
             else pool, slots)
           nslots
       in
-      let run_seq_command nslots ready n = function
+      let run_seq_command nslots ready n status =
+        start := Unix.gettimeofday ();
+        match status with
         | Done r ->
           log "Job %a finished" (slog (string_of_int @* V.hash)) n;
           let results = M.add n r results in
@@ -181,7 +221,7 @@ module Make (G : G) = struct
             else OpamProcess.run_background cmd
           in
           let running =
-            M.add n (p, cont, OpamProcess.text_of_command cmd) running
+            M.add n (p, ref 0, cont, OpamProcess.text_of_command cmd) running
           in
           print_status (M.cardinal results) running;
           loop nslots results running ready
@@ -196,7 +236,7 @@ module Make (G : G) = struct
         (* Cleanup *)
         let errors,pend =
           if dry_run then [node,error],[] else
-          M.fold (fun n (p,cont,_text) (errors,pend) ->
+          M.fold (fun n (p,_start,cont,_text) (errors,pend) ->
               try
                 match OpamProcess.dontwait p with
                 | None -> (* process still running *)
@@ -267,7 +307,7 @@ module Make (G : G) = struct
       else
       (* Wait for a process to end *)
       let processes =
-        M.fold (fun n (p,x,_) acc -> (p,(n,x)) :: acc) running []
+        M.fold (fun n (p,_,x,_) acc -> (p,(n,x)) :: acc) running []
       in
       let process, result =
         if dry_run then
@@ -292,8 +332,27 @@ module Make (G : G) = struct
         (fun n roots -> if G.in_degree g n = 0 then S.add n roots else roots)
         g S.empty
     in
+    let running = ref true in
+    let rec f () =
+      try
+        Unix.sleep 4;
+        while !running do
+          Unix.sleepf 0.1;
+          if !running then
+            update_status ()
+        done
+      with Sys.Break ->
+        f () (* XXX This __cannot__ be correct! *) in
+    let () =
+      if OpamConsole.disp_status_line () then
+        ignore (Thread.create f ())
+    in
     let r = loop pools M.empty M.empty roots in
+    running := false;
+    disp_running := M.empty;
+    running_title := "";
     OpamConsole.clear_status ();
+    last_status := "";
     r
 
   let iter ~jobs ~command ?dry_run ?pools g =

src/core/opamProcess.ml

@@ -269,6 +269,7 @@ type t = {
   p_time   : float;
   p_stdout : string option;
   p_stderr : string option;
+  mutable p_cycle : int;
   p_env    : string option;
   p_info   : string option;
   p_metadata: (string * string) list;
@@ -492,6 +493,7 @@ let create ?info_file ?env_file ?(allow_stdin=not Sys.win32) ?stdout_file ?stder
     p_time   = time;
     p_stdout = stdout_file;
     p_stderr = stderr_file;
+    p_cycle  = 0;
     p_env    = env_file;
     p_info   = info_file;
     p_metadata = metadata;
@@ -591,6 +593,7 @@ let dry_run_background c = {
   p_time   = Unix.gettimeofday ();
   p_stdout = None;
   p_stderr = None;
+  p_cycle  = 0;
   p_env    = None;
   p_info   = None;
   p_metadata = OpamStd.Option.default [] c.cmd_metadata;
@@ -624,16 +627,29 @@ let set_verbose_f, print_verbose_f, isset_verbose_f, stop_verbose_f =
     stop ();
     (* implem relies on sigalrm, not implemented on win32.
        This will fall back to buffered output. *)
-    if Sys.win32 then () else
+    (*if Sys.win32 then () else*)
     let files = OpamStd.List.sort_nodup compare files in
     let ics =
       List.map
         (open_in_gen [Open_nonblock;Open_rdonly;Open_text;Open_creat] 0o600)
         files
     in
-    let f () =
+    let f =
+      let buffer = Buffer.create 80 in
+      fun () ->
       List.iter (fun ic ->
-          try while true do verbose_print_out (input_line ic) done
+          try while true do
+            (* XXX This should with a better read function *)
+            let line = input_line ic in (* line = "" => we must have read a newline, right, therefore if line = "", we can't possibly be at the start of the file??? *)
+            seek_in ic (pos_in ic - 1);
+            let c = input_char ic in
+            if c <> '\n' then
+              Buffer.add_string buffer line
+            else
+              let buffered = Buffer.contents buffer in
+              let () = Buffer.clear buffer in
+              verbose_print_out (buffered ^ line)
+            done
           with End_of_file -> flush stdout
         ) ics
     in
@@ -644,6 +660,7 @@ let set_verbose_f, print_verbose_f, isset_verbose_f, stop_verbose_f =
     | None -> ()
   in
   let isset () = !verbose_f <> None in
+  (* XXX Need a "super print" mechanism here - nothing should be buffered at the end *)
   let flush_and_stop () = print (); stop () in
   set, print, isset, flush_and_stop
 
@@ -685,22 +702,43 @@ let exit_status p return =
     r_cleanup  = cleanup;
   }
 
+let win32_thread (hndl, running) =
+  let rec loop () =
+    try
+      while !running do
+        Unix.sleepf 0.1;
+        if !running then
+          hndl ();
+      done
+    with Sys.Break ->
+      loop () (* XXX This __cannot__ be correct! *)
+  in loop ()
+
 let safe_wait fallback_pid f x =
   let sh =
     if isset_verbose_f () then
-      let hndl _ = print_verbose_f () in
-      Some (Sys.signal Sys.sigalrm (Sys.Signal_handle hndl))
+      if Sys.win32 then
+        let running = ref true in
+        (* XXX Do we need to wait on these threads to release resources??? *)
+        let _ = Thread.create win32_thread (print_verbose_f, running) in
+        Some (fun () -> running := false)
+      else
+        let hndl _ = print_verbose_f () in
+        let sh = Sys.signal Sys.sigalrm (Sys.Signal_handle hndl) in
+        Some (fun () -> Sys.set_signal Sys.sigalrm sh)
     else None
   in
   let cleanup () =
     match sh with
     | Some sh ->
-      ignore (Unix.alarm 0); (* cancels the alarm *)
-      Sys.set_signal Sys.sigalrm sh
+      if not Sys.win32 then
+        ignore (Unix.alarm 0); (* cancels the alarm *)
+      sh ()
     | None -> ()
   in
   let rec aux () =
-    if sh <> None then ignore (Unix.alarm 1);
+    if sh <> None && not Sys.win32 then
+      ignore (Unix.alarm 1);
     match
       try f x with
       | Unix.Unix_error (Unix.EINTR,_,_) -> aux () (* handled signal *)

src/core/opamProcess.mli

@@ -69,6 +69,7 @@ type t = {
   p_time   : float;         (** Process start time *)
   p_stdout : string option; (** stdout dump file *)
   p_stderr : string option; (** stderr dump file *)
+  mutable p_cycle : int;    (** Number of times output has been detected *)
   p_env    : string option; (** dump environment variables *)
   p_info   : string option; (** dump process info *)
   p_metadata: (string * string) list; (** Metadata associated to the process *)