Prefer newest packages by default

Based on the discussion at ocaml#8021, dune will prefer the newest versions of packages when solving dependencies. This policy can be configured by a command line argument to `dune pkg lock` and by a field of each context in dune-workspace. This change includes some formatting changes to the messages printed when solving dependencies which were necessary to handle the fact that different build contexts can now have different package solutions. Signed-off-by: Stephen Sherratt <[email protected]>
gridbugs · Jun 23, 2023 · de4d8c6 · de4d8c6
1 parent 3abf19f
commit de4d8c6
Show file tree

Hide file tree

Showing 9 changed files with 280 additions and 84 deletions.
diff --git a/bin/pkg.ml b/bin/pkg.ml
@@ -86,6 +86,32 @@ module Lock = struct
         Repo_selection.local_repo_with_env ~opam_repo_dir_path ~env
   end
 
+  module Version_preference = struct
+    include Dune_pkg.Opam.Version_preference
+
+    let term =
+      let all_strings = List.map all_by_string ~f:fst in
+      let doc =
+        sprintf
+          "Whether to prefer the newest compatible version of a package or the \
+           oldest compatible version of packages while solving dependencies. \
+           This overrides any setting in the current workspace. The default is \
+           %s."
+          (to_string default)
+      in
+      let docv = String.concat ~sep:"|" all_strings |> sprintf "(%s)" in
+      Arg.(
+        value
+        & opt (some (enum all_by_string)) None
+        & info [ "version-preference" ] ~doc ~docv)
+
+    let choose ~from_arg ~from_context =
+      match (from_arg, from_context) with
+      | Some from_arg, _ -> from_arg
+      | None, Some from_context -> from_context
+      | None, None -> default
+  end
+
   (* Converts the package table found inside a [Dune_project.t] into the
      package table expected by the dependency solver *)
   let opam_file_map_of_dune_package_map
@@ -100,44 +126,65 @@ module Lock = struct
         (opam_package_name, opam_file))
     |> OpamPackage.Name.Map.of_list
 
-  (* Logic for choosing the lockdir path(s) to generate *)
-  let choose_lock_dir_paths ~context_name_arg ~all_contexts_arg =
-    let open Fiber.O in
-    match (context_name_arg, all_contexts_arg) with
-    | Some _, true ->
-      User_error.raise
-        [ Pp.text "--context and --all-contexts are mutually exclusive" ]
-    | context_name_opt, false -> (
-      let+ workspace = Memo.run (Workspace.workspace ()) in
-      let context_name =
-        Option.value context_name_opt ~default:Dune_engine.Context_name.default
-      in
-      let context =
-        List.find workspace.contexts ~f:(fun context ->
-            Dune_engine.Context_name.equal
-              (Workspace.Context.name context)
-              context_name)
-      in
-      match context with
-      | None ->
+  module Per_context = struct
+    type t =
+      { lock_dir_path : Path.Source.t
+      ; version_preference : Version_preference.t
+      }
+
+    let choose ~context_name_arg ~all_contexts_arg ~version_preference_arg =
+      let open Fiber.O in
+      match (context_name_arg, all_contexts_arg) with
+      | Some _, true ->
         User_error.raise
-          [ Pp.textf "Unknown build context: %s"
-              (Dune_engine.Context_name.to_string context_name
-              |> String.maybe_quoted)
+          [ Pp.text "--context and --all-contexts are mutually exclusive" ]
+      | context_name_opt, false -> (
+        let+ workspace = Memo.run (Workspace.workspace ()) in
+        let context_name =
+          Option.value context_name_opt
+            ~default:Dune_engine.Context_name.default
+        in
+        let context =
+          List.find workspace.contexts ~f:(fun context ->
+              Dune_engine.Context_name.equal
+                (Workspace.Context.name context)
+                context_name)
+        in
+        match context with
+        | None ->
+          User_error.raise
+            [ Pp.textf "Unknown build context: %s"
+                (Dune_engine.Context_name.to_string context_name
+                |> String.maybe_quoted)
+            ]
+        | Some
+            (Default
+              { lock; version_preference = version_preference_context; _ }) ->
+          [ { lock_dir_path = Option.value lock ~default:Lock_dir.default_path
+            ; version_preference =
+                Version_preference.choose ~from_arg:version_preference_arg
+                  ~from_context:version_preference_context
+            }
           ]
-      | Some (Default { lock; _ }) ->
-        [ Option.value lock ~default:Lock_dir.default_path ]
-      | Some (Opam _) ->
-        User_error.raise
-          [ Pp.textf "Unexpected opam build context: %s"
-              (Dune_engine.Context_name.to_string context_name
-              |> String.maybe_quoted)
-          ])
-    | None, true ->
-      let+ workspace = Memo.run (Workspace.workspace ()) in
-      List.filter_map workspace.contexts ~f:(function
-        | Workspace.Context.Default { lock; _ } -> lock
-        | Opam _ -> None)
+        | Some (Opam _) ->
+          User_error.raise
+            [ Pp.textf "Unexpected opam build context: %s"
+                (Dune_engine.Context_name.to_string context_name
+                |> String.maybe_quoted)
+            ])
+      | None, true ->
+        let+ workspace = Memo.run (Workspace.workspace ()) in
+        List.filter_map workspace.contexts ~f:(function
+          | Workspace.Context.Default
+              { lock; version_preference = version_preference_context; _ } ->
+            Option.map lock ~f:(fun lock_dir_path ->
+                { lock_dir_path
+                ; version_preference =
+                    Version_preference.choose ~from_arg:version_preference_arg
+                      ~from_context:version_preference_context
+                })
+          | Opam _ -> None)
+  end
 
   let context_term =
     Arg.(
@@ -156,14 +203,15 @@ module Lock = struct
       Arg.(
         value & flag
         & info [ "all-contexts" ] ~doc:"Generate the lockdir for all contexts")
-    in
+    and+ version_preference = Version_preference.term in
     let common = Common.forbid_builds common in
     let config = Common.init common in
     Scheduler.go ~common ~config @@ fun () ->
     let open Fiber.O in
-    let* lock_dir_paths =
-      choose_lock_dir_paths ~context_name_arg:context_name
+    let* per_context =
+      Per_context.choose ~context_name_arg:context_name
         ~all_contexts_arg:all_contexts
+        ~version_preference_arg:version_preference
     in
     let+ source_dir = Memo.run (Source_tree.root ()) in
     let project = Source_tree.Dir.project source_dir in
@@ -172,13 +220,16 @@ module Lock = struct
     (* Construct 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 summary, lock_dir =
-      Dune_pkg.Opam.solve_lock_dir ~repo_selection opam_file_map
-    in
-    Console.print_user_message
-      (Dune_pkg.Opam.Summary.selected_packages_message summary);
     let write_disk_list =
-      List.map lock_dir_paths ~f:(fun lock_dir_path ->
+      List.map per_context
+        ~f:(fun { Per_context.lock_dir_path; version_preference } ->
+          let summary, lock_dir =
+            Dune_pkg.Opam.solve_lock_dir ~version_preference ~repo_selection
+              opam_file_map
+          in
+          Console.print_user_message
+            (Dune_pkg.Opam.Summary.selected_packages_message summary
+               ~lock_dir_path);
           Lock_dir.Write_disk.prepare ~lock_dir_path lock_dir)
     in
     (* All the file IO side effects happen here: *)

diff --git a/src/dune_pkg/opam.ml b/src/dune_pkg/opam.ml
@@ -177,6 +177,31 @@ module Local_repo_with_env = struct
     }
 end
 
+module Version_preference = struct
+  type t =
+    | Newest
+    | Oldest
+
+  let equal a b =
+    match (a, b) with
+    | Newest, Newest | Oldest, Oldest -> true
+    | _ -> false
+
+  let to_string = function
+    | Newest -> "newest"
+    | Oldest -> "oldest"
+
+  let to_dyn t = Dyn.variant (to_string t) []
+
+  let default = Newest
+
+  let all = [ Newest; Oldest ]
+
+  let all_by_string = List.map all ~f:(fun t -> (to_string t, t))
+
+  let decode = Dune_sexp.Decoder.enum all_by_string
+end
+
 module Opam_solver = struct
   module type CONTEXT = Opam_0install.S.CONTEXT
 
@@ -255,9 +280,7 @@ module Opam_solver = struct
     include
       Context_with_local_packages (Context_either (Dir_context) (Switch_context))
 
-    let prefer_oldest = true
-
-    let create_dir_context ~local_repo_with_env ~local_packages =
+    let create_dir_context ~prefer_oldest ~local_repo_with_env ~local_packages =
       let { Local_repo_with_env.local_repo = { Local_repo.packages_dir_path }
           ; env
           } =
@@ -270,7 +293,7 @@ module Opam_solver = struct
       in
       create ~base_context:(Left dir_context) ~local_packages
 
-    let create_switch_context ~switch_state ~local_packages =
+    let create_switch_context ~prefer_oldest ~switch_state ~local_packages =
       let switch_context =
         Switch_context.create ~prefer_oldest
           ~constraints:OpamPackage.Name.Map.empty switch_state
@@ -329,18 +352,21 @@ end
 module Summary = struct
   type t = { opam_packages_to_lock : OpamPackage.t list }
 
-  let selected_packages_message t =
-    match t.opam_packages_to_lock with
-    | [] ->
-      User_message.make
-        [ Pp.tag User_message.Style.Success (Pp.text "No dependencies to lock")
+  let selected_packages_message t ~lock_dir_path =
+    let parts =
+      match t.opam_packages_to_lock with
+      | [] ->
+        [ Pp.tag User_message.Style.Success
+            (Pp.text "(no dependencies to lock)")
         ]
-    | opam_packages_to_lock ->
-      User_message.make
-        (Pp.tag User_message.Style.Success
-           (Pp.text "Selected the following packages:")
-        :: List.map opam_packages_to_lock ~f:(fun package ->
-               Pp.text (OpamPackage.to_string package)))
+      | opam_packages_to_lock ->
+        List.map opam_packages_to_lock ~f:(fun package ->
+            Pp.text (OpamPackage.to_string package))
+    in
+    User_message.make
+      (Pp.textf "Solution for %s:"
+         (Path.Source.to_string_maybe_quoted lock_dir_path)
+      :: parts)
 end
 
 let opam_package_to_lock_file_pkg ~repo_state ~local_packages opam_package =
@@ -399,12 +425,19 @@ let solve_package_list local_packages context =
   | Error e -> User_error.raise [ Pp.text (Solver.diagnostics e) ]
   | Ok packages -> Solver.packages_of_result packages
 
-let solve_lock_dir ~repo_selection local_packages =
+let solve_lock_dir ~version_preference ~repo_selection local_packages =
+  let prefer_oldest =
+    match (version_preference : Version_preference.t) with
+    | Oldest -> true
+    | Newest -> false
+  in
   let is_local_package package =
     OpamPackage.Name.Map.mem (OpamPackage.name package) local_packages
   in
   Repo_selection.with_state repo_selection ~f:(fun repo_state ->
-      let context = Repo_state.create_context repo_state local_packages in
+      let context =
+        Repo_state.create_context repo_state local_packages ~prefer_oldest
+      in
       let opam_packages_to_lock =
         solve_package_list local_packages context
         (* don't include local packages in the lock dir *)

diff --git a/src/dune_pkg/opam.mli b/src/dune_pkg/opam.mli
@@ -48,10 +48,30 @@ module Summary : sig
   type t
 
   (** A message listing selected packages *)
-  val selected_packages_message : t -> User_message.t
+  val selected_packages_message :
+    t -> lock_dir_path:Path.Source.t -> User_message.t
+end
+
+module Version_preference : sig
+  type t =
+    | Newest
+    | Oldest
+
+  val equal : t -> t -> bool
+
+  val to_string : t -> string
+
+  val to_dyn : t -> Dyn.t
+
+  val default : t
+
+  val all_by_string : (string * t) list
+
+  val decode : t Dune_sexp.Decoder.t
 end
 
 val solve_lock_dir :
-     repo_selection:Repo_selection.t
+     version_preference:Version_preference.t
+  -> repo_selection:Repo_selection.t
   -> OpamFile.OPAM.t OpamTypes.name_map
   -> Summary.t * Lock_dir.t
diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml
@@ -568,6 +568,7 @@ end = struct
     match context with
     | Default
         { lock = _
+        ; version_preference = _
         ; base =
             { targets
             ; name

diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml
@@ -263,12 +263,16 @@ module Context = struct
     type t =
       { base : Common.t
       ; lock : Path.Source.t option
+      ; version_preference : Dune_pkg.Opam.Version_preference.t option
       }
 
-    let to_dyn { base; lock } =
+    let to_dyn { base; lock; version_preference } =
       Dyn.record
         [ ("base", Common.to_dyn base)
         ; ("lock", Dyn.(option Path.Source.to_dyn) lock)
+        ; ( "version_preference"
+          , Dyn.option Dune_pkg.Opam.Version_preference.to_dyn
+              version_preference )
         ]
 
     let decode =
@@ -283,6 +287,8 @@ module Context = struct
            2. allow external paths
         *)
         field_o "lock" (Dpath.Local.decode ~dir:(Path.source Path.Source.root))
+      and+ version_preference =
+        field_o "version_preference" Dune_pkg.Opam.Version_preference.decode
       in
       let lock = Option.map lock ~f:Path.as_in_source_tree_exn in
       fun ~profile_default ~instrument_with_default ~x ->
@@ -298,10 +304,13 @@ module Context = struct
         let base =
           { common with targets = Target.add common.targets x; name }
         in
-        { base; lock }
+        { base; lock; version_preference }
 
-    let equal { base; lock } t =
-      Common.equal base t.base && Option.equal Path.Source.equal lock t.lock
+    let equal { base; lock; version_preference } t =
+      Common.equal base t.base
+      && Option.equal Path.Source.equal lock t.lock
+      && Option.equal Dune_pkg.Opam.Version_preference.equal version_preference
+           t.version_preference
   end
 
   type t =
@@ -360,6 +369,7 @@ module Context = struct
   let default ~x ~profile ~instrument_with =
     Default
       { lock = None
+      ; version_preference = None
       ; base =
           { loc = Loc.of_pos __POS__
           ; targets = [ Option.value x ~default:Target.Native ]

diff --git a/src/dune_rules/workspace.mli b/src/dune_rules/workspace.mli
@@ -48,6 +48,7 @@ module Context : sig
     type t =
       { base : Common.t
       ; lock : Path.Source.t option
+      ; version_preference : Dune_pkg.Opam.Version_preference.t option
       }
   end