Source file `solver.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
module Make(Context : S.CONTEXT) = struct
  module Input = Model.Make(Context)

  let version = Input.version
  let package_name = Input.package_name
  let formula = Input.formula

  let requirements ~context pkgs =
    let role =
      match pkgs with
      | [pkg] -> Input.role context pkg
      | pkgs ->
        let impl = Input.virtual_impl ~context ~depends:pkgs () in
        Input.virtual_role [impl]
    in
    { Input.role; command = None }

  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.requirements   (* So we can run another solve *)

  let solve context pkgs =
    let req = requirements ~context pkgs in
    match Solver.do_solve ~closest_match:false req with
    | Some sels -> Ok sels
    | None -> Error req

  let pp_short f (impl : Input.impl) =
    Input.pp_impl f impl

  let rec partition f = function
    | [] -> [], []
    | x :: xs ->
      let ys, zs = partition f xs in
      match f x with
      | `Left y  -> (y :: ys), zs
      | `Right z -> ys, (z :: zs)

  let pp_rolemap ~verbose f reasons =
    let short, long =
      reasons
      |> Solver.Output.RoleMap.bindings
      |> partition (fun (_role, component) ->
          match Diagnostics.Component.selected_impl component with
          | Some impl when Diagnostics.Component.notes component = [] -> `Left impl
          | _ -> `Right component
        )
    in
    let pp_item f c = Fmt.pf f "- @[%a@]" (Diagnostics.Component.pp ~verbose) c in
    Fmt.pf f "Selected: @[<hov>%a@]@,%a" (Fmt.(list ~sep:sp) pp_short) short
      (Fmt.(list ~sep:cut) pp_item) long

  let diagnostics_rolemap req =
    Solver.do_solve req ~closest_match:true
    |> Option.get
    |> Diagnostics.of_result

  let diagnostics ?(verbose=false) req =
    diagnostics_rolemap req
    |> Fmt.str "Can't find all required versions.@\n@[<v0>%a@]" (pp_rolemap ~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))
end