From c4f0b2a742f80e9a090e8622803de4ad6af91abf Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 27 Dec 2024 19:36:49 +0000 Subject: [PATCH] refactor(pkg): inline 0install/opam shim We don't need this to be a separate library as it's just an implemenetation detail of our solver for now Signed-off-by: Rudi Grinberg Signed-off-by: Rudi Grinberg --- src/dune_pkg/dune | 1 - src/dune_pkg/opam_solver.ml | 376 ++++++++++++++++++++++++- src/opam-0install/LICENSE.md | 13 - src/opam-0install/lib/dune | 3 - src/opam-0install/lib/opam_0install.ml | 1 - src/opam-0install/lib/s.ml | 48 ---- src/opam-0install/lib/solver.ml | 368 ------------------------ src/opam-0install/lib/solver.mli | 13 - 8 files changed, 375 insertions(+), 448 deletions(-) delete mode 100644 src/opam-0install/LICENSE.md delete mode 100644 src/opam-0install/lib/dune delete mode 100644 src/opam-0install/lib/opam_0install.ml delete mode 100644 src/opam-0install/lib/s.ml delete mode 100644 src/opam-0install/lib/solver.ml delete mode 100644 src/opam-0install/lib/solver.mli diff --git a/src/dune_pkg/dune b/src/dune_pkg/dune index 886858e4b7f3..ea2f4ed48b95 100644 --- a/src/dune_pkg/dune +++ b/src/dune_pkg/dune @@ -19,7 +19,6 @@ opam_repository opam_format opam_state - opam_0install build_info zeroinstall_solver fmt diff --git a/src/dune_pkg/opam_solver.ml b/src/dune_pkg/opam_solver.ml index 1ced879fc476..894cb7aa74f3 100644 --- a/src/dune_pkg/opam_solver.ml +++ b/src/dune_pkg/opam_solver.ml @@ -256,7 +256,381 @@ module Context_for_dune = struct ;; end -module Solver = Opam_0install.Solver.Make (Context_for_dune) +module Solver = struct + module Context = Context_for_dune + open Pp.O + + (* Copyright (c) 2020 Thomas Leonard + + Permission to use, copy, modify, and distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + module Input = struct + (* Note: [OpamFormula.neg] doesn't work in the [Empty] case, so we just + record whether to negate the result here. *) + type restriction = + { kind : [ `Ensure | `Prevent ] + ; expr : OpamFormula.version_formula + } + + type real_role = + { context : Context.t + ; name : OpamPackage.Name.t + } + + type role = + | Real of real_role (* A role is usually an opam package name *) + | Virtual of < > * impl list (* (Object just for sorting) *) + + and real_impl = + { pkg : OpamPackage.t + ; opam : OpamFile.OPAM.t + ; requires : dependency list + } + + and dependency = + { drole : role + ; importance : [ `Essential | `Restricts ] + ; restrictions : restriction list + } + + and impl = + | RealImpl of real_impl (* An implementation is usually an opam package *) + | VirtualImpl of int * dependency list (* (int just for sorting) *) + | Reject of OpamPackage.t + | Dummy (* Used for diagnostics *) + + let rec pp_version = function + | RealImpl impl -> + Pp.text (OpamPackage.Version.to_string (OpamPackage.version impl.pkg)) + | Reject pkg -> Pp.text (OpamPackage.version_to_string pkg) + | VirtualImpl (_i, deps) -> + Pp.concat_map ~sep:(Pp.char '&') deps ~f:(fun d -> pp_role d.drole) + | Dummy -> Pp.text "(no version)" + + and pp_impl = function + | RealImpl impl -> Pp.text (OpamPackage.to_string impl.pkg) + | Reject pkg -> Pp.text (OpamPackage.to_string pkg) + | VirtualImpl _ as x -> pp_version x + | Dummy -> Pp.text "(no solution found)" + + and pp_role = function + | Real t -> Pp.text (OpamPackage.Name.to_string t.name) + | Virtual (_, impls) -> Pp.concat_map ~sep:(Pp.char '|') impls ~f:pp_impl + ;; + + let pp_impl_long = pp_impl + + module Role = struct + type t = role + + let pp = pp_role + + let compare a b = + match a, b with + | Real a, Real b -> OpamPackage.Name.compare a.name b.name + | Virtual (a, _), Virtual (b, _) -> Ordering.to_int (Poly.compare a b) + | Real _, Virtual _ -> -1 + | Virtual _, Real _ -> 1 + ;; + end + + let role context name = Real { context; name } + + let virtual_impl ~context ~depends () = + let depends = + List.map depends ~f:(fun name -> + let drole = role context name in + let importance = `Essential in + { drole; importance; restrictions = [] }) + in + VirtualImpl (-1, depends) + ;; + + let virtual_role impls = + let impls = + List.mapi impls ~f:(fun i -> + function + | VirtualImpl (_, x) -> VirtualImpl (i, x) + | x -> x) + in + Virtual (object end, impls) + ;; + + type dep_info = + { dep_role : Role.t + ; dep_importance : [ `Essential | `Restricts ] + } + + let dummy_impl = Dummy + + (* Turn an opam dependency formula into a 0install list of dependencies. *) + let list_deps ~context ~importance ~rank deps = + let open OpamTypes in + let rec aux = function + | Empty -> [] + | Atom (name, restrictions) -> + let drole = role context name in + [ { drole; restrictions; importance } ] + | Block x -> aux x + | And (x, y) -> aux x @ aux y + | Or _ as o -> + let impls = group_ors o in + let drole = virtual_role impls in + (* Essential because we must apply a restriction, even if its + components are only restrictions. *) + [ { drole; restrictions = []; importance = `Essential } ] + and group_ors = function + | Or (x, y) -> group_ors x @ group_ors y + | expr -> + let i = !rank in + rank := i + 1; + [ VirtualImpl (i, aux expr) ] + in + aux deps + ;; + + let requires _ = function + | Dummy | Reject _ -> [] + | VirtualImpl (_, deps) -> deps + | RealImpl impl -> impl.requires + ;; + + let dep_info { drole; importance; restrictions = _ } = + { dep_role = drole; dep_importance = importance } + ;; + + type role_information = { impls : impl list } + type conflict_class = string + + let conflict_class = function + | RealImpl impl -> + OpamFile.OPAM.conflict_class impl.opam |> List.map ~f:OpamPackage.Name.to_string + | VirtualImpl _ -> [] + | Dummy | Reject _ -> [] + ;; + + (* Opam uses conflicts, e.g. + conflicts if X {> 1} OR Y {< 1 OR > 2} + whereas 0install uses restricts, e.g. + restrict to X {<= 1} AND Y {>= 1 AND <= 2} + + Warning: [OpamFormula.neg _ Empty = Empty], so does NOT reverse the result in this case. + For empty conflicts this is fine (don't conflict with anything, just like an empty depends + list). But for the version expressions inside, it's wrong: a conflict with no expression + conflicts with all versions and should restrict the choice to nothing, not to everything. + So, we just tag the formula as [`Prevent] instead of negating it. *) + let prevent f = + OpamFormula.neg Fun.id f + |> OpamFormula.map (fun (a, expr) -> + OpamFormula.Atom (a, [ { kind = `Prevent; expr } ])) + ;; + + let ensure = + OpamFormula.map (fun (name, vexpr) -> + let rlist = + match vexpr with + | OpamFormula.Empty -> [] + | r -> [ { kind = `Ensure; expr = r } ] + in + OpamFormula.Atom (name, rlist)) + ;; + + (* Get all the candidates for a role. *) + let implementations = function + | Virtual (_, impls) -> Fiber.return { impls } + | Real role -> + let context = role.context in + let+ impls = + Context.candidates context role.name + >>| List.filter_map ~f:(function + | _, Error _rejection -> None + | version, Ok opam -> + let pkg = OpamPackage.create role.name version in + (* Note: we ignore depopts here: see opam/doc/design/depopts-and-features *) + let requires = + let rank = ref 0 in + let make_deps importance xform get = + get opam + |> Context.filter_deps context pkg + |> xform + |> list_deps ~context ~importance ~rank + in + make_deps `Essential ensure OpamFile.OPAM.depends + @ make_deps `Restricts prevent OpamFile.OPAM.conflicts + in + Some (RealImpl { pkg; opam; requires })) + in + { impls } + ;; + + let restrictions dependency = dependency.restrictions + + let meets_restriction impl { kind; expr } = + match impl with + | Dummy -> true + | VirtualImpl _ -> assert false (* Can't constrain version of a virtual impl! *) + | Reject _ -> false + | RealImpl impl -> + let result = + OpamFormula.check_version_formula expr (OpamPackage.version impl.pkg) + in + (match kind with + | `Ensure -> result + | `Prevent -> not result) + ;; + + type rejection = Context.rejection + + let rejects role = + match role with + | Virtual _ -> Fiber.return ([], []) + | Real role -> + let+ rejects = + Context.candidates role.context role.name + >>| List.filter_map ~f:(function + | _, Ok _ -> None + | version, Error reason -> + let pkg = OpamPackage.create role.name version in + Some (Reject pkg, reason)) + in + let notes = [] in + rejects, notes + ;; + + let compare_version a b = + match a, b with + | RealImpl a, RealImpl b -> OpamPackage.compare a.pkg b.pkg + | VirtualImpl (ia, _), VirtualImpl (ib, _) -> Ordering.to_int (Int.compare ia ib) + | Reject a, Reject b -> OpamPackage.compare a b + | ( (RealImpl _ | Reject _ | VirtualImpl _ | Dummy) + , (RealImpl _ | Reject _ | VirtualImpl _ | Dummy) ) -> + Ordering.to_int (Poly.compare b a) + ;; + + let user_restrictions = function + | Virtual _ -> None + | Real role -> + (match Context.user_restrictions role.context role.name with + | None -> None + | Some f -> Some { kind = `Ensure; expr = OpamFormula.Atom f }) + ;; + + let string_of_op = function + | `Eq -> "=" + | `Geq -> ">=" + | `Gt -> ">" + | `Leq -> "<=" + | `Lt -> "<" + | `Neq -> "<>" + ;; + + let string_of_version_formula = + OpamFormula.string_of_formula (fun (rel, v) -> + Printf.sprintf "%s %s" (string_of_op rel) (OpamPackage.Version.to_string v)) + ;; + + let string_of_restriction = function + | { kind = `Prevent; expr = OpamFormula.Empty } -> "conflict with all versions" + | { kind = `Prevent; expr } -> + Format.sprintf "not(%s)" (string_of_version_formula expr) + | { kind = `Ensure; expr } -> string_of_version_formula expr + ;; + + let describe_problem _impl = Context.pp_rejection + + let version = function + | RealImpl impl -> Some impl.pkg + | Reject pkg -> Some pkg + | VirtualImpl _ -> None + | Dummy -> None + ;; + end + + let requirements ~context pkgs = + match pkgs with + | [ pkg ] -> Input.role context pkg + | pkgs -> + let impl = Input.virtual_impl ~context ~depends:pkgs () in + Input.virtual_role [ impl ] + ;; + + module Solver = Zeroinstall_solver.Make (Input) + module Diagnostics = Zeroinstall_solver.Diagnostics (Solver.Output) + + let solve context pkgs = + let req = requirements ~context pkgs in + Solver.do_solve ~closest_match:false req + >>| function + | Some sels -> Ok sels + | None -> Error req + ;; + + let rec partition_three f = function + | [] -> [], [], [] + | first :: rest -> + let xs, ys, zs = partition_three f rest in + (match f first with + | `Left x -> x :: xs, ys, zs + | `Middle y -> xs, y :: ys, zs + | `Right z -> xs, ys, z :: zs) + ;; + + let pp_rolemap ~verbose reasons = + let good, bad, unknown = + reasons + |> Solver.Output.RoleMap.bindings + |> partition_three (fun (role, component) -> + match Diagnostics.Component.selected_impl component with + | Some impl when Diagnostics.Component.notes component = [] -> `Left impl + | _ -> + (match Diagnostics.Component.rejects component with + | _, `No_candidates -> `Right role + | _, _ -> `Middle component)) + in + let pp_bad = Diagnostics.Component.pp ~verbose in + let pp_unknown role = Pp.box (Solver.Output.Role.pp role) in + match unknown with + | [] -> + Pp.paragraph "Selected candidates: " + ++ Pp.hovbox (Pp.concat_map ~sep:Pp.space good ~f:Input.pp_impl) + ++ Pp.cut + ++ Pp.enumerate bad ~f:pp_bad + | _ -> + (* In case of unknown packages, no need to print the full diagnostic + list, the problem is simpler. *) + Pp.hovbox + (Pp.text "The following packages couldn't be found: " + ++ Pp.concat_map ~sep:Pp.space unknown ~f:pp_unknown) + ;; + + let diagnostics_rolemap req = + Solver.do_solve req ~closest_match:true >>| Option.value_exn >>= Diagnostics.of_result + ;; + + let diagnostics ?(verbose = false) req = + let+ diag = diagnostics_rolemap req in + Pp.paragraph "Couldn't solve the package dependency formula." + ++ Pp.cut + ++ Pp.vbox (pp_rolemap ~verbose diag) + ;; + + let packages_of_result sels = + Solver.Output.to_map sels + |> Solver.Output.RoleMap.to_seq + |> List.of_seq + |> List.filter_map ~f:(fun (_role, sel) -> Input.version (Solver.Output.unwrap sel)) + ;; +end let is_valid_global_variable_name = function | "root" -> false diff --git a/src/opam-0install/LICENSE.md b/src/opam-0install/LICENSE.md deleted file mode 100644 index 2ea64bb96144..000000000000 --- a/src/opam-0install/LICENSE.md +++ /dev/null @@ -1,13 +0,0 @@ -Copyright (c) 2020 Thomas Leonard - -Permission to use, copy, modify, and distribute this software for any -purpose with or without fee is hereby granted, provided that the above -copyright notice and this permission notice appear in all copies. - -THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/src/opam-0install/lib/dune b/src/opam-0install/lib/dune deleted file mode 100644 index 283f64623325..000000000000 --- a/src/opam-0install/lib/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name opam_0install) - (libraries fiber opam_state opam_format pp stdune zeroinstall_solver)) diff --git a/src/opam-0install/lib/opam_0install.ml b/src/opam-0install/lib/opam_0install.ml deleted file mode 100644 index d7235ba2f232..000000000000 --- a/src/opam-0install/lib/opam_0install.ml +++ /dev/null @@ -1 +0,0 @@ -module Solver = Solver diff --git a/src/opam-0install/lib/s.ml b/src/opam-0install/lib/s.ml deleted file mode 100644 index 9166503fd65c..000000000000 --- a/src/opam-0install/lib/s.ml +++ /dev/null @@ -1,48 +0,0 @@ -module type CONTEXT = sig - type t - - (** A reason why a package can't be used as input to the solver. e.g. it is - for a different platform, or conflicts with a user-provided constraint. *) - type rejection - - val pp_rejection : rejection -> 'tag Pp.t - - (** [candidates t name] is the list of available versions of [name], in order - of decreasing preference. If the user or environment provides additional - constraints that mean a version should be rejected, include that here too. Rejects - are only used for generating diagnostics reports. Candidates whose "availablity" field - isn't satisfied must be rejected here. *) - val candidates - : t - -> OpamPackage.Name.t - -> (OpamPackage.Version.t * (OpamFile.OPAM.t, rejection) result) list Fiber.t - - (** [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 user_restrictions : t -> OpamPackage.Name.t -> OpamFormula.version_constraint option - - (** [filter_deps t pkg f] is used to pre-process depends and conflicts. - [pkg] is the package which has the dependency [f]. - For example, you can use this to filter out dependencies that are only needed on Windows - if the platform is Linux. *) - val filter_deps : t -> OpamPackage.t -> OpamTypes.filtered_formula -> OpamTypes.formula -end - -module type SOLVER = sig - type t - type selections - type diagnostics - - (** [solve t package_names] finds a compatible set of package versions that - includes all packages in [package_names] and their required dependencies. *) - val solve : t -> OpamPackage.Name.t list -> (selections, diagnostics) result Fiber.t - - val packages_of_result : selections -> OpamPackage.t list - - (** [diagnostics d] is a message explaining why [d] failed, generated by - performing another solve which doesn't abort on failure. *) - val diagnostics - : ?verbose:bool - -> diagnostics - -> Stdune.User_message.Style.t Pp.t Fiber.t -end diff --git a/src/opam-0install/lib/solver.ml b/src/opam-0install/lib/solver.ml deleted file mode 100644 index 3ae48cd275bd..000000000000 --- a/src/opam-0install/lib/solver.ml +++ /dev/null @@ -1,368 +0,0 @@ -open Stdune -open Fiber.O -open Pp.O - -module Make (Context : S.CONTEXT) = struct - module Input = struct - (* Note: [OpamFormula.neg] doesn't work in the [Empty] case, so we just - record whether to negate the result here. *) - type restriction = - { kind : [ `Ensure | `Prevent ] - ; expr : OpamFormula.version_formula - } - - type real_role = - { context : Context.t - ; name : OpamPackage.Name.t - } - - type role = - | Real of real_role (* A role is usually an opam package name *) - | Virtual of < > * impl list (* (Object just for sorting) *) - - and real_impl = - { pkg : OpamPackage.t - ; opam : OpamFile.OPAM.t - ; requires : dependency list - } - - and dependency = - { drole : role - ; importance : [ `Essential | `Restricts ] - ; restrictions : restriction list - } - - and impl = - | RealImpl of real_impl (* An implementation is usually an opam package *) - | VirtualImpl of int * dependency list (* (int just for sorting) *) - | Reject of OpamPackage.t - | Dummy (* Used for diagnostics *) - - let rec pp_version = function - | RealImpl impl -> - Pp.text (OpamPackage.Version.to_string (OpamPackage.version impl.pkg)) - | Reject pkg -> Pp.text (OpamPackage.version_to_string pkg) - | VirtualImpl (_i, deps) -> - Pp.concat_map ~sep:(Pp.char '&') deps ~f:(fun d -> pp_role d.drole) - | Dummy -> Pp.text "(no version)" - - and pp_impl = function - | RealImpl impl -> Pp.text (OpamPackage.to_string impl.pkg) - | Reject pkg -> Pp.text (OpamPackage.to_string pkg) - | VirtualImpl _ as x -> pp_version x - | Dummy -> Pp.text "(no solution found)" - - and pp_role = function - | Real t -> Pp.text (OpamPackage.Name.to_string t.name) - | Virtual (_, impls) -> Pp.concat_map ~sep:(Pp.char '|') impls ~f:pp_impl - ;; - - let pp_impl_long = pp_impl - - module Role = struct - type t = role - - let pp = pp_role - - let compare a b = - match a, b with - | Real a, Real b -> OpamPackage.Name.compare a.name b.name - | Virtual (a, _), Virtual (b, _) -> Ordering.to_int (Poly.compare a b) - | Real _, Virtual _ -> -1 - | Virtual _, Real _ -> 1 - ;; - end - - let role context name = Real { context; name } - - open Fiber.O - - let virtual_impl ~context ~depends () = - let depends = - List.map depends ~f:(fun name -> - let drole = role context name in - let importance = `Essential in - { drole; importance; restrictions = [] }) - in - VirtualImpl (-1, depends) - ;; - - let virtual_role impls = - let impls = - List.mapi impls ~f:(fun i -> - function - | VirtualImpl (_, x) -> VirtualImpl (i, x) - | x -> x) - in - Virtual (object end, impls) - ;; - - type dep_info = - { dep_role : Role.t - ; dep_importance : [ `Essential | `Restricts ] - } - - let dummy_impl = Dummy - - (* Turn an opam dependency formula into a 0install list of dependencies. *) - let list_deps ~context ~importance ~rank deps = - let open OpamTypes in - let rec aux = function - | Empty -> [] - | Atom (name, restrictions) -> - let drole = role context name in - [ { drole; restrictions; importance } ] - | Block x -> aux x - | And (x, y) -> aux x @ aux y - | Or _ as o -> - let impls = group_ors o in - let drole = virtual_role impls in - (* Essential because we must apply a restriction, even if its - components are only restrictions. *) - [ { drole; restrictions = []; importance = `Essential } ] - and group_ors = function - | Or (x, y) -> group_ors x @ group_ors y - | expr -> - let i = !rank in - rank := i + 1; - [ VirtualImpl (i, aux expr) ] - in - aux deps - ;; - - let requires _ = function - | Dummy | Reject _ -> [] - | VirtualImpl (_, deps) -> deps - | RealImpl impl -> impl.requires - ;; - - let dep_info { drole; importance; restrictions = _ } = - { dep_role = drole; dep_importance = importance } - ;; - - type role_information = { impls : impl list } - type conflict_class = string - - let conflict_class = function - | RealImpl impl -> - OpamFile.OPAM.conflict_class impl.opam |> List.map ~f:OpamPackage.Name.to_string - | VirtualImpl _ -> [] - | Dummy | Reject _ -> [] - ;; - - (* Opam uses conflicts, e.g. - conflicts if X {> 1} OR Y {< 1 OR > 2} - whereas 0install uses restricts, e.g. - restrict to X {<= 1} AND Y {>= 1 AND <= 2} - - Warning: [OpamFormula.neg _ Empty = Empty], so does NOT reverse the result in this case. - For empty conflicts this is fine (don't conflict with anything, just like an empty depends - list). But for the version expressions inside, it's wrong: a conflict with no expression - conflicts with all versions and should restrict the choice to nothing, not to everything. - So, we just tag the formula as [`Prevent] instead of negating it. *) - let prevent f = - OpamFormula.neg Fun.id f - |> OpamFormula.map (fun (a, expr) -> - OpamFormula.Atom (a, [ { kind = `Prevent; expr } ])) - ;; - - let ensure = - OpamFormula.map (fun (name, vexpr) -> - let rlist = - match vexpr with - | OpamFormula.Empty -> [] - | r -> [ { kind = `Ensure; expr = r } ] - in - OpamFormula.Atom (name, rlist)) - ;; - - (* Get all the candidates for a role. *) - let implementations = function - | Virtual (_, impls) -> Fiber.return { impls } - | Real role -> - let context = role.context in - let+ impls = - Context.candidates context role.name - >>| List.filter_map ~f:(function - | _, Error _rejection -> None - | version, Ok opam -> - let pkg = OpamPackage.create role.name version in - (* Note: we ignore depopts here: see opam/doc/design/depopts-and-features *) - let requires = - let rank = ref 0 in - let make_deps importance xform get = - get opam - |> Context.filter_deps context pkg - |> xform - |> list_deps ~context ~importance ~rank - in - make_deps `Essential ensure OpamFile.OPAM.depends - @ make_deps `Restricts prevent OpamFile.OPAM.conflicts - in - Some (RealImpl { pkg; opam; requires })) - in - { impls } - ;; - - let restrictions dependency = dependency.restrictions - - let meets_restriction impl { kind; expr } = - match impl with - | Dummy -> true - | VirtualImpl _ -> assert false (* Can't constrain version of a virtual impl! *) - | Reject _ -> false - | RealImpl impl -> - let result = - OpamFormula.check_version_formula expr (OpamPackage.version impl.pkg) - in - (match kind with - | `Ensure -> result - | `Prevent -> not result) - ;; - - type rejection = Context.rejection - - let rejects role = - match role with - | Virtual _ -> Fiber.return ([], []) - | Real role -> - let+ rejects = - Context.candidates role.context role.name - >>| List.filter_map ~f:(function - | _, Ok _ -> None - | version, Error reason -> - let pkg = OpamPackage.create role.name version in - Some (Reject pkg, reason)) - in - let notes = [] in - rejects, notes - ;; - - let compare_version a b = - match a, b with - | RealImpl a, RealImpl b -> OpamPackage.compare a.pkg b.pkg - | VirtualImpl (ia, _), VirtualImpl (ib, _) -> Ordering.to_int (Int.compare ia ib) - | Reject a, Reject b -> OpamPackage.compare a b - | ( (RealImpl _ | Reject _ | VirtualImpl _ | Dummy) - , (RealImpl _ | Reject _ | VirtualImpl _ | Dummy) ) -> - Ordering.to_int (Poly.compare b a) - ;; - - let user_restrictions = function - | Virtual _ -> None - | Real role -> - (match Context.user_restrictions role.context role.name with - | None -> None - | Some f -> Some { kind = `Ensure; expr = OpamFormula.Atom f }) - ;; - - let string_of_op = function - | `Eq -> "=" - | `Geq -> ">=" - | `Gt -> ">" - | `Leq -> "<=" - | `Lt -> "<" - | `Neq -> "<>" - ;; - - let string_of_version_formula = - OpamFormula.string_of_formula (fun (rel, v) -> - Printf.sprintf "%s %s" (string_of_op rel) (OpamPackage.Version.to_string v)) - ;; - - let string_of_restriction = function - | { kind = `Prevent; expr = OpamFormula.Empty } -> "conflict with all versions" - | { kind = `Prevent; expr } -> - Format.sprintf "not(%s)" (string_of_version_formula expr) - | { kind = `Ensure; expr } -> string_of_version_formula expr - ;; - - let describe_problem _impl = Context.pp_rejection - - let version = function - | RealImpl impl -> Some impl.pkg - | Reject pkg -> Some pkg - | VirtualImpl _ -> None - | Dummy -> None - ;; - end - - let requirements ~context pkgs = - match pkgs with - | [ pkg ] -> Input.role context pkg - | pkgs -> - let impl = Input.virtual_impl ~context ~depends:pkgs () in - Input.virtual_role [ impl ] - ;; - - module Solver = Zeroinstall_solver.Make (Input) - module Diagnostics = Zeroinstall_solver.Diagnostics (Solver.Output) - - type t = Context.t - type selections = Solver.Output.t - type diagnostics = Input.Role.t (* So we can run another solve *) - - let solve context pkgs = - let req = requirements ~context pkgs in - Solver.do_solve ~closest_match:false req - >>| function - | Some sels -> Ok sels - | None -> Error req - ;; - - let rec partition_three f = function - | [] -> [], [], [] - | first :: rest -> - let xs, ys, zs = partition_three f rest in - (match f first with - | `Left x -> x :: xs, ys, zs - | `Middle y -> xs, y :: ys, zs - | `Right z -> xs, ys, z :: zs) - ;; - - let pp_rolemap ~verbose reasons = - let good, bad, unknown = - reasons - |> Solver.Output.RoleMap.bindings - |> partition_three (fun (role, component) -> - match Diagnostics.Component.selected_impl component with - | Some impl when Diagnostics.Component.notes component = [] -> `Left impl - | _ -> - (match Diagnostics.Component.rejects component with - | _, `No_candidates -> `Right role - | _, _ -> `Middle component)) - in - let pp_bad = Diagnostics.Component.pp ~verbose in - let pp_unknown role = Pp.box (Solver.Output.Role.pp role) in - match unknown with - | [] -> - Pp.paragraph "Selected candidates: " - ++ Pp.hovbox (Pp.concat_map ~sep:Pp.space good ~f:Input.pp_impl) - ++ Pp.cut - ++ Pp.enumerate bad ~f:pp_bad - | _ -> - (* In case of unknown packages, no need to print the full diagnostic - list, the problem is simpler. *) - Pp.hovbox - (Pp.text "The following packages couldn't be found: " - ++ Pp.concat_map ~sep:Pp.space unknown ~f:pp_unknown) - ;; - - let diagnostics_rolemap req = - Solver.do_solve req ~closest_match:true >>| Option.value_exn >>= Diagnostics.of_result - ;; - - let diagnostics ?(verbose = false) req = - let+ diag = diagnostics_rolemap req in - Pp.paragraph "Couldn't solve the package dependency formula." - ++ Pp.cut - ++ Pp.vbox (pp_rolemap ~verbose diag) - ;; - - let packages_of_result sels = - Solver.Output.to_map sels - |> Solver.Output.RoleMap.to_seq - |> List.of_seq - |> List.filter_map ~f:(fun (_role, sel) -> Input.version (Solver.Output.unwrap sel)) - ;; -end diff --git a/src/opam-0install/lib/solver.mli b/src/opam-0install/lib/solver.mli deleted file mode 100644 index e89b3b4d9baa..000000000000 --- a/src/opam-0install/lib/solver.mli +++ /dev/null @@ -1,13 +0,0 @@ -module Make (C : S.CONTEXT) : sig - module Input : Zeroinstall_solver.S.SOLVER_INPUT with type rejection = C.rejection - - module Solver : sig - module Output : Zeroinstall_solver.S.SOLVER_RESULT with module Input = Input - end - - include S.SOLVER with type t = C.t and type selections = Solver.Output.t - - module Diagnostics : sig - include module type of Zeroinstall_solver.Diagnostics (Solver.Output) - end -end