Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Handle more complex package formulaes in depends and depopts fields.

This is part of #200, where we want to express more complex (optional) dependencies between packages, for instance:

depopts: [ "async" {="108.00.02"} | ("lwt" {>="2.4.1"} "ssl") | "mirage-net" ]
  • Loading branch information...
commit 0c56aab52082f370a0f85d79b81e2b49f8b4cab5 1 parent b48561b
@samoht samoht authored
View
108 src/client.ml
@@ -435,15 +435,14 @@ let update_repo_index t =
) repo_s
) repo_index
-let base_packages = [ "base-unix"; "base-bigarray"; "base-threads" ]
+let base_packages = List.map N.of_string [ "base-unix"; "base-bigarray"; "base-threads" ]
let create_default_compiler_description t =
let ocaml_version = OCaml_V.of_string Globals.default_compiler_version in
- let mk name = ((name,None),None) in
let f =
OpamFile.Comp.create_preinstalled
ocaml_version
- (List.map mk (if !Globals.base_packages then base_packages else []))
+ (if !Globals.base_packages then base_packages else [])
[ ("CAML_LD_LIBRARY_PATH", "=",
"%{lib}%/stublibs"
^ ":" ^
@@ -613,22 +612,22 @@ let update_packages t ~show_packages repos =
(N.to_string name)
(V.to_string version);
has_error := true);
- let map_b b = List.map (List.map (fun s -> b, s)) in
+ let map_b b = Formula.fold_left (fun accu (n,_) -> (b, n) :: accu) [] in
let depends = map_b true (OpamFile.OPAM.depends opam) in
let depopts = map_b false (OpamFile.OPAM.depopts opam) in
- List.iter (List.iter (fun (mandatory, ((d,_),_)) ->
- match find_available_package_by_name t (N.of_string d) with
+ List.iter (fun (mandatory, d) ->
+ match find_available_package_by_name t d with
| None ->
if mandatory then
Globals.warning
"Package %s depends on the unknown package %s"
- (NV.to_string nv) d
+ (NV.to_string nv) (N.to_string d)
else
Globals.warning
"Package %s depends optionally on the unknown package %s"
- (NV.to_string nv) d
+ (NV.to_string nv) (N.to_string d)
| Some _ -> ()
- )) (depends @ depopts)
+ ) (depends @ depopts)
) (get_available_current t);
if !has_error then
Globals.exit 1
@@ -1074,15 +1073,12 @@ let proceed_toinstall t nv =
in depends (XXX there is surely a way to get it from the solver) *)
let local_sections = OpamFile.Dot_config.Section.available config in
let libraries_in_opam =
- List.fold_left (fun accu l ->
- List.fold_left (fun accu ((n,_),_) ->
- let n = N.of_string n in
- let nv = find_installed_package_by_name t n in
- let opam = OpamFile.OPAM.read (Path.G.opam t.global nv) in
- let libs = OpamFile.OPAM.libraries opam in
- let syntax = OpamFile.OPAM.syntax opam in
- List.fold_right Section.Set.add (libs @ syntax) accu
- ) accu l
+ Formula.fold_left (fun accu (n,_) ->
+ let nv = find_installed_package_by_name t n in
+ let opam = OpamFile.OPAM.read (Path.G.opam t.global nv) in
+ let libs = OpamFile.OPAM.libraries opam in
+ let syntax = OpamFile.OPAM.syntax opam in
+ List.fold_right Section.Set.add (libs @ syntax) accu
) Section.Set.empty (OpamFile.OPAM.depends opam) in
let libraries_in_config =
List.fold_left (fun accu s ->
@@ -1568,32 +1564,27 @@ module Heuristic = struct
let pkg_available, pkg_not =
List.partition
- (function (name, _), _ ->
- N.Map.mem (N.of_string name) available)
- (OpamFile.Comp.packages comp) in
-
- let () = (* check that all packages in [comp] are in [available]
- except for "base-..."
- (depending if "-no-base-packages" is set or not) *)
- match
- let pkg_not = List.rev_map (function (n, _), _ -> n) pkg_not in
- if !Globals.base_packages then
- pkg_not
- else
- List.filter (fun n -> not (List.mem n base_packages)) pkg_not
- with
- | [] -> ()
- | l ->
- let () = List.iter (Globals.error "Package %s not found") l in
- Globals.exit 66 in
-
- List.rev_map
- (function
- | (name, _), None ->
- let name = N.of_string name in
- f_h None (N.Map.find name available) name
- | n, v -> n, v)
- pkg_available
+ (fun (n, _) -> N.Map.mem n available)
+ (Formula.atoms (OpamFile.Comp.packages comp)) in
+
+ (* check that all packages in [comp] are in [available]
+ except for "base-..."
+ (depending if "-no-base-packages" is set or not) *)
+ let pkg_not = List.rev_map (function (n, _) -> n) pkg_not in
+ let pkg_not =
+ if !Globals.base_packages then
+ pkg_not
+ else
+ List.filter (fun n -> not (List.mem n base_packages)) pkg_not in
+ if pkg_not <> [] then (
+ List.iter (N.to_string |> Globals.error "Package %s not found") pkg_not;
+ Globals.exit 2
+ );
+
+ List.rev_map (function
+ | n, None -> f_h None (N.Map.find n available) n
+ | n, Some (r,v) -> (N.to_string n, None), Some (r, V.to_string v)
+ ) pkg_available
(* Take a list of version constraints and an heuristic, and return a list of
packages constraints satisfying the constraints *)
@@ -2000,16 +1991,16 @@ let install names =
List.iter
(fun nv ->
let opam = OpamFile.OPAM.read (Path.G.opam t.global nv) in
- let f_warn =
- List.iter
- (fun ((n, _), _) ->
- if not (N.Map.mem (N.of_string n) available) then
- Globals.warning "unknown package %S" n) in
- List.iter (List.iter f_warn)
- [ OpamFile.OPAM.depends opam
- ; OpamFile.OPAM.depopts opam ];
- f_warn (OpamFile.OPAM.conflicts opam))
- pkg_new;
+ let f_warn (n, _) =
+ if not (N.Map.mem n available) then
+ Globals.warning "unknown package %S" (N.to_string n)
+ in
+ List.iter (Formula.iter f_warn) [
+ OpamFile.OPAM.depends opam;
+ OpamFile.OPAM.depopts opam;
+ OpamFile.OPAM.conflicts opam;
+ ]
+ ) pkg_new;
let name_new = List.map NV.name pkg_new in
List.iter (fun n -> log "new: %s" (N.to_string n)) name_new;
@@ -2314,9 +2305,12 @@ let config request =
| Some oversion ->
let comp = OpamFile.Comp.read (Path.G.compiler t.global oversion) in
let names =
- List.filter
- (fun n -> NV.Set.exists (fun nv -> NV.name nv = n) t.installed)
- (List.map (function (n, _), _ -> N.of_string n) (OpamFile.Comp.packages comp))
+ Utils.filter_map
+ (fun (n,_) ->
+ if NV.Set.exists (fun nv -> NV.name nv = n) t.installed
+ then Some n
+ else None)
+ (Formula.atoms (OpamFile.Comp.packages comp))
@ List.map Full_section.package c.options in
(* Compute the transitive closure of package dependencies *)
let package_deps =
View
117 src/file_format.ml
@@ -288,76 +288,53 @@ let assoc_list items n parse =
let assoc_string_list s n =
assoc_list s n (parse_list parse_string)
-(* transform: "foo" (< "1", > "2") => "foo" (< "1"), "foo" (>"2") *)
-let rec parse_constraints name = function
- | [] -> []
- | (Symbol r) :: (String v) :: [] ->
- [ ((name,None), Some (r, v)) ]
- | (Symbol r) :: (String v) :: (Symbol ",") :: t ->
- ((name,None), Some (r, v)) :: parse_constraints name t
- | x -> bad_format "Expecting a constraint, got %s" (kinds x)
-
-(* contains only "," *)
-let rec parse_and_formula_aux = function
- | [] -> []
- | [String name] -> [ ((name,None), None) ]
- | [Option(String name, g)] -> parse_constraints name g
- | [Group g] -> parse_and_formula_aux g
- | [ x ] -> bad_format "Expecting string or group, got %s" (kind x)
- | e1 :: e2 -> parse_and_formula_aux [e1] @ parse_and_formula_aux e2
-
-let parse_and_formula = function
- | List l -> parse_and_formula_aux l
+(* Parse any constraint list *)
+let rec parse_constraints t =
+ let open Types.Formula in
+ match t with
+ | [] -> Empty
+ | (Symbol r) :: (String v) :: [] -> Atom (r, Types.V.of_string v)
+ | (Symbol r) :: (String v) :: (Symbol "&") :: t -> And (Atom (r, Types.V.of_string v), parse_constraints t)
+ | (Symbol r) :: (String v) :: (Symbol "|") :: t -> Or (Atom (r, Types.V.of_string v), parse_constraints t)
+ | [Group g] -> Block (parse_constraints g)
+ | x -> bad_format "Expecting a list of constraints, got %s" (kinds x)
+
+let rec make_constraints t =
+ let open Types.Formula in
+ match t with
+ | Empty -> []
+ | Atom (r, v) -> [Symbol r; String (Types.V.to_string v)]
+ | And (x, y) -> make_constraints x @ [Symbol "&"] @ make_constraints y
+ | Or (x, y) -> make_constraints x @ [Symbol "|"] @ make_constraints y
+ | Block g -> [Group (make_constraints g)]
+
+(* parse a list of formulas *)
+let rec parse_formulas 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)
+
+let rec make_formulas 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
+
+let parse_formula = function
+ | List l -> parse_formulas l
| x -> bad_format "Expecting list, got %s" (kind x)
-(* contains only "|" *)
-let rec parse_or_formula_aux = function
- | [] -> []
- | [String name] -> [ ((name,None), None) ]
- | [Option(String name, g)] -> parse_constraints name g
- | [Group g] -> parse_or_formula_aux g
- | [ x ] -> bad_format "Expecting string or group, got %s" (kind x)
- | e1 :: Symbol "|" :: e2 -> parse_or_formula_aux [e1] @ parse_or_formula_aux e2
- | _ -> bad_format "Expecting a 'or' formula"
-
-let parse_or_formula = function
- | List l -> parse_or_formula_aux l
- | x -> bad_format "Expecting list, got %s" (kind x)
-
-let rec parse_cnf_formula_aux = function
- | [] -> []
- | e1 :: e2 -> parse_or_formula_aux [e1] :: parse_cnf_formula_aux e2
-
-let parse_cnf_formula = function
- | List l -> parse_cnf_formula_aux l
- | x -> bad_format "Expecting list, got %s" (kind x)
-
-let make_constraint = function
- | (name,_), None -> String name
- | (name,_), Some (r,v) -> Option (String name, [Symbol r; String v])
-
-let make_and_formula_aux l =
- List.map make_constraint l
-
-let make_and_formula l =
- List (make_and_formula_aux l)
-
-let make_cnf_formula l =
- let cnf =
- List.fold_left (fun cnf l ->
- let orl = List.map make_constraint l in
- let orl =
- List.fold_left (fun orl elt ->
- match orl with
- | [] -> [elt]
- | _ -> elt :: Symbol "|" :: orl
- ) [] orl in
- match orl with
- | [] -> cnf
- | [c] -> c :: cnf
- | _ -> (Group (List.rev orl)) :: cnf
- ) [] l in
- List (List.rev cnf)
+let make_formula f =
+ List (make_formulas f)
let parse_relop = function
| "=" -> `Eq
@@ -373,6 +350,10 @@ let parse_constraint = function
with _ -> bad_format "Expecting a relop, got %s" r)
| x -> bad_format "Expecting a constraint, got %s" (kind x)
+let make_constraint = function
+ | (name,_), None -> String name
+ | (name,_), Some (r,v) -> Option (String name, [Symbol r; String v])
+
let string_of_relop = function
| `Eq -> "="
| `Geq -> ">="
View
16 src/file_format.mli
@@ -207,19 +207,11 @@ val assoc_sections: item list -> string -> (section -> 'a) -> 'a list
open Types
-(** Parse an AND formala such as
- ["foo", "bar" (<"1", >"2"), "aa" ] *)
-val parse_and_formula : value -> and_formula
+(** Parse package formula *)
+val parse_formula : value -> Formula.t
-(** Parse an CNF formula (which contains only inlevel OR) such as
- ["foo" ("bar"(<"1") | "bar" (>"2"))] *)
-val parse_cnf_formula : value -> cnf_formula
-
-(** Build an AND formula *)
-val make_and_formula : and_formula -> value
-
-(** Build a CNF formula *)
-val make_cnf_formula : cnf_formula -> value
+(** Build a formula *)
+val make_formula : Formula.t -> value
(** Parse a simple constraint *)
val parse_constraint: value -> ocaml_constraint
View
48 src/opamFile.ml
@@ -499,9 +499,9 @@ module OPAM = struct
build_env : (string * string * string) list;
build : command list;
remove : command list;
- depends : cnf_formula;
- depopts : cnf_formula;
- conflicts : and_formula;
+ depends : Formula.t;
+ depopts : Formula.t;
+ conflicts : Formula.t;
libraries : section list;
syntax : section list;
patches : (basename * filter option) list;
@@ -518,9 +518,9 @@ module OPAM = struct
build_env = [];
build = [];
remove = [];
- depends = [];
- depopts = [];
- conflicts = [];
+ depends = Formula.Empty;
+ depopts = Formula.Empty;
+ conflicts = Formula.Empty;
libraries = [];
syntax = [];
files = [];
@@ -615,17 +615,15 @@ module OPAM = struct
(* XXX: Pre-encode the depends and conflict fields to avoid
headaches when interfacing with the solver *)
- let lencode = List.map (fun ((n,a),c) -> (Common.CudfAdd.encode n,a), c)
- let llencode = List.map lencode
+ 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_cnf_formula (llencode t.depopts)) in
+ let depopts = string_of_value (File_format.make_formula (encode t.depopts)) in
{ D.default_package with
D.name = N.to_string t.name ;
D.version = V.to_string t.version ;
- D.depends = llencode t.depends ;
- D.conflicts = lencode t.conflicts ;
+ D.depends = Formula.to_cnf (encode t.depends);
+ D.conflicts = Formula.to_conjunction (encode t.conflicts);
D.extras = (s_depopts, depopts) :: D.default_package.D.extras }
let to_package t ~installed =
@@ -648,9 +646,9 @@ module OPAM = struct
Variable (s_build_env, make_list make_env_variable t.build_env);
Variable (s_build, make_list make_command t.build);
Variable (s_remove, make_list make_command t.remove);
- Variable (s_depends, make_cnf_formula t.depends);
- Variable (s_depopts, make_cnf_formula t.depopts);
- Variable (s_conflicts, make_and_formula t.conflicts);
+ Variable (s_depends, make_formula t.depends);
+ Variable (s_depopts, make_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);
Variable (s_files, make_list make_file t.files);
@@ -706,9 +704,9 @@ module OPAM = struct
let build_env = assoc_list s s_build_env (parse_list parse_env_variable) in
let build = assoc_default [] s s_build parse_commands in
let remove = assoc_list s s_remove parse_commands in
- let depends = assoc_list s s_depends parse_cnf_formula in
- let depopts = assoc_list s s_depopts parse_cnf_formula in
- let conflicts = assoc_list s s_conflicts parse_and_formula 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 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
let ocaml_version = assoc_option s s_ocaml_version parse_constraint in
@@ -1052,7 +1050,7 @@ module Comp = struct
asmcomp : string list ;
bytelink : string list ;
asmlink : string list ;
- packages : and_formula ;
+ packages : Formula.t ;
requires : section list;
pp : ppflag option;
env : (string * string * string) list;
@@ -1071,13 +1069,19 @@ module Comp = struct
asmcomp = [];
bytelink = [];
asmlink = [];
- packages = [];
+ packages = Formula.Empty;
requires = [];
pp = None;
env = [];
}
let create_preinstalled name packages env =
+ let open Formula in
+ let mk n = Atom (n, Empty) in
+ let rec aux accu t = match accu, t with
+ | Empty, x -> mk x
+ | _ , x -> And(accu, mk x) in
+ let packages = List.fold_left aux Formula.Empty packages in
{ empty with name; preinstalled = true; packages; env }
let s_name = "name"
@@ -1156,7 +1160,7 @@ module Comp = struct
let asmcomp = assoc_string_list s s_asmcomp in
let bytelink = assoc_string_list s s_bytecomp in
let asmlink = assoc_string_list s s_asmlink in
- let packages = assoc_list s s_packages parse_and_formula in
+ let packages = assoc_default Formula.Empty s s_packages parse_formula in
let requires =
assoc_list s s_requires (parse_list (parse_string |> Section.of_string)) in
let pp = assoc_default None s s_pp parse_ppflags in
@@ -1198,7 +1202,7 @@ module Comp = struct
Variable (s_asmcomp , make_list make_string s.asmcomp);
Variable (s_bytelink , make_list make_string s.bytelink);
Variable (s_asmlink , make_list make_string s.asmlink);
- Variable (s_packages , make_and_formula s.packages);
+ Variable (s_packages , make_formula s.packages);
Variable (s_requires , make_list (Section.to_string |> make_string) s.requires);
Variable (s_env , make_list make_env_variable s.env);
] @ match s.pp with
View
14 src/opamFile.mli
@@ -108,13 +108,13 @@ module OPAM: sig
val remove: t -> command list
(** Package dependencies *)
- val depends: t -> cnf_formula
+ val depends: t -> Formula.t
(** Optional dependencies *)
- val depopts: t -> cnf_formula
+ val depopts: t -> Formula.t
(** Package conflicts *)
- val conflicts: t -> and_formula
+ val conflicts: t -> Formula.t
(** List of exported libraries *)
val libraries: t -> section list
@@ -135,10 +135,10 @@ module OPAM: sig
val patches: t -> (basename * filter option) list
(** Construct as [depends] *)
- val with_depends : t -> cnf_formula -> t
+ val with_depends : t -> Formula.t -> t
(** Construct as [depopts] *)
- val with_depopts : t -> cnf_formula -> t
+ val with_depopts : t -> Formula.t -> t
(** Construct as [build] *)
val with_build: t -> command list -> t
@@ -196,7 +196,7 @@ module Comp: sig
(** Create a pre-installed compiler description file *)
val create_preinstalled:
- OCaml_V.t -> and_formula -> (string * string * string) list -> t
+ OCaml_V.t -> name list -> (string * string * string) list -> t
(** Is it a pre-installed compiler description file *)
val preinstalled: t -> bool
@@ -221,7 +221,7 @@ module Comp: sig
val build: t -> string list list
(** Packages to install immediately after the creation of OCaml *)
- val packages: t -> and_formula
+ val packages: t -> Formula.t
(** Linking options to give to the native code compiler *)
val asmlink: t -> string list
View
8 src/scripts/opam_mk_repo.ml
@@ -83,11 +83,9 @@ let () =
let opam = OpamFile.OPAM.read opam_f in
let deps = OpamFile.OPAM.depends opam in
let depopts = OpamFile.OPAM.depopts opam in
- List.fold_left (fun accu l ->
- List.fold_left (fun accu ((n,_),_) ->
- N.Set.add (N.of_string n) accu
- ) accu l
- ) N.Set.empty (deps @ depopts)
+ Formula.fold_left (fun accu (n,_) ->
+ N.Set.add n accu
+ ) N.Set.empty (Formula.And (deps, depopts))
) else
N.Set.empty in
V.Set.fold (fun v set ->
View
19 src/solver.ml
@@ -91,13 +91,14 @@ module PA_graph = struct
end
type request = {
- wish_install: and_formula;
- wish_remove : and_formula;
- wish_upgrade: and_formula;
+ wish_install: Formula.conjunction;
+ wish_remove : Formula.conjunction;
+ wish_upgrade: Formula.conjunction;
}
-let string_of_vpkg =
- string_of_atom_formula
+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}"
@@ -199,6 +200,9 @@ let string_of_cudf (p, c) =
| Some (r,v) -> Printf.sprintf " (%s %d)" (relop r) v in
Printf.sprintf "%s%s" p (const c)
+let string_of_internal_request =
+ string_of_internal_request string_of_cudf
+
let string_of_cudfs l =
string_of_list string_of_cudf l
@@ -384,8 +388,9 @@ module Graph = struct
if List.mem_assoc opt pkg.Cudf.pkg_extra then
match List.assoc opt pkg.Cudf.pkg_extra with
| `String s ->
- let deps = File_format.parse_cnf_formula
+ let deps = File_format.parse_formula
(Parser.value Lexer.token (Lexing.from_string s)) in
+ let deps = Formula.to_cnf deps in
let deps = Debian.Debcudf.lltocudf table deps in
{ pkg with Cudf.depends = deps @ pkg.Cudf.depends }
| _ -> assert false
@@ -461,7 +466,7 @@ end = struct
let resolve_final_state univ req =
log "FINAL_STATE: universe=%s request=<%s>"
(string_of_universe univ)
- (string_of_internal_request string_of_cudf req);
+ (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 (); *)
View
6 src/solver.mli
@@ -54,9 +54,9 @@ end
(** Solver request *)
type request = {
- wish_install: and_formula;
- wish_remove : and_formula;
- wish_upgrade: and_formula;
+ wish_install: Formula.conjunction;
+ wish_remove : Formula.conjunction;
+ wish_upgrade: Formula.conjunction;
}
(** Convert a request to a string *)
View
116 src/types.ml
@@ -634,6 +634,8 @@ end = struct
end
+type ocaml_constraint = relop * OCaml_V.t
+
module Alias: ABSTRACT = Base
(* OPAM version *)
@@ -972,14 +974,114 @@ let string_of_config = function
Printf.sprintf "include(%b,%s)"
b (String.concat "," (List.map N.to_string l))
-type atom_formula = Debian.Format822.vpkg
-type and_formula = atom_formula list
-type cnf_formula = Debian.Format822.vpkgformula
-type ocaml_constraint = relop * OCaml_V.t
+module Formula = struct
+
+ type conjunction = Debian.Format822.vpkglist
+
+ type cnf = Debian.Format822.vpkgformula
+
+ type 'a formula =
+ | Empty
+ | Atom of 'a
+ | Block of 'a formula
+ | And of 'a formula * 'a formula
+ | Or of 'a formula * 'a formula
-let string_of_atom_formula = function
- | ((n,_), None) -> n
- | ((n,_), Some (r,c)) -> Printf.sprintf "%s (%s %s)" n r c
+ let string_of_formula string_of_a f =
+ let rec aux = function
+ | Empty -> ""
+ | Atom a -> string_of_a a
+ | Block x -> Printf.sprintf "(%s)" (aux x)
+ | And(x,y) -> Printf.sprintf "%s & %s" (aux x) (aux y)
+ | Or(x,y) -> Printf.sprintf "%s | %s" (aux x) (aux y) in
+ aux f
+
+ let rec map f = function
+ | Empty -> Empty
+ | Atom x -> Atom (f x)
+ | Block x -> Block (map f x)
+ | And(x,y) -> And (map f x, map f y)
+ | Or(x,y) -> Or (map f x, map f y)
+
+ let rec iter f = function
+ | Empty -> ()
+ | Atom x -> f x
+ | Block x -> iter f x
+ | And(x,y) -> iter f x; iter f y
+ | Or(x,y) -> iter f x; iter f y
+
+ let rec fold_left f i = function
+ | Empty -> i
+ | Atom x -> f i x
+ | Block x -> fold_left f i x
+ | And(x,y) -> fold_left f (fold_left f i x) y
+ | Or(x,y) -> fold_left f (fold_left f i x) y
+
+ type t = (name * (string * version) formula) formula
+
+ let to_string t =
+ let string_of_constraint (relop, version) =
+ Printf.sprintf "%s %s" relop (V.to_string version) in
+ let string_of_pkg = function
+ | n, Empty -> N.to_string n
+ | n, c -> Printf.sprintf "%s %s" (N.to_string n) (string_of_formula string_of_constraint c) in
+ string_of_formula string_of_pkg t
+
+ (* unroll to a CNF formula *)
+ let rec unroll f t =
+ let rec mk_left x y = match y with
+ | Block y -> mk_left x y
+ | And (a,b) -> And (mk_left x a, mk_left x b)
+ | _ -> Or (x,y) in
+ let rec mk_right x y = match x with
+ | Block x -> mk_right x y
+ | And (a,b) -> And (mk_right a y, mk_right b y)
+ | _ -> mk_left x y in
+ let rec mk = function
+ | Empty -> Empty
+ | Block x -> mk x
+ | Atom x -> f x
+ | And (x,y) -> And (mk x, mk y)
+ | Or (x,y) -> mk_right (mk x) (mk y) in
+ mk t
+
+ let unroll t =
+ let atom (r,v) = Atom (r, v) in
+ let vpkg (x, c) =
+ match unroll atom c with
+ | Empty -> Atom (x, None)
+ | cs -> map (fun c -> x, Some c) cs in
+ unroll vpkg t
+
+ let atoms t =
+ fold_left (fun accu x -> x::accu) [] (unroll t)
+
+ (* Convert to dose-CNF *)
+ let to_cnf t =
+ let rec or_formula = function
+ | Atom (x,None) -> [(N.to_string x, None), None]
+ | Atom (x,Some(r,v)) -> [(N.to_string x, None), Some(r, V.to_string v)]
+ | Or(x,y) -> or_formula x @ or_formula y
+ | Empty
+ | Block _
+ | And _ -> assert false in
+ let rec aux t = match t with
+ | Empty -> []
+ | Block x -> assert false
+ | Atom _
+ | Or _ -> [or_formula t]
+ | And(x,y) -> aux x @ aux y in
+ aux (unroll t)
+
+ let to_conjunction t =
+ let rec aux = function
+ | [] -> []
+ | [x]::t -> x::aux t
+ | _ ->
+ Globals.error_and_exit "%s is not a valid conjunction" (to_string t) in
+ aux (to_cnf t)
+
+end
module Remote_file: sig
include ABSTRACT
View
42 src/types.mli
@@ -364,6 +364,8 @@ module OCaml_V: sig
val compare: t -> relop -> t -> bool
end
+type ocaml_constraint = relop * OCaml_V.t
+
(** OPAM version *)
module OPAM_V: ABSTRACT
@@ -555,14 +557,42 @@ val string_of_config: config -> string
(** Compiler aliases *)
module Alias: ABSTRACT
-type atom_formula = Debian.Format822.vpkg
-type and_formula = atom_formula list
+module Formula: sig
-(** Pretty-print *)
-val string_of_atom_formula : atom_formula -> string
+ type conjunction = Debian.Format822.vpkglist
-type cnf_formula = Debian.Format822.vpkgformula
-type ocaml_constraint = relop * OCaml_V.t
+ type cnf = Debian.Format822.vpkgformula
+
+ type 'a formula =
+ | Empty
+ | Atom of 'a
+ | Block of 'a formula
+ | And of 'a formula * 'a formula
+ | Or of 'a formula * 'a formula
+
+ val string_of_formula: ('a -> string) -> 'a formula -> string
+
+ val map: ('a -> 'b) -> 'a formula -> 'b formula
+
+ val iter: ('a -> unit) -> 'a formula -> unit
+
+ val fold_left: ('a -> 'b -> 'a) -> 'a -> 'b formula -> 'a
+
+ (** An atom is: [name] * ([relop] * [version]) formula.
+ Examples of valid formulaes:
+ - "foo" {> "1" & (<"3" | ="5")}
+ - "foo" {= "1" | > "4"} | ("bar" "bouh") *)
+ type t = (name * (string * version) formula) formula
+
+ val atoms: t -> (name * (string * version) option) list
+
+ val to_string: t -> string
+
+ val to_conjunction: t -> conjunction
+
+ val to_cnf: t -> cnf
+
+end
module Remote_file: sig
include ABSTRACT
Please sign in to comment.
Something went wrong with that request. Please try again.