diff --git a/lib-cudf/model.mli b/lib-cudf/model.mli index e9a0e41..6403932 100644 --- a/lib-cudf/model.mli +++ b/lib-cudf/model.mli @@ -17,7 +17,47 @@ val fop : Cudf_types.relop -> int -> int -> bool module Make (Context : S.CONTEXT) : sig + type restriction = { + kind : [ `Ensure | `Prevent ]; + expr : (Cudf_types.relop * Cudf_types.version) list; (* TODO: might not be a list *) + (* NOTE: each list is a raw or the list is an OR case (see Cudf_types.vpkgforula) *) + } + + type real_role = { + context : Context.t; + name : Cudf_types.pkgname; + } + + type role = + | Real of real_role (* A role is usually an opam package name *) + | Virtual of int * impl list (* (int just for sorting) *) + and real_impl = { + pkg : Cudf.package; + requires : dependency list; + } + and dependency = { + drole : role; + importance : [ `Essential | `Recommended | `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 (Cudf_types.pkgname * Cudf_types.version) + | Dummy (* Used for diagnostics *) + + module Role : sig + type t = role + val pp : Format.formatter -> t -> unit + val compare : t -> t -> int + end + include Zeroinstall_solver.S.SOLVER_INPUT + with type restriction := restriction + and type impl := impl + and type dependency := dependency + and type rejection = Context.rejection + and module Role := Role val role : Context.t -> Cudf_types.pkgname -> Role.t diff --git a/lib-cudf/opam_0install_cudf.ml b/lib-cudf/opam_0install_cudf.ml index d43d3b0..53a92fe 100644 --- a/lib-cudf/opam_0install_cudf.ml +++ b/lib-cudf/opam_0install_cudf.ml @@ -78,12 +78,117 @@ let solve context pkgs = | Some sels -> Ok sels | None -> Error req -let diagnostics ?verbose req = - Solver.do_solve req ~closest_match:true - |> Option.get - |> Diagnostics.get_failure_reason ?verbose - let packages_of_result sels = sels |> Solver.Output.to_map |> Solver.Output.RoleMap.to_seq |> List.of_seq |> List.filter_map (fun (_role, sel) -> Input.version (Solver.Output.unwrap sel)) + +module Raw_diagnostics = struct + type restriction = Input.restriction = { + kind : [`Ensure | `Prevent]; + expr : (Cudf_types.relop * Cudf_types.version) list; + } + + type role = + | Real of Cudf_types.pkgname + | Virtual of impl list + and real_impl = { + pkg : Cudf.package; + requires : dependency list; + } + and dependency = { + drole : role; + importance : [`Essential | `Recommended | `Restricts]; + restrictions : restriction list; + } + and impl = + | RealImpl of real_impl + | VirtualImpl of dependency list + | Reject of (Cudf_types.pkgname * Cudf_types.version) + | Dummy + + type rejection_reason = + | ModelRejection of Cudf_types.vpkg + | FailsRestriction of restriction + | DepFailsRestriction of dependency * restriction + | ConflictsRole of role + | DiagnosticsFailure of string + + type reject = impl * rejection_reason + type candidates = reject list * [`All_unusable | `No_candidates | `Conflicts] + + type outcome = + | SelectedImpl of impl + | RejectedCandidates of candidates + + type note = + | UserRequested of restriction + | ReplacesConflict of role + | ReplacedByConflict of role + | Restricts of role * impl * restriction list + | Feed_problem of string + + type t = { + role : role; + outcome : outcome; + notes : note list; + } + + let rec map_role = function + | Input.Real {context = _; name} -> Real name + | Input.Virtual (_, impls) -> Virtual (List.map map_impl impls) + and map_impl = function + | Input.RealImpl {pkg; requires} -> RealImpl {pkg; requires = List.map map_dependency requires} + | Input.VirtualImpl (_, dependencies) -> VirtualImpl (List.map map_dependency dependencies) + | Input.Reject pkg -> Reject pkg + | Input.Dummy -> Dummy + and map_dependency {drole; importance; restrictions} = + { drole = map_role drole; importance; restrictions} + + let map_note = function + | Diagnostics.Note.UserRequested restriction -> UserRequested restriction + | Diagnostics.Note.ReplacesConflict role -> ReplacesConflict (map_role role) + | Diagnostics.Note.ReplacedByConflict role -> ReplacedByConflict (map_role role) + | Diagnostics.Note.Restricts (role, impl, restrictions) -> Restricts (map_role role, map_impl impl, restrictions) + | Diagnostics.Note.RequiresCommand _ -> assert false (* NOTE: the current implementation does not have any commands *) + | Diagnostics.Note.Feed_problem msg -> Feed_problem msg + + let map_reason = function + | `Model_rejection (Context.UserConstraint rejection) -> ModelRejection rejection + | `FailsRestriction restriction -> FailsRestriction restriction + | `DepFailsRestriction (dependency, restriction) -> DepFailsRestriction (map_dependency dependency, restriction) + | `MachineGroupConflict _ -> assert false (* NOTE: the current implementation does not have any machine groups *) + | `ClassConflict _ -> assert false (* NOTE: the current implementation does not have any class-conflicts *) + | `ConflictsRole role -> ConflictsRole (map_role role) + | `MissingCommand _ -> assert false (* NOTE: the current implementation does not have any commands *) + | `DiagnosticsFailure msg -> DiagnosticsFailure msg + + let map_reject (impl, reason) = + (map_impl impl, map_reason reason) + + let map_candidates (rejects, kind) = + (List.map map_reject rejects, kind) + + let get_aux req = + Solver.do_solve req ~closest_match:true + |> Option.get + + let get req = + get_aux req |> + Diagnostics.of_result |> + Solver.Output.RoleMap.bindings |> + List.map (fun (_role, component) -> + let selected_impl = Option.map map_impl (Diagnostics.Component.selected_impl component) in + { + role = map_role (Diagnostics.Component.role component); + outcome = begin match selected_impl with + | Some selected_impl -> SelectedImpl selected_impl + | None -> RejectedCandidates (map_candidates (Diagnostics.Component.rejects component)) + end; + notes = List.map map_note (Diagnostics.Component.notes component); + } + ) +end + +let diagnostics ?verbose req = + Raw_diagnostics.get_aux req |> Diagnostics.get_failure_reason ?verbose diff --git a/lib-cudf/opam_0install_cudf.mli b/lib-cudf/opam_0install_cudf.mli index 08fe1eb..0bd5587 100644 --- a/lib-cudf/opam_0install_cudf.mli +++ b/lib-cudf/opam_0install_cudf.mli @@ -1,7 +1,6 @@ type t type selections - type diagnostics val create : @@ -30,3 +29,57 @@ val packages_of_result : selections -> (Cudf_types.pkgname * Cudf_types.version) val diagnostics : ?verbose:bool -> diagnostics -> string (** [diagnostics d] is a message explaining why [d] failed, generated by performing another solve which doesn't abort on failure. *) + +module Raw_diagnostics : sig + type restriction = { + kind : [`Ensure | `Prevent]; + expr : (Cudf_types.relop * Cudf_types.version) list; + } + + type role = + | Real of Cudf_types.pkgname + | Virtual of impl list + and real_impl = { + pkg : Cudf.package; + requires : dependency list; + } + and dependency = { + drole : role; + importance : [`Essential | `Recommended | `Restricts]; + restrictions : restriction list; + } + and impl = + | RealImpl of real_impl + | VirtualImpl of dependency list + | Reject of (Cudf_types.pkgname * Cudf_types.version) + | Dummy + + type rejection_reason = + | ModelRejection of Cudf_types.vpkg + | FailsRestriction of restriction + | DepFailsRestriction of dependency * restriction + | ConflictsRole of role + | DiagnosticsFailure of string + + type reject = impl * rejection_reason + type candidates = reject list * [`All_unusable | `No_candidates | `Conflicts] + + type outcome = + | SelectedImpl of impl + | RejectedCandidates of candidates + + type note = + | UserRequested of restriction + | ReplacesConflict of role + | ReplacedByConflict of role + | Restricts of role * impl * restriction list + | Feed_problem of string + + type t = { + role : role; + outcome : outcome; + notes : note list; + } + + val get : diagnostics -> t list +end