Progress indication for lockdir generation (#10802)

First pass at progress indication for lockdir generation, where the
status line displays a message while the package repos are being
updated, and a second message during solving. This might be updated in
the future to display finer-grained status updates.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

bin/pkg/lock.ml

@@ -5,6 +5,53 @@ module Opam_repo = Dune_pkg.Opam_repo
 module Lock_dir = Dune_pkg.Lock_dir
 module Pin_stanza = Dune_pkg.Pin_stanza
 
+module Progress_indicator = struct
+  module Per_lockdir = struct
+    module State = struct
+      module Repository = Dune_pkg.Pkg_workspace.Repository
+
+      type t =
+        | Updating_repos of Repository.Name.t list
+        | Solving
+
+      let pp = function
+        | Updating_repos repo_names ->
+          Pp.textf
+            "Updating package repos %s..."
+            (List.map repo_names ~f:(fun repo_name ->
+               Repository.Name.to_string repo_name |> String.quoted)
+             |> String.enumerate_and)
+        | Solving -> Pp.text "Solving..."
+      ;;
+    end
+
+    type t =
+      { lockdir_path : Path.Source.t
+      ; state : State.t option ref
+      }
+
+    let create lockdir_path = { lockdir_path; state = ref None }
+  end
+
+  (* The progress indicator for the entire lock operation, which may
+     involve generating multiple lockdirs *)
+  type t = Per_lockdir.t list
+
+  let pp (t : t) =
+    (* Only display the first non-done lockdir state, since the status
+       line can only consist of a single line. *)
+    List.find_map t ~f:(fun { Per_lockdir.lockdir_path; state } ->
+      Option.map !state ~f:(fun state ->
+        Pp.concat
+          [ Pp.textf "Locking %s: " (Path.Source.to_string_maybe_quoted lockdir_path)
+          ; Per_lockdir.State.pp state
+          ]))
+    |> Option.value ~default:Pp.nop
+  ;;
+
+  let add_overlay (t : t) = Console.Status_line.add_overlay (Live (fun () -> pp t))
+end
+
 let resolve_project_sources sources =
   let scan_project ~read ~files =
     let read file = Memo.of_reproducible_fiber (read file) in
@@ -26,6 +73,7 @@ let solve_lock_dir
   version_preference
   solver_env_from_current_system
   lock_dir_path
+  progress_state
   =
   let open Fiber.O in
   let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in
@@ -46,30 +94,29 @@ let solve_lock_dir
       ~unset_solver_vars_from_context:
         (unset_solver_vars_of_workspace workspace ~lock_dir_path)
   in
-  let overlay =
-    Console.Status_line.add_overlay (Constant (Pp.text "Solving for Build Plan"))
-  in
   let* repos =
-    repositories_of_workspace workspace
-    |> get_repos ~repositories:(repositories_of_lock_dir workspace ~lock_dir_path)
+    let repo_map = repositories_of_workspace workspace in
+    let repo_names =
+      Dune_pkg.Pkg_workspace.Repository.Name.Map.keys repo_map
+      |> List.sort ~compare:Dune_pkg.Pkg_workspace.Repository.Name.compare
+    in
+    progress_state
+    := Some (Progress_indicator.Per_lockdir.State.Updating_repos repo_names);
+    get_repos repo_map ~repositories:(repositories_of_lock_dir workspace ~lock_dir_path)
   in
-  Fiber.finalize
-    ~finally:(fun () ->
-      Console.Status_line.remove_overlay overlay;
-      Fiber.return ())
-    (fun () ->
-      let* pins = resolve_project_sources project_sources in
-      Dune_pkg.Opam_solver.solve_lock_dir
-        solver_env
-        (Pkg_common.Version_preference.choose
-           ~from_arg:version_preference
-           ~from_context:
-             (Option.bind lock_dir ~f:(fun lock_dir -> lock_dir.version_preference)))
-        repos
-        ~pins
-        ~local_packages:
-          (Package_name.Map.map local_packages ~f:Dune_pkg.Local_package.for_solver)
-        ~constraints:(constraints_of_workspace workspace ~lock_dir_path))
+  let* pins = resolve_project_sources project_sources in
+  progress_state := Some Progress_indicator.Per_lockdir.State.Solving;
+  Dune_pkg.Opam_solver.solve_lock_dir
+    solver_env
+    (Pkg_common.Version_preference.choose
+       ~from_arg:version_preference
+       ~from_context:
+         (Option.bind lock_dir ~f:(fun lock_dir -> lock_dir.version_preference)))
+    repos
+    ~pins
+    ~local_packages:
+      (Package_name.Map.map local_packages ~f:Dune_pkg.Local_package.for_solver)
+    ~constraints:(constraints_of_workspace workspace ~lock_dir_path)
   >>= function
   | Error (`Diagnostic_message message) -> Fiber.return (Error (lock_dir_path, message))
   | Ok { lock_dir; files; pinned_packages } ->
@@ -86,6 +133,7 @@ let solve_lock_dir
            | packages -> pp_packages packages)
         ]
     in
+    progress_state := None;
     let+ lock_dir = Lock_dir.compute_missing_checksums ~pinned_packages lock_dir in
     Ok (Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir, summary_message)
 ;;
@@ -103,16 +151,30 @@ let solve
      effects after performing validation so that if materializing any
      lockdir would fail then no side effect takes place. *)
   (let+ errors, solutions =
-     Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs_arg workspace
-     |> Fiber.parallel_map
-          ~f:
-            (solve_lock_dir
+     let lock_dirs =
+       Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs_arg workspace
+     in
+     let progress_indicator =
+       List.map lock_dirs ~f:Progress_indicator.Per_lockdir.create
+     in
+     let overlay = Progress_indicator.add_overlay progress_indicator in
+     let+ result =
+       Fiber.finalize
+         ~finally:(fun () ->
+           Console.Status_line.remove_overlay overlay;
+           Fiber.return ())
+         (fun () ->
+           Fiber.parallel_map progress_indicator ~f:(fun { lockdir_path; state } ->
+             solve_lock_dir
                workspace
                ~local_packages
                ~project_sources
                version_preference
-               solver_env_from_current_system)
-     >>| List.partition_map ~f:Result.to_either
+               solver_env_from_current_system
+               lockdir_path
+               state))
+     in
+     List.partition_map result ~f:Result.to_either
    in
    match errors with
    | [] -> Ok solutions

src/dune_pkg/workspace.mli

@@ -15,6 +15,7 @@ module Repository : sig
     type t
 
     val equal : t -> t -> bool
+    val compare : t -> t -> ordering
     val pp : t -> 'a Pp.t
 
     include Stringlike with type t := t