opam-0install-cudf: Add support for the avoid-version flag

dune-project

@@ -54,5 +54,6 @@ the CUDF interface.
 ")
  (depends
   cudf
-  (ocaml (>= 4.10.0))
-  0install-solver))
+  (ocaml (>= 4.08.0))
+  0install-solver
+  (alcotest :with-test)))

lib-cudf/model.ml

@@ -66,29 +66,23 @@ module Make (Context : S.CONTEXT) = struct
     let compare a b =
       match a, b with
       | Real a, Real b -> String.compare a.name b.name
-      | Virtual (a, _), Virtual (b, _) -> compare (a : int) b
+      | Virtual (a, _), Virtual (b, _) -> Int.compare a b
       | Real _, Virtual _ -> -1
       | Virtual _, Real _ -> 1
   end
 
   let role context name = Real { context; name }
 
-  let fresh_id =
-    let i = ref 0 in
-    fun () ->
-      incr i;
-      !i
-
   let virtual_impl ~context ~depends () =
     let depends = depends |> List.map (fun (name, importance) ->
         let drole = role context name in
         let importance = (importance :> [ `Essential | `Recommended | `Restricts ]) in
         { drole; importance; restrictions = []}
       ) in
-    VirtualImpl (fresh_id (), depends)
+    VirtualImpl (Context.fresh_id context, depends)
 
-  let virtual_role impls =
-    Virtual (fresh_id (), impls)
+  let virtual_role ~context impls =
+    Virtual (Context.fresh_id context, impls)
 
   type command = |          (* We don't use 0install commands anywhere *)
   type command_name = private string
@@ -126,13 +120,13 @@ module Make (Context : S.CONTEXT) = struct
       | x::(_::_ as y) -> aux [x] @ aux y
       | [o] ->
         let impls = group_ors o in
-        let drole = virtual_role impls in
+        let drole = virtual_role ~context impls in
         (* Essential because we must apply a restriction, even if its
            components are only restrictions. *)
         [{ drole; restrictions = []; importance = `Essential }]
     and group_ors = function
       | x::(_::_ as y) -> group_ors [x] @ group_ors y
-      | [expr] -> [VirtualImpl (fresh_id (), aux [[expr]])]
+      | [expr] -> [VirtualImpl (Context.fresh_id context, aux [[expr]])]
       | [] -> [Reject (pname, pver)]
     in
     aux deps
@@ -220,9 +214,9 @@ module Make (Context : S.CONTEXT) = struct
 
   let compare_version a b =
     match a, b with
-    | RealImpl a, RealImpl b -> compare (a.pkg.Cudf.version : int) b.pkg.Cudf.version
-    | VirtualImpl (ia, _), VirtualImpl (ib, _) -> compare (ia : int) ib
-    | Reject a, Reject b -> compare (snd a : int) (snd b)
+    | RealImpl a, RealImpl b -> Int.compare a.pkg.Cudf.version b.pkg.Cudf.version
+    | VirtualImpl (ia, _), VirtualImpl (ib, _) -> Int.compare ia ib
+    | Reject a, Reject b -> Int.compare (snd a) (snd b)
     | (RealImpl _ | Reject _ | VirtualImpl _ | Dummy),
       (RealImpl _ | Reject _ | VirtualImpl _ | Dummy)
       -> compare b a

lib-cudf/model.mli

@@ -25,7 +25,7 @@ module Make (Context : S.CONTEXT) : sig
   (** [version impl] is the Opam package for [impl], if any.
       Virtual and dummy implementations return [None]. *)
 
-  val virtual_role : impl list -> Role.t
+  val virtual_role : context:Context.t -> impl list -> Role.t
   (** [virtual_role impls] is a virtual package name with candidates [impls].
       This is used if the user requests multiple packages on the command line
       (the single [impl] will also be virtual). *)

lib-cudf/opam_0install_cudf.ml

@@ -1,10 +1,39 @@
+let tagged_with_avoid_version pkg =
+  List.exists (function
+    | "avoid-version", (`Int 1 | `Bool true) -> true
+    | _ -> false
+  ) pkg.Cudf.pkg_extra
+
+let version_rev_compare ~prefer_oldest ~handle_avoid_version =
+  (* Unrolled for performance purpose *)
+  if prefer_oldest then
+    if handle_avoid_version then
+      fun pkg1 pkg2 ->
+        match tagged_with_avoid_version pkg1, tagged_with_avoid_version pkg2 with
+        | true, true | false, false -> Int.compare pkg1.Cudf.version pkg2.Cudf.version
+        | true, false -> 1
+        | false, true -> -1
+    else
+      fun pkg1 pkg2 ->
+        Int.compare pkg1.Cudf.version pkg2.Cudf.version
+  else if handle_avoid_version then
+    fun pkg1 pkg2 ->
+      match tagged_with_avoid_version pkg1, tagged_with_avoid_version pkg2 with
+      | true, true | false, false -> Int.compare pkg2.Cudf.version pkg1.Cudf.version
+      | true, false -> 1
+      | false, true -> -1
+  else
+    fun pkg1 pkg2 ->
+      Int.compare pkg2.Cudf.version pkg1.Cudf.version
+
 module Context = struct
   type rejection = UserConstraint of Cudf_types.vpkg
 
   type t = {
     universe : Cudf.universe;
     constraints : (Cudf_types.pkgname * (Cudf_types.relop * Cudf_types.version)) list;
-    prefer_oldest : bool;
+    fresh_id : int ref;
+    version_rev_compare : Cudf.package -> Cudf.package -> int;
   }
 
   let user_restrictions t name =
@@ -15,19 +44,13 @@ module Context = struct
         acc
     ) [] t.constraints
 
-  let version_compare t pkg1 pkg2 =
-    if t.prefer_oldest then
-      compare (pkg1.Cudf.version : int) pkg2.Cudf.version
-    else
-      compare (pkg2.Cudf.version : int) pkg1.Cudf.version
-
   let candidates t name =
     let user_constraints = user_restrictions t name in
     match Cudf.lookup_packages t.universe name with
     | [] ->
         [] (* Package not found *)
     | versions ->
-        List.fast_sort (version_compare t) versions (* Higher versions are preferred. *)
+        List.fast_sort t.version_rev_compare versions (* Higher versions are preferred. *)
         |> List.map (fun pkg ->
           let rec check_constr = function
             | [] -> (pkg.Cudf.version, Ok pkg)
@@ -51,14 +74,18 @@ module Context = struct
 
   let pp_rejection f = function
     | UserConstraint (name, c) -> Format.fprintf f "Rejected by user-specified constraint %s%s" name (print_constr c)
+
+  let fresh_id {fresh_id; _} =
+    incr fresh_id;
+    !fresh_id
 end
 
 module Input = Model.Make(Context)
 
 let requirements ~context pkgs =
   let role =
     let impl = Input.virtual_impl ~context ~depends:pkgs () in
-    Input.virtual_role [impl]
+    Input.virtual_role ~context [impl]
   in
   { Input.role; command = None }
 
@@ -69,8 +96,13 @@ type t = Context.t
 type selections = Solver.Output.t
 type diagnostics = Input.requirements   (* So we can run another solve *)
 
-let create ?(prefer_oldest=false) ~constraints universe =
-  { Context.universe; constraints; prefer_oldest }
+let create ?(prefer_oldest=false) ?(handle_avoid_version=true) ~constraints universe =
+  {
+    Context.universe;
+    constraints;
+    fresh_id = ref 0;
+    version_rev_compare = version_rev_compare ~prefer_oldest ~handle_avoid_version;
+  }
 
 let solve context pkgs =
   let req = requirements ~context pkgs in

lib-cudf/opam_0install_cudf.mli

@@ -6,6 +6,7 @@ type diagnostics
 
 val create :
   ?prefer_oldest:bool ->
+  ?handle_avoid_version:bool ->
   constraints:(Cudf_types.pkgname * (Cudf_types.relop * Cudf_types.version)) list ->
   Cudf.universe ->
   t

lib-cudf/s.ml

@@ -16,4 +16,6 @@ module type CONTEXT = sig
   val user_restrictions : t -> Cudf_types.pkgname -> (Cudf_types.relop * Cudf_types.version) list
   (** [user_restrictions t pkg] is the user's constraint on [pkg], if any. This is just
       used for diagnostics; you still have to filter them out yourself in [candidates]. *)
+
+  val fresh_id : t -> int
 end

opam-0install-cudf.opam

@@ -23,8 +23,9 @@ bug-reports: "https://github.com/ocaml-opam/opam-0install-solver/issues"
 depends: [
   "dune" {>= "2.7"}
   "cudf"
-  "ocaml" {>= "4.10.0"}
+  "ocaml" {>= "4.08.0"}
   "0install-solver"
+  "alcotest" {with-test}
   "odoc" {with-doc}
 ]
 build: [

test/cudf/dune

@@ -0,0 +1,4 @@
+(test
+ (name test)
+ (package opam-0install-cudf)
+ (libraries alcotest opam-0install-cudf))

test/cudf/test.ml

@@ -0,0 +1,87 @@
+let universe =
+  Cudf.load_universe [
+    {Cudf.default_package with package = "a"; version = 1};
+    {Cudf.default_package with package = "a"; version = 2};
+    {Cudf.default_package with package = "a"; version = 3};
+    {Cudf.default_package with package = "a"; version = 4};
+
+    {Cudf.default_package with package = "b"; version = 1};
+    {Cudf.default_package with package = "b"; version = 2; pkg_extra = [("avoid-version", `Int 1)]};
+    {Cudf.default_package with package = "b"; version = 3; pkg_extra = [("avoid-version", `Int 0)]};
+    {Cudf.default_package with package = "b"; version = 4};
+
+    {Cudf.default_package with package = "c"; version = 1; pkg_extra = [("avoid-version", `Int 1)]};
+    {Cudf.default_package with package = "c"; version = 2};
+    {Cudf.default_package with package = "c"; version = 3};
+    {Cudf.default_package with package = "c"; version = 4; pkg_extra = [("avoid-version", `Int 0)]};
+
+    {Cudf.default_package with package = "d"; version = 1; pkg_extra = [("avoid-version", `Int 0)]};
+    {Cudf.default_package with package = "d"; version = 2};
+    {Cudf.default_package with package = "d"; version = 3};
+    {Cudf.default_package with package = "d"; version = 4; pkg_extra = [("avoid-version", `Int 1)]};
+  ]
+
+let solve ?prefer_oldest req =
+  let x = Opam_0install_cudf.create ?prefer_oldest ~constraints:[] universe in
+  match Opam_0install_cudf.solve x req with
+  | Ok sel -> Ok (Opam_0install_cudf.packages_of_result sel)
+  | Error diag -> Error (Opam_0install_cudf.diagnostics ~verbose:true diag)
+
+let simple_solve () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("a", 4)])
+    (solve [("a", `Essential)])
+
+let simple_oldest () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("a", 1)])
+    (solve ~prefer_oldest:true [("a", `Essential)])
+
+let simple_avoid_1 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("b", 4)])
+    (solve [("b", `Essential)])
+
+let oldest_avoid_1 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("b", 1)])
+    (solve ~prefer_oldest:true [("b", `Essential)])
+
+let simple_avoid_2 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("c", 4)])
+    (solve [("c", `Essential)])
+
+let oldest_avoid_2 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("c", 2)])
+    (solve ~prefer_oldest:true [("c", `Essential)])
+
+let simple_avoid_3 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("d", 3)])
+    (solve [("d", `Essential)])
+
+let oldest_avoid_3 () =
+  Alcotest.(check (result (list (pair string int)) string))
+    "equal" (Ok [("d", 1)])
+    (solve ~prefer_oldest:true [("d", `Essential)])
+
+let () =
+  Alcotest.run "cudf"
+    [
+      ( "simple solve",
+        [
+          Alcotest.test_case "normal" `Quick simple_solve;
+          Alcotest.test_case "oldest" `Quick simple_oldest;
+        ] );
+      ( "avoid-version",
+        [
+          Alcotest.test_case "normal 1" `Quick simple_avoid_1;
+          Alcotest.test_case "oldest 1" `Quick oldest_avoid_2;
+          Alcotest.test_case "normal 2" `Quick simple_avoid_2;
+          Alcotest.test_case "oldest 2" `Quick oldest_avoid_2;
+          Alcotest.test_case "normal 3" `Quick simple_avoid_3;
+          Alcotest.test_case "oldest 3" `Quick oldest_avoid_3;
+        ] );
+    ]

test/diagnostics/dune

@@ -7,6 +7,7 @@
   packages/main/main.1/opam
   packages/foo/foo.1/opam
   packages/foo/foo.2/opam)
+ (package opam-0install)
  (action
   (with-stdout-to
    test_diagnostics.output