refactor: explode Pkg_common.Per_context

Signed-off-by: Ali Caglayan <[email protected]>

bin/describe/describe_pkg.ml

@@ -119,8 +119,9 @@ module List_locked_dependencies = struct
 
   let enumerate_lock_dirs_by_path =
     let open Fiber.O in
-    let+ per_contexts = Pkg_common.Per_context.choose ~version_preference_arg:None in
-    List.filter_map per_contexts ~f:(fun { Pkg_common.Per_context.lock_dir_path; _ } ->
+    let+ workspace = Memo.run (Workspace.workspace ()) in
+    let per_contexts = Pkg_common.lock_dirs_of_workspace workspace in
+    List.filter_map per_contexts ~f:(fun lock_dir_path ->
       if Path.exists (Path.source lock_dir_path)
       then (
         try Some (lock_dir_path, Lock_dir.read_disk lock_dir_path) with

bin/pkg/lock.ml

@@ -5,102 +5,76 @@ module Opam_repo = Dune_pkg.Opam_repo
 module Repository_id = Dune_pkg.Repository_id
 module Lock_dir = Dune_pkg.Lock_dir
 
-let contexts_with_dup_lock_dir_paths ts =
-  List.map ts ~f:(fun { Per_context.lock_dir_path; context_common; _ } ->
-    lock_dir_path, context_common)
-  |> Path.Source.Map.of_list_multi
-  |> Path.Source.Map.to_list
-  |> List.find_opt ~f:(fun (_, context_commons) -> List.length context_commons > 1)
-;;
-
-let check_for_dup_lock_dir_paths ts =
-  contexts_with_dup_lock_dir_paths ts
-  |> Option.iter ~f:(fun (lock_dir_path, context_commons) ->
-    let loc = (List.hd context_commons : Workspace.Context.Common.t).loc in
-    User_error.raise
-      ~loc
-      ([ Pp.text
-           "Refusing to proceed as multiple selected contexts would create a lock dir at \
-            the same path."
-       ; Pp.textf
-           "These contexts all create a lock dir: %s"
-           (Path.Source.to_string_maybe_quoted lock_dir_path)
-       ]
-       @ List.map context_commons ~f:(fun (c : Dune_rules.Workspace.Context.Common.t) ->
-         Pp.textf
-           "- %s (defined at %s)"
-           (Context_name.to_string c.name |> String.maybe_quoted)
-           (Loc.to_file_colon_line c.loc))))
-;;
-
-let solve per_context ~update_opam_repositories ~solver_env_from_current_system =
+let solve
+  workspace
+  ~update_opam_repositories
+  ~solver_env_from_current_system
+  ~version_preference
+  =
   let open Fiber.O in
-  check_for_dup_lock_dir_paths per_context;
   (* a list of thunks that will perform all the file IO side
      effects after performing validation so that if materializing any
      lockdir would fail then no side effect takes place. *)
   (let* local_packages = find_local_packages in
    let+ solutions =
-     Fiber.parallel_map
-       per_context
-       ~f:
-         (fun
-           { Per_context.lock_dir_path
-           ; version_preference
-           ; repos
-           ; solver_env = solver_env_from_context
-           ; context_common = { name = context_name; _ }
-           ; constraints
-           ; repositories
-           }
-         ->
-         let solver_env =
-           solver_env ~solver_env_from_context ~solver_env_from_current_system
-         in
-         let* repos = get_repos repos ~repositories ~update_opam_repositories in
-         let overlay =
-           Console.Status_line.add_overlay (Constant (Pp.text "Solving for Build Plan"))
+     lock_dirs_of_workspace workspace
+     |> Fiber.parallel_map ~f:(fun lock_dir_path ->
+       let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in
+       let solver_env =
+         solver_env
+           ~solver_env_from_context:
+             (Option.bind lock_dir ~f:(fun lock_dir -> lock_dir.solver_env))
+           ~solver_env_from_current_system
+       in
+       let* repos =
+         get_repos
+           (repositories_of_workspace workspace)
+           ~repositories:(repositories_of_lock_dir workspace ~lock_dir_path)
+           ~update_opam_repositories
+       in
+       let overlay =
+         Console.Status_line.add_overlay (Constant (Pp.text "Solving for Build Plan"))
+       in
+       Fiber.finalize
+         ~finally:(fun () ->
+           Console.Status_line.remove_overlay overlay;
+           Fiber.return ())
+         (fun () ->
+           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
+             ~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) -> Error (lock_dir_path, message)
+       | Ok { lock_dir; files; _ } ->
+         let summary_message =
+           User_message.make
+             [ Pp.tag
+                 User_message.Style.Success
+                 (Pp.textf
+                    "Solution for %s:"
+                    (Path.Source.to_string_maybe_quoted lock_dir_path))
+             ; (match Package_name.Map.values lock_dir.packages with
+                | [] ->
+                  Pp.tag User_message.Style.Warning @@ Pp.text "(no dependencies to lock)"
+                | packages -> pp_packages packages)
+             ]
          in
-         Fiber.finalize
-           ~finally:(fun () ->
-             Console.Status_line.remove_overlay overlay;
-             Fiber.return ())
-           (fun () ->
-             Dune_pkg.Opam_solver.solve_lock_dir
-               solver_env
-               version_preference
-               repos
-               ~local_packages:
-                 (Package_name.Map.map
-                    local_packages
-                    ~f:Dune_pkg.Local_package.for_solver)
-               ~constraints)
-         >>| function
-         | Error (`Diagnostic_message message) -> Error (context_name, message)
-         | Ok { lock_dir; files; _ } ->
-           let summary_message =
-             User_message.make
-               [ Pp.tag
-                   User_message.Style.Success
-                   (Pp.textf
-                      "Solution for %s:"
-                      (Path.Source.to_string_maybe_quoted lock_dir_path))
-               ; (match Package_name.Map.values lock_dir.packages with
-                  | [] ->
-                    Pp.tag User_message.Style.Warning
-                    @@ Pp.text "(no dependencies to lock)"
-                  | packages -> pp_packages packages)
-               ]
-           in
-           Ok (Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir, summary_message))
+         Ok (Lock_dir.Write_disk.prepare ~lock_dir_path ~files lock_dir, summary_message))
    in
    Result.List.all solutions)
   >>| function
-  | Error (context_name, message) ->
+  | Error (lock_dir_path, message) ->
     User_error.raise
       [ Pp.textf
-          "Unable to solve dependencies in build context: %s"
-          (Dune_engine.Context_name.to_string context_name |> String.maybe_quoted)
+          "Unable to solve dependencies for %s:"
+          (Path.Source.to_string_maybe_quoted lock_dir_path)
       ; message
       ]
   | Ok write_disks_with_summaries ->
@@ -110,13 +84,9 @@ let solve per_context ~update_opam_repositories ~solver_env_from_current_system
     List.iter write_disk_list ~f:Lock_dir.Write_disk.commit
 ;;
 
-let lock
-  ~dont_poll_system_solver_variables
-  ~version_preference
-  ~update_opam_repositories
-  =
+let lock ~dont_poll_system_solver_variables ~version_preference ~update_opam_repositories =
   let open Fiber.O in
-  let* per_context = Per_context.choose ~version_preference_arg:version_preference
+  let* workspace = Memo.run (Workspace.workspace ())
   and* solver_env_from_current_system =
     if dont_poll_system_solver_variables
     then Fiber.return None
@@ -125,7 +95,11 @@ let lock
         ~path:(Env_path.path Stdune.Env.initial)
       >>| Option.some
   in
-  solve per_context ~update_opam_repositories ~solver_env_from_current_system
+  solve
+    workspace
+    ~update_opam_repositories
+    ~solver_env_from_current_system
+    ~version_preference
 ;;
 
 let term =

bin/pkg/outdated.ml

@@ -6,32 +6,24 @@ module Opam_repo = Dune_pkg.Opam_repo
 let find_outdated_packages ~transitive () =
   let open Fiber.O in
   let+ pps, not_founds =
-    Per_context.choose ~version_preference_arg:None
-    >>= Fiber.parallel_map
-          ~f:
-            (fun
-              { Per_context.lock_dir_path
-              ; version_preference = _
-              ; repos
-              ; solver_env = _
-              ; context_common = _
-              ; repositories
-              ; constraints = _
-              }
-            ->
-            (* updating makes sense when checking for outdated packages *)
-            let* repos = get_repos repos ~repositories ~update_opam_repositories:true
-            and+ local_packages = find_local_packages in
-            let lock_dir = Lock_dir.read_disk lock_dir_path in
-            let+ results =
-              Dune_pkg_outdated.find ~repos ~local_packages lock_dir.packages
-            in
-            ( Dune_pkg_outdated.pp ~transitive ~lock_dir_path results
-            , ( Dune_pkg_outdated.packages_that_were_not_found results
-                |> Package_name.Set.of_list
-                |> Package_name.Set.to_list
-              , lock_dir_path
-              , repos ) ))
+    let* workspace = Memo.run (Workspace.workspace ()) in
+    lock_dirs_of_workspace workspace
+    |> Fiber.parallel_map ~f:(fun lock_dir_path ->
+      (* updating makes sense when checking for outdated packages *)
+      let* repos =
+        get_repos
+          (repositories_of_workspace workspace)
+          ~repositories:(repositories_of_lock_dir workspace ~lock_dir_path)
+          ~update_opam_repositories:true
+      and+ local_packages = find_local_packages in
+      let lock_dir = Lock_dir.read_disk lock_dir_path in
+      let+ results = Dune_pkg_outdated.find ~repos ~local_packages lock_dir.packages in
+      ( Dune_pkg_outdated.pp ~transitive ~lock_dir_path results
+      , ( Dune_pkg_outdated.packages_that_were_not_found results
+          |> Package_name.Set.of_list
+          |> Package_name.Set.to_list
+        , lock_dir_path
+        , repos ) ))
     >>| List.split
   in
   (match pps with

bin/pkg/pkg_common.ml

@@ -37,66 +37,36 @@ module Version_preference = struct
   ;;
 end
 
-module Per_context = struct
-  type t =
-    { lock_dir_path : Path.Source.t
-    ; version_preference : Version_preference.t
-    ; solver_env : Dune_pkg.Solver_env.t option
-    ; repositories : Dune_pkg.Pkg_workspace.Repository.Name.t list
-    ; context_common : Dune_rules.Workspace.Context.Common.t
-    ; repos :
-        Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t
-    ; constraints : Dune_lang.Package_dependency.t list
-    }
+let repositories_of_workspace (workspace : Workspace.t) =
+  List.map workspace.repos ~f:(fun repo ->
+    Dune_pkg.Pkg_workspace.Repository.name repo, repo)
+  |> Dune_pkg.Pkg_workspace.Repository.Name.Map.of_list_exn
+;;
 
-  let repositories_of_workspace (workspace : Workspace.t) =
-    List.map workspace.repos ~f:(fun repo ->
-      Dune_pkg.Pkg_workspace.Repository.name repo, repo)
-    |> Dune_pkg.Pkg_workspace.Repository.Name.Map.of_list_exn
-  ;;
+let lock_dirs_of_workspace (workspace : Workspace.t) =
+  List.filter_map workspace.contexts ~f:(function
+    | Workspace.Context.Default { lock_dir; base = _ } ->
+      let lock_dir_path = Option.value lock_dir ~default:Dune_pkg.Lock_dir.default_path in
+      Some lock_dir_path
+    | Opam _ -> None)
+;;
 
-  let make_solver workspace context_common ~version_preference_arg ~lock_dir =
-    let lock_dir_path = Option.value lock_dir ~default:Dune_pkg.Lock_dir.default_path in
-    let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in
-    let solver_env = Option.bind lock_dir ~f:(fun lock_dir -> lock_dir.solver_env) in
-    let version_preference_context =
-      Option.bind lock_dir ~f:(fun lock_dir -> lock_dir.version_preference)
-    in
-    let repositories =
-      Option.map lock_dir ~f:(fun lock_dir -> lock_dir.repositories)
-      |> Option.value
-           ~default:
-             (List.map
-                Workspace.default_repositories
-                ~f:Dune_pkg.Pkg_workspace.Repository.name)
-    in
-    let constraints =
-      match lock_dir with
-      | None -> []
-      | Some lock_dir -> lock_dir.constraints
-    in
-    { lock_dir_path
-    ; version_preference =
-        Version_preference.choose
-          ~from_arg:version_preference_arg
-          ~from_context:version_preference_context
-    ; context_common
-    ; solver_env
-    ; repositories
-    ; repos = repositories_of_workspace workspace
-    ; constraints
-    }
-  ;;
+let constraints_of_workspace (workspace : Workspace.t) ~lock_dir_path =
+  let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in
+  match lock_dir with
+  | None -> []
+  | Some lock_dir -> lock_dir.constraints
+;;
 
-  let choose ~version_preference_arg =
-    let open Fiber.O in
-    let+ workspace = Memo.run (Workspace.workspace ()) in
-    List.filter_map workspace.contexts ~f:(function
-      | Workspace.Context.Default { lock_dir; base = context_common } ->
-        Some (make_solver workspace context_common ~version_preference_arg ~lock_dir)
-      | Opam _ -> None)
-  ;;
-end
+let repositories_of_lock_dir workspace ~lock_dir_path =
+  let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in
+  Option.map lock_dir ~f:(fun lock_dir -> lock_dir.repositories)
+  |> Option.value
+       ~default:
+         (List.map
+            Workspace.default_repositories
+            ~f:Dune_pkg.Pkg_workspace.Repository.name)
+;;
 
 let location_of_opam_url url =
   match (url : OpamUrl.t).backend with

bin/pkg/pkg_common.mli

@@ -12,25 +12,27 @@ val solver_env
   -> Dune_pkg.Solver_env.t
 
 module Version_preference : sig
+  type t := Dune_pkg.Version_preference.t
+
   val term : Dune_pkg.Version_preference.t option Term.t
+  val choose : from_arg:t option -> from_context:t option -> t
 end
 
-module Per_context : sig
-  type t =
-    { lock_dir_path : Path.Source.t
-    ; version_preference : Dune_pkg.Version_preference.t
-    ; solver_env : Dune_pkg.Solver_env.t option
-    ; repositories : Dune_pkg.Pkg_workspace.Repository.Name.t list
-    ; context_common : Workspace.Context.Common.t
-    ; repos :
-        Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t
-    ; constraints : Dune_lang.Package_dependency.t list
-    }
-
-  val choose
-    :  version_preference_arg:Dune_pkg.Version_preference.t option
-    -> t list Fiber.t
-end
+val repositories_of_workspace
+  :  Workspace.t
+  -> Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t
+
+val lock_dirs_of_workspace : Workspace.t -> Path.Source.t list
+
+val repositories_of_lock_dir
+  :  Workspace.t
+  -> lock_dir_path:Path.Source.t
+  -> Dune_pkg.Pkg_workspace.Repository.Name.t list
+
+val constraints_of_workspace
+  :  Workspace.t
+  -> lock_dir_path:Path.Source.t
+  -> Dune_lang.Package_dependency.t list
 
 val get_repos
   :  Dune_pkg.Pkg_workspace.Repository.t Dune_pkg.Pkg_workspace.Repository.Name.Map.t