1 |
commit: 294b229cd1f177bd30b79d0fa5193c113be7cf96 |
2 |
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org> |
3 |
AuthorDate: Sun May 1 17:45:23 2016 +0000 |
4 |
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org> |
5 |
CommitDate: Tue May 3 09:13:52 2016 +0000 |
6 |
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=294b229c |
7 |
|
8 |
dev-ml/ppx_core: fix build with ocaml 4.03 |
9 |
|
10 |
Package-Manager: portage-2.2.28 |
11 |
Signed-off-by: Alexis Ballier <aballier <AT> gentoo.org> |
12 |
|
13 |
dev-ml/ppx_core/files/oc43.patch | 741 ++++++++++++++++++++++++++++++ |
14 |
dev-ml/ppx_core/ppx_core-113.33.00.ebuild | 6 +- |
15 |
2 files changed, 746 insertions(+), 1 deletion(-) |
16 |
|
17 |
diff --git a/dev-ml/ppx_core/files/oc43.patch b/dev-ml/ppx_core/files/oc43.patch |
18 |
new file mode 100644 |
19 |
index 0000000..d5f961d |
20 |
--- /dev/null |
21 |
+++ b/dev-ml/ppx_core/files/oc43.patch |
22 |
@@ -0,0 +1,741 @@ |
23 |
+diff -uNr ppx_core-113.33.00/_oasis ppx_core-113.33.00+4.03/_oasis |
24 |
+--- ppx_core-113.33.00/_oasis 2016-03-09 16:44:53.000000000 +0100 |
25 |
++++ ppx_core-113.33.00+4.03/_oasis 2016-03-23 17:20:19.000000000 +0100 |
26 |
+@@ -1,8 +1,8 @@ |
27 |
+ OASISFormat: 0.4 |
28 |
+-OCamlVersion: >= 4.02.3 |
29 |
++OCamlVersion: >= 4.03.0 |
30 |
+ FindlibVersion: >= 1.3.2 |
31 |
+ Name: ppx_core |
32 |
+-Version: 113.33.00 |
33 |
++Version: 113.33.00+4.03 |
34 |
+ Synopsis: Standard library for ppx rewriters |
35 |
+ Authors: Jane Street Group, LLC <opensource@××××××××××.com> |
36 |
+ Copyrights: (C) 2015-2016 Jane Street Group LLC <opensource@××××××××××.com> |
37 |
+diff -uNr ppx_core-113.33.00/src/ast_builder.ml ppx_core-113.33.00+4.03/src/ast_builder.ml |
38 |
+--- ppx_core-113.33.00/src/ast_builder.ml 2016-03-09 16:44:53.000000000 +0100 |
39 |
++++ ppx_core-113.33.00+4.03/src/ast_builder.ml 2016-03-23 17:20:19.000000000 +0100 |
40 |
+@@ -28,21 +28,21 @@ |
41 |
+ ({ txt = "nonrec"; loc }, PStr []) :: td.ptype_attributes } |
42 |
+ ;; |
43 |
+ |
44 |
+- let eint ~loc t = pexp_constant ~loc (Const_int t) |
45 |
+- let echar ~loc t = pexp_constant ~loc (Const_char t) |
46 |
+- let estring ~loc t = pexp_constant ~loc (Const_string (t, None)) |
47 |
+- let efloat ~loc t = pexp_constant ~loc (Const_float t) |
48 |
+- let eint32 ~loc t = pexp_constant ~loc (Const_int32 t) |
49 |
+- let eint64 ~loc t = pexp_constant ~loc (Const_int64 t) |
50 |
+- let enativeint ~loc t = pexp_constant ~loc (Const_nativeint t) |
51 |
+- |
52 |
+- let pint ~loc t = ppat_constant ~loc (Const_int t) |
53 |
+- let pchar ~loc t = ppat_constant ~loc (Const_char t) |
54 |
+- let pstring ~loc t = ppat_constant ~loc (Const_string (t, None)) |
55 |
+- let pfloat ~loc t = ppat_constant ~loc (Const_float t) |
56 |
+- let pint32 ~loc t = ppat_constant ~loc (Const_int32 t) |
57 |
+- let pint64 ~loc t = ppat_constant ~loc (Const_int64 t) |
58 |
+- let pnativeint ~loc t = ppat_constant ~loc (Const_nativeint t) |
59 |
++ let eint ~loc t = pexp_constant ~loc (Pconst_integer (string_of_int t, None)) |
60 |
++ let echar ~loc t = pexp_constant ~loc (Pconst_char t) |
61 |
++ let estring ~loc t = pexp_constant ~loc (Pconst_string (t, None)) |
62 |
++ let efloat ~loc t = pexp_constant ~loc (Pconst_float (t, None)) |
63 |
++ let eint32 ~loc t = pexp_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) |
64 |
++ let eint64 ~loc t = pexp_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) |
65 |
++ let enativeint ~loc t = pexp_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) |
66 |
++ |
67 |
++ let pint ~loc t = ppat_constant ~loc (Pconst_integer (string_of_int t, None)) |
68 |
++ let pchar ~loc t = ppat_constant ~loc (Pconst_char t) |
69 |
++ let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, None)) |
70 |
++ let pfloat ~loc t = ppat_constant ~loc (Pconst_float (t, None)) |
71 |
++ let pint32 ~loc t = ppat_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) |
72 |
++ let pint64 ~loc t = ppat_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) |
73 |
++ let pnativeint ~loc t = ppat_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) |
74 |
+ |
75 |
+ let ebool ~loc t = pexp_construct ~loc (Located.lident ~loc (string_of_bool t)) None |
76 |
+ let pbool ~loc t = ppat_construct ~loc (Located.lident ~loc (string_of_bool t)) None |
77 |
+@@ -77,10 +77,11 @@ |
78 |
+ | _ -> pexp_apply ~loc e el |
79 |
+ ;; |
80 |
+ |
81 |
+- let eapply ~loc e el = pexp_apply ~loc e (List.map el ~f:(fun e -> ("", e))) |
82 |
++ let eapply ~loc e el = |
83 |
++ pexp_apply ~loc e (List.map el ~f:(fun e -> (Asttypes.Nolabel, e))) |
84 |
+ |
85 |
+ let eabstract ~loc ps e = |
86 |
+- List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc "" None p e) |
87 |
++ List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc Asttypes.Nolabel None p e) |
88 |
+ ;; |
89 |
+ |
90 |
+ let pconstruct cd arg = ppat_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg |
91 |
+diff -uNr ppx_core-113.33.00/src/ast_pattern.ml ppx_core-113.33.00+4.03/src/ast_pattern.ml |
92 |
+--- ppx_core-113.33.00/src/ast_pattern.ml 2016-03-09 16:44:53.000000000 +0100 |
93 |
++++ ppx_core-113.33.00+4.03/src/ast_pattern.ml 2016-03-23 17:20:19.000000000 +0100 |
94 |
+@@ -80,6 +80,13 @@ |
95 |
+ |
96 |
+ let ( >>| ) t f = map t ~f |
97 |
+ |
98 |
++let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k f )) |
99 |
++let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f a ))) |
100 |
++let map2 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f a b))) |
101 |
++ |
102 |
++let alt_option some none = |
103 |
++ alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None) |
104 |
++ |
105 |
+ let many (T f) = T (fun ctx loc l k -> |
106 |
+ k (List.map l ~f:(fun x -> f ctx loc x (fun x -> x)))) |
107 |
+ ;; |
108 |
+@@ -96,25 +103,37 @@ |
109 |
+ |
110 |
+ let ( ^:: ) = cons |
111 |
+ |
112 |
+-let eint t = pexp_constant (const_int t) |
113 |
+-let echar t = pexp_constant (const_char t) |
114 |
+-let estring t = pexp_constant (const_string t drop) |
115 |
+-let efloat t = pexp_constant (const_float t) |
116 |
+-let eint32 t = pexp_constant (const_int32 t) |
117 |
+-let eint64 t = pexp_constant (const_int64 t) |
118 |
++let echar t = pexp_constant (pconst_char t ) |
119 |
++let estring t = pexp_constant (pconst_string t drop) |
120 |
++let efloat t = pexp_constant (pconst_float t drop) |
121 |
++ |
122 |
++let pchar t = ppat_constant (pconst_char t ) |
123 |
++let pstring t = ppat_constant (pconst_string t drop) |
124 |
++let pfloat t = ppat_constant (pconst_float t drop) |
125 |
++ |
126 |
++let int' (T f) = T (fun ctx loc x k -> f ctx loc (int_of_string x) k) |
127 |
++let int32' (T f) = T (fun ctx loc x k -> f ctx loc (Int32.of_string x) k) |
128 |
++let int64' (T f) = T (fun ctx loc x k -> f ctx loc (Int64.of_string x) k) |
129 |
++let nativeint' (T f) = T (fun ctx loc x k -> f ctx loc (Nativeint.of_string x) k) |
130 |
++ |
131 |
++let const_int t = pconst_integer (int' t) none |
132 |
++let const_int32 t = pconst_integer (int32' t) (some (char 'l')) |
133 |
++let const_int64 t = pconst_integer (int64' t) (some (char 'L')) |
134 |
++let const_nativeint t = pconst_integer (nativeint' t) (some (char 'n')) |
135 |
++ |
136 |
++let eint t = pexp_constant (const_int t) |
137 |
++let eint32 t = pexp_constant (const_int32 t) |
138 |
++let eint64 t = pexp_constant (const_int64 t) |
139 |
+ let enativeint t = pexp_constant (const_nativeint t) |
140 |
+ |
141 |
+-let pint t = ppat_constant (const_int t) |
142 |
+-let pchar t = ppat_constant (const_char t) |
143 |
+-let pstring t = ppat_constant (const_string t drop) |
144 |
+-let pfloat t = ppat_constant (const_float t) |
145 |
+-let pint32 t = ppat_constant (const_int32 t) |
146 |
+-let pint64 t = ppat_constant (const_int64 t) |
147 |
++let pint t = ppat_constant (const_int t) |
148 |
++let pint32 t = ppat_constant (const_int32 t) |
149 |
++let pint64 t = ppat_constant (const_int64 t) |
150 |
+ let pnativeint t = ppat_constant (const_nativeint t) |
151 |
+ |
152 |
+ let single_expr_payload t = pstr (pstr_eval t nil ^:: nil) |
153 |
+ |
154 |
+-let no_label t = string "" ** t |
155 |
++let no_label t = (cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel")) ** t |
156 |
+ |
157 |
+ let attribute (T f1) (T f2) = T (fun ctx loc ((name : _ Location.loc), payload) k -> |
158 |
+ let k = f1 ctx name.loc name.txt k in |
159 |
+diff -uNr ppx_core-113.33.00/src/ast_pattern.mli ppx_core-113.33.00+4.03/src/ast_pattern.mli |
160 |
+--- ppx_core-113.33.00/src/ast_pattern.mli 2016-03-09 16:44:53.000000000 +0100 |
161 |
++++ ppx_core-113.33.00+4.03/src/ast_pattern.mli 2016-03-23 17:20:19.000000000 +0100 |
162 |
+@@ -115,6 +115,10 @@ |
163 |
+ one. *) |
164 |
+ val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t |
165 |
+ |
166 |
++(** Same as [alt], for the common case where the left-hand-side captures a value but not |
167 |
++ the right-hand-side. *) |
168 |
++val alt_option : ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option -> 'b, 'c) t |
169 |
++ |
170 |
+ (** Same as [alt] *) |
171 |
+ val ( ||| ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t |
172 |
+ |
173 |
+@@ -125,6 +129,10 @@ |
174 |
+ (** Same as [map] *) |
175 |
+ val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t |
176 |
+ |
177 |
++val map0 : ('a, 'b, 'c) t -> f: 'v -> ('a, 'v -> 'b, 'c) t |
178 |
++val map1 : ('a, 'v1 -> 'b, 'c) t -> f:('v1 -> 'v) -> ('a, 'v -> 'b, 'c) t |
179 |
++val map2 : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t |
180 |
++ |
181 |
+ val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t |
182 |
+ val many : ('a, 'b -> 'b, 'c) t -> ('a list, 'c list -> 'd, 'd) t |
183 |
+ |
184 |
+@@ -194,7 +202,7 @@ |
185 |
+ |
186 |
+ val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t |
187 |
+ |
188 |
+-val no_label : (expression, 'a, 'b) t -> (string * expression, 'a, 'b) t |
189 |
++val no_label : (expression, 'a, 'b) t -> (Asttypes.arg_label * expression, 'a, 'b) t |
190 |
+ |
191 |
+ val attribute : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (attribute, 'a, 'c) t |
192 |
+ val extension : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (attribute, 'a, 'c) t |
193 |
+diff -uNr ppx_core-113.33.00/src/attribute.ml ppx_core-113.33.00+4.03/src/attribute.ml |
194 |
+--- ppx_core-113.33.00/src/attribute.ml 2016-03-09 16:44:53.000000000 +0100 |
195 |
++++ ppx_core-113.33.00+4.03/src/attribute.ml 2016-03-23 17:20:19.000000000 +0100 |
196 |
+@@ -15,6 +15,10 @@ |
197 |
+ ; "ocaml.doc" |
198 |
+ ; "ocaml.text" |
199 |
+ ; "nonrec" |
200 |
++ ; "ocaml.noalloc" |
201 |
++ ; "ocaml.unboxed" |
202 |
++ ; "ocaml.untagged" |
203 |
++ ; "ocaml.inline" |
204 |
+ ] |
205 |
+ ;; |
206 |
+ |
207 |
+@@ -74,6 +78,7 @@ |
208 |
+ | Pstr_eval : structure_item t |
209 |
+ | Pstr_extension : structure_item t |
210 |
+ | Psig_extension : signature_item t |
211 |
++ | Row_field : row_field t |
212 |
+ |
213 |
+ let label_declaration = Label_declaration |
214 |
+ let constructor_declaration = Constructor_declaration |
215 |
+@@ -100,6 +105,7 @@ |
216 |
+ let pstr_eval = Pstr_eval |
217 |
+ let pstr_extension = Pstr_extension |
218 |
+ let psig_extension = Psig_extension |
219 |
++ let row_field = Row_field |
220 |
+ |
221 |
+ let get_pstr_eval st = |
222 |
+ match st.pstr_desc with |
223 |
+@@ -116,6 +122,17 @@ |
224 |
+ | Psig_extension (e, l) -> (e, l) |
225 |
+ | _ -> failwith "Attribute.Context.get_psig_extension" |
226 |
+ |
227 |
++ module Row_field = struct |
228 |
++ let get_attrs = function |
229 |
++ | Rinherit _ -> [] |
230 |
++ | Rtag (_, attrs, _, _) -> attrs |
231 |
++ |
232 |
++ let set_attrs attrs = function |
233 |
++ | Rinherit _ -> invalid_arg "Row_field.set_attrs" |
234 |
++ | Rtag (lbl, _, can_be_constant, params_opts) -> |
235 |
++ Rtag (lbl, attrs, can_be_constant, params_opts) |
236 |
++ end |
237 |
++ |
238 |
+ let get_attributes : type a. a t -> a -> attributes = fun t x -> |
239 |
+ match t with |
240 |
+ | Label_declaration -> x.pld_attributes |
241 |
+@@ -143,6 +160,7 @@ |
242 |
+ | Pstr_eval -> snd (get_pstr_eval x) |
243 |
+ | Pstr_extension -> snd (get_pstr_extension x) |
244 |
+ | Psig_extension -> snd (get_psig_extension x) |
245 |
++ | Row_field -> Row_field.get_attrs x |
246 |
+ |
247 |
+ let set_attributes : type a. a t -> a -> attributes -> a = fun t x attrs -> |
248 |
+ match t with |
249 |
+@@ -174,6 +192,7 @@ |
250 |
+ { x with pstr_desc = Pstr_extension (get_pstr_extension x |> fst, attrs) } |
251 |
+ | Psig_extension -> |
252 |
+ { x with psig_desc = Psig_extension (get_psig_extension x |> fst, attrs) } |
253 |
++ | Row_field -> Row_field.set_attrs attrs x |
254 |
+ |
255 |
+ let desc : type a. a t -> string = function |
256 |
+ | Label_declaration -> "label declaration" |
257 |
+@@ -201,6 +220,7 @@ |
258 |
+ | Pstr_eval -> "toplevel expression" |
259 |
+ | Pstr_extension -> "toplevel extension" |
260 |
+ | Psig_extension -> "toplevel signature extension" |
261 |
++ | Row_field -> "row field" |
262 |
+ |
263 |
+ (* |
264 |
+ let pattern : type a b c d. a t |
265 |
+@@ -435,6 +455,7 @@ |
266 |
+ method! attribute (name, _) = |
267 |
+ Location.raise_errorf ~loc:name.loc |
268 |
+ "attribute not expected here, Ppx_core.Std.Attribute needs updating!" |
269 |
++ name.txt |
270 |
+ |
271 |
+ method private check_node : type a. a Context.t -> a -> a = fun context node -> |
272 |
+ let attrs = Context.get_attributes context node in |
273 |
+@@ -480,6 +501,7 @@ |
274 |
+ method! module_expr x = super#module_expr (self#check_node Context.Module_expr x) |
275 |
+ method! value_binding x = super#value_binding (self#check_node Context.Value_binding x) |
276 |
+ method! module_binding x = super#module_binding (self#check_node Context.Module_binding x) |
277 |
++ method! row_field x = super#row_field (self#check_node Context.Row_field x) |
278 |
+ |
279 |
+ method! class_field x = |
280 |
+ let x = self#check_node Context.Class_field x in |
281 |
+diff -uNr ppx_core-113.33.00/src/attribute.mli ppx_core-113.33.00+4.03/src/attribute.mli |
282 |
+--- ppx_core-113.33.00/src/attribute.mli 2016-03-09 16:44:53.000000000 +0100 |
283 |
++++ ppx_core-113.33.00+4.03/src/attribute.mli 2016-03-23 17:20:19.000000000 +0100 |
284 |
+@@ -42,6 +42,7 @@ |
285 |
+ val pstr_eval : structure_item t |
286 |
+ val pstr_extension : structure_item t |
287 |
+ val psig_extension : signature_item t |
288 |
++ val row_field : row_field t |
289 |
+ end |
290 |
+ |
291 |
+ (** [declare fully_qualified_name context payload_pattern k] declares an attribute. [k] is |
292 |
+diff -uNr ppx_core-113.33.00/src/common.ml ppx_core-113.33.00+4.03/src/common.ml |
293 |
+--- ppx_core-113.33.00/src/common.ml 2016-03-09 16:44:53.000000000 +0100 |
294 |
++++ ppx_core-113.33.00+4.03/src/common.ml 2016-03-23 17:20:19.000000000 +0100 |
295 |
+@@ -16,7 +16,7 @@ |
296 |
+ List.fold_right |
297 |
+ (fun (tp, _variance) acc -> |
298 |
+ let loc = tp.ptyp_loc in |
299 |
+- ptyp_arrow ~loc "" (f ~loc tp) acc) |
300 |
++ ptyp_arrow ~loc Nolabel (f ~loc tp) acc) |
301 |
+ td.ptype_params |
302 |
+ result_type |
303 |
+ ;; |
304 |
+@@ -74,7 +74,9 @@ |
305 |
+ |
306 |
+ method! constructor_declaration cd = |
307 |
+ (* Don't recurse through cd.pcd_res *) |
308 |
+- List.iter (fun ty -> self#core_type ty) cd.pcd_args |
309 |
++ match cd.pcd_args with |
310 |
++ | Pcstr_tuple args -> List.iter (fun ty -> self#core_type ty) args |
311 |
++ | Pcstr_record _ -> failwith "Pcstr_record not supported" |
312 |
+ end |
313 |
+ |
314 |
+ let types_are_recursive ?(stop_on_functions = true) ?(short_circuit = fun _ -> None) |
315 |
+@@ -110,6 +112,7 @@ |
316 |
+ match payload with |
317 |
+ | PStr [] -> name.loc |
318 |
+ | PStr (x :: l) -> { x.pstr_loc with loc_end = (last x l).pstr_loc.loc_end } |
319 |
++ | PSig _ -> failwith "Not yet implemented" |
320 |
+ | PTyp t -> t.ptyp_loc |
321 |
+ | PPat (x, None) -> x.ppat_loc |
322 |
+ | PPat (x, Some e) -> { x.ppat_loc with loc_end = e.pexp_loc.loc_end } |
323 |
+diff -uNr ppx_core-113.33.00/src/gen/common.ml ppx_core-113.33.00+4.03/src/gen/common.ml |
324 |
+--- ppx_core-113.33.00/src/gen/common.ml 2016-03-09 16:44:53.000000000 +0100 |
325 |
++++ ppx_core-113.33.00+4.03/src/gen/common.ml 2016-03-23 17:20:19.000000000 +0100 |
326 |
+@@ -70,8 +70,13 @@ |
327 |
+ | Type_variant cds -> |
328 |
+ List.fold_left cds ~init:acc |
329 |
+ ~f:(fun acc (cd : Types.constructor_declaration) -> |
330 |
+- List.fold_left cd.cd_args ~init:acc |
331 |
+- ~f:(add_type_expr_dependencies env)) |
332 |
++ match cd.cd_args with |
333 |
++ | Cstr_tuple typ_exprs -> |
334 |
++ List.fold_left typ_exprs ~init:acc ~f:(add_type_expr_dependencies env) |
335 |
++ | Cstr_record label_decls -> |
336 |
++ List.fold_left label_decls ~init:acc |
337 |
++ ~f:(fun acc (label_decl : Types.label_declaration) -> |
338 |
++ add_type_expr_dependencies env acc label_decl.ld_type)) |
339 |
+ | Type_abstract -> |
340 |
+ match td.type_manifest with |
341 |
+ | None -> acc |
342 |
+diff -uNr ppx_core-113.33.00/src/gen/gen_ast_builder.ml ppx_core-113.33.00+4.03/src/gen/gen_ast_builder.ml |
343 |
+--- ppx_core-113.33.00/src/gen/gen_ast_builder.ml 2016-03-09 16:44:53.000000000 +0100 |
344 |
++++ ppx_core-113.33.00+4.03/src/gen/gen_ast_builder.ml 2016-03-23 17:20:19.000000000 +0100 |
345 |
+@@ -121,57 +121,60 @@ |
346 |
+ open M |
347 |
+ |
348 |
+ let gen_combinator_for_constructor ~wrapper:(wpath, wprefix, has_attrs) path ~prefix cd = |
349 |
+- let args = |
350 |
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "x%d" i) |
351 |
+- in |
352 |
+- let exp = |
353 |
+- Exp.construct (Loc.mk (fqn_longident path cd.cd_id)) |
354 |
+- (match args with |
355 |
+- | [] -> None |
356 |
+- | [x] -> Some (evar x) |
357 |
+- | _ -> Some (Exp.tuple (List.map args ~f:evar))) |
358 |
+- in |
359 |
+- let body = |
360 |
+- let fields = |
361 |
+- [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc")) |
362 |
+- , evar "loc" |
363 |
+- ) |
364 |
+- ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc")) |
365 |
+- , exp |
366 |
+- ) |
367 |
+- ] |
368 |
++ match cd.cd_args with |
369 |
++ | Cstr_record _ -> failwith "Cstr_record not supported" |
370 |
++ | Cstr_tuple cd_args -> |
371 |
++ let args = |
372 |
++ List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) |
373 |
++ in |
374 |
++ let exp = |
375 |
++ Exp.construct (Loc.mk (fqn_longident path cd.cd_id)) |
376 |
++ (match args with |
377 |
++ | [] -> None |
378 |
++ | [x] -> Some (evar x) |
379 |
++ | _ -> Some (Exp.tuple (List.map args ~f:evar))) |
380 |
+ in |
381 |
+- let fields = |
382 |
+- if has_attrs then |
383 |
+- ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes")) |
384 |
+- , [%expr []] |
385 |
+- ) |
386 |
+- :: fields |
387 |
++ let body = |
388 |
++ let fields = |
389 |
++ [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc")) |
390 |
++ , evar "loc" |
391 |
++ ) |
392 |
++ ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc")) |
393 |
++ , exp |
394 |
++ ) |
395 |
++ ] |
396 |
++ in |
397 |
++ let fields = |
398 |
++ if has_attrs then |
399 |
++ ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes")) |
400 |
++ , [%expr []] |
401 |
++ ) |
402 |
++ :: fields |
403 |
++ else |
404 |
++ fields |
405 |
++ in |
406 |
++ Exp.record fields None |
407 |
++ in |
408 |
++ let body = |
409 |
++ (* match args with |
410 |
++ | [] -> [%expr fun () -> [%e body]] |
411 |
++ | _ ->*) |
412 |
++ List.fold_right args ~init:body ~f:(fun arg acc -> |
413 |
++ [%expr fun [%p pvar arg] -> [%e acc]]) |
414 |
++ in |
415 |
++ (* let body = |
416 |
++ if not has_attrs then |
417 |
++ body |
418 |
++ else |
419 |
++ [%expr fun ?(attrs=[]) -> [%e body]] |
420 |
++ in*) |
421 |
++ let body = |
422 |
++ if fixed_loc then |
423 |
++ body |
424 |
+ else |
425 |
+- fields |
426 |
++ [%expr fun ~loc -> [%e body]] |
427 |
+ in |
428 |
+- Exp.record fields None |
429 |
+- in |
430 |
+- let body = |
431 |
+-(* match args with |
432 |
+- | [] -> [%expr fun () -> [%e body]] |
433 |
+- | _ ->*) |
434 |
+- List.fold_right args ~init:body ~f:(fun arg acc -> |
435 |
+- [%expr fun [%p pvar arg] -> [%e acc]]) |
436 |
+- in |
437 |
+-(* let body = |
438 |
+- if not has_attrs then |
439 |
+- body |
440 |
+- else |
441 |
+- [%expr fun ?(attrs=[]) -> [%e body]] |
442 |
+- in*) |
443 |
+- let body = |
444 |
+- if fixed_loc then |
445 |
+- body |
446 |
+- else |
447 |
+- [%expr fun ~loc -> [%e body]] |
448 |
+- in |
449 |
+- [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]] |
450 |
++ [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]] |
451 |
+ ;; |
452 |
+ |
453 |
+ let gen_combinator_for_record path ~prefix lds = |
454 |
+@@ -189,10 +192,10 @@ |
455 |
+ let body = |
456 |
+ let l = List.filter funcs ~f:(fun f -> f <> "loc" && f <> "attributes") in |
457 |
+ match l with |
458 |
+- | [x] -> Exp.fun_ "" None (pvar x) body |
459 |
++ | [x] -> Exp.fun_ Nolabel None (pvar x) body |
460 |
+ | _ -> |
461 |
+ List.fold_right l ~init:body ~f:(fun func acc -> |
462 |
+- Exp.fun_ func None (pvar func) acc |
463 |
++ Exp.fun_ (Labelled func) None (pvar func) acc |
464 |
+ ) |
465 |
+ in |
466 |
+ (* let body = |
467 |
+diff -uNr ppx_core-113.33.00/src/gen/gen_ast_pattern.ml ppx_core-113.33.00+4.03/src/gen/gen_ast_pattern.ml |
468 |
+--- ppx_core-113.33.00/src/gen/gen_ast_pattern.ml 2016-03-09 16:44:53.000000000 +0100 |
469 |
++++ ppx_core-113.33.00+4.03/src/gen/gen_ast_pattern.ml 2016-03-23 17:20:19.000000000 +0100 |
470 |
+@@ -157,66 +157,69 @@ |
471 |
+ ] |
472 |
+ |
473 |
+ let gen_combinator_for_constructor ?wrapper path ~prefix cd = |
474 |
+- let args = |
475 |
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "x%d" i) |
476 |
+- in |
477 |
+- let funcs = |
478 |
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "f%d" i) |
479 |
+- in |
480 |
+- let pat = |
481 |
+- Pat.construct (Loc.mk (fqn_longident path cd.cd_id)) |
482 |
+- (match args with |
483 |
+- | [] -> None |
484 |
+- | [x] -> Some (pvar x) |
485 |
+- | _ -> Some (Pat.tuple (List.map args ~f:pvar))) |
486 |
+- in |
487 |
+- let exp = |
488 |
+- apply_parsers funcs (List.map args ~f:evar) cd.cd_args |
489 |
+- in |
490 |
+- let expected = without_prefix ~prefix (Ident.name cd.cd_id) in |
491 |
+- let body = |
492 |
+- [%expr |
493 |
+- match x with |
494 |
+- | [%p pat] -> ctx.matched <- ctx.matched + 1; [%e exp] |
495 |
+- | _ -> fail loc [%e Exp.constant (Const_string (expected, None))] |
496 |
+- ] |
497 |
+- in |
498 |
+- let body = |
499 |
+- match wrapper with |
500 |
+- | None -> body |
501 |
+- | Some (path, prefix, has_attrs) -> |
502 |
+- let body = |
503 |
+- [%expr |
504 |
+- let loc = [%e Exp.field (evar "x") |
505 |
+- (Loc.mk @@ fqn_longident' path (prefix ^ "loc"))] |
506 |
+- in |
507 |
+- let x = [%e Exp.field (evar "x") |
508 |
+- (Loc.mk @@ fqn_longident' path (prefix ^ "desc"))] |
509 |
+- in |
510 |
+- [%e body] |
511 |
+- ] |
512 |
+- in |
513 |
+- if has_attrs then |
514 |
+- [%expr |
515 |
+- [%e assert_no_attributes ~path ~prefix]; |
516 |
+- [%e body] |
517 |
+- ] |
518 |
+- else |
519 |
+- body |
520 |
+- in |
521 |
+- let body = |
522 |
+- let loc = |
523 |
++ match cd.cd_args with |
524 |
++ | Cstr_record _ -> failwith "Cstr_record not supported" |
525 |
++ | Cstr_tuple cd_args -> |
526 |
++ let args = |
527 |
++ List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) |
528 |
++ in |
529 |
++ let funcs = |
530 |
++ List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) |
531 |
++ in |
532 |
++ let pat = |
533 |
++ Pat.construct (Loc.mk (fqn_longident path cd.cd_id)) |
534 |
++ (match args with |
535 |
++ | [] -> None |
536 |
++ | [x] -> Some (pvar x) |
537 |
++ | _ -> Some (Pat.tuple (List.map args ~f:pvar))) |
538 |
++ in |
539 |
++ let exp = |
540 |
++ apply_parsers funcs (List.map args ~f:evar) cd_args |
541 |
++ in |
542 |
++ let expected = without_prefix ~prefix (Ident.name cd.cd_id) in |
543 |
++ let body = |
544 |
++ [%expr |
545 |
++ match x with |
546 |
++ | [%p pat] -> ctx.matched <- ctx.matched + 1; [%e exp] |
547 |
++ | _ -> fail loc [%e Exp.constant (Pconst_string (expected, None))] |
548 |
++ ] |
549 |
++ in |
550 |
++ let body = |
551 |
+ match wrapper with |
552 |
+- | None -> [%pat? loc] |
553 |
+- | Some _ -> [%pat? _loc] |
554 |
++ | None -> body |
555 |
++ | Some (path, prefix, has_attrs) -> |
556 |
++ let body = |
557 |
++ [%expr |
558 |
++ let loc = [%e Exp.field (evar "x") |
559 |
++ (Loc.mk @@ fqn_longident' path (prefix ^ "loc"))] |
560 |
++ in |
561 |
++ let x = [%e Exp.field (evar "x") |
562 |
++ (Loc.mk @@ fqn_longident' path (prefix ^ "desc"))] |
563 |
++ in |
564 |
++ [%e body] |
565 |
++ ] |
566 |
++ in |
567 |
++ if has_attrs then |
568 |
++ [%expr |
569 |
++ [%e assert_no_attributes ~path ~prefix]; |
570 |
++ [%e body] |
571 |
++ ] |
572 |
++ else |
573 |
++ body |
574 |
+ in |
575 |
+- [%expr T (fun ctx [%p loc] x k -> [%e body])] |
576 |
+- in |
577 |
+- let body = |
578 |
+- List.fold_right funcs ~init:body ~f:(fun func acc -> |
579 |
+- [%expr fun (T [%p pvar func]) -> [%e acc]]) |
580 |
+- in |
581 |
+- [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]] |
582 |
++ let body = |
583 |
++ let loc = |
584 |
++ match wrapper with |
585 |
++ | None -> [%pat? loc] |
586 |
++ | Some _ -> [%pat? _loc] |
587 |
++ in |
588 |
++ [%expr T (fun ctx [%p loc] x k -> [%e body])] |
589 |
++ in |
590 |
++ let body = |
591 |
++ List.fold_right funcs ~init:body ~f:(fun func acc -> |
592 |
++ [%expr fun (T [%p pvar func]) -> [%e acc]]) |
593 |
++ in |
594 |
++ [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]] |
595 |
+ ;; |
596 |
+ |
597 |
+ let gen_combinator_for_record path ~prefix ~has_attrs lds = |
598 |
+@@ -241,7 +244,7 @@ |
599 |
+ let body = [%expr T (fun ctx loc x k -> [%e body])] in |
600 |
+ let body = |
601 |
+ List.fold_right funcs ~init:body ~f:(fun func acc -> |
602 |
+- Exp.fun_ func None [%pat? T [%p pvar func]] acc) |
603 |
++ Exp.fun_ (Labelled func) None [%pat? T [%p pvar func]] acc) |
604 |
+ in |
605 |
+ [%stri let [%p pvar (Common.function_name_of_path path)] = [%e body]] |
606 |
+ ;; |
607 |
+diff -uNr ppx_core-113.33.00/src/gen/gen.ml ppx_core-113.33.00+4.03/src/gen/gen.ml |
608 |
+--- ppx_core-113.33.00/src/gen/gen.ml 2016-03-09 16:44:53.000000000 +0100 |
609 |
++++ ppx_core-113.33.00+4.03/src/gen/gen.ml 2016-03-23 17:20:19.000000000 +0100 |
610 |
+@@ -23,7 +23,7 @@ |
611 |
+ |
612 |
+ method apply |
613 |
+ : Parsetree.expression |
614 |
+- -> (string * Parsetree.expression) list |
615 |
++ -> (Asttypes.arg_label * Parsetree.expression) list |
616 |
+ -> Parsetree.expression |
617 |
+ |
618 |
+ method abstract |
619 |
+@@ -49,9 +49,9 @@ |
620 |
+ method class_params = [] |
621 |
+ |
622 |
+ method apply expr args = Exp.apply expr args |
623 |
+- method abstract patt expr = Exp.fun_ "" None patt expr |
624 |
++ method abstract patt expr = Exp.fun_ Nolabel None patt expr |
625 |
+ |
626 |
+- method typ ty = Typ.arrow "" ty ty |
627 |
++ method typ ty = Typ.arrow Nolabel ty ty |
628 |
+ |
629 |
+ method array = [%expr Array.map] |
630 |
+ method any = [%expr fun x -> x] |
631 |
+@@ -68,7 +68,7 @@ |
632 |
+ method class_params = [] |
633 |
+ |
634 |
+ method apply expr args = Exp.apply expr args |
635 |
+- method abstract patt expr = Exp.fun_ "" None patt expr |
636 |
++ method abstract patt expr = Exp.fun_ Nolabel None patt expr |
637 |
+ |
638 |
+ method typ ty = [%type: [%t ty] -> unit] |
639 |
+ method array = [%expr Array.iter] |
640 |
+@@ -88,8 +88,9 @@ |
641 |
+ |
642 |
+ method class_params = [(Typ.var "acc", Asttypes.Invariant)] |
643 |
+ |
644 |
+- method apply expr args = Exp.apply expr (args @ [("", evar "acc")]) |
645 |
+- method abstract patt expr = Exp.fun_ "" None patt (Exp.fun_ "" None (pvar "acc") expr) |
646 |
++ method apply expr args = Exp.apply expr (args @ [(Asttypes.Nolabel, evar "acc")]) |
647 |
++ method abstract patt expr = |
648 |
++ Exp.fun_ Nolabel None patt (Exp.fun_ Nolabel None (pvar "acc") expr) |
649 |
+ |
650 |
+ method typ ty = [%type: [%t ty] -> 'acc -> 'acc] |
651 |
+ method array = |
652 |
+@@ -121,8 +122,9 @@ |
653 |
+ |
654 |
+ method class_params = [(Typ.var "acc", Asttypes.Invariant)] |
655 |
+ |
656 |
+- method apply expr args = Exp.apply expr (args @ [("", evar "acc")]) |
657 |
+- method abstract patt expr = Exp.fun_ "" None patt (Exp.fun_ "" None (pvar "acc") expr) |
658 |
++ method apply expr args = Exp.apply expr (args @ [(Asttypes.Nolabel, evar "acc")]) |
659 |
++ method abstract patt expr = |
660 |
++ Exp.fun_ Nolabel None patt (Exp.fun_ Nolabel None (pvar "acc") expr) |
661 |
+ |
662 |
+ method typ ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc] |
663 |
+ method array = |
664 |
+@@ -180,12 +182,12 @@ |
665 |
+ |
666 |
+ method class_params = [(Typ.var "ctx", Asttypes.Invariant)] |
667 |
+ |
668 |
+- method apply expr args = Exp.apply expr (("", evar "ctx") :: args) |
669 |
++ method apply expr args = Exp.apply expr ((Asttypes.Nolabel, evar "ctx") :: args) |
670 |
+ method abstract patt expr = |
671 |
+ if uses_ctx expr then |
672 |
+- Exp.fun_ "" None (pvar "ctx") (Exp.fun_ "" None patt expr) |
673 |
++ Exp.fun_ Nolabel None (pvar "ctx") (Exp.fun_ Nolabel None patt expr) |
674 |
+ else |
675 |
+- Exp.fun_ "" None (pvar "_ctx") (Exp.fun_ "" None patt expr) |
676 |
++ Exp.fun_ Nolabel None (pvar "_ctx") (Exp.fun_ Nolabel None patt expr) |
677 |
+ |
678 |
+ method typ ty = [%type: 'ctx -> [%t ty] -> [%t ty]] |
679 |
+ method array = [%expr fun ctx a -> Array.map (f ctx) a] |
680 |
+@@ -219,7 +221,7 @@ |
681 |
+ let ty = Typ.constr (Loc.mk ~loc (longident_of_path path)) params in |
682 |
+ let ty = |
683 |
+ List.fold_right |
684 |
+- (fun param ty -> Typ.arrow "" (what#typ param) ty) |
685 |
++ (fun param ty -> Typ.arrow Nolabel (what#typ param) ty) |
686 |
+ params (what#typ ty) |
687 |
+ in |
688 |
+ Typ.poly vars ty |
689 |
+@@ -244,7 +246,8 @@ |
690 |
+ | _ -> |
691 |
+ Exp.apply map |
692 |
+ (List.map |
693 |
+- (fun te -> ("", type_expr_mapper ~what ~all_types ~var_mappers te)) |
694 |
++ (fun te -> |
695 |
++ (Asttypes.Nolabel, type_expr_mapper ~what ~all_types ~var_mappers te)) |
696 |
+ params) |
697 |
+ else |
698 |
+ what#any |
699 |
+@@ -263,7 +266,8 @@ |
700 |
+ List.map2 |
701 |
+ (fun te var -> |
702 |
+ (var, |
703 |
+- what#apply (type_expr_mapper ~what ~all_types ~var_mappers te) [("", evar var)])) |
704 |
++ what#apply (type_expr_mapper ~what ~all_types ~var_mappers te) |
705 |
++ [(Asttypes.Nolabel, evar var)])) |
706 |
+ tes vars |
707 |
+ ;; |
708 |
+ |
709 |
+@@ -290,24 +294,27 @@ |
710 |
+ let cases = |
711 |
+ List.map |
712 |
+ (fun cd -> |
713 |
+- let vars = vars_of_list cd.cd_args in |
714 |
+- let cstr = Loc.mk ~loc (lident (Ident.name cd.cd_id)) in |
715 |
+- let deconstruct = |
716 |
+- Pat.construct cstr |
717 |
+- (match vars with |
718 |
+- | [] -> None |
719 |
+- | _ -> Some (Pat.tuple (List.map pvar vars))) |
720 |
+- in |
721 |
+- let reconstruct = |
722 |
+- Exp.construct cstr |
723 |
+- (match vars with |
724 |
+- | [] -> None |
725 |
+- | _ -> Some (Exp.tuple (List.map evar vars))) |
726 |
+- in |
727 |
+- let mappers = |
728 |
+- map_variables ~what ~all_types ~var_mappers vars cd.cd_args |
729 |
+- in |
730 |
+- Exp.case deconstruct (what#combine mappers ~reconstruct)) |
731 |
++ match cd.cd_args with |
732 |
++ | Cstr_tuple args -> |
733 |
++ let vars = vars_of_list args in |
734 |
++ let cstr = Loc.mk ~loc (lident (Ident.name cd.cd_id)) in |
735 |
++ let deconstruct = |
736 |
++ Pat.construct cstr |
737 |
++ (match vars with |
738 |
++ | [] -> None |
739 |
++ | _ -> Some (Pat.tuple (List.map pvar vars))) |
740 |
++ in |
741 |
++ let reconstruct = |
742 |
++ Exp.construct cstr |
743 |
++ (match vars with |
744 |
++ | [] -> None |
745 |
++ | _ -> Some (Exp.tuple (List.map evar vars))) |
746 |
++ in |
747 |
++ let mappers = |
748 |
++ map_variables ~what ~all_types ~var_mappers vars args |
749 |
++ in |
750 |
++ Exp.case deconstruct (what#combine mappers ~reconstruct) |
751 |
++ | Cstr_record _ -> failwith "Cstr_record not supported") |
752 |
+ cds |
753 |
+ in |
754 |
+ what#abstract (pvar "x") (Exp.match_ (evar "x") cases) |
755 |
+@@ -333,7 +340,7 @@ |
756 |
+ | Some te -> type_expr_mapper ~what ~all_types ~var_mappers te |
757 |
+ in |
758 |
+ List.fold_right |
759 |
+- (fun (_, v) acc -> Exp.fun_ "" None (pvar v) acc) |
760 |
++ (fun (_, v) acc -> Exp.fun_ Nolabel None (pvar v) acc) |
761 |
+ var_mappers body |
762 |
+ end |
763 |
+ ;; |
764 |
|
765 |
diff --git a/dev-ml/ppx_core/ppx_core-113.33.00.ebuild b/dev-ml/ppx_core/ppx_core-113.33.00.ebuild |
766 |
index d00d096..1ba1112 100644 |
767 |
--- a/dev-ml/ppx_core/ppx_core-113.33.00.ebuild |
768 |
+++ b/dev-ml/ppx_core/ppx_core-113.33.00.ebuild |
769 |
@@ -4,7 +4,7 @@ |
770 |
|
771 |
EAPI="5" |
772 |
|
773 |
-inherit oasis |
774 |
+inherit oasis eutils |
775 |
|
776 |
DESCRIPTION="Standard library for ppx rewriters" |
777 |
HOMEPAGE="http://www.janestreet.com/ocaml" |
778 |
@@ -19,6 +19,10 @@ DEPEND="dev-ml/ppx_tools:=" |
779 |
RDEPEND="${DEPEND}" |
780 |
DEPEND="${DEPEND} dev-ml/opam" |
781 |
|
782 |
+src_prepare() { |
783 |
+ has_version '>=dev-lang/ocaml-4.03' && epatch "${FILESDIR}/oc43.patch" |
784 |
+} |
785 |
+ |
786 |
src_configure() { |
787 |
emake setup.exe |
788 |
OASIS_SETUP_COMMAND="./setup.exe" oasis_src_configure |