(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2012 Johannes 'josch' Schauer <j.schauer@email.de>      *)
(*  Copyright (C) 2012 Pietro Abate <pietro.abate@pps.jussieu.fr>         *)
(*                                                                        *)
(*  This library is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version.  A special linking    *)
(*  exception to the GNU Lesser General Public License applies to this    *)
(*  library, see the COPYING file for more information.                   *)
(**************************************************************************)

open! ExtLib
open Dose_common
open Dose_debian
open Dose_algo
open Dose_extra

#define __label __FILE__
let label =  __label ;;
include Util.Logging(struct let label = label end) ;;

module CudfSet = CudfAdd.Cudf_set

module Int = struct type t = int let compare = Stdlib.compare end
module IntSet = Set.Make(Int)
module StringSet = Set.Make(String)

module type Ot = sig
  val options :
    ?status:int ->
    ?version:string ->
    ?suppress_usage:bool ->
    ?suppress_help:bool ->
    ?prog:string ->
    ?formatter:OptParse.Formatter.t -> unit -> OptParse.OptParser.t
end

module MakeOptions(O : Ot) = struct
  open OptParse ;;

  let verbose = StdOpt.incr_option ()
  let quiet = StdOpt.store_true ()
  let options = O.options ~version:"unreleased" () ;;

  open OptParser ;;

  add options ~short_name:'v' ~long_name:"verbose" ~help:"print additional information" verbose;
  add options ~long_name:"quiet" ~help:"do no print any messages" quiet;
end

let string_of pp arg =
  ignore(pp Format.str_formatter arg);
  Format.flush_str_formatter ()

(* this function receives a cudf package but expects that this package is the
 * encoding of a Debian binary or source package
 * it will thus print the cudf package in a Debian specific manner *)
let pp_package ?(noversion=false) fmt pkg =
  let name = try
      (CudfAdd.decode (Cudf.lookup_package_property pkg "name"))
    with Not_found ->
      failwith (Printf.sprintf "cannot find Debian name for cudf package %s"
                  (CudfAdd.string_of_package pkg))
  in
  let version = try
      (CudfAdd.decode (Cudf.lookup_package_property pkg "number"))
    with Not_found ->
      failwith (Printf.sprintf "cannot find Debian version for cudf package %s"
                  (CudfAdd.string_of_package pkg))
  in
  match (CudfAdd.decode (Cudf.lookup_package_property pkg "type")) with
  | "bin" -> begin
      let arch = try
          (CudfAdd.decode (Cudf.lookup_package_property pkg "architecture"))
        with Not_found ->
          failwith (Printf.sprintf
                      "cannot find Debian architecture for cudf package %s"
                      (CudfAdd.string_of_package pkg))
      in
      if noversion then
        Format.fprintf fmt "%s:%s" name arch
      else
        Format.fprintf fmt "%s:%s (= %s)" name arch version
    end
  | "src" -> begin
      if noversion then
        Format.fprintf fmt "src:%s" name
      else
        Format.fprintf fmt "src:%s (= %s)" name version
    end
  | t -> failwith (Printf.sprintf "invalid type %s for cudf package %s" t
                     (CudfAdd.string_of_package pkg))

let string_of_package ?(noversion=false) = string_of (pp_package ~noversion)

let string_of_list string_of_item sep l =
  let buf = Buffer.create 1023 in
  let rec aux = function
    | [] -> assert false
    | [last] -> (* last item, no trailing sep *)
        Buffer.add_string buf (string_of_item last)
    | item :: tl -> (* at least one item in tl *)
        Buffer.add_string buf (string_of_item item);
        Buffer.add_string buf sep;
        aux tl in
  let _ =
    match l with
      | [] -> ()
      | [sole] -> Buffer.add_string buf (string_of_item sole)
      | _ -> aux l in
  Buffer.contents buf
;;

let string_of_pkglist = string_of_list (string_of_package ~noversion:false) ", ";;

(* check if a package is member of a package list *)
let pkg_list_mem l pkg =
  List.exists (fun p -> (CudfAdd.compare p pkg)=0) l
;;

let pkg_is_arch_all pkg =
  try (Cudf.lookup_package_property pkg "architecture") = "all"
  with Not_found -> false
;;

let pkg_is_not_arch_all pkg = not(pkg_is_arch_all pkg);;

let debversion_of_cudfpkg pkg =
  try
    CudfAdd.decode (Cudf.lookup_package_property pkg "number")
  with Not_found ->
    failwith (Printf.sprintf "cudf package %s does not have Debian version"
                (CudfAdd.string_of_package pkg))

let debtype_of_cudfpkg pkg =
  try
    match CudfAdd.decode (Cudf.lookup_package_property pkg "type") with
    | "bin" -> `BinPkg
    | "src" -> `SrcPkg
    | _ -> failwith "invalid type for debcudf"
  with Not_found ->
    failwith (Printf.sprintf "cudf package %s does not have Debian type"
                (CudfAdd.string_of_package pkg))

let debarchitecture_of_cudfpkg pkg =
  (* these functions are for pretty printing Debian binary and source packages
   * as well as for uniquely identifying and comparing them. For both purposes,
   * the Debian source package architectures are irrelevant *)
  if debtype_of_cudfpkg pkg <> `BinPkg then
    failwith "can only get debarchitecture of binary packages";
  try
    CudfAdd.decode (Cudf.lookup_package_property pkg "architecture")
  with Not_found ->
    failwith (Printf.sprintf "cudf package %s does not have Debian architecture"
                (CudfAdd.string_of_package pkg))

let debname_of_cudfpkg pkg =
  try
    CudfAdd.decode (Cudf.lookup_package_property pkg "name")
  with Not_found ->
    failwith (Printf.sprintf "cudf package %s does not have Debian name"
                (CudfAdd.string_of_package pkg))

let debessential_of_cudfpkg pkg =
  if debtype_of_cudfpkg pkg <> `BinPkg then
    failwith "can only get essential property of binary packages";
  let ess = try
      CudfAdd.decode (Cudf.lookup_package_property pkg "essential")
    with Not_found -> "false"
  in
  match ess with
  | "true" -> true
  | "false" -> false
  | _ -> failwith (Printf.sprintf "invalid value for property essential: %s" ess)

let debbintriplet_of_cudfpkg pkg =
  if debtype_of_cudfpkg pkg <> `BinPkg then
    failwith "can only get debbintriplet of binary packages";
  (debname_of_cudfpkg pkg, debarchitecture_of_cudfpkg pkg, debversion_of_cudfpkg pkg)

let debsrctuple_of_cudfpkg pkg =
  if debtype_of_cudfpkg pkg <> `SrcPkg then
    failwith "can only get debsrctuple of source packages";
  (debname_of_cudfpkg pkg, debversion_of_cudfpkg pkg)

let debcudf_compare a b =
  let name_a = debname_of_cudfpkg a in
  let name_b = debname_of_cudfpkg b in
  (* since cudf versions are assigned such that they allow total ordering in
   * the same way that the Debian version would, we can use them for faster
   * comparison instead of slow Debian version comparsion *)
  let cudfver_a = a.Cudf.version in
  let cudfver_b = b.Cudf.version in
  let type_a = debtype_of_cudfpkg a in
  let type_b = debtype_of_cudfpkg b in
  (* comparison between source and binary packages is sorted as in buildGraph *)
  match type_a, type_b with
  | `SrcPkg, `BinPkg -> -1
  | `BinPkg, `SrcPkg -> 1
  | `SrcPkg, `SrcPkg -> begin
      let name_cmp = Stdlib.compare name_a name_b in
      if name_cmp <> 0 then
        name_cmp
      else
        let ver_cmp = Stdlib.compare cudfver_a cudfver_b in
        if ver_cmp = 0 then fatal "duplicate source package";
        ver_cmp
    end
  | `BinPkg, `BinPkg -> begin
      let name_cmp = Stdlib.compare name_a name_b in
      if name_cmp <> 0 then
        name_cmp
      else begin
        let ver_cmp = Stdlib.compare cudfver_a cudfver_b in
        if ver_cmp <> 0 then
          ver_cmp
        else begin
          let arch_a = debarchitecture_of_cudfpkg a in
          let arch_b = debarchitecture_of_cudfpkg b in
          let arch_cmp = Stdlib.compare arch_a arch_b in
          if arch_cmp = 0 then fatal "duplicate binary package";
          arch_cmp
        end
      end
    end

(* sort a package list by their name/version/architecture *)
let debcudf_sort pkgs = List.sort ~cmp:debcudf_compare pkgs;;

(*
 * return each line of a textfile in a list
 * allow comments, empty lines and spaces in the textfile
 * *)
let read_linebased_file filename =
  let ic = open_in filename in
  (* remove everything after the # and strip whitespaces *)
  let process_line line = String.strip (
    try String.sub line 0 (String.index line '#')
    with Not_found -> line)
  in
  (* process each line and only keep the non-empty ones *)
  let result = List.filter
    (fun line -> String.length line > 0)
    (List.map process_line (Std.input_list ic))
  in
  close_in ic;
  result
;;

(* given one or more package lists, returns the unique union of them *)
let unique ll =
  CudfSet.elements (List.fold_left (fun acc l ->
    CudfSet.union acc (CudfAdd.to_set l)
  ) CudfSet.empty ll)
;;

let optimal_subset ?(global_constraints=[]) ?(available=(fun _ -> true)) pkg univ closure =
  let dummy = { Depsolver.dummy_request with
                Cudf.depends =
                  List.map (fun (_,pkglist) ->
                      List.map (fun uid ->
                          let pkg = CudfAdd.inttopkg univ uid in
                          (pkg.Cudf.package,Some(`Eq,pkg.Cudf.version))
                        ) pkglist
                    ) global_constraints }
  in
  let cudf_closure = List.filter_map (fun i ->
      let pkg = try
          CudfAdd.inttopkg univ i
        with Not_found -> fatal "Cannot find pkg for int %d" i
      in
      if List.mem ("type", `String "src") pkg.Cudf.pkg_extra then
        Some pkg
      else begin
        let notavail = if available pkg then `Int 0 else `Int 1 in
        Some { pkg with Cudf.pkg_extra = ("notavailable", notavail) :: pkg.Cudf.pkg_extra }
      end
    ) closure
  in
  (* create a cudf request with
   *  - all packages in the universe
   *  - the notavailable property in the preamble
   *  - the request to install the current package
   *  - to optimize first by minimum number of not-available packages in the
   *    solution and then by solution size *)
  let newuniverse = Cudf.load_universe cudf_closure in
  let preamble = Debcudf.preamble in
  let preamble = CudfAdd.add_properties preamble [("notavailable",(`Int (Some 0)))] in
  let install = (pkg.Cudf.package, Some (`Eq, pkg.Cudf.version)) in
  let request = { Cudf.default_request
                  with Cudf.request_id = "";
                       Cudf.install = [install] }
  in
  let criteria = "-sum(solution,notavailable),-count(solution)" in
  let cmd = "aspcud $in $out $pref" in
  try
    Depsolver.check_request ~dummy ~cmd ~criteria (preamble,newuniverse,request)
  with e ->
    warning "exception when handling %s" pkg.Cudf.package;
    raise e
;;

(* split the installation set in a list of list of packages.
 * Each list is associated to a dependendency of the give package.
 * *)
(*
 * in case more than one package in a disjunction is part of the installation
 * set, it is sufficient to just pick any one package in the disjunction
 * because in the end it is not important that the union of all those choices
 * makes the original installation set but that the union of all these choices
 * creates any valid installation set. This is fulfilled by picking a valid
 * installation set for any single package in a disjunction.
 *
 *
 *)
let partition_deps ?(partition_optimizer=(fun _ s -> s)) pool univ iss pkg =
  let to_set l = List.fold_right IntSet.add l IntSet.empty in
  let globalid = Cudf.universe_size univ in
  let l = List.map (fun vpkglist ->
    let l = CudfAdd.resolve_vpkgs_int univ vpkglist in
    let s = to_set l in
    let intrs = IntSet.inter iss s in
    if IntSet.cardinal intrs > 1 then
      debug "More then one package in the intersection";
    if not(IntSet.is_empty intrs) then begin
      let pid = IntSet.choose intrs in
      let dc = Depsolver_int.dependency_closure_cache pool [pid] in
      (* the closure contains the globalid which we do not want *)
      let dcs = IntSet.remove globalid (to_set dc) in
      (* calculate the intersection between the chosen installation set and the
       * dependency closure of pid *)
      (* but the result will include "pid". This is important because the
       * buildGraph will make connections to their source packages of all
       * binary packages in the IS but not from the binary package the IS
       * belongs to *)
      let dcs = IntSet.inter iss dcs in
      (* pass the installation set to the optimizer *)
      let dcs = partition_optimizer pid dcs in
      (pid,dcs)
    end else
      fatal "the intersection between a dependency disjunction and the installation set must not be empty";
  ) pkg.Cudf.depends in
  l
;;

let compute_dependency_sets_opt ?(global_constraints=[]) ?(partition=true) ?(available=(fun _ -> true)) opt_partition_cache pool univ srcpkg =
  let id = CudfAdd.pkgtoint univ srcpkg in
  let globalid = Cudf.universe_size univ in
  (* remove the global id from the dependency closure *)
  let closure = List.filter_map (function
      |i when i = globalid -> None
      |i -> Some i)
      (Depsolver_int.dependency_closure_cache pool [id])
  in
  (* given a package and an installation set, passes that set to a solver to
   * find a smaller set
   *
   * results are cached and retrieved from the cache if it has them
   * caching is useful because only a about a third of all installation sets is
   * unique. Thus, caching reduces runtime by about a factor of about three *)
  let partition_optimizer pid dcs =
    let cache_key = (pid, (IntSet.elements dcs)) in
    match Hashtbl.find_option opt_partition_cache cache_key with
    | Some is -> is
    | None -> begin
        let r = optimal_subset ~global_constraints ~available (CudfAdd.inttopkg univ pid) univ (IntSet.elements dcs) in
        let is = match r with
          |Depsolver.Error s -> fatal "%s" s;
          |Depsolver.Unsat _ -> fatal "this must not happen";
          |Depsolver.Sat (_,soluniv) ->
            Cudf.fold_packages (fun acc pkg ->
                IntSet.add (CudfAdd.pkgtoint univ pkg) acc
              ) IntSet.empty soluniv
        in
        Hashtbl.add opt_partition_cache cache_key is;
        is
      end
  in
  (* compute an optimal installation set for the given source package
   *
   * since there are no duplicate source packages, the results of this do not
   * have to be cached *)
  let r = optimal_subset ~global_constraints ~available srcpkg univ closure in
  begin match r with
    |Depsolver.Error s -> fatal "%s" s;
    |Depsolver.Unsat diagnosis -> begin
        if Util.Debug.is_enabled "BootstrapCommon" then begin match diagnosis with
          | None -> ()
          | Some diagnosis -> Diagnostic.fprintf ~explain:true ~failure:true Format.err_formatter diagnosis
        end;
        warning "source package %s cannot be compiled"
          (string_of_package srcpkg);
        IntSet.empty, []
      end
    |Depsolver.Sat (_,soluniv) -> begin
        (* remove source package from installation set *)
        let iss = Cudf.fold_packages (fun acc pkg ->
            IntSet.add (CudfAdd.pkgtoint univ pkg) acc
          ) IntSet.empty soluniv
        in
        if partition then
          iss, (partition_deps ~partition_optimizer pool univ iss srcpkg)
        else
          iss, []
      end
  end
;;

(* compute_dependency_sets using low level integer interface *)
let compute_dependency_sets ?(global_constraints=[]) ?(partition=true) custom_is_ht pool univ srcpkg =
  let id = CudfAdd.pkgtoint univ srcpkg in
  let closure = Depsolver_int.dependency_closure_cache pool [id] in
  let solver = Depsolver_int.init_solver_closure ~global_constraints pool closure in
  let req = [id] in
  let excludeset = Hashtbl.find_option custom_is_ht srcpkg.Cudf.package in
  let explain = true in
  let d = match excludeset with
    | Some es -> begin
        (* generate an installation set without one or more packages *)
        (* get ids to not include *)
        let excludelits = List.filter_map (fun pid ->
          if pid = id then None
          else begin
            let pkg = CudfAdd.inttopkg univ pid in
            if StringSet.mem pkg.Cudf.package es then
              Some (Depsolver_int.S.lit_of_var (solver.Depsolver_int.map#vartoint pid) false)
            else None
          end
        ) closure in
        match excludelits with
          | [] -> begin (* empty list. Solve normally *)
              warning "list of packages to exclude from the IS of %s is empty" (srcpkg.Cudf.package);
              Depsolver_int.solve ?tested:None ~explain solver req
            end
          | _ -> begin
              let solver = Depsolver_int.copy_solver solver in
              Depsolver_int.S.add_rule solver.Depsolver_int.constraints (Array.of_list excludelits) [];
              Depsolver_int.solve ?tested:None ~explain solver req
            end
      end
    | None -> (* generate an installation set normally *)
        Depsolver_int.solve ?tested:None ~explain solver req
  in
  match d with
  |Diagnostic.SuccessInt f_int -> begin
    let globalid = solver.Depsolver_int.map#vartoint (Cudf.universe_size univ) in
    let cudfis = List.filter_map (function
            |i when i = globalid -> None
            |i -> Some (solver.Depsolver_int.map#inttovar i))
        (f_int ())
    in
    let iss = List.fold_right IntSet.add cudfis IntSet.empty in
    if partition then
      iss, (partition_deps pool univ iss srcpkg)
    else
      iss, []
  end
  | _ -> begin
      if Util.Debug.is_enabled "BootstrapCommon" then begin
        (*let result = Depsolver.diagnosis solver.Depsolver_int.map univ d req in*)
        Diagnostic.fprintf ~explain:true ~failure:true Format.err_formatter { Diagnostic.result = Diagnostic.result solver.Depsolver_int.map univ d; request = Diagnostic.request univ req }
      end;
      (* source package could not be compiled. If the installation set was chosen
       * manually, fail. Otherwise just throw a warning. *)
      match excludeset with
        | Some es -> failwith (Printf.sprintf "source package %s is not compilable after excluding %s" (srcpkg.Cudf.package) (String.concat "," (StringSet.elements es)))
        | None ->
          warning "source package %s cannot be compiled"
            (string_of_package srcpkg);
    IntSet.empty, []
  end
;;

let get_custom_is_ht arch custom_is_files =
  let lines = List.fold_left (fun l f ->
    List.rev_append (read_linebased_file f) l
  ) [] custom_is_files in
  let custom_is_ht = Hashtbl.create (List.length lines) in
  List.iter (fun line ->
    match String.nsplit line " " with
      | hd::tl ->
          let bins = List.fold_left (fun acc d ->
            StringSet.add (CudfAdd.encode (d^":"^arch)) acc
          ) StringSet.empty tl in
          let oldbins = Hashtbl.find_default custom_is_ht (CudfAdd.encode hd) StringSet.empty in
          Hashtbl.replace custom_is_ht (CudfAdd.encode hd) (StringSet.union bins oldbins)
      | _ -> ();
  ) lines;
  custom_is_ht
;;

let get_reduced_deps_ht ?(weak_file="./droppable/weak-build-dependencies.list") remove_weak archs srcpkglist reduced_deps_files =
  let lines = List.fold_left (fun l f ->
    List.rev_append (read_linebased_file f) l
  ) [] reduced_deps_files in
  let reduced_deps_ht = Hashtbl.create (List.length lines) in
  List.iter (fun line ->
    match String.nsplit line " " with
      | hd::tl ->
          let deps = List.fold_left (fun acc d ->
            List.fold_left (fun a arch ->
              StringSet.add (CudfAdd.encode (d^":"^arch)) a
            ) acc archs
          ) StringSet.empty tl in
          let olddeps = Hashtbl.find_default reduced_deps_ht (CudfAdd.encode hd) StringSet.empty in
          Hashtbl.replace reduced_deps_ht (CudfAdd.encode hd) (StringSet.union deps olddeps)
      | _ -> ();
  ) lines;
  (* get the set of weak dependencies *)
  let weak_deps_set = if weak_file <> "" then begin
    List.fold_left (fun acc line ->
      List.fold_left (fun a arch ->
        StringSet.add (CudfAdd.encode (line^":"^arch)) a
      ) acc archs
    ) StringSet.empty (read_linebased_file weak_file)
  end else StringSet.empty in
  (* make the weak build dependencies a build profile of all source packages in
   * the graph *)
  if not (StringSet.is_empty weak_deps_set) && remove_weak then begin
    List.iter (fun pkg ->
      let value = Hashtbl.find_default reduced_deps_ht (pkg.Cudf.package) StringSet.empty in
      Hashtbl.replace reduced_deps_ht (pkg.Cudf.package) (StringSet.union value weak_deps_set)
    ) srcpkglist;
  end;
  reduced_deps_ht, weak_deps_set
;;

let get_src_package ?(allowmismatch=false) universe binpkg =
  try Sources.get_src_package universe binpkg
  with Sources.MismatchSrc sl -> begin (* names matches but version doesnt *)
    if allowmismatch then begin
      warning "binary package %s does not have an associated source package - falling back to highest version"
        (string_of_package binpkg);
      List.hd (List.sort ~cmp:(Cudf.(>%)) sl)
    end else
      raise Sources.NotfoundSrc
  end
;;

(* given a universe, return a hashtable mapping source packages to a list of
 * binary packages *)
let srcbin_table ?(available=CudfAdd.Cudf_set.empty) ?(allowmismatch=false) ?(ignoresrclessbin=false) universe =
  let h = CudfAdd.Cudf_hashtbl.create (Cudf.universe_size universe) in
  let aux binpkg =
    if CudfAdd.get_property "type" binpkg = "bin" then begin
      try
        let srcpkg = get_src_package ~allowmismatch universe binpkg in
        try let l = CudfAdd.Cudf_hashtbl.find h srcpkg in l := binpkg::!l
        with Not_found -> CudfAdd.Cudf_hashtbl.add h srcpkg (ref [binpkg])
      with Sources.NotfoundSrc ->
        (* No source was found for this binary. That's okay if this binary is
         * member of the available set *)
        if CudfAdd.Cudf_set.mem binpkg available then
          ()
        else
          (* it's also okay if the user requested to ignore source-less binaries *)
          if ignoresrclessbin then begin
            warning "binary package %s does not have an associated source package - ignoring"
              (string_of_package binpkg);
            ()
          end else
            failwith (Printf.sprintf "can't find source package for binary package %s"
                        (string_of_package binpkg))
    end
  in
  Cudf.iter_packages aux universe ;
  h
;;

let get_bin_packages h srcpkg =
  try !(CudfAdd.Cudf_hashtbl.find h srcpkg)
  with Not_found ->
    warning "Source package %s is not associated to any binary package"
      (string_of_package srcpkg);
    []
;;

let parse_packages ?(noindep=false) parse_cmdline build host foreign = function
  |[] | [_] -> fatal
    "You must provide a list of Debian Packages files and \
     a Debian Sources file"
  |l ->
      begin match List.rev l with
      |h::t ->
          let (fg,bg) = parse_cmdline (`Deb,false) [h] in
          let fgl = Sources.input_raw ~archs:[build] fg in
          let bgl = Sources.input_raw ~archs:[build] bg in
          let fgsrcl = Sources.sources2packages ~noindep build host fgl in
          let bgsrcl = Sources.sources2packages ~noindep build host bgl in
          let pkgl = Packages.input_raw ~archs:(build::host::foreign) t in
          (pkgl, (fgsrcl,bgsrcl), fgl)
      |_ -> assert false
      end
;;

let read_package_file ?(archs=[]) tocudf f =
  let l = Packages.input_raw ~archs [f] in
  List.fold_left (fun acc pkg ->
    let cudfpkg =
      try tocudf pkg
      with Not_found ->
        failwith (Printf.sprintf "cannot find cudf version for %s - do \
                  your foreground packages contain it?" (pkg#name));
    in
    CudfAdd.Cudf_set.add cudfpkg acc
  ) CudfAdd.Cudf_set.empty l
;;

let more_problems_callback printer universe results summary d =
  if summary then Diagnostic.collect results d ;
  match d with
  |{Diagnostic.result = Diagnostic.Failure (f) } -> begin
      let new_reasons = f () in
      List.iter (fun reason ->
          match reason with
          |Diagnostic.Conflict (i,j,vpkg) -> begin
              info "handling conflict between %s and %s because of %s"
                (string_of_package i) (string_of_package j)
                (Cudf_types_pp.string_of_vpkg vpkg);
              let filter k l = List.filter (fun (p,c) ->
                  let other = p=k.Cudf.package && Cudf.version_matches k.Cudf.version c in
                  let provides = List.exists (function
                      | n,None -> p=n
                      | n,Some (`Eq, version) ->
                        p=n && Cudf.version_matches version c
                    ) k.Cudf.provides
                  in
                  not other && not provides
                ) l.Cudf.conflicts in
              let new_i = { i with Cudf.conflicts = filter j i } in
              let new_j = { j with Cudf.conflicts = filter i j } in
              (* modify i to no longer contain the conflict vpkg *)
              let pkglist = Cudf.fold_packages (fun acc pkg ->
                  if Cudf.(=%) pkg i then      new_i::acc
                  else if Cudf.(=%) pkg j then new_j::acc
                  else pkg::acc
                ) [] !universe in
              universe := Cudf.load_universe pkglist;
            end
          |Diagnostic.Missing (i,vpkgs) -> begin
              info "handling missing dependency of %s on %s"
                (string_of_package i)
                (Cudf_types_pp.string_of_vpkglist vpkgs);
              let new_i = {
                i with
                Cudf.depends = List.filter ((<>) vpkgs) i.Cudf.depends
              } in
              (* modify i to no longer contain the conflict vpkg *)
              let pkglist = Cudf.fold_packages (fun acc pkg ->
                  if Cudf.(=%) pkg i then new_i::acc
                  else pkg::acc
                ) [] !universe in
              universe := Cudf.load_universe pkglist;
            end
          |Diagnostic.Dependency _ -> () (* we ignore dependency paths *)
        ) new_reasons;
      printer d
    end
  |{Diagnostic.result = Diagnostic.Success _} -> ()
;;

let parse_debian_pkgstring universe native_arch pkgstring =
  let add_name_arch n a = CudfAdd.encode (Printf.sprintf "%s:%s" n a) in
  let parse_vpkglist s =
    let _loc = Format822.dummy_loc in
    List.map (function
        |((n,a),Some("=",v)) -> (n,a,v)
        |(_,None) ->
          raise (Format822.ParseError ([],s,"you must specify a version" ))
        |_ -> raise (Format822.ParseError ([],s,""))
      ) (Dose_pef.Packages.parse_vpkglist ("pkgstring", (_loc,s)))
  in
  List.fold_left (fun acc (n,a,v) ->
      let cudfname = match a with
        | None -> failwith (Printf.sprintf "package %s (= %s) is without architecture" n v)
        | Some "all" -> add_name_arch n native_arch
        | Some a -> add_name_arch n a
      in
      (* we convert cudf versions to Debian versions and compare that
       * with the version we got and use this to filter the result
       * instead of just converting the cudf version to the Debian
       * version directly because to do that we'd need access
       * to the cudf table but we don't *)
      let pkgs = List.filter (fun p ->
          CudfAdd.string_of_version p = v
        ) (Cudf.lookup_packages universe cudfname) in
      let pkg = match pkgs with
        | [] -> failwith (Printf.sprintf "cannot find %s" cudfname)
        | [p] -> p
        | _ -> failwith (Printf.sprintf "more than one match for %s" cudfname)
      in
      IntSet.add (CudfAdd.pkgtoint universe pkg) acc
    ) IntSet.empty (parse_vpkglist pkgstring)
;;