Remove custom deduplication of packages and use opam solver instead

CHANGES.md

@@ -21,6 +21,9 @@
   this case and the message has been reformatted and reworded to make the
   salient information easier to see. (#384, @gridbugs)
 
+- Encode `dev-repo` constraints in the opam solver - this allows to resolve
+  more involved version constraints that were failing before (#396, @samoht)
+
 ### Deprecated
 
 ### Fixed

lib/dev_repo.ml

@@ -32,3 +32,10 @@ module Map = Map.Make (struct
 
   let compare = compare
 end)
+
+module Tbl = Hashtbl.Make (struct
+  type nonrec t = t
+
+  let hash = Hashtbl.hash
+  let equal = String.equal
+end)

lib/dev_repo.mli

@@ -21,3 +21,4 @@ val repo_name : t -> (string, Rresult.R.msg) result
     Returns an error if the result would be the empty string. *)
 
 module Map : Map.S with type key = t
+module Tbl : Hashtbl.S with type key = t

lib/duniverse.ml

@@ -122,25 +122,6 @@ module Repo = struct
     provided_packages : OpamPackage.t list;
   }
 
-  let log_url_selection ~dev_repo ~packages ~highest_version_package =
-    let url_to_string : unresolved Url.t -> string = function
-      | Git { repo; ref } -> Printf.sprintf "%s#%s" repo ref
-      | Other s -> s
-    in
-    let pp_package fmt { Package.opam = { name; version }; url; _ } =
-      Format.fprintf fmt "%a.%a: %s" Opam.Pp.package_name name Opam.Pp.version
-        version (url_to_string url)
-    in
-    let sep fmt () = Format.fprintf fmt "\n" in
-    Logs.warn (fun l ->
-        l
-          "The following packages come from the same repository %s but are \
-           associated with different URLs:\n\
-           %a\n\
-           The url for the highest versioned package was selected: %a"
-          (Dev_repo.to_string dev_repo)
-          (Fmt.list ~sep pp_package) packages pp_package highest_version_package)
-
   module Unresolved_url_map = Map.Make (struct
     type t = unresolved Url.t
 
@@ -165,23 +146,18 @@ module Repo = struct
     match urls with
     | [ (url, hashes) ] -> Ok { dir; url; hashes; provided_packages }
     | _ ->
-        (* If packages from the same repo were resolved to different URLs, we need to pick
-           a single one. Here we decided to go with the one associated with the package
-           that has the higher version. We need a better long term solution as this won't
-           play nicely with pins for instance.
-           The best solution here would be to use source trimming, so we can pull each individual
-           package to its own directory and strip out all the unrelated source code but we would
-           need dune to provide that feature. *)
-        let* highest_version_package =
-          Base.List.max_elt packages ~compare:(fun p p' ->
-              OpamPackage.Version.compare p.Package.opam.version p'.opam.version)
-          |> Base.Result.of_option
-               ~error:(Rresult.R.msg "No packages to compare, internal failure")
-        in
-        log_url_selection ~dev_repo ~packages ~highest_version_package;
-        let url = highest_version_package.url in
-        let hashes = highest_version_package.hashes in
-        Ok { dir; url; hashes; provided_packages }
+        let pp_hash = Fmt.of_to_string OpamHash.to_string in
+        (* this should not happen because we passed extra constraints
+           to the opam solver to avoid this situation *)
+        Fmt.failwith
+          "The following packages have the same `dev-repo' but are using  \
+           different versions of the archive tarballs:\n\
+           %a\n\
+           This should not happen, please report the issue to \
+           https://github.com/tarides/opam-monorepo.\n\
+           %!"
+          Fmt.Dump.(list (pair (Url.pp string) (list pp_hash)))
+          urls
 
   let equal equal_ref t t' =
     let { dir; url; hashes; provided_packages } = t in

lib/opam_solve.ml

@@ -199,6 +199,83 @@ module Opam_monorepo_context (Base_context : BASE_CONTEXT) :
     | Error _ -> false
     | Ok opam_file -> Opam.has_cross_compile_tag opam_file
 
+  (* this is a hack - as we don't have a global view of the package
+     universe, we build the dev_repo table lazily, whenever the 0install
+     solver request more information about a package (by calling
+     [Solver.candidates]. *)
+  let dev_repos = Dev_repo.Tbl.create 13
+
+  let hashes pkg =
+    match OpamFile.OPAM.url pkg with
+    | None -> []
+    | Some url ->
+        (* note: pinned packages do not have any checksums set *)
+        OpamFile.URL.checksum url
+
+  (* build the list of conflicts by removing packages with the same hash *)
+  let conflicts_with_same_dev_repo_but_a_different_hash =
+    let memo = Hashtbl.create 13 in
+    fun (name, version, hashes) pkgs ->
+      match Hashtbl.find_opt memo (name, version) with
+      | Some r -> r
+      | None ->
+          let r =
+            match hashes with
+            | [] -> (* pinned package or virtual package *) []
+            | _ ->
+                let same_hash h = List.exists ~f:(fun h' -> h = h') hashes in
+                let conflict (n, _, hs) =
+                  (* remove self conflicts *)
+                  n <> name
+                  && (* remove packages with the same dev-repo and the same hash *)
+                  not (List.exists ~f:same_hash hs)
+                in
+                List.filter ~f:conflict pkgs
+          in
+          Hashtbl.add memo (name, version) r;
+          r
+
+  let with_conflict pkg =
+    let name = OpamFile.OPAM.name pkg in
+    let version = OpamFile.OPAM.version pkg in
+    let hashes = hashes pkg in
+    let entry = (name, version, hashes) in
+    match OpamFile.OPAM.dev_repo pkg with
+    | None -> pkg
+    | Some dev_repo ->
+        let dev_repo = Dev_repo.from_string (OpamUrl.to_string dev_repo) in
+        let in_conflicts =
+          match Dev_repo.Tbl.find_all dev_repos dev_repo with
+          | [] ->
+              Dev_repo.Tbl.add dev_repos dev_repo entry;
+              []
+          | conflicts ->
+              if not (List.mem entry ~set:conflicts) then
+                Dev_repo.Tbl.add dev_repos dev_repo entry;
+              (* remove packages from the same repo *)
+              conflicts_with_same_dev_repo_but_a_different_hash entry conflicts
+        in
+        let conflicts =
+          in_conflicts
+          |> List.map ~f:(fun (name, version, _) ->
+                 let version =
+                   let open OpamTypes in
+                   let v = OpamPackage.Version.to_string version in
+                   OpamFormula.Atom (Constraint (`Eq, FString v))
+                 in
+                 OpamFormula.Atom (name, version))
+          |> OpamFormula.ors
+        in
+        OpamFile.OPAM.with_conflicts conflicts pkg
+
+  let add_url_conflicts pkgs =
+    List.map
+      ~f:(fun (v, pkg) ->
+        match pkg with
+        | Error _ -> (v, pkg)
+        | Ok pkg -> (v, Ok (with_conflict pkg)))
+      pkgs
+
   let candidates
       {
         base_context;
@@ -229,6 +306,7 @@ module Opam_monorepo_context (Base_context : BASE_CONTEXT) :
         |> remove_opam_provided ~opam_provided
         |> demote_candidates_to_avoid
         |> promote_version preferred_version
+        |> add_url_conflicts
 
   let user_restrictions { base_context; _ } name =
     Base_context.user_restrictions base_context name

test/lib/test_duniverse.ml

@@ -217,27 +217,6 @@ module Repo = struct
                  ];
              })
         ();
-      make_test ~name:"Pick URL from highest version package" ~dev_repo:"d"
-        ~packages:
-          [
-            package_factory ~name:"d" ~version:"1" ~url:(Other "u1") ~hashes:[]
-              ();
-            package_factory ~name:"d-lwt" ~version:"2" ~url:(Other "u2")
-              ~hashes:[] ();
-          ]
-        ~expected:
-          (Ok
-             {
-               dir = "d";
-               url = Other "u2";
-               hashes = [];
-               provided_packages =
-                 [
-                   opam_factory ~name:"d" ~version:"1";
-                   opam_factory ~name:"d-lwt" ~version:"2";
-                 ];
-             })
-        ();
       make_test ~name:"An empty string dev_repo results in an error"
         ~dev_repo:"" ~packages:[]
         ~expected: