Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 143 lines (124 sloc) 4.795 kb
aa67aa9 @samoht Big refactoring work.
samoht authored
1 (***********************************************************************)
2 (* *)
3 (* Copyright 2012 OCamlPro *)
4 (* Copyright 2012 INRIA *)
5 (* *)
6 (* All rights reserved. This file is distributed under the terms of *)
7 (* the GNU Public License version 3.0. *)
8 (* *)
9 (* OPAM is distributed in the hope that it will be useful, *)
10 (* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
11 (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
12 (* GNU General Public License for more details. *)
13 (* *)
14 (***********************************************************************)
15
16 type conjunction = Debian.Format822.vpkglist
17
18 type cnf = Debian.Format822.vpkgformula
19
20 let string_of_vpkg = function
21 | ((n,_), None) -> n
22 | ((n,_), Some (r,c)) -> Printf.sprintf "%s (%s %s)" n r c
23
24 let string_of_conjunction c =
25 Printf.sprintf "(%s)" (String.concat " & " (List.map string_of_vpkg c))
26
27 let string_of_cnf cnf =
28 let string_of_clause c =
29 Printf.sprintf "(%s)" (String.concat " | " (List.map string_of_vpkg c)) in
30 Printf.sprintf "(%s)" (String.concat " & " (List.map string_of_clause cnf))
31
32 type 'a formula =
33 | Empty
34 | Atom of 'a
35 | Block of 'a formula
36 | And of 'a formula * 'a formula
37 | Or of 'a formula * 'a formula
38
39 let string_of_formula string_of_a f =
40 let rec aux = function
41 | Empty -> ""
42 | Atom a -> string_of_a a
43 | Block x -> Printf.sprintf "(%s)" (aux x)
44 | And(x,y) -> Printf.sprintf "%s & %s" (aux x) (aux y)
45 | Or(x,y) -> Printf.sprintf "%s | %s" (aux x) (aux y) in
46 aux f
47
48 let rec map f = function
49 | Empty -> Empty
50 | Atom x -> Atom (f x)
51 | Block x -> Block (map f x)
52 | And(x,y) -> And (map f x, map f y)
53 | Or(x,y) -> Or (map f x, map f y)
54
55 let rec iter f = function
56 | Empty -> ()
57 | Atom x -> f x
58 | Block x -> iter f x
59 | And(x,y) -> iter f x; iter f y
60 | Or(x,y) -> iter f x; iter f y
61
62 let rec fold_left f i = function
63 | Empty -> i
64 | Atom x -> f i x
65 | Block x -> fold_left f i x
66 | And(x,y) -> fold_left f (fold_left f i x) y
67 | Or(x,y) -> fold_left f (fold_left f i x) y
68
69 type t = (OpamPackage.Name.t * (string * OpamPackage.Version.t) formula) formula
70
247d8aa @samoht Use any kind of formula for compiler constraints
samoht authored
71 let rec eval atom = function
72 | Empty -> true
73 | Atom x -> atom x
74 | Block x -> eval atom x
75 | And(x,y) -> eval atom x && eval atom y
76 | Or(x,y) -> eval atom x && eval atom y
77
aa67aa9 @samoht Big refactoring work.
samoht authored
78 let to_string t =
79 let string_of_constraint (relop, version) =
80 Printf.sprintf "%s %s" relop (OpamPackage.Version.to_string version) in
81 let string_of_pkg = function
82 | n, Empty -> OpamPackage.Name.to_string n
83 | n, c ->
84 Printf.sprintf "%s %s"
85 (OpamPackage.Name.to_string n)
86 (string_of_formula string_of_constraint c) in
87 string_of_formula string_of_pkg t
88
89 (* unroll to a CNF formula *)
90 let rec unroll f t =
91 let rec mk_left x y = match y with
92 | Block y -> mk_left x y
93 | And (a,b) -> And (mk_left x a, mk_left x b)
94 | _ -> Or (x,y) in
95 let rec mk_right x y = match x with
96 | Block x -> mk_right x y
97 | And (a,b) -> And (mk_right a y, mk_right b y)
98 | _ -> mk_left x y in
99 let rec mk = function
100 | Empty -> Empty
101 | Block x -> mk x
102 | Atom x -> f x
103 | And (x,y) -> And (mk x, mk y)
104 | Or (x,y) -> mk_right (mk x) (mk y) in
105 mk t
106
107 let unroll t =
108 let atom (r,v) = Atom (r, v) in
109 let vpkg (x, c) =
110 match unroll atom c with
111 | Empty -> Atom (x, None)
112 | cs -> map (fun c -> x, Some c) cs in
113 unroll vpkg t
114
115 let atoms t =
116 fold_left (fun accu x -> x::accu) [] (unroll t)
117
118 (* Convert to dose-CNF *)
119 let to_cnf t =
120 let rec or_formula = function
121 | Atom (x,None) -> [(OpamPackage.Name.to_string x, None), None]
122 | Atom (x,Some(r,v)) -> [(OpamPackage.Name.to_string x, None),
123 Some(r, OpamPackage.Version.to_string v)]
124 | Or(x,y) -> or_formula x @ or_formula y
125 | Empty
126 | Block _
127 | And _ -> assert false in
128 let rec aux t = match t with
129 | Empty -> []
130 | Block x -> assert false
131 | Atom _
132 | Or _ -> [or_formula t]
133 | And(x,y) -> aux x @ aux y in
134 aux (unroll t)
135
136 let to_conjunction t =
137 let rec aux = function
138 | [] -> []
139 | [x]::t -> x::aux t
140 | _ ->
141 OpamGlobals.error_and_exit "%s is not a valid conjunction" (to_string t) in
142 aux (to_cnf t)
Something went wrong with that request. Please try again.