···
+
(* Implementation of the PubGrub algorithm in OCaml *)
+
module type PACKAGE_ID = sig
+
val compare : t -> t -> int
+
val to_string : t -> string
+
module type VERSION = sig
+
val compare : t -> t -> int
+
val to_string : t -> string
+
module type VERSION_SET = sig
+
val singleton : version -> t
+
val union : t -> t -> t
+
val intersection : t -> t -> t
+
val complement : t -> t
+
val is_empty : t -> bool
+
val contains : version -> t -> bool
+
val subset_of : t -> t -> bool
+
val is_disjoint : t -> t -> bool
+
val to_string : t -> string
+
(* Terms and Constraints *)
+
| Positive of 'vs (* The package version must be in this set *)
+
| Negative of 'vs (* The package version must not be in this set *)
+
type ('v, 'vs) t = ('v, 'vs) term
+
let any (vs : 'vs) : ('v, 'vs) t = Positive vs
+
let empty (vs : 'vs) : ('v, 'vs) t = Negative vs
+
let exact (v : 'v) (mk_singleton : 'v -> 'vs) : ('v, 'vs) t =
+
Positive (mk_singleton v)
+
| Positive vs -> Negative vs
+
| Negative vs -> Positive vs
+
let contains (v : 'v) (vs_contains : 'v -> 'vs -> bool) term =
+
| Positive vs -> vs_contains v vs
+
| Negative vs -> not (vs_contains v vs)
+
let intersect_positive_positive vs_intersect vs1 vs2 =
+
Positive (vs_intersect vs1 vs2)
+
let intersect_negative_negative vs_intersect vs_complement vs1 vs2 =
+
Negative (vs_intersect (vs_complement vs1) (vs_complement vs2))
+
let intersect_positive_negative vs_intersect vs_complement vs1 vs2 =
+
let intersection = vs_intersect vs1 (vs_complement vs2) in
+
let intersect_negative_positive vs_intersect vs_complement vs1 vs2 =
+
let intersection = vs_intersect (vs_complement vs1) vs2 in
+
let intersection vs_intersect vs_complement t1 t2 =
+
| Positive vs1, Positive vs2 ->
+
intersect_positive_positive vs_intersect vs1 vs2
+
| Negative vs1, Negative vs2 ->
+
intersect_negative_negative vs_intersect vs_complement vs1 vs2
+
| Positive vs1, Negative vs2 ->
+
intersect_positive_negative vs_intersect vs_complement vs1 vs2
+
| Negative vs1, Positive vs2 ->
+
intersect_negative_positive vs_intersect vs_complement vs1 vs2
+
let union_positive_positive vs_union vs1 vs2 =
+
Positive (vs_union vs1 vs2)
+
let union_negative_negative vs_intersect vs1 vs2 =
+
Negative (vs_intersect vs1 vs2)
+
let union_positive_negative vs_intersect vs_complement vs_is_empty vs1 vs2 =
+
let diff = vs_intersect vs1 (vs_complement vs2) in
+
if vs_is_empty diff then Negative vs2 else Positive diff
+
let union_negative_positive vs_intersect vs_complement vs_is_empty vs1 vs2 =
+
let diff = vs_intersect (vs_complement vs1) vs2 in
+
if vs_is_empty diff then Negative vs1 else Positive diff
+
let union vs_union vs_intersect vs_complement vs_is_empty t1 t2 =
+
| Positive vs1, Positive vs2 ->
+
union_positive_positive vs_union vs1 vs2
+
| Negative vs1, Negative vs2 ->
+
union_negative_negative vs_intersect vs1 vs2
+
| Positive vs1, Negative vs2 ->
+
union_positive_negative vs_intersect vs_complement vs_is_empty vs1 vs2
+
| Negative vs1, Positive vs2 ->
+
union_negative_positive vs_intersect vs_complement vs_is_empty vs1 vs2
+
let is_positive = function
+
let to_string (_ : 'v -> string) (vs_to_str : 'vs -> string) term =
+
| Positive vs -> vs_to_str vs
+
| Negative vs -> "not " ^ vs_to_str vs
+
(* Incompatibilities *)
+
type ('p, 'v, 'vs, 'meta) incompatibility = {
+
terms : (('p * ('v, 'vs) term) list);
+
cause : ('p, 'v, 'vs, 'meta) incompatibility_cause;
+
and ('p, 'v, 'vs, 'meta) incompatibility_cause =
+
| NoVersions of 'p * 'vs
+
| Dependency of 'p * 'vs * 'p * 'vs
+
| External of 'p * 'vs * 'meta
+
module Incompatibility = struct
+
type ('p, 'v, 'vs, 'meta) t = ('p, 'v, 'vs, 'meta) incompatibility
+
let not_root pkg ver vs_singleton =
+
{ terms = [(pkg, Negative (vs_singleton ver))];
+
cause = Root (pkg, ver) }
+
let no_versions pkg term =
+
{ terms = [(pkg, term)];
+
cause = NoVersions (pkg, vs) }
+
failwith "Expected positive term"
+
let from_dependency pkg_from vs_from pkg_to vs_to =
+
{ terms = [(pkg_from, Positive vs_from); (pkg_to, Negative vs_to)];
+
cause = Dependency (pkg_from, vs_from, pkg_to, vs_to) }
+
let from_derivation incomp1 incomp2 =
+
{ terms = []; (* This will be populated during conflict resolution *)
+
cause = Derived (incomp1, incomp2) }
+
(* Partial Solutions *)
+
type ('p, 'v, 'vs) partial_solution = {
+
decisions : ('p * 'v) list;
+
assignments : ('p * ('v, 'vs) term * int * bool) list;
+
module PartialSolution = struct
+
type ('p, 'v, 'vs) t = ('p, 'v, 'vs) partial_solution
+
let current_decision_level solution = solution.decision_level
+
let add_decision solution package version vs_singleton =
+
let decision_level = solution.decision_level + 1 in
+
let new_assignment = (package, Positive (vs_singleton version), decision_level, true) in
+
decisions = (package, version) :: solution.decisions;
+
assignments = new_assignment :: solution.assignments;
+
let add_derivation solution package term cause_incompat decision_level =
+
let new_assignment = (package, term, decision_level, false) in
+
assignments = new_assignment :: solution.assignments;
+
let check_assignment p_compare pkg term (assign_pkg, assign_term, _, _) =
+
if p_compare assign_pkg pkg = 0 then
+
match assign_term, term with
+
| Positive _, Positive _ -> true
+
| Negative _, Negative _ -> true
+
let relation solution p_compare incompatibility =
+
let rec check_terms satisfied unsatisfied_term = function
+
if satisfied then `Satisfied else `AlmostSatisfied unsatisfied_term
+
| (pkg, term) :: rest ->
+
List.exists (fun a -> check_assignment p_compare pkg term a) solution.assignments in
+
check_terms satisfied unsatisfied_term rest
+
check_terms false (pkg, term) rest
+
check_terms true (List.hd incompatibility.terms) incompatibility.terms
+
let extract_solution solution =
+
solution.decisions |> List.rev
+
let backtrack solution level =
+
List.filter (fun (_, _, assignment_level, _) -> assignment_level <= level) solution.assignments in
+
List.filter (fun (_, _) -> level <= solution.decision_level) solution.decisions in
+
{ decision_level = level; assignments = new_assignments; decisions = new_decisions }
+
(* Dependency Provider *)
+
module type DEPENDENCY_PROVIDER = sig
+
val get_root_package : unit -> package_id
+
val get_root_version : unit -> version
+
val available_versions : package_id -> version list
+
val get_dependencies : package_id -> version -> ((package_id * version_set) list, error) result
+
val choose_version : package_id -> version_set -> version option
+
(* Solver Configuration *)
+
max_iterations : int option;
+
(* Main Solver Interface *)
+
module type SOLVER = sig
+
| DependencyProviderError of {
+
| MaxIterationsExceeded
+
type solution = (package_id * version) list
+
(module DEPENDENCY_PROVIDER with
+
type package_id = package_id and
+
type version = version and
+
type version_set = version_set and
+
type error = string) ->
+
(solution, error) result
+
val explain_error : error -> string
+
(* Functor Implementation *)
+
(VS : VERSION_SET with type version = V.t) = struct
+
type version_set = VS.t
+
| DependencyProviderError of {
+
| MaxIterationsExceeded
+
type solution = (package_id * version) list
+
(* Helper functions for the PubGrub algorithm *)
+
let add_incompatibility_from_dependencies package version deps =
+
List.map (fun (dep_pkg, dep_vs) ->
+
Incompatibility.from_dependency package (VS.singleton version) dep_pkg dep_vs
+
let check_max_iterations config iterations =
+
match config.max_iterations with
+
| Some max when iterations >= max -> Error MaxIterationsExceeded
+
let process_unit_propagation solution incompatibility =
+
match PartialSolution.relation solution P.compare incompatibility with
+
Error (`Conflict incompatibility)
+
| `AlmostSatisfied (pkg, term) ->
+
(* Add derived assignment *)
+
PartialSolution.add_derivation
+
solution pkg (Term.negate term) incompatibility solution.decision_level in
+
let unit_propagation solution incompatibilities package =
+
let relevant_incompats =
+
List.filter (fun incomp ->
+
List.exists (fun (pkg, _) -> P.compare pkg package = 0) incomp.terms
+
let rec process_incompats solution = function
+
match process_unit_propagation solution incomp with
+
| Ok new_solution -> process_incompats new_solution rest
+
process_incompats solution relevant_incompats
+
let propagate_all solution incompatibilities pending_packages =
+
let rec propagate solution = function
+
match unit_propagation solution incompatibilities pkg with
+
| Ok new_solution -> propagate new_solution rest
+
| Error (`Conflict incomp) ->
+
(* Simple conflict handling for now - just fails with explanation *)
+
Printf.sprintf "Conflict found for package %s" (P.to_string pkg) in
+
Error (Unsatisfiable { explanation })
+
propagate solution pending_packages
+
let get_packages_with_constraints solution =
+
List.fold_left (fun acc (package, _, _, _) ->
+
if List.exists (fun (p, _) -> P.compare p package = 0) solution.decisions then
+
) [] solution.assignments
+
|> List.sort_uniq P.compare
+
let get_package_constraints solution package =
+
List.fold_left (fun acc (pkg, term, _, _) ->
+
if P.compare pkg package = 0 then
+
) [] solution.assignments
+
let compute_effective_range constraints =
+
let process_constraint range term =
+
| Positive vs1, Positive vs2 ->
+
Positive (VS.intersection vs1 vs2)
+
| Negative vs1, Positive vs2 ->
+
let complement = VS.complement vs1 in
+
Positive (VS.intersection vs2 complement)
+
| Positive vs1, Negative vs2 ->
+
let complement = VS.complement vs2 in
+
Positive (VS.intersection vs1 complement)
+
| Negative vs1, Negative vs2 ->
+
Negative (VS.union vs1 vs2)
+
| [] -> Positive VS.any
+
List.fold_left process_constraint first rest
+
let extract_version_set = function
+
| Negative vs -> VS.complement vs
+
(* Main solver implementation *)
+
(module Provider : DEPENDENCY_PROVIDER with
+
type package_id = package_id and
+
type version = version and
+
type version_set = version_set and
+
let root_pkg = Provider.get_root_package () in
+
let root_version = Provider.get_root_version () in
+
let initial_solution = PartialSolution.empty in
+
let initial_incompats = [
+
Incompatibility.not_root root_pkg root_version VS.singleton
+
let rec solve_loop solution incompatibilities iterations =
+
match check_max_iterations config iterations with
+
(* Get all packages that need propagation *)
+
List.map (fun (package, _, _, _) -> package) solution.assignments in
+
(* Run unit propagation on all packages *)
+
match propagate_all solution incompatibilities pending_packages with
+
| Ok propagated_solution ->
+
(* Check if we're done *)
+
if List.length propagated_solution.decisions = 0 then
+
else if List.exists (fun (pkg, _) -> P.compare pkg root_pkg = 0) propagated_solution.decisions then
+
(* We have a solution *)
+
Ok (PartialSolution.extract_solution propagated_solution)
+
(* Decision making - pick next package to decide on *)
+
let packages_with_constraints =
+
get_packages_with_constraints propagated_solution in
+
match packages_with_constraints with
+
(* No more packages to decide on, we're done *)
+
Ok (PartialSolution.extract_solution propagated_solution)
+
(* Find constraints for this package *)
+
get_package_constraints propagated_solution next_pkg in
+
(* Compute effective range *)
+
compute_effective_range constraints in
+
let effective_vs = extract_version_set effective_range in
+
match Provider.choose_version next_pkg effective_vs with
+
(* No valid version - add incompatibility and backtrack *)
+
let incomp = Incompatibility.no_versions next_pkg effective_range in
+
solve_loop propagated_solution (incomp :: incompatibilities) (iterations + 1)
+
(* Get dependencies for this version *)
+
match Provider.get_dependencies next_pkg version with
+
Error (DependencyProviderError {
+
(* Add decision and dependencies as incompatibilities *)
+
PartialSolution.add_decision
+
propagated_solution next_pkg version VS.singleton in
+
add_incompatibility_from_dependencies next_pkg version deps in
+
(new_incompats @ incompatibilities)
+
match solve_loop initial_solution initial_incompats 0 with
+
(* Empty solution - just return the root package *)
+
Ok [(root_pkg, root_version)]
+
| Ok solution -> Ok solution
+
(* Format error messages *)
+
let explain_error = function
+
| Unsatisfiable { explanation } ->
+
"Dependency resolution failed: " ^ explanation
+
| DependencyProviderError { package; version; message } ->
+
Printf.sprintf "Error retrieving dependencies for %s %s: %s"
+
(P.to_string package) (V.to_string version) message
+
| MaxIterationsExceeded ->
+
"Dependency resolution exceeded maximum iterations"
anil.recoil.org