Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Improve the parsing of optional dependencies.

It has no impact on the semantics of optional dependencies yet (ie. we just care about the collection of packages in depopts, not the formula)
  • Loading branch information...
commit f8960176c43bef0b9c2c87610f58035475ee3038 1 parent 2585dd9
@samoht samoht authored
View
31 src/file_format.ml
@@ -309,32 +309,43 @@ let rec make_constraints t =
| Block g -> [Group (make_constraints g)]
(* parse a list of formulas *)
-let rec parse_formulas t =
+let rec parse_formulas opt t =
let open Types.Formula in
match t with
| [] -> Empty
| [String name] -> Atom (Types.N.of_string name, Empty)
| [Option(String name, g)] -> Atom (Types.N.of_string name, parse_constraints g)
- | [Group g] -> parse_formulas g
- | e1 :: Symbol "|" :: e2 -> Or (parse_formulas [e1], parse_formulas e2)
- | e1 :: e2 -> And (parse_formulas [e1], parse_formulas e2)
+ | [Group g] -> parse_formulas opt g
+ | e1 :: Symbol "|" :: e2 -> Or (parse_formulas opt [e1], parse_formulas opt e2)
+ | e1 :: Symbol "&" :: e2 -> And (parse_formulas opt [e1], parse_formulas opt e2)
+ | e1 :: e2 when opt -> Or (parse_formulas opt [e1], parse_formulas opt e2)
+ | e1 :: e2 -> And (parse_formulas opt [e1], parse_formulas opt e2)
-let rec make_formulas t =
+let rec make_formulas opt t =
let open Types.Formula in
match t with
| Empty -> []
| Atom (name, Empty) -> [String (Types.N.to_string name)]
| Atom (name, cs) -> [Option(String (Types.N.to_string name), make_constraints cs)]
- | Block f -> [Group (make_formulas f)]
- | And(e,f) -> make_formulas e @ make_formulas f
- | Or(e,f) -> make_formulas e @ [Symbol "|"] @ make_formulas f
+ | Block f -> [Group (make_formulas opt f)]
+ | And(e,f) when opt -> make_formulas opt e @ [Symbol "&"] @ make_formulas opt f
+ | And(e,f) -> make_formulas opt e @ make_formulas opt f
+ | Or(e,f) when opt -> make_formulas opt e @ make_formulas opt f
+ | Or(e,f) -> make_formulas opt e @ [Symbol "|"] @ make_formulas opt f
let parse_formula = function
- | List l -> parse_formulas l
+ | List l -> parse_formulas false l
| x -> bad_format "Expecting list, got %s" (kind x)
let make_formula f =
- List (make_formulas f)
+ List (make_formulas false f)
+
+let parse_opt_formula = function
+ | List l -> parse_formulas true l
+ | x -> bad_format "Expecting list, got %s" (kind x)
+
+let make_opt_formula f =
+ List (make_formulas true f)
let parse_relop = function
| "=" -> `Eq
View
10 src/file_format.mli
@@ -207,12 +207,18 @@ val assoc_sections: item list -> string -> (section -> 'a) -> 'a list
open Types
-(** Parse package formula *)
+(** Parse package formula where AND are implicit: [x y -> x & y] *)
val parse_formula : value -> Formula.t
-(** Build a formula *)
+(** Build a formula where AND are implicit. *)
val make_formula : Formula.t -> value
+(** Parse optional package formula where OR are implicit: [x y -> x | y] *)
+val parse_opt_formula : value -> Formula.t
+
+(** Build a formula where OR are implicit. *)
+val make_opt_formula : Formula.t -> value
+
(** Parse a simple constraint *)
val parse_constraint: value -> ocaml_constraint
View
6 src/opamFile.ml
@@ -618,7 +618,7 @@ module OPAM = struct
let encode = Formula.map (fun (n,c) -> N.of_string (Common.CudfAdd.encode (N.to_string n)), c)
let default_package t =
- let depopts = string_of_value (File_format.make_formula (encode t.depopts)) in
+ let depopts = string_of_value (File_format.make_opt_formula t.depopts) in
{ D.default_package with
D.name = N.to_string t.name ;
D.version = V.to_string t.version ;
@@ -647,7 +647,7 @@ module OPAM = struct
Variable (s_build, make_list make_command t.build);
Variable (s_remove, make_list make_command t.remove);
Variable (s_depends, make_formula t.depends);
- Variable (s_depopts, make_formula t.depopts);
+ Variable (s_depopts, make_opt_formula t.depopts);
Variable (s_conflicts, make_formula t.conflicts);
Variable (s_libraries, make_list (Section.to_string |> make_string) t.libraries);
Variable (s_syntax, make_list (Section.to_string |> make_string) t.syntax);
@@ -705,7 +705,7 @@ module OPAM = struct
let build = assoc_default [] s s_build parse_commands in
let remove = assoc_list s s_remove parse_commands in
let depends = assoc_default Formula.Empty s s_depends parse_formula in
- let depopts = assoc_default Formula.Empty s s_depopts parse_formula in
+ let depopts = assoc_default Formula.Empty s s_depopts parse_opt_formula in
let conflicts = assoc_default Formula.Empty s s_conflicts parse_formula in
let libraries = assoc_list s s_libraries (parse_list (parse_string |> Section.of_string)) in
let syntax = assoc_list s s_syntax (parse_list (parse_string |> Section.of_string)) in
View
72 src/solver.ml
@@ -96,22 +96,11 @@ type request = {
wish_upgrade: Formula.conjunction;
}
-let string_of_vpkg = function
- | ((n,_), None) -> n
- | ((n,_), Some (r,c)) -> Printf.sprintf "%s (%s %s)" n r c
-
-let string_of_list f l =
- Printf.sprintf "{%s}"
- (String.concat ", " (List.map f l))
-
-let string_of_vpkgs =
- string_of_list string_of_vpkg
-
let string_of_request r =
Printf.sprintf "install:%s remove:%s upgrade:%s"
- (string_of_vpkgs r.wish_install)
- (string_of_vpkgs r.wish_remove)
- (string_of_vpkgs r.wish_upgrade)
+ (Formula.string_of_conjunction r.wish_install)
+ (Formula.string_of_conjunction r.wish_remove)
+ (Formula.string_of_conjunction r.wish_upgrade)
type solution = {
to_remove: NV.t list; (* order : first element needs to be removed before the others *)
@@ -163,9 +152,9 @@ type 'a internal_request = {
let string_of_internal_request f r =
Printf.sprintf "install:%s remove:%s upgrade:%s"
- (string_of_list f r.i_wish_install)
- (string_of_list f r.i_wish_remove)
- (string_of_list f r.i_wish_upgrade)
+ (Utils.string_of_list f r.i_wish_install)
+ (Utils.string_of_list f r.i_wish_remove)
+ (Utils.string_of_list f r.i_wish_upgrade)
let request_map f r =
let f = List.map f in
@@ -185,7 +174,7 @@ let string_of_package p =
p.Debian.Packages.name p.Debian.Packages.version installed
let string_of_packages l =
- string_of_list string_of_package l
+ Utils.string_of_list string_of_package l
let string_of_cudf (p, c) =
let relop = function
@@ -204,7 +193,7 @@ let string_of_internal_request =
string_of_internal_request string_of_cudf
let string_of_cudfs l =
- string_of_list string_of_cudf l
+ Utils.string_of_list string_of_cudf l
(* Universe of packages *)
type universe = U of package list
@@ -219,10 +208,10 @@ let string_of_cudf_package p =
p.Cudf.version installed
let string_of_cudf_packages l =
- string_of_list string_of_cudf_package l
+ Utils.string_of_list string_of_cudf_package l
let string_of_answer l =
- string_of_list (string_of_internal_action string_of_cudf_package) l
+ Utils.string_of_list (string_of_internal_action string_of_cudf_package) l
let string_of_universe u =
string_of_cudf_packages (Cudf.get_packages u)
@@ -281,6 +270,21 @@ let string_of_reasons table reasons =
) chains;
Buffer.contents b
+let depopts pkg =
+ let opt = OpamFile.OPAM.s_depopts in
+ if List.mem_assoc opt pkg.Cudf.pkg_extra then
+ match List.assoc opt pkg.Cudf.pkg_extra with
+ | `String s ->
+ let value = Parser.value Lexer.token (Lexing.from_string s) in
+ Some (File_format.parse_formula value)
+ | _ -> assert false
+ else
+ None
+
+let encode ((n,a),c) = (Common.CudfAdd.encode n,a),c
+let lencode = List.map encode
+let llencode = List.map lencode
+
module O_pkg = struct
type t = Cudf.package
let to_string = string_of_cudf_package
@@ -384,17 +388,12 @@ module Graph = struct
file.ml when we create the debian package. It could make sense
to do it here. *)
let extended_dependencies table pkg =
- let opt = OpamFile.OPAM.s_depopts in
- if List.mem_assoc opt pkg.Cudf.pkg_extra then
- match List.assoc opt pkg.Cudf.pkg_extra with
- | `String s ->
- let value = Parser.value Lexer.token (Lexing.from_string s) in
- let deps = Formula.to_cnf (File_format.parse_formula value) in
- let deps = Debian.Debcudf.lltocudf table deps in
- { pkg with Cudf.depends = deps @ pkg.Cudf.depends }
- | _ -> assert false
- else
- pkg
+ match depopts pkg with
+ | Some deps ->
+ let cnf = Formula.to_cnf deps in
+ let deps = Debian.Debcudf.lltocudf table (llencode cnf) in
+ { pkg with Cudf.depends = deps @ pkg.Cudf.depends }
+ | None -> pkg
let filter_dependencies f_direction ?(depopts=false) (U l_pkg_pb) (P pkg_l) =
let pkg_map =
@@ -442,7 +441,7 @@ end = struct
include Common.CudfAdd.Cudf_set
let to_string s =
- string_of_list string_of_cudf_package (elements s)
+ Utils.string_of_list string_of_cudf_package (elements s)
let choose_one s =
match elements s with
@@ -463,9 +462,8 @@ end = struct
(* Return the state in which the system has to go *)
let resolve_final_state univ req =
- log "FINAL_STATE: universe=%s request=<%s>"
- (string_of_universe univ)
- (string_of_internal_request req);
+ log "RESOLVE(final-state): universe=%s" (string_of_universe univ);
+ log "RESOLVE(final-state): request=%s" (string_of_internal_request req);
let r = Algo.Depsolver.check_request (to_cudf_doc univ req) in
(* Diagnostic.fprintf ~explain:true ~failure:true ~success:true Format.err_formatter r;
Format.pp_print_flush Format.err_formatter (); *)
@@ -495,7 +493,7 @@ end = struct
| Diagnostic.Failure e -> Conflicts e
| Diagnostic.Success f ->
let final_state = f ~all:true () in
- log "FINAL_STATE: state=%s" (string_of_cudf_packages final_state);
+ log "RESOLVE(simple): final-state=%s" (string_of_cudf_packages final_state);
try
let diff = Common.CudfDiff.diff univ (Cudf.load_universe final_state) in
Success (actions_of_diff diff)
View
12 src/types.ml
@@ -980,6 +980,18 @@ module Formula = struct
type cnf = Debian.Format822.vpkgformula
+ let string_of_vpkg = function
+ | ((n,_), None) -> n
+ | ((n,_), Some (r,c)) -> Printf.sprintf "%s (%s %s)" n r c
+
+ let string_of_conjunction c =
+ Printf.sprintf "(%s)" (String.concat " & " (List.map string_of_vpkg c))
+
+ let string_of_cnf cnf =
+ let string_of_clause c =
+ Printf.sprintf "(%s)" (String.concat " | " (List.map string_of_vpkg c)) in
+ Printf.sprintf "(%s)" (String.concat " & " (List.map string_of_clause cnf))
+
type 'a formula =
| Empty
| Atom of 'a
View
9 src/types.mli
@@ -559,10 +559,19 @@ module Alias: ABSTRACT
module Formula: sig
+ (** AND formulas *)
type conjunction = Debian.Format822.vpkglist
+ (** Pretty print AND formulas *)
+ val string_of_conjunction: conjunction -> string
+
+ (** CNF formulas *)
type cnf = Debian.Format822.vpkgformula
+ (** Pretty print CNF formulas *)
+ val string_of_cnf: cnf -> string
+
+ (** General formulas *)
type 'a formula =
| Empty
| Atom of 'a
View
4 src/utils.ml
@@ -40,6 +40,10 @@ module StringMap = Map.Make(OString)
let (|>) f g x = g (f x)
+let string_of_list f l =
+ Printf.sprintf "{%s}"
+ (String.concat ", " (List.map f l))
+
let string_strip str =
let p = ref 0 in
let l = String.length str in
Please sign in to comment.
Something went wrong with that request. Please try again.