Add a raw diagnostics API for conflicts post-processing

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
 

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

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