1 |
commit: 915138df1231e929152fc5452e6b1c698b8c4481 |
2 |
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org> |
3 |
AuthorDate: Wed Sep 7 09:53:00 2016 +0000 |
4 |
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org> |
5 |
CommitDate: Wed Sep 7 09:57:21 2016 +0000 |
6 |
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=915138df |
7 |
|
8 |
dev-ml/js_of_ocaml: remove old |
9 |
|
10 |
Package-Manager: portage-2.3.0 |
11 |
|
12 |
dev-ml/js_of_ocaml/Manifest | 2 - |
13 |
dev-ml/js_of_ocaml/files/oc43.patch | 1418 ----------------------------- |
14 |
dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild | 59 -- |
15 |
dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild | 57 -- |
16 |
4 files changed, 1536 deletions(-) |
17 |
|
18 |
diff --git a/dev-ml/js_of_ocaml/Manifest b/dev-ml/js_of_ocaml/Manifest |
19 |
index 1e574d2..470a36f 100644 |
20 |
--- a/dev-ml/js_of_ocaml/Manifest |
21 |
+++ b/dev-ml/js_of_ocaml/Manifest |
22 |
@@ -1,3 +1 @@ |
23 |
-DIST js_of_ocaml-2.7.tar.gz 1304487 SHA256 52922f55428a1d8a55ec2493c4989152e06efd29a981adf8ac9f343f558854b5 SHA512 ab6e5d16342bf763c10eb5c2e7589610622034eee2ad82aa09c6f68448f155a5c56584702307852b251bde80146c1b7115ed6add1358ad96b130c9dd2b96118b WHIRLPOOL 278c17432fdf9bf670df33479c68705868be39eb4d53f67fc489fe44ac2e7645dd5e2ed3e6e71752a2387b516ce0ab6dc99ac1d870fc75ffdad9df87031e9de4 |
24 |
DIST js_of_ocaml-2.8.1.tar.gz 1329825 SHA256 954ed80b3f37e10666e36ffa3c1d846e1913b8c7be9f0af79889f829b1333e1e SHA512 bce4b173c29396ce7f28f12afd3185cdf402150a7390b9f5a21f14f71e72b3e5ae16234ed65e9d7b18ed2c0de524b658495d62d4673dfe3e61d5f0556b5a125c WHIRLPOOL ac66e7fa70e7365dc5a404d95b9f14186d727756df3aaebfa5d433237d33cb1f070ad74db12136b2a2b2db75b3eac127729343838f361000f962f2a5bc309d79 |
25 |
-DIST js_of_ocaml-2.8.tar.gz 1330364 SHA256 98564d9a36025edb5edd9d58c565fc7b38a3b49f9b8e32d7dc29289d443894b0 SHA512 914b2a1a452acd494c3373fa65e858c2747bd7d946d6077320429160d4172f627978a0b4ee526fc6e39378dffc9c965b81e5a1f16eba1f60529e4a6b5f474c1e WHIRLPOOL cfb71c97c3c43e873dc1f83b26ccacf93be846940596e99f004e6539c5bfa15e810d290b254c4bfecce65133dc6b79247c3cb2cd301297b6062ac6526147f94d |
26 |
|
27 |
diff --git a/dev-ml/js_of_ocaml/files/oc43.patch b/dev-ml/js_of_ocaml/files/oc43.patch |
28 |
deleted file mode 100644 |
29 |
index face810..00000000 |
30 |
--- a/dev-ml/js_of_ocaml/files/oc43.patch |
31 |
+++ /dev/null |
32 |
@@ -1,1418 +0,0 @@ |
33 |
-commit 3e4d39ece5a67bfc17f47c3da8a95ccca789abd5 |
34 |
-Author: Hugo Heuzard <hugo.heuzard@×××××.com> |
35 |
-Date: Mon Mar 28 23:35:47 2016 +0100 |
36 |
- |
37 |
- Deriving_json for ocaml 4.03 |
38 |
- |
39 |
- move |
40 |
- |
41 |
-diff --git a/.gitignore b/.gitignore |
42 |
-index 71e4ccf..ccbb796 100644 |
43 |
---- a/.gitignore |
44 |
-+++ b/.gitignore |
45 |
-@@ -58,6 +58,7 @@ benchmarks/results |
46 |
- benchmarks/config |
47 |
- lib/deriving_json/deriving_Json_lexer.ml |
48 |
- lib/ppx/ppx_js.ml |
49 |
-+lib/ppx/ppx_deriving_json.ml |
50 |
- lib/ppx/ppx_js |
51 |
- Makefile.local |
52 |
- |
53 |
-diff --git a/lib/ppx/ppx_deriving_json.cppo.ml b/lib/ppx/ppx_deriving_json.cppo.ml |
54 |
-new file mode 100644 |
55 |
-index 0000000..814ed99 |
56 |
---- /dev/null |
57 |
-+++ b/lib/ppx/ppx_deriving_json.cppo.ml |
58 |
-@@ -0,0 +1,711 @@ |
59 |
-+(* Js_of_ocaml |
60 |
-+ * http://www.ocsigen.org |
61 |
-+ * Copyright Vasilis Papavasileiou 2015 |
62 |
-+ * |
63 |
-+ * This program is free software; you can redistribute it and/or modify |
64 |
-+ * it under the terms of the GNU Lesser General Public License as published by |
65 |
-+ * the Free Software Foundation, with linking exception; |
66 |
-+ * either version 2.1 of the License, or (at your option) any later version. |
67 |
-+ * |
68 |
-+ * This program is distributed in the hope that it will be useful, |
69 |
-+ * but WITHOUT ANY WARRANTY; without even the implied warranty of |
70 |
-+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
71 |
-+ * GNU Lesser General Public License for more details. |
72 |
-+ * |
73 |
-+ * You should have received a copy of the GNU Lesser General Public License |
74 |
-+ * along with this program; if not, write to the Free Software |
75 |
-+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
76 |
-+ *) |
77 |
-+ |
78 |
-+let deriver = "json" |
79 |
-+ |
80 |
-+(* Copied (and adapted) this from ppx_deriving repo (commit |
81 |
-+ e2079fa8f3460055bf990461f295c6c4b391fafc) ; we get an empty set of |
82 |
-+ let bindings with ppx_deriving 3.0 *) |
83 |
-+let sanitize expr = [%expr |
84 |
-+ (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] |
85 |
-+ |
86 |
-+let var_ptuple l = |
87 |
-+ List.map Ast_convenience.pvar l |> Ast_helper.Pat.tuple |
88 |
-+ |
89 |
-+let map_loc f {Location.txt; loc} = |
90 |
-+ {Location.txt = f txt; loc} |
91 |
-+ |
92 |
-+let suffix_lid {Location.txt; loc} ~suffix = |
93 |
-+ let txt = Ppx_deriving.mangle_lid (`Suffix suffix) txt in |
94 |
-+ Ast_helper.Exp.ident {txt; loc} ~loc |
95 |
-+ |
96 |
-+let suffix_decl ({Parsetree.ptype_loc = loc} as d) ~suffix = |
97 |
-+ (let s = |
98 |
-+ Ppx_deriving.mangle_type_decl (`Suffix suffix) d |> |
99 |
-+ Longident.parse |
100 |
-+ in |
101 |
-+ Location.mkloc s loc) |> Ast_helper.Exp.ident ~loc |
102 |
-+ |
103 |
-+let suffix_decl_p ({Parsetree.ptype_loc = loc} as d) ~suffix = |
104 |
-+ (let s = Ppx_deriving.mangle_type_decl (`Suffix suffix) d in |
105 |
-+ Location.mkloc s loc) |> Ast_helper.Pat.var ~loc |
106 |
-+ |
107 |
-+let rec fresh_vars ?(acc = []) n = |
108 |
-+ if n <= 0 then |
109 |
-+ List.rev acc |
110 |
-+ else |
111 |
-+ let acc = Ppx_deriving.fresh_var acc :: acc in |
112 |
-+ fresh_vars ~acc (n - 1) |
113 |
-+ |
114 |
-+let unreachable_case () = |
115 |
-+ Ast_helper.Exp.case [%pat? _ ] [%expr assert false] |
116 |
-+ |
117 |
-+let label_of_constructor = map_loc (fun c -> Longident.Lident c) |
118 |
-+ |
119 |
-+let wrap_write r ~pattern = [%expr fun buf [%p pattern] -> [%e r]] |
120 |
-+ |
121 |
-+let buf_expand r = [%expr fun buf -> [%e r]] |
122 |
-+ |
123 |
-+let seqlist = function |
124 |
-+ | h :: l -> |
125 |
-+ let f acc e = [%expr [%e acc]; [%e e]] in |
126 |
-+ List.fold_left f h l |
127 |
-+ | [] -> |
128 |
-+ [%expr ()] |
129 |
-+ |
130 |
-+let check_record_fields = |
131 |
-+ List.iter @@ function |
132 |
-+ | {Parsetree.pld_mutable = Mutable} -> |
133 |
-+ Location.raise_errorf |
134 |
-+ "%s cannot be derived for mutable records" deriver |
135 |
-+ | {pld_type = {ptyp_desc = Ptyp_poly _}} -> |
136 |
-+ Location.raise_errorf |
137 |
-+ "%s cannot be derived for polymorphic records" deriver |
138 |
-+ | _ -> |
139 |
-+ () |
140 |
-+ |
141 |
-+let maybe_tuple_type = function |
142 |
-+ | [y] -> y |
143 |
-+ | l -> Ast_helper.Typ.tuple l |
144 |
-+ |
145 |
-+let rec write_tuple_contents l ly ~tag ~poly = |
146 |
-+ let e = |
147 |
-+ let f v y = |
148 |
-+ let arg = Ast_convenience.evar v in |
149 |
-+ let e = write_body_of_type y ~arg ~poly in |
150 |
-+ [%expr Buffer.add_string buf ","; [%e e]] |
151 |
-+ in |
152 |
-+ List.map2 f l ly |> seqlist |
153 |
-+ and s = Ast_convenience.str ("[" ^ string_of_int tag) in [%expr |
154 |
-+ Buffer.add_string buf [%e s]; |
155 |
-+ [%e e]; |
156 |
-+ Buffer.add_string buf "]"] |
157 |
-+ |
158 |
-+and write_body_of_tuple_type l ~arg ~poly ~tag = |
159 |
-+ let n = List.length l in |
160 |
-+ let vars = fresh_vars n in |
161 |
-+ let e = write_tuple_contents vars l ~tag ~poly |
162 |
-+ and p = var_ptuple vars in |
163 |
-+ [%expr let [%p p] = [%e arg] in [%e e]] |
164 |
-+ |
165 |
-+and write_poly_case r ~arg ~poly = |
166 |
-+ match r with |
167 |
-+ | Parsetree.Rtag (label, _, _, l) -> |
168 |
-+ let i = Ppx_deriving.hash_variant label |
169 |
-+ and n = List.length l in |
170 |
-+ let v = Ppx_deriving.fresh_var [] in |
171 |
-+ let lhs = |
172 |
-+ (if n = 0 then None else Some (Ast_convenience.pvar v)) |> |
173 |
-+ Ast_helper.Pat.variant label |
174 |
-+ and rhs = |
175 |
-+ match l with |
176 |
-+ | [] -> |
177 |
-+ let e = Ast_convenience.int i in |
178 |
-+ [%expr Deriving_Json.Json_int.write buf [%e e]] |
179 |
-+ | _ -> |
180 |
-+ let l = [[%type: int]; maybe_tuple_type l] |
181 |
-+ and arg = Ast_helper.Exp.tuple Ast_convenience.[int i; evar v] in |
182 |
-+ write_body_of_tuple_type l ~arg ~poly ~tag:0 |
183 |
-+ in |
184 |
-+ Ast_helper.Exp.case lhs rhs |
185 |
-+ | Rinherit ({ptyp_desc = Ptyp_constr (lid, _)} as y) -> |
186 |
-+ Ast_helper.Exp.case (Ast_helper.Pat.type_ lid) |
187 |
-+ (write_body_of_type y ~arg ~poly) |
188 |
-+ | Rinherit {ptyp_loc} -> |
189 |
-+ Location.raise_errorf ~loc:ptyp_loc |
190 |
-+ "%s write case cannot be derived" deriver |
191 |
-+ |
192 |
-+and write_body_of_type y ~arg ~poly = |
193 |
-+ match y with |
194 |
-+ | [%type: unit] -> |
195 |
-+ [%expr Deriving_Json.Json_unit.write buf [%e arg]] |
196 |
-+ | [%type: int] -> |
197 |
-+ [%expr Deriving_Json.Json_int.write buf [%e arg]] |
198 |
-+ | [%type: int32] | [%type: Int32.t] -> |
199 |
-+ [%expr Deriving_Json.Json_int32.write buf [%e arg]] |
200 |
-+ | [%type: int64] | [%type: Int64.t] -> |
201 |
-+ [%expr Deriving_Json.Json_int64.write buf [%e arg]] |
202 |
-+ | [%type: nativeint] | [%type: Nativeint.t] -> |
203 |
-+ [%expr Deriving_Json.Json_nativeint.write buf [%e arg]] |
204 |
-+ | [%type: float] -> |
205 |
-+ [%expr Deriving_Json.Json_float.write buf [%e arg]] |
206 |
-+ | [%type: bool] -> |
207 |
-+ [%expr Deriving_Json.Json_bool.write buf [%e arg]] |
208 |
-+ | [%type: char] -> |
209 |
-+ [%expr Deriving_Json.Json_char.write buf [%e arg]] |
210 |
-+ | [%type: string] -> |
211 |
-+ [%expr Deriving_Json.Json_string.write buf [%e arg]] |
212 |
-+ | [%type: bytes] -> |
213 |
-+ [%expr Deriving_Json.Json_bytes.write buf [%e arg]] |
214 |
-+ | [%type: [%t? y] list] -> |
215 |
-+ let e = write_of_type y ~poly in |
216 |
-+ [%expr Deriving_Json.write_list [%e e] buf [%e arg]] |
217 |
-+ | [%type: [%t? y] ref] -> |
218 |
-+ let e = write_of_type y ~poly in |
219 |
-+ [%expr Deriving_Json.write_ref [%e e] buf [%e arg]] |
220 |
-+ | [%type: [%t? y] option] -> |
221 |
-+ let e = write_of_type y ~poly in |
222 |
-+ [%expr Deriving_Json.write_option [%e e] buf [%e arg]] |
223 |
-+ | [%type: [%t? y] array] -> |
224 |
-+ let e = write_of_type y ~poly in |
225 |
-+ [%expr Deriving_Json.write_array [%e e] buf [%e arg]] |
226 |
-+ | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> |
227 |
-+ [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf [%e arg]] |
228 |
-+ | { Parsetree.ptyp_desc = Ptyp_tuple l } -> |
229 |
-+ write_body_of_tuple_type l ~arg ~poly ~tag:0 |
230 |
-+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> |
231 |
-+ List.map (write_poly_case ~arg ~poly) l @ [unreachable_case ()] |> |
232 |
-+ Ast_helper.Exp.match_ arg |
233 |
-+ | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> |
234 |
-+ let e = suffix_lid lid ~suffix:"to_json" |
235 |
-+ and l = List.map (write_of_type ~poly) l in |
236 |
-+ [%expr [%e Ast_convenience.app e l] buf [%e arg]] |
237 |
-+ | { Parsetree.ptyp_loc } -> |
238 |
-+ Location.raise_errorf ~loc:ptyp_loc |
239 |
-+ "%s_write cannot be derived for %s" |
240 |
-+ deriver (Ppx_deriving.string_of_core_type y) |
241 |
-+ |
242 |
-+and write_of_type y ~poly = |
243 |
-+ let v = "a" in |
244 |
-+ let arg = Ast_convenience.evar v |
245 |
-+ and pattern = Ast_convenience.pvar v in |
246 |
-+ wrap_write (write_body_of_type y ~arg ~poly) ~pattern |
247 |
-+ |
248 |
-+and write_of_record ?(tag=0) d l = |
249 |
-+ let pattern = |
250 |
-+ let l = |
251 |
-+ let f {Parsetree.pld_name} = |
252 |
-+ label_of_constructor pld_name, |
253 |
-+ Ast_helper.Pat.var pld_name |
254 |
-+ in |
255 |
-+ List.map f l |
256 |
-+ in |
257 |
-+ Ast_helper.Pat.record l Asttypes.Closed |
258 |
-+ and e = |
259 |
-+ let l = |
260 |
-+ let f {Parsetree.pld_name = {txt}} = txt in |
261 |
-+ List.map f l |
262 |
-+ and ly = |
263 |
-+ let f {Parsetree.pld_type} = pld_type in |
264 |
-+ List.map f l |
265 |
-+ in |
266 |
-+ write_tuple_contents l ly ~tag ~poly:true |
267 |
-+ in |
268 |
-+ wrap_write e ~pattern |
269 |
-+ |
270 |
-+let recognize_case_of_constructor i l = |
271 |
-+ let lhs = |
272 |
-+ match l with |
273 |
-+ | [] -> [%pat? `Cst [%p Ast_convenience.pint i]] |
274 |
-+ | _ -> [%pat? `NCst [%p Ast_convenience.pint i]] |
275 |
-+ in |
276 |
-+ Ast_helper.Exp.case lhs [%expr true] |
277 |
-+ |
278 |
-+let recognize_body_of_poly_variant l ~loc = |
279 |
-+ let l = |
280 |
-+ let f = function |
281 |
-+ | Parsetree.Rtag (label, _, _, l) -> |
282 |
-+ let i = Ppx_deriving.hash_variant label in |
283 |
-+ recognize_case_of_constructor i l |
284 |
-+ | Rinherit {ptyp_desc = Ptyp_constr (lid, _)} -> |
285 |
-+ let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] in |
286 |
-+ Ast_helper.Exp.case ~guard [%pat? x] [%expr true] |
287 |
-+ | _ -> |
288 |
-+ Location.raise_errorf ~loc |
289 |
-+ "%s_recognize cannot be derived" deriver |
290 |
-+ and default = Ast_helper.Exp.case [%pat? _] [%expr false] in |
291 |
-+ List.map f l @ [default] |
292 |
-+ in |
293 |
-+ Ast_helper.Exp.function_ l |
294 |
-+ |
295 |
-+let tag_error_case ?(typename="") () = |
296 |
-+ let y = Ast_convenience.str typename in |
297 |
-+ Ast_helper.Exp.case |
298 |
-+ [%pat? _] |
299 |
-+ [%expr Deriving_Json_lexer.tag_error ~typename:[%e y] buf] |
300 |
-+ |
301 |
-+let maybe_tuple_type = function |
302 |
-+ | [y] -> y |
303 |
-+ | l -> Ast_helper.Typ.tuple l |
304 |
-+ |
305 |
-+let rec read_poly_case ?decl y = function |
306 |
-+ | Parsetree.Rtag (label, _, _, l) -> |
307 |
-+ let i = Ppx_deriving.hash_variant label |> Ast_convenience.pint in |
308 |
-+ (match l with |
309 |
-+ | [] -> |
310 |
-+ Ast_helper.Exp.case [%pat? `Cst [%p i]] |
311 |
-+ (Ast_helper.Exp.variant label None) |
312 |
-+ | l -> |
313 |
-+ Ast_helper.Exp.case [%pat? `NCst [%p i]] [%expr |
314 |
-+ Deriving_Json_lexer.read_comma buf; |
315 |
-+ let v = [%e read_body_of_type ?decl (maybe_tuple_type l)] in |
316 |
-+ Deriving_Json_lexer.read_rbracket buf; |
317 |
-+ [%e Ast_helper.Exp.variant label (Some [%expr v])]]) |
318 |
-+ | Rinherit {ptyp_desc = Ptyp_constr (lid, l)} -> |
319 |
-+ let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] |
320 |
-+ and e = |
321 |
-+ let e = suffix_lid lid ~suffix:"of_json_with_tag" |
322 |
-+ and l = List.map (read_of_type ?decl) l in |
323 |
-+ [%expr ([%e Ast_convenience.app e l] buf x :> [%t y])] |
324 |
-+ in |
325 |
-+ Ast_helper.Exp.case ~guard [%pat? x] e |
326 |
-+ | Rinherit {ptyp_loc} -> |
327 |
-+ Location.raise_errorf ~loc:ptyp_loc |
328 |
-+ "%s read case cannot be derived" deriver |
329 |
-+ |
330 |
-+and read_of_poly_variant ?decl l y ~loc = |
331 |
-+ List.map (read_poly_case ?decl y) l @ [tag_error_case ()] |> |
332 |
-+ Ast_helper.Exp.function_ |> |
333 |
-+ buf_expand |
334 |
-+ |
335 |
-+and read_tuple_contents ?decl l ~f = |
336 |
-+ let n = List.length l in |
337 |
-+ let lv = fresh_vars n in |
338 |
-+ let f v y acc = |
339 |
-+ let e = read_body_of_type ?decl y in [%expr |
340 |
-+ Deriving_Json_lexer.read_comma buf; |
341 |
-+ let [%p Ast_convenience.pvar v] = [%e e] in |
342 |
-+ [%e acc]] |
343 |
-+ and acc = List.map Ast_convenience.evar lv |> f in |
344 |
-+ let acc = [%expr Deriving_Json_lexer.read_rbracket buf; [%e acc]] in |
345 |
-+ List.fold_right2 f lv l acc |
346 |
-+ |
347 |
-+and read_body_of_tuple_type ?decl l = [%expr |
348 |
-+ Deriving_Json_lexer.read_lbracket buf; |
349 |
-+ ignore (Deriving_Json_lexer.read_tag_1 0 buf); |
350 |
-+ [%e read_tuple_contents ?decl l ~f:Ast_helper.Exp.tuple]] |
351 |
-+ |
352 |
-+and read_of_record_raw ?decl l = |
353 |
-+ let f = |
354 |
-+ let f {Parsetree.pld_name} e = label_of_constructor pld_name, e in |
355 |
-+ fun l' -> Ast_helper.Exp.record (List.map2 f l l') None |
356 |
-+ and l = |
357 |
-+ let f {Parsetree.pld_type} = pld_type in |
358 |
-+ List.map f l |
359 |
-+ in |
360 |
-+ read_tuple_contents l ?decl ~f |
361 |
-+ |
362 |
-+and read_of_record decl l = |
363 |
-+ let e = read_of_record_raw ~decl l in |
364 |
-+ [%expr |
365 |
-+ Deriving_Json_lexer.read_lbracket buf; |
366 |
-+ ignore (Deriving_Json_lexer.read_tag_2 0 254 buf); |
367 |
-+ [%e e]] |> buf_expand |
368 |
-+ |
369 |
-+and read_body_of_type ?decl y = |
370 |
-+ let poly = match decl with Some _ -> true | _ -> false in |
371 |
-+ match y with |
372 |
-+ | [%type: unit] -> |
373 |
-+ [%expr Deriving_Json.Json_unit.read buf] |
374 |
-+ | [%type: int] -> |
375 |
-+ [%expr Deriving_Json.Json_int.read buf] |
376 |
-+ | [%type: int32] | [%type: Int32.t] -> |
377 |
-+ [%expr Deriving_Json.Json_int32.read buf] |
378 |
-+ | [%type: int64] | [%type: Int64.t] -> |
379 |
-+ [%expr Deriving_Json.Json_int64.read buf] |
380 |
-+ | [%type: nativeint] | [%type: Nativeint.t] -> |
381 |
-+ [%expr Deriving_Json.Json_nativeint.read buf] |
382 |
-+ | [%type: float] -> |
383 |
-+ [%expr Deriving_Json.Json_float.read buf] |
384 |
-+ | [%type: bool] -> |
385 |
-+ [%expr Deriving_Json.Json_bool.read buf] |
386 |
-+ | [%type: char] -> |
387 |
-+ [%expr Deriving_Json.Json_char.read buf] |
388 |
-+ | [%type: string] -> |
389 |
-+ [%expr Deriving_Json.Json_string.read buf] |
390 |
-+ | [%type: bytes] -> |
391 |
-+ [%expr Deriving_Json.Json_bytes.read buf] |
392 |
-+ | [%type: [%t? y] list] -> |
393 |
-+ [%expr Deriving_Json.read_list [%e read_of_type ?decl y] buf] |
394 |
-+ | [%type: [%t? y] ref] -> |
395 |
-+ [%expr Deriving_Json.read_ref [%e read_of_type ?decl y] buf] |
396 |
-+ | [%type: [%t? y] option] -> |
397 |
-+ [%expr Deriving_Json.read_option [%e read_of_type ?decl y] buf] |
398 |
-+ | [%type: [%t? y] array] -> |
399 |
-+ [%expr Deriving_Json.read_array [%e read_of_type ?decl y] buf] |
400 |
-+ | { Parsetree.ptyp_desc = Ptyp_tuple l } -> |
401 |
-+ read_body_of_tuple_type l ?decl |
402 |
-+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> |
403 |
-+ let e = |
404 |
-+ (match decl with |
405 |
-+ | Some decl -> |
406 |
-+ let e = suffix_decl decl ~suffix:"of_json_with_tag" |
407 |
-+ and l = |
408 |
-+ let {Parsetree.ptype_params = l} = decl |
409 |
-+ and f (y, _) = read_of_type y ~decl in |
410 |
-+ List.map f l |
411 |
-+ in |
412 |
-+ Ast_convenience.app e l |
413 |
-+ | None -> |
414 |
-+ read_of_poly_variant l y ~loc) |
415 |
-+ and tag = [%expr Deriving_Json_lexer.read_vcase buf] in |
416 |
-+ [%expr [%e e] buf [%e tag]] |
417 |
-+ | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> |
418 |
-+ [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf] |
419 |
-+ | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> |
420 |
-+ let e = suffix_lid lid ~suffix:"of_json" |
421 |
-+ and l = List.map (read_of_type ?decl) l in |
422 |
-+ [%expr [%e Ast_convenience.app e l] buf] |
423 |
-+ | { Parsetree.ptyp_loc } -> |
424 |
-+ Location.raise_errorf ~loc:ptyp_loc |
425 |
-+ "%s_read cannot be derived for %s" deriver |
426 |
-+ (Ppx_deriving.string_of_core_type y) |
427 |
-+ |
428 |
-+and read_of_type ?decl y = |
429 |
-+ read_body_of_type ?decl y |> buf_expand |
430 |
-+ |
431 |
-+let json_of_type ?decl y = |
432 |
-+ let read = read_of_type ?decl y |
433 |
-+ and write = |
434 |
-+ let poly = match decl with Some _ -> true | _ -> false in |
435 |
-+ write_of_type y ~poly in |
436 |
-+ [%expr Deriving_Json.make [%e write] [%e read]] |
437 |
-+ |
438 |
-+let fun_str_wrap d e y ~f ~suffix = |
439 |
-+ let e = Ppx_deriving.poly_fun_of_type_decl d e |> sanitize |
440 |
-+ and v = suffix_decl_p d ~suffix |
441 |
-+ and y = Ppx_deriving.poly_arrow_of_type_decl f d y in |
442 |
-+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
443 |
-+ |
444 |
-+let read_str_wrap d e = |
445 |
-+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] |
446 |
-+ and suffix = "of_json" in |
447 |
-+ let y = f (Ppx_deriving.core_type_of_type_decl d) in |
448 |
-+ fun_str_wrap d e y ~f ~suffix |
449 |
-+ |
450 |
-+let read_tag_str_wrap d e = |
451 |
-+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] |
452 |
-+ and suffix = "of_json_with_tag" |
453 |
-+ and y = |
454 |
-+ let y = Ppx_deriving.core_type_of_type_decl d in |
455 |
-+ [%type: Deriving_Json_lexer.lexbuf -> |
456 |
-+ [`NCst of int | `Cst of int] -> [%t y]] |
457 |
-+ in |
458 |
-+ fun_str_wrap d e y ~f ~suffix |
459 |
-+ |
460 |
-+let write_str_wrap d e = |
461 |
-+ let f y = [%type: Buffer.t -> [%t y] -> unit] |
462 |
-+ and suffix = "to_json" in |
463 |
-+ let y = |
464 |
-+ let y = Ppx_deriving.core_type_of_type_decl d in |
465 |
-+ (match d with |
466 |
-+ | {ptype_manifest = |
467 |
-+ Some {ptyp_desc = Parsetree.Ptyp_variant (_, _, _)}} -> |
468 |
-+ [%type: [> [%t y]]] |
469 |
-+ | _ -> |
470 |
-+ y) |> f |
471 |
-+ in |
472 |
-+ fun_str_wrap d e y ~f ~suffix |
473 |
-+ |
474 |
-+let recognize_str_wrap d e = |
475 |
-+ let v = suffix_decl_p d ~suffix:"recognize" |
476 |
-+ and y = [%type: [`NCst of int | `Cst of int] -> bool] in |
477 |
-+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
478 |
-+ |
479 |
-+let json_poly_type d = |
480 |
-+ let f y = [%type: [%t y] Deriving_Json.t] in |
481 |
-+ let y = f (Ppx_deriving.core_type_of_type_decl d) in |
482 |
-+ Ppx_deriving.poly_arrow_of_type_decl f d y |
483 |
-+ |
484 |
-+let json_str_wrap d e = |
485 |
-+ let v = suffix_decl_p d ~suffix:"json" |
486 |
-+ and e = Ppx_deriving.(poly_fun_of_type_decl d e) |
487 |
-+ and y = json_poly_type d in |
488 |
-+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
489 |
-+ |
490 |
-+let json_str d = |
491 |
-+ let write = |
492 |
-+ let f acc id = |
493 |
-+ let poly = Ast_convenience.evar ("poly_" ^ id) in |
494 |
-+ [%expr [%e acc] (Deriving_Json.write [%e poly])] |
495 |
-+ and acc = suffix_decl d ~suffix:"to_json" in |
496 |
-+ Ppx_deriving.fold_left_type_decl f acc d |
497 |
-+ and read = |
498 |
-+ let f acc id = |
499 |
-+ let poly = Ast_convenience.evar ("poly_" ^ id) in |
500 |
-+ [%expr [%e acc] (Deriving_Json.read [%e poly])] |
501 |
-+ and acc = suffix_decl d ~suffix:"of_json" in |
502 |
-+ Ppx_deriving.fold_left_type_decl f acc d |
503 |
-+ in |
504 |
-+ [%expr Deriving_Json.make [%e write] [%e read]] |> |
505 |
-+ json_str_wrap d |
506 |
-+ |
507 |
-+let write_decl_of_type d y = |
508 |
-+ (let e = |
509 |
-+ let arg = Ast_convenience.evar "a" in |
510 |
-+ write_body_of_type y ~arg ~poly:true |
511 |
-+ in |
512 |
-+ [%expr fun buf a -> [%e e]]) |> write_str_wrap d |
513 |
-+ |
514 |
-+let read_decl_of_type decl y = |
515 |
-+ read_body_of_type y ~decl |> buf_expand |> read_str_wrap decl |
516 |
-+ |
517 |
-+let json_decls_of_type decl y = |
518 |
-+ let recognize, read_tag = |
519 |
-+ match y with |
520 |
-+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); |
521 |
-+ ptyp_loc = loc } -> |
522 |
-+ Some (recognize_body_of_poly_variant l ~loc |
523 |
-+ |> recognize_str_wrap decl), |
524 |
-+ Some (read_of_poly_variant l y ~decl ~loc |
525 |
-+ |> read_tag_str_wrap decl) |
526 |
-+ | _ -> |
527 |
-+ None, None |
528 |
-+ in |
529 |
-+ write_decl_of_type decl y, |
530 |
-+ read_decl_of_type decl y, |
531 |
-+ json_str decl, |
532 |
-+ recognize, read_tag |
533 |
-+ |
534 |
-+let write_case (i, i', l) {Parsetree.pcd_name; pcd_args; pcd_loc} = |
535 |
-+ let i, i', lhs, rhs = |
536 |
-+ match pcd_args with |
537 |
-+#if OCAML_VERSION >= (4, 03, 0) |
538 |
-+ | Pcstr_tuple [] | Pcstr_record [] -> |
539 |
-+#else |
540 |
-+ | [] -> |
541 |
-+#endif |
542 |
-+ i + 1, |
543 |
-+ i', |
544 |
-+ None, |
545 |
-+ [%expr Deriving_Json.Json_int.write buf |
546 |
-+ [%e Ast_convenience.int i]] |
547 |
-+#if OCAML_VERSION >= (4, 03, 0) |
548 |
-+ | Pcstr_tuple ([ _ ] as args) -> |
549 |
-+#else |
550 |
-+ | [ _ ] as args -> |
551 |
-+#endif |
552 |
-+ let v = Ppx_deriving.fresh_var [] in |
553 |
-+ i, |
554 |
-+ i' + 1, |
555 |
-+ Some (Ast_convenience.pvar v), |
556 |
-+ write_tuple_contents [v] args ~tag:i' ~poly:true |
557 |
-+#if OCAML_VERSION >= (4, 03, 0) |
558 |
-+ | Pcstr_tuple args -> |
559 |
-+#else |
560 |
-+ | args -> |
561 |
-+#endif |
562 |
-+ let vars = fresh_vars (List.length args) in |
563 |
-+ i, |
564 |
-+ i' + 1, |
565 |
-+ Some (var_ptuple vars), |
566 |
-+ write_tuple_contents vars args ~tag:i' ~poly:true |
567 |
-+#if OCAML_VERSION >= (4, 03, 0) |
568 |
-+ | Pcstr_record args -> |
569 |
-+ let vars = fresh_vars (List.length args) in |
570 |
-+ i, |
571 |
-+ i' + 1, |
572 |
-+ Some (var_ptuple vars), |
573 |
-+ write_of_record vars args ~tag:i' |
574 |
-+#endif |
575 |
-+ in |
576 |
-+ i, i', |
577 |
-+ Ast_helper. |
578 |
-+ (Exp.case (Pat.construct (label_of_constructor pcd_name) lhs) |
579 |
-+ rhs) :: l |
580 |
-+ |
581 |
-+let write_decl_of_variant d l = |
582 |
-+ (let _, _, l = List.fold_left write_case (0, 0, []) l in |
583 |
-+ Ast_helper.Exp.function_ l) |> buf_expand |> |
584 |
-+ write_str_wrap d |
585 |
-+ |
586 |
-+let read_case ?decl (i, i', l) |
587 |
-+ {Parsetree.pcd_name; pcd_args; pcd_loc} = |
588 |
-+ match pcd_args with |
589 |
-+#if OCAML_VERSION >= (4, 03, 0) |
590 |
-+ | Pcstr_tuple [] | Pcstr_record [] -> |
591 |
-+#else |
592 |
-+ | [] -> |
593 |
-+#endif |
594 |
-+ i + 1, i', |
595 |
-+ Ast_helper.Exp.case |
596 |
-+ [%pat? `Cst [%p Ast_convenience.pint i]] |
597 |
-+ (Ast_helper.Exp.construct (label_of_constructor pcd_name) None) |
598 |
-+ :: l |
599 |
-+#if OCAML_VERSION >= (4, 03, 0) |
600 |
-+ | Pcstr_tuple pcd_args -> |
601 |
-+#else |
602 |
-+ | pcd_args -> |
603 |
-+#endif |
604 |
-+ let f l = |
605 |
-+ let args = |
606 |
-+ match l with |
607 |
-+ | [] -> None |
608 |
-+ | [e] -> Some e |
609 |
-+ | l -> Some (Ast_helper.Exp.tuple l) |
610 |
-+ in Ast_helper.Exp.construct (label_of_constructor pcd_name) args |
611 |
-+ in |
612 |
-+ let expr = read_tuple_contents ?decl pcd_args ~f in |
613 |
-+ let case = Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']] expr in |
614 |
-+ i, i' + 1, case :: l |
615 |
-+#if OCAML_VERSION >= (4, 03, 0) |
616 |
-+ | Pcstr_record pcd_args -> |
617 |
-+ let expr = read_of_record_raw ?decl pcd_args in |
618 |
-+ let case = Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']] expr in |
619 |
-+ i, i' + 1, case :: l |
620 |
-+#endif |
621 |
-+ |
622 |
-+let read_decl_of_variant decl l = |
623 |
-+ (let _, _, l = List.fold_left (read_case ~decl) (0, 0, []) l |
624 |
-+ and e = [%expr Deriving_Json_lexer.read_case buf] in |
625 |
-+ Ast_helper.Exp.match_ e (l @ [tag_error_case ()])) |> |
626 |
-+ buf_expand |> |
627 |
-+ read_str_wrap decl |
628 |
-+ |
629 |
-+let json_decls_of_variant d l = |
630 |
-+ write_decl_of_variant d l, read_decl_of_variant d l, json_str d, |
631 |
-+ None, None |
632 |
-+ |
633 |
-+let write_decl_of_record d l = |
634 |
-+ write_of_record d l |> write_str_wrap d |
635 |
-+ |
636 |
-+let read_decl_of_record d l = |
637 |
-+ read_of_record d l |> read_str_wrap d |
638 |
-+ |
639 |
-+let json_decls_of_record d l = |
640 |
-+ check_record_fields l; |
641 |
-+ write_decl_of_record d l, read_decl_of_record d l, json_str d, |
642 |
-+ None, None |
643 |
-+ |
644 |
-+let json_str_of_decl ({Parsetree.ptype_loc} as d) = |
645 |
-+ Ast_helper.with_default_loc ptype_loc @@ fun () -> |
646 |
-+ match d with |
647 |
-+ | { Parsetree.ptype_manifest = Some y } -> |
648 |
-+ json_decls_of_type d y |
649 |
-+ | { ptype_kind = Ptype_variant l } -> |
650 |
-+ json_decls_of_variant d l |
651 |
-+ | { ptype_kind = Ptype_record l } -> |
652 |
-+ json_decls_of_record d l |
653 |
-+ | _ -> |
654 |
-+ Location.raise_errorf "%s cannot be derived for %s" deriver |
655 |
-+ (Ppx_deriving.mangle_type_decl (`Suffix "") d) |
656 |
-+ |
657 |
-+let read_sig_of_decl ({Parsetree.ptype_loc} as d) = |
658 |
-+ (let s = |
659 |
-+ let s = Ppx_deriving.mangle_type_decl (`Suffix "of_json") d in |
660 |
-+ Location.mkloc s ptype_loc |
661 |
-+ and y = |
662 |
-+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in |
663 |
-+ let y = f (Ppx_deriving.core_type_of_type_decl d) in |
664 |
-+ Ppx_deriving.poly_arrow_of_type_decl f d y |
665 |
-+ in |
666 |
-+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
667 |
-+ |
668 |
-+let recognize_sig_of_decl ({Parsetree.ptype_loc} as d) = |
669 |
-+ (let s = |
670 |
-+ let s = Ppx_deriving.mangle_type_decl (`Suffix "recognize") d in |
671 |
-+ Location.mkloc s ptype_loc |
672 |
-+ and y = [%type: [ `NCst of int | `Cst of int ] -> bool] in |
673 |
-+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
674 |
-+ |
675 |
-+let read_with_tag_sig_of_decl ({Parsetree.ptype_loc} as d) = |
676 |
-+ (let s = |
677 |
-+ let s = |
678 |
-+ Ppx_deriving.mangle_type_decl (`Suffix "of_json_with_tag") d |
679 |
-+ in |
680 |
-+ Location.mkloc s ptype_loc |
681 |
-+ and y = |
682 |
-+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in |
683 |
-+ let y = |
684 |
-+ let y = Ppx_deriving.core_type_of_type_decl d in |
685 |
-+ f [%type: [ `NCst of int | `Cst of int ] -> [%t y]] |
686 |
-+ in |
687 |
-+ Ppx_deriving.poly_arrow_of_type_decl f d y |
688 |
-+ in |
689 |
-+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
690 |
-+ |
691 |
-+let write_sig_of_decl ({Parsetree.ptype_loc} as d) = |
692 |
-+ (let s = |
693 |
-+ let s = Ppx_deriving.mangle_type_decl (`Suffix "to_json") d in |
694 |
-+ Location.mkloc s ptype_loc |
695 |
-+ and y = |
696 |
-+ let f y = [%type: Buffer.t -> [%t y] -> unit] in |
697 |
-+ let y = f (Ppx_deriving.core_type_of_type_decl d) in |
698 |
-+ Ppx_deriving.poly_arrow_of_type_decl f d y |
699 |
-+ in |
700 |
-+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
701 |
-+ |
702 |
-+let json_sig_of_decl ({Parsetree.ptype_loc} as d) = |
703 |
-+ (let s = |
704 |
-+ let s = Ppx_deriving.mangle_type_decl (`Suffix "json") d in |
705 |
-+ Location.mkloc s ptype_loc |
706 |
-+ and y = |
707 |
-+ let f y = [%type: [%t y] Deriving_Json.t] in |
708 |
-+ let y = f (Ppx_deriving.core_type_of_type_decl d) in |
709 |
-+ Ppx_deriving.poly_arrow_of_type_decl f d y |
710 |
-+ in |
711 |
-+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
712 |
-+ |
713 |
-+let sigs_of_decl ({Parsetree.ptype_loc} as d) = |
714 |
-+ Ast_helper.with_default_loc ptype_loc @@ fun () -> |
715 |
-+ let l = [ |
716 |
-+ read_sig_of_decl d; |
717 |
-+ write_sig_of_decl d; |
718 |
-+ json_sig_of_decl d |
719 |
-+ ] in |
720 |
-+ match d with |
721 |
-+ | { Parsetree.ptype_manifest = |
722 |
-+ Some {Parsetree.ptyp_desc = Parsetree.Ptyp_variant _}} -> |
723 |
-+ read_with_tag_sig_of_decl d :: recognize_sig_of_decl d :: l |
724 |
-+ | _ -> |
725 |
-+ l |
726 |
-+ |
727 |
-+let register_for_expr s f = |
728 |
-+ let core_type ({Parsetree.ptyp_loc} as y) = |
729 |
-+ let f () = f y |> sanitize in |
730 |
-+ Ast_helper.with_default_loc ptyp_loc f |
731 |
-+ in |
732 |
-+ Ppx_deriving.(create s ~core_type () |> register) |
733 |
-+ |
734 |
-+let _ = |
735 |
-+ register_for_expr "of_json" @@ fun y -> [%expr |
736 |
-+ fun s -> |
737 |
-+ [%e read_of_type y] |
738 |
-+ (Deriving_Json_lexer.init_lexer (Lexing.from_string s))] |
739 |
-+ |
740 |
-+let _ = |
741 |
-+ register_for_expr "to_json" @@ fun y -> [%expr |
742 |
-+ fun x -> |
743 |
-+ let buf = Buffer.create 50 in |
744 |
-+ [%e write_of_type y ~poly:false] buf x; |
745 |
-+ Buffer.contents buf] |
746 |
-+ |
747 |
-+let _ = |
748 |
-+ let core_type ({Parsetree.ptyp_loc} as y) = |
749 |
-+ let f () = json_of_type y |> sanitize in |
750 |
-+ Ast_helper.with_default_loc ptyp_loc f |
751 |
-+ and type_decl_str ~options ~path l = |
752 |
-+ let lw, lr, lj, lp, lrv = |
753 |
-+ let f d (lw, lr, lj, lp, lrv) = |
754 |
-+ let w, r, j, p, rv = json_str_of_decl d in |
755 |
-+ w :: lw, r :: lr, j :: lj, |
756 |
-+ (match p with Some p -> p :: lp | None -> lp), |
757 |
-+ (match rv with Some rv -> rv :: lrv | None -> lrv) |
758 |
-+ and acc = [], [], [], [], [] in |
759 |
-+ List.fold_right f l acc |
760 |
-+ and f = Ast_helper.Str.value Asttypes.Recursive |
761 |
-+ and f' = Ast_helper.Str.value Asttypes.Nonrecursive in |
762 |
-+ let l = [f (lrv @ lr); f lw; f' lj] in |
763 |
-+ match lp with [] -> l | _ -> f lp :: l |
764 |
-+ and type_decl_sig ~options ~path l = |
765 |
-+ List.map sigs_of_decl l |> List.flatten |
766 |
-+ in |
767 |
-+ Ppx_deriving. |
768 |
-+ (create "json" ~core_type ~type_decl_str ~type_decl_sig () |
769 |
-+ |> register) |
770 |
-diff --git a/lib/ppx/ppx_deriving_json.ml b/lib/ppx/ppx_deriving_json.ml |
771 |
-deleted file mode 100644 |
772 |
-index e96ce3f..0000000 |
773 |
---- a/lib/ppx/ppx_deriving_json.ml |
774 |
-+++ /dev/null |
775 |
-@@ -1,675 +0,0 @@ |
776 |
--(* Js_of_ocaml |
777 |
-- * http://www.ocsigen.org |
778 |
-- * Copyright Vasilis Papavasileiou 2015 |
779 |
-- * |
780 |
-- * This program is free software; you can redistribute it and/or modify |
781 |
-- * it under the terms of the GNU Lesser General Public License as published by |
782 |
-- * the Free Software Foundation, with linking exception; |
783 |
-- * either version 2.1 of the License, or (at your option) any later version. |
784 |
-- * |
785 |
-- * This program is distributed in the hope that it will be useful, |
786 |
-- * but WITHOUT ANY WARRANTY; without even the implied warranty of |
787 |
-- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
788 |
-- * GNU Lesser General Public License for more details. |
789 |
-- * |
790 |
-- * You should have received a copy of the GNU Lesser General Public License |
791 |
-- * along with this program; if not, write to the Free Software |
792 |
-- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
793 |
-- *) |
794 |
-- |
795 |
--let deriver = "json" |
796 |
-- |
797 |
--(* Copied (and adapted) this from ppx_deriving repo (commit |
798 |
-- e2079fa8f3460055bf990461f295c6c4b391fafc) ; we get an empty set of |
799 |
-- let bindings with ppx_deriving 3.0 *) |
800 |
--let sanitize expr = [%expr |
801 |
-- (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] |
802 |
-- |
803 |
--let var_ptuple l = |
804 |
-- List.map Ast_convenience.pvar l |> Ast_helper.Pat.tuple |
805 |
-- |
806 |
--let map_loc f {Location.txt; loc} = |
807 |
-- {Location.txt = f txt; loc} |
808 |
-- |
809 |
--let suffix_lid {Location.txt; loc} ~suffix = |
810 |
-- let txt = Ppx_deriving.mangle_lid (`Suffix suffix) txt in |
811 |
-- Ast_helper.Exp.ident {txt; loc} ~loc |
812 |
-- |
813 |
--let suffix_decl ({Parsetree.ptype_loc = loc} as d) ~suffix = |
814 |
-- (let s = |
815 |
-- Ppx_deriving.mangle_type_decl (`Suffix suffix) d |> |
816 |
-- Longident.parse |
817 |
-- in |
818 |
-- Location.mkloc s loc) |> Ast_helper.Exp.ident ~loc |
819 |
-- |
820 |
--let suffix_decl_p ({Parsetree.ptype_loc = loc} as d) ~suffix = |
821 |
-- (let s = Ppx_deriving.mangle_type_decl (`Suffix suffix) d in |
822 |
-- Location.mkloc s loc) |> Ast_helper.Pat.var ~loc |
823 |
-- |
824 |
--let rec fresh_vars ?(acc = []) n = |
825 |
-- if n <= 0 then |
826 |
-- List.rev acc |
827 |
-- else |
828 |
-- let acc = Ppx_deriving.fresh_var acc :: acc in |
829 |
-- fresh_vars ~acc (n - 1) |
830 |
-- |
831 |
--let unreachable_case () = |
832 |
-- Ast_helper.Exp.case [%pat? _ ] [%expr assert false] |
833 |
-- |
834 |
--let label_of_constructor = map_loc (fun c -> Longident.Lident c) |
835 |
-- |
836 |
--let wrap_write r ~pattern = [%expr fun buf [%p pattern] -> [%e r]] |
837 |
-- |
838 |
--let buf_expand r = [%expr fun buf -> [%e r]] |
839 |
-- |
840 |
--let seqlist = function |
841 |
-- | h :: l -> |
842 |
-- let f acc e = [%expr [%e acc]; [%e e]] in |
843 |
-- List.fold_left f h l |
844 |
-- | [] -> |
845 |
-- [%expr ()] |
846 |
-- |
847 |
--let check_record_fields = |
848 |
-- List.iter @@ function |
849 |
-- | {Parsetree.pld_mutable = Mutable} -> |
850 |
-- Location.raise_errorf |
851 |
-- "%s cannot be derived for mutable records" deriver |
852 |
-- | {pld_type = {ptyp_desc = Ptyp_poly _}} -> |
853 |
-- Location.raise_errorf |
854 |
-- "%s cannot be derived for polymorphic records" deriver |
855 |
-- | _ -> |
856 |
-- () |
857 |
-- |
858 |
--let maybe_tuple_type = function |
859 |
-- | [y] -> y |
860 |
-- | l -> Ast_helper.Typ.tuple l |
861 |
-- |
862 |
--let rec write_tuple_contents l ly tag ~poly = |
863 |
-- let e = |
864 |
-- let f v y = |
865 |
-- let arg = Ast_convenience.evar v in |
866 |
-- let e = write_body_of_type y ~arg ~poly in |
867 |
-- [%expr Buffer.add_string buf ","; [%e e]] |
868 |
-- in |
869 |
-- List.map2 f l ly |> seqlist |
870 |
-- and s = Ast_convenience.str ("[" ^ string_of_int tag) in [%expr |
871 |
-- Buffer.add_string buf [%e s]; |
872 |
-- [%e e]; |
873 |
-- Buffer.add_string buf "]"] |
874 |
-- |
875 |
--and write_body_of_tuple_type l ~arg ~poly ~tag = |
876 |
-- let n = List.length l in |
877 |
-- let vars = fresh_vars n in |
878 |
-- let e = write_tuple_contents vars l tag ~poly |
879 |
-- and p = var_ptuple vars in |
880 |
-- [%expr let [%p p] = [%e arg] in [%e e]] |
881 |
-- |
882 |
--and write_poly_case r ~arg ~poly = |
883 |
-- match r with |
884 |
-- | Parsetree.Rtag (label, _, _, l) -> |
885 |
-- let i = Ppx_deriving.hash_variant label |
886 |
-- and n = List.length l in |
887 |
-- let v = Ppx_deriving.fresh_var [] in |
888 |
-- let lhs = |
889 |
-- (if n = 0 then None else Some (Ast_convenience.pvar v)) |> |
890 |
-- Ast_helper.Pat.variant label |
891 |
-- and rhs = |
892 |
-- match l with |
893 |
-- | [] -> |
894 |
-- let e = Ast_convenience.int i in |
895 |
-- [%expr Deriving_Json.Json_int.write buf [%e e]] |
896 |
-- | _ -> |
897 |
-- let l = [[%type: int]; maybe_tuple_type l] |
898 |
-- and arg = Ast_helper.Exp.tuple Ast_convenience.[int i; evar v] in |
899 |
-- write_body_of_tuple_type l ~arg ~poly ~tag:0 |
900 |
-- in |
901 |
-- Ast_helper.Exp.case lhs rhs |
902 |
-- | Rinherit ({ptyp_desc = Ptyp_constr (lid, _)} as y) -> |
903 |
-- Ast_helper.Exp.case (Ast_helper.Pat.type_ lid) |
904 |
-- (write_body_of_type y ~arg ~poly) |
905 |
-- | Rinherit {ptyp_loc} -> |
906 |
-- Location.raise_errorf ~loc:ptyp_loc |
907 |
-- "%s write case cannot be derived" deriver |
908 |
-- |
909 |
--and write_body_of_type y ~arg ~poly = |
910 |
-- match y with |
911 |
-- | [%type: unit] -> |
912 |
-- [%expr Deriving_Json.Json_unit.write buf [%e arg]] |
913 |
-- | [%type: int] -> |
914 |
-- [%expr Deriving_Json.Json_int.write buf [%e arg]] |
915 |
-- | [%type: int32] | [%type: Int32.t] -> |
916 |
-- [%expr Deriving_Json.Json_int32.write buf [%e arg]] |
917 |
-- | [%type: int64] | [%type: Int64.t] -> |
918 |
-- [%expr Deriving_Json.Json_int64.write buf [%e arg]] |
919 |
-- | [%type: nativeint] | [%type: Nativeint.t] -> |
920 |
-- [%expr Deriving_Json.Json_nativeint.write buf [%e arg]] |
921 |
-- | [%type: float] -> |
922 |
-- [%expr Deriving_Json.Json_float.write buf [%e arg]] |
923 |
-- | [%type: bool] -> |
924 |
-- [%expr Deriving_Json.Json_bool.write buf [%e arg]] |
925 |
-- | [%type: char] -> |
926 |
-- [%expr Deriving_Json.Json_char.write buf [%e arg]] |
927 |
-- | [%type: string] -> |
928 |
-- [%expr Deriving_Json.Json_string.write buf [%e arg]] |
929 |
-- | [%type: bytes] -> |
930 |
-- [%expr Deriving_Json.Json_bytes.write buf [%e arg]] |
931 |
-- | [%type: [%t? y] list] -> |
932 |
-- let e = write_of_type y ~poly in |
933 |
-- [%expr Deriving_Json.write_list [%e e] buf [%e arg]] |
934 |
-- | [%type: [%t? y] ref] -> |
935 |
-- let e = write_of_type y ~poly in |
936 |
-- [%expr Deriving_Json.write_ref [%e e] buf [%e arg]] |
937 |
-- | [%type: [%t? y] option] -> |
938 |
-- let e = write_of_type y ~poly in |
939 |
-- [%expr Deriving_Json.write_option [%e e] buf [%e arg]] |
940 |
-- | [%type: [%t? y] array] -> |
941 |
-- let e = write_of_type y ~poly in |
942 |
-- [%expr Deriving_Json.write_array [%e e] buf [%e arg]] |
943 |
-- | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> |
944 |
-- [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf [%e arg]] |
945 |
-- | { Parsetree.ptyp_desc = Ptyp_tuple l } -> |
946 |
-- write_body_of_tuple_type l ~arg ~poly ~tag:0 |
947 |
-- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> |
948 |
-- List.map (write_poly_case ~arg ~poly) l @ [unreachable_case ()] |> |
949 |
-- Ast_helper.Exp.match_ arg |
950 |
-- | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> |
951 |
-- let e = suffix_lid lid ~suffix:"to_json" |
952 |
-- and l = List.map (write_of_type ~poly) l in |
953 |
-- [%expr [%e Ast_convenience.app e l] buf [%e arg]] |
954 |
-- | { Parsetree.ptyp_loc } -> |
955 |
-- Location.raise_errorf ~loc:ptyp_loc |
956 |
-- "%s_write cannot be derived for %s" |
957 |
-- deriver (Ppx_deriving.string_of_core_type y) |
958 |
-- |
959 |
--and write_of_type y ~poly = |
960 |
-- let v = "a" in |
961 |
-- let arg = Ast_convenience.evar v |
962 |
-- and pattern = Ast_convenience.pvar v in |
963 |
-- wrap_write (write_body_of_type y ~arg ~poly) ~pattern |
964 |
-- |
965 |
--and write_of_record d l = |
966 |
-- let pattern = |
967 |
-- let l = |
968 |
-- let f {Parsetree.pld_name} = |
969 |
-- label_of_constructor pld_name, |
970 |
-- Ast_helper.Pat.var pld_name |
971 |
-- in |
972 |
-- List.map f l |
973 |
-- in |
974 |
-- Ast_helper.Pat.record l Asttypes.Closed |
975 |
-- and e = |
976 |
-- let l = |
977 |
-- let f {Parsetree.pld_name = {txt}} = txt in |
978 |
-- List.map f l |
979 |
-- and ly = |
980 |
-- let f {Parsetree.pld_type} = pld_type in |
981 |
-- List.map f l |
982 |
-- in |
983 |
-- write_tuple_contents l ly 0 ~poly:true |
984 |
-- in |
985 |
-- wrap_write e ~pattern |
986 |
-- |
987 |
--let recognize_case_of_constructor i l = |
988 |
-- let lhs = |
989 |
-- match l with |
990 |
-- | [] -> [%pat? `Cst [%p Ast_convenience.pint i]] |
991 |
-- | _ -> [%pat? `NCst [%p Ast_convenience.pint i]] |
992 |
-- in |
993 |
-- Ast_helper.Exp.case lhs [%expr true] |
994 |
-- |
995 |
--let recognize_body_of_poly_variant l ~loc = |
996 |
-- let l = |
997 |
-- let f = function |
998 |
-- | Parsetree.Rtag (label, _, _, l) -> |
999 |
-- let i = Ppx_deriving.hash_variant label in |
1000 |
-- recognize_case_of_constructor i l |
1001 |
-- | Rinherit {ptyp_desc = Ptyp_constr (lid, _)} -> |
1002 |
-- let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] in |
1003 |
-- Ast_helper.Exp.case ~guard [%pat? x] [%expr true] |
1004 |
-- | _ -> |
1005 |
-- Location.raise_errorf ~loc |
1006 |
-- "%s_recognize cannot be derived" deriver |
1007 |
-- and default = Ast_helper.Exp.case [%pat? _] [%expr false] in |
1008 |
-- List.map f l @ [default] |
1009 |
-- in |
1010 |
-- Ast_helper.Exp.function_ l |
1011 |
-- |
1012 |
--let tag_error_case ?(typename="") () = |
1013 |
-- let y = Ast_convenience.str typename in |
1014 |
-- Ast_helper.Exp.case |
1015 |
-- [%pat? _] |
1016 |
-- [%expr Deriving_Json_lexer.tag_error ~typename:[%e y] buf] |
1017 |
-- |
1018 |
--let maybe_tuple_type = function |
1019 |
-- | [y] -> y |
1020 |
-- | l -> Ast_helper.Typ.tuple l |
1021 |
-- |
1022 |
--let rec read_poly_case ?decl y = function |
1023 |
-- | Parsetree.Rtag (label, _, _, l) -> |
1024 |
-- let i = Ppx_deriving.hash_variant label |> Ast_convenience.pint in |
1025 |
-- (match l with |
1026 |
-- | [] -> |
1027 |
-- Ast_helper.Exp.case [%pat? `Cst [%p i]] |
1028 |
-- (Ast_helper.Exp.variant label None) |
1029 |
-- | l -> |
1030 |
-- Ast_helper.Exp.case [%pat? `NCst [%p i]] [%expr |
1031 |
-- Deriving_Json_lexer.read_comma buf; |
1032 |
-- let v = [%e read_body_of_type ?decl (maybe_tuple_type l)] in |
1033 |
-- Deriving_Json_lexer.read_rbracket buf; |
1034 |
-- [%e Ast_helper.Exp.variant label (Some [%expr v])]]) |
1035 |
-- | Rinherit {ptyp_desc = Ptyp_constr (lid, l)} -> |
1036 |
-- let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] |
1037 |
-- and e = |
1038 |
-- let e = suffix_lid lid ~suffix:"of_json_with_tag" |
1039 |
-- and l = List.map (read_of_type ?decl) l in |
1040 |
-- [%expr ([%e Ast_convenience.app e l] buf x :> [%t y])] |
1041 |
-- in |
1042 |
-- Ast_helper.Exp.case ~guard [%pat? x] e |
1043 |
-- | Rinherit {ptyp_loc} -> |
1044 |
-- Location.raise_errorf ~loc:ptyp_loc |
1045 |
-- "%s read case cannot be derived" deriver |
1046 |
-- |
1047 |
--and read_of_poly_variant ?decl l y ~loc = |
1048 |
-- List.map (read_poly_case ?decl y) l @ [tag_error_case ()] |> |
1049 |
-- Ast_helper.Exp.function_ |> |
1050 |
-- buf_expand |
1051 |
-- |
1052 |
--and read_tuple_contents ?decl l ~f = |
1053 |
-- let n = List.length l in |
1054 |
-- let lv = fresh_vars n in |
1055 |
-- let f v y acc = |
1056 |
-- let e = read_body_of_type ?decl y in [%expr |
1057 |
-- Deriving_Json_lexer.read_comma buf; |
1058 |
-- let [%p Ast_convenience.pvar v] = [%e e] in |
1059 |
-- [%e acc]] |
1060 |
-- and acc = List.map Ast_convenience.evar lv |> f in |
1061 |
-- let acc = [%expr Deriving_Json_lexer.read_rbracket buf; [%e acc]] in |
1062 |
-- List.fold_right2 f lv l acc |
1063 |
-- |
1064 |
--and read_body_of_tuple_type ?decl l = [%expr |
1065 |
-- Deriving_Json_lexer.read_lbracket buf; |
1066 |
-- ignore (Deriving_Json_lexer.read_tag_1 0 buf); |
1067 |
-- [%e read_tuple_contents ?decl l ~f:Ast_helper.Exp.tuple]] |
1068 |
-- |
1069 |
--and read_of_record decl l = |
1070 |
-- let e = |
1071 |
-- let f = |
1072 |
-- let f {Parsetree.pld_name} e = label_of_constructor pld_name, e in |
1073 |
-- fun l' -> Ast_helper.Exp.record (List.map2 f l l') None |
1074 |
-- and l = |
1075 |
-- let f {Parsetree.pld_type} = pld_type in |
1076 |
-- List.map f l |
1077 |
-- in |
1078 |
-- read_tuple_contents l ~decl ~f |
1079 |
-- in [%expr |
1080 |
-- Deriving_Json_lexer.read_lbracket buf; |
1081 |
-- ignore (Deriving_Json_lexer.read_tag_2 0 254 buf); |
1082 |
-- [%e e]] |> buf_expand |
1083 |
-- |
1084 |
--and read_body_of_type ?decl y = |
1085 |
-- let poly = match decl with Some _ -> true | _ -> false in |
1086 |
-- match y with |
1087 |
-- | [%type: unit] -> |
1088 |
-- [%expr Deriving_Json.Json_unit.read buf] |
1089 |
-- | [%type: int] -> |
1090 |
-- [%expr Deriving_Json.Json_int.read buf] |
1091 |
-- | [%type: int32] | [%type: Int32.t] -> |
1092 |
-- [%expr Deriving_Json.Json_int32.read buf] |
1093 |
-- | [%type: int64] | [%type: Int64.t] -> |
1094 |
-- [%expr Deriving_Json.Json_int64.read buf] |
1095 |
-- | [%type: nativeint] | [%type: Nativeint.t] -> |
1096 |
-- [%expr Deriving_Json.Json_nativeint.read buf] |
1097 |
-- | [%type: float] -> |
1098 |
-- [%expr Deriving_Json.Json_float.read buf] |
1099 |
-- | [%type: bool] -> |
1100 |
-- [%expr Deriving_Json.Json_bool.read buf] |
1101 |
-- | [%type: char] -> |
1102 |
-- [%expr Deriving_Json.Json_char.read buf] |
1103 |
-- | [%type: string] -> |
1104 |
-- [%expr Deriving_Json.Json_string.read buf] |
1105 |
-- | [%type: bytes] -> |
1106 |
-- [%expr Deriving_Json.Json_bytes.read buf] |
1107 |
-- | [%type: [%t? y] list] -> |
1108 |
-- [%expr Deriving_Json.read_list [%e read_of_type ?decl y] buf] |
1109 |
-- | [%type: [%t? y] ref] -> |
1110 |
-- [%expr Deriving_Json.read_ref [%e read_of_type ?decl y] buf] |
1111 |
-- | [%type: [%t? y] option] -> |
1112 |
-- [%expr Deriving_Json.read_option [%e read_of_type ?decl y] buf] |
1113 |
-- | [%type: [%t? y] array] -> |
1114 |
-- [%expr Deriving_Json.read_array [%e read_of_type ?decl y] buf] |
1115 |
-- | { Parsetree.ptyp_desc = Ptyp_tuple l } -> |
1116 |
-- read_body_of_tuple_type l ?decl |
1117 |
-- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> |
1118 |
-- let e = |
1119 |
-- (match decl with |
1120 |
-- | Some decl -> |
1121 |
-- let e = suffix_decl decl ~suffix:"of_json_with_tag" |
1122 |
-- and l = |
1123 |
-- let {Parsetree.ptype_params = l} = decl |
1124 |
-- and f (y, _) = read_of_type y ~decl in |
1125 |
-- List.map f l |
1126 |
-- in |
1127 |
-- Ast_convenience.app e l |
1128 |
-- | None -> |
1129 |
-- read_of_poly_variant l y ~loc) |
1130 |
-- and tag = [%expr Deriving_Json_lexer.read_vcase buf] in |
1131 |
-- [%expr [%e e] buf [%e tag]] |
1132 |
-- | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> |
1133 |
-- [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf] |
1134 |
-- | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> |
1135 |
-- let e = suffix_lid lid ~suffix:"of_json" |
1136 |
-- and l = List.map (read_of_type ?decl) l in |
1137 |
-- [%expr [%e Ast_convenience.app e l] buf] |
1138 |
-- | { Parsetree.ptyp_loc } -> |
1139 |
-- Location.raise_errorf ~loc:ptyp_loc |
1140 |
-- "%s_read cannot be derived for %s" deriver |
1141 |
-- (Ppx_deriving.string_of_core_type y) |
1142 |
-- |
1143 |
--and read_of_type ?decl y = |
1144 |
-- read_body_of_type ?decl y |> buf_expand |
1145 |
-- |
1146 |
--let json_of_type ?decl y = |
1147 |
-- let read = read_of_type ?decl y |
1148 |
-- and write = |
1149 |
-- let poly = match decl with Some _ -> true | _ -> false in |
1150 |
-- write_of_type y ~poly in |
1151 |
-- [%expr Deriving_Json.make [%e write] [%e read]] |
1152 |
-- |
1153 |
--let fun_str_wrap d e y ~f ~suffix = |
1154 |
-- let e = Ppx_deriving.poly_fun_of_type_decl d e |> sanitize |
1155 |
-- and v = suffix_decl_p d ~suffix |
1156 |
-- and y = Ppx_deriving.poly_arrow_of_type_decl f d y in |
1157 |
-- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
1158 |
-- |
1159 |
--let read_str_wrap d e = |
1160 |
-- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] |
1161 |
-- and suffix = "of_json" in |
1162 |
-- let y = f (Ppx_deriving.core_type_of_type_decl d) in |
1163 |
-- fun_str_wrap d e y ~f ~suffix |
1164 |
-- |
1165 |
--let read_tag_str_wrap d e = |
1166 |
-- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] |
1167 |
-- and suffix = "of_json_with_tag" |
1168 |
-- and y = |
1169 |
-- let y = Ppx_deriving.core_type_of_type_decl d in |
1170 |
-- [%type: Deriving_Json_lexer.lexbuf -> |
1171 |
-- [`NCst of int | `Cst of int] -> [%t y]] |
1172 |
-- in |
1173 |
-- fun_str_wrap d e y ~f ~suffix |
1174 |
-- |
1175 |
--let write_str_wrap d e = |
1176 |
-- let f y = [%type: Buffer.t -> [%t y] -> unit] |
1177 |
-- and suffix = "to_json" in |
1178 |
-- let y = |
1179 |
-- let y = Ppx_deriving.core_type_of_type_decl d in |
1180 |
-- (match d with |
1181 |
-- | {ptype_manifest = |
1182 |
-- Some {ptyp_desc = Parsetree.Ptyp_variant (_, _, _)}} -> |
1183 |
-- [%type: [> [%t y]]] |
1184 |
-- | _ -> |
1185 |
-- y) |> f |
1186 |
-- in |
1187 |
-- fun_str_wrap d e y ~f ~suffix |
1188 |
-- |
1189 |
--let recognize_str_wrap d e = |
1190 |
-- let v = suffix_decl_p d ~suffix:"recognize" |
1191 |
-- and y = [%type: [`NCst of int | `Cst of int] -> bool] in |
1192 |
-- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
1193 |
-- |
1194 |
--let json_poly_type d = |
1195 |
-- let f y = [%type: [%t y] Deriving_Json.t] in |
1196 |
-- let y = f (Ppx_deriving.core_type_of_type_decl d) in |
1197 |
-- Ppx_deriving.poly_arrow_of_type_decl f d y |
1198 |
-- |
1199 |
--let json_str_wrap d e = |
1200 |
-- let v = suffix_decl_p d ~suffix:"json" |
1201 |
-- and e = Ppx_deriving.(poly_fun_of_type_decl d e) |
1202 |
-- and y = json_poly_type d in |
1203 |
-- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) |
1204 |
-- |
1205 |
--let json_str d = |
1206 |
-- let write = |
1207 |
-- let f acc id = |
1208 |
-- let poly = Ast_convenience.evar ("poly_" ^ id) in |
1209 |
-- [%expr [%e acc] (Deriving_Json.write [%e poly])] |
1210 |
-- and acc = suffix_decl d ~suffix:"to_json" in |
1211 |
-- Ppx_deriving.fold_left_type_decl f acc d |
1212 |
-- and read = |
1213 |
-- let f acc id = |
1214 |
-- let poly = Ast_convenience.evar ("poly_" ^ id) in |
1215 |
-- [%expr [%e acc] (Deriving_Json.read [%e poly])] |
1216 |
-- and acc = suffix_decl d ~suffix:"of_json" in |
1217 |
-- Ppx_deriving.fold_left_type_decl f acc d |
1218 |
-- in |
1219 |
-- [%expr Deriving_Json.make [%e write] [%e read]] |> |
1220 |
-- json_str_wrap d |
1221 |
-- |
1222 |
--let write_decl_of_type d y = |
1223 |
-- (let e = |
1224 |
-- let arg = Ast_convenience.evar "a" in |
1225 |
-- write_body_of_type y ~arg ~poly:true |
1226 |
-- in |
1227 |
-- [%expr fun buf a -> [%e e]]) |> write_str_wrap d |
1228 |
-- |
1229 |
--let read_decl_of_type decl y = |
1230 |
-- read_body_of_type y ~decl |> buf_expand |> read_str_wrap decl |
1231 |
-- |
1232 |
--let json_decls_of_type decl y = |
1233 |
-- let recognize, read_tag = |
1234 |
-- match y with |
1235 |
-- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); |
1236 |
-- ptyp_loc = loc } -> |
1237 |
-- Some (recognize_body_of_poly_variant l ~loc |
1238 |
-- |> recognize_str_wrap decl), |
1239 |
-- Some (read_of_poly_variant l y ~decl ~loc |
1240 |
-- |> read_tag_str_wrap decl) |
1241 |
-- | _ -> |
1242 |
-- None, None |
1243 |
-- in |
1244 |
-- write_decl_of_type decl y, |
1245 |
-- read_decl_of_type decl y, |
1246 |
-- json_str decl, |
1247 |
-- recognize, read_tag |
1248 |
-- |
1249 |
--let write_case (i, i', l) {Parsetree.pcd_name; pcd_args; pcd_loc} = |
1250 |
-- let n = List.length pcd_args in |
1251 |
-- let vars = fresh_vars n in |
1252 |
-- let i, i', lhs, rhs = |
1253 |
-- match vars with |
1254 |
-- | [] -> |
1255 |
-- i + 1, |
1256 |
-- i', |
1257 |
-- None, |
1258 |
-- [%expr Deriving_Json.Json_int.write buf |
1259 |
-- [%e Ast_convenience.int i]] |
1260 |
-- | [v] -> |
1261 |
-- i, |
1262 |
-- i' + 1, |
1263 |
-- Some (Ast_convenience.pvar v), |
1264 |
-- write_tuple_contents vars pcd_args i' ~poly:true |
1265 |
-- | _ -> |
1266 |
-- i, |
1267 |
-- i' + 1, |
1268 |
-- Some (var_ptuple vars), |
1269 |
-- write_tuple_contents vars pcd_args i' ~poly:true |
1270 |
-- in |
1271 |
-- i, i', |
1272 |
-- Ast_helper. |
1273 |
-- (Exp.case (Pat.construct (label_of_constructor pcd_name) lhs) |
1274 |
-- rhs) :: l |
1275 |
-- |
1276 |
--let write_decl_of_variant d l = |
1277 |
-- (let _, _, l = List.fold_left write_case (0, 0, []) l in |
1278 |
-- Ast_helper.Exp.function_ l) |> buf_expand |> |
1279 |
-- write_str_wrap d |
1280 |
-- |
1281 |
--let read_case ?decl (i, i', l) |
1282 |
-- {Parsetree.pcd_name; pcd_args; pcd_loc} = |
1283 |
-- match pcd_args with |
1284 |
-- | [] -> |
1285 |
-- i + 1, i', |
1286 |
-- Ast_helper.Exp.case |
1287 |
-- [%pat? `Cst [%p Ast_convenience.pint i]] |
1288 |
-- (Ast_helper.Exp.construct (label_of_constructor pcd_name) None) |
1289 |
-- :: l |
1290 |
-- | _ -> |
1291 |
-- i, i' + 1, |
1292 |
-- ((let f l = |
1293 |
-- (match l with |
1294 |
-- | [] -> None |
1295 |
-- | [e] -> Some e |
1296 |
-- | l -> Some (Ast_helper.Exp.tuple l)) |> |
1297 |
-- Ast_helper.Exp.construct (label_of_constructor pcd_name) |
1298 |
-- in |
1299 |
-- read_tuple_contents ?decl pcd_args ~f) |> |
1300 |
-- Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']]) |
1301 |
-- :: l |
1302 |
-- |
1303 |
--let read_decl_of_variant decl l = |
1304 |
-- (let _, _, l = List.fold_left (read_case ~decl) (0, 0, []) l |
1305 |
-- and e = [%expr Deriving_Json_lexer.read_case buf] in |
1306 |
-- Ast_helper.Exp.match_ e (l @ [tag_error_case ()])) |> |
1307 |
-- buf_expand |> |
1308 |
-- read_str_wrap decl |
1309 |
-- |
1310 |
--let json_decls_of_variant d l = |
1311 |
-- write_decl_of_variant d l, read_decl_of_variant d l, json_str d, |
1312 |
-- None, None |
1313 |
-- |
1314 |
--let write_decl_of_record d l = |
1315 |
-- write_of_record d l |> write_str_wrap d |
1316 |
-- |
1317 |
--let read_decl_of_record d l = |
1318 |
-- read_of_record d l |> read_str_wrap d |
1319 |
-- |
1320 |
--let json_decls_of_record d l = |
1321 |
-- check_record_fields l; |
1322 |
-- write_decl_of_record d l, read_decl_of_record d l, json_str d, |
1323 |
-- None, None |
1324 |
-- |
1325 |
--let json_str_of_decl ({Parsetree.ptype_loc} as d) = |
1326 |
-- Ast_helper.with_default_loc ptype_loc @@ fun () -> |
1327 |
-- match d with |
1328 |
-- | { Parsetree.ptype_manifest = Some y } -> |
1329 |
-- json_decls_of_type d y |
1330 |
-- | { ptype_kind = Ptype_variant l } -> |
1331 |
-- json_decls_of_variant d l |
1332 |
-- | { ptype_kind = Ptype_record l } -> |
1333 |
-- json_decls_of_record d l |
1334 |
-- | _ -> |
1335 |
-- Location.raise_errorf "%s cannot be derived for %s" deriver |
1336 |
-- (Ppx_deriving.mangle_type_decl (`Suffix "") d) |
1337 |
-- |
1338 |
--let read_sig_of_decl ({Parsetree.ptype_loc} as d) = |
1339 |
-- (let s = |
1340 |
-- let s = Ppx_deriving.mangle_type_decl (`Suffix "of_json") d in |
1341 |
-- Location.mkloc s ptype_loc |
1342 |
-- and y = |
1343 |
-- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in |
1344 |
-- let y = f (Ppx_deriving.core_type_of_type_decl d) in |
1345 |
-- Ppx_deriving.poly_arrow_of_type_decl f d y |
1346 |
-- in |
1347 |
-- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
1348 |
-- |
1349 |
--let recognize_sig_of_decl ({Parsetree.ptype_loc} as d) = |
1350 |
-- (let s = |
1351 |
-- let s = Ppx_deriving.mangle_type_decl (`Suffix "recognize") d in |
1352 |
-- Location.mkloc s ptype_loc |
1353 |
-- and y = [%type: [ `NCst of int | `Cst of int ] -> bool] in |
1354 |
-- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
1355 |
-- |
1356 |
--let read_with_tag_sig_of_decl ({Parsetree.ptype_loc} as d) = |
1357 |
-- (let s = |
1358 |
-- let s = |
1359 |
-- Ppx_deriving.mangle_type_decl (`Suffix "of_json_with_tag") d |
1360 |
-- in |
1361 |
-- Location.mkloc s ptype_loc |
1362 |
-- and y = |
1363 |
-- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in |
1364 |
-- let y = |
1365 |
-- let y = Ppx_deriving.core_type_of_type_decl d in |
1366 |
-- f [%type: [ `NCst of int | `Cst of int ] -> [%t y]] |
1367 |
-- in |
1368 |
-- Ppx_deriving.poly_arrow_of_type_decl f d y |
1369 |
-- in |
1370 |
-- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
1371 |
-- |
1372 |
--let write_sig_of_decl ({Parsetree.ptype_loc} as d) = |
1373 |
-- (let s = |
1374 |
-- let s = Ppx_deriving.mangle_type_decl (`Suffix "to_json") d in |
1375 |
-- Location.mkloc s ptype_loc |
1376 |
-- and y = |
1377 |
-- let f y = [%type: Buffer.t -> [%t y] -> unit] in |
1378 |
-- let y = f (Ppx_deriving.core_type_of_type_decl d) in |
1379 |
-- Ppx_deriving.poly_arrow_of_type_decl f d y |
1380 |
-- in |
1381 |
-- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
1382 |
-- |
1383 |
--let json_sig_of_decl ({Parsetree.ptype_loc} as d) = |
1384 |
-- (let s = |
1385 |
-- let s = Ppx_deriving.mangle_type_decl (`Suffix "json") d in |
1386 |
-- Location.mkloc s ptype_loc |
1387 |
-- and y = |
1388 |
-- let f y = [%type: [%t y] Deriving_Json.t] in |
1389 |
-- let y = f (Ppx_deriving.core_type_of_type_decl d) in |
1390 |
-- Ppx_deriving.poly_arrow_of_type_decl f d y |
1391 |
-- in |
1392 |
-- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value |
1393 |
-- |
1394 |
--let sigs_of_decl ({Parsetree.ptype_loc} as d) = |
1395 |
-- Ast_helper.with_default_loc ptype_loc @@ fun () -> |
1396 |
-- let l = [ |
1397 |
-- read_sig_of_decl d; |
1398 |
-- write_sig_of_decl d; |
1399 |
-- json_sig_of_decl d |
1400 |
-- ] in |
1401 |
-- match d with |
1402 |
-- | { Parsetree.ptype_manifest = |
1403 |
-- Some {Parsetree.ptyp_desc = Parsetree.Ptyp_variant _}} -> |
1404 |
-- read_with_tag_sig_of_decl d :: recognize_sig_of_decl d :: l |
1405 |
-- | _ -> |
1406 |
-- l |
1407 |
-- |
1408 |
--let register_for_expr s f = |
1409 |
-- let core_type ({Parsetree.ptyp_loc} as y) = |
1410 |
-- let f () = f y |> sanitize in |
1411 |
-- Ast_helper.with_default_loc ptyp_loc f |
1412 |
-- in |
1413 |
-- Ppx_deriving.(create s ~core_type () |> register) |
1414 |
-- |
1415 |
--let _ = |
1416 |
-- register_for_expr "of_json" @@ fun y -> [%expr |
1417 |
-- fun s -> |
1418 |
-- [%e read_of_type y] |
1419 |
-- (Deriving_Json_lexer.init_lexer (Lexing.from_string s))] |
1420 |
-- |
1421 |
--let _ = |
1422 |
-- register_for_expr "to_json" @@ fun y -> [%expr |
1423 |
-- fun x -> |
1424 |
-- let buf = Buffer.create 50 in |
1425 |
-- [%e write_of_type y ~poly:false] buf x; |
1426 |
-- Buffer.contents buf] |
1427 |
-- |
1428 |
--let _ = |
1429 |
-- let core_type ({Parsetree.ptyp_loc} as y) = |
1430 |
-- let f () = json_of_type y |> sanitize in |
1431 |
-- Ast_helper.with_default_loc ptyp_loc f |
1432 |
-- and type_decl_str ~options ~path l = |
1433 |
-- let lw, lr, lj, lp, lrv = |
1434 |
-- let f d (lw, lr, lj, lp, lrv) = |
1435 |
-- let w, r, j, p, rv = json_str_of_decl d in |
1436 |
-- w :: lw, r :: lr, j :: lj, |
1437 |
-- (match p with Some p -> p :: lp | None -> lp), |
1438 |
-- (match rv with Some rv -> rv :: lrv | None -> lrv) |
1439 |
-- and acc = [], [], [], [], [] in |
1440 |
-- List.fold_right f l acc |
1441 |
-- and f = Ast_helper.Str.value Asttypes.Recursive |
1442 |
-- and f' = Ast_helper.Str.value Asttypes.Nonrecursive in |
1443 |
-- let l = [f (lrv @ lr); f lw; f' lj] in |
1444 |
-- match lp with [] -> l | _ -> f lp :: l |
1445 |
-- and type_decl_sig ~options ~path l = |
1446 |
-- List.map sigs_of_decl l |> List.flatten |
1447 |
-- in |
1448 |
-- Ppx_deriving. |
1449 |
-- (create "json" ~core_type ~type_decl_str ~type_decl_sig () |
1450 |
-- |> register) |
1451 |
|
1452 |
diff --git a/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild b/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild |
1453 |
deleted file mode 100644 |
1454 |
index 2de89b9..00000000 |
1455 |
--- a/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild |
1456 |
+++ /dev/null |
1457 |
@@ -1,59 +0,0 @@ |
1458 |
-# Copyright 1999-2015 Gentoo Foundation |
1459 |
-# Distributed under the terms of the GNU General Public License v2 |
1460 |
-# $Id$ |
1461 |
- |
1462 |
-EAPI=5 |
1463 |
- |
1464 |
-inherit findlib eutils |
1465 |
- |
1466 |
-DESCRIPTION="A compiler from OCaml bytecode to javascript" |
1467 |
-HOMEPAGE="http://ocsigen.org/js_of_ocaml/" |
1468 |
-SRC_URI="https://github.com/ocsigen/js_of_ocaml/archive/${PV}.tar.gz -> ${P}.tar.gz" |
1469 |
- |
1470 |
-LICENSE="LGPL-2.1-with-linking-exception" |
1471 |
-SLOT="0/${PV}" |
1472 |
-KEYWORDS="~amd64" |
1473 |
-IUSE="+ocamlopt doc +deriving +ppx +ppx-deriving +react +xml X" |
1474 |
- |
1475 |
-RDEPEND=" |
1476 |
- >=dev-lang/ocaml-3.12:=[ocamlopt?,X?] |
1477 |
- >=dev-ml/lwt-2.4.4:= |
1478 |
- react? ( dev-ml/react:= dev-ml/reactiveData:= ) |
1479 |
- xml? ( >=dev-ml/tyxml-3.6:= ) |
1480 |
- ppx? ( dev-ml/ppx_tools:= ) |
1481 |
- ppx-deriving? ( dev-ml/ppx_deriving:= ) |
1482 |
- dev-ml/cmdliner:= |
1483 |
- dev-ml/menhir:= |
1484 |
- dev-ml/ocaml-base64:= |
1485 |
- dev-ml/camlp4:= |
1486 |
- dev-ml/cppo:= |
1487 |
- deriving? ( >=dev-ml/deriving-0.6:= )" |
1488 |
-DEPEND="${RDEPEND} |
1489 |
- dev-ml/ocamlbuild" |
1490 |
- |
1491 |
-src_prepare() { |
1492 |
- has_version '>=dev-lang/ocaml-4.03' && epatch "${FILESDIR}/oc43.patch" |
1493 |
-} |
1494 |
- |
1495 |
-src_configure() { |
1496 |
- printf "\n\n" >> Makefile.conf |
1497 |
- use ocamlopt || echo "BEST := byte" >> Makefile.conf |
1498 |
- use ocamlopt || echo "NATDYNLINK := NO" >> Makefile.conf |
1499 |
- use deriving || echo "WITH_DERIVING := NO" >> Makefile.conf |
1500 |
- use X || echo "WITH_GRAPHICS := NO" >> Makefile.conf |
1501 |
- use react || echo "WITH_REACT := NO" >> Makefile.conf |
1502 |
- use ppx || echo "WITH_PPX := NO" >> Makefile.conf |
1503 |
- use ppx-deriving || echo "WITH_PPX_PPX_DERIVING := NO" >> Makefile.conf |
1504 |
-} |
1505 |
- |
1506 |
-src_compile() { |
1507 |
- emake |
1508 |
- use doc && emake doc |
1509 |
-} |
1510 |
- |
1511 |
-src_install() { |
1512 |
- findlib_src_preinst |
1513 |
- emake BINDIR="${ED}/usr/bin/" install |
1514 |
- dodoc CHANGES README.md |
1515 |
- use doc && dohtml -r doc/api/html/ |
1516 |
-} |
1517 |
|
1518 |
diff --git a/dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild b/dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild |
1519 |
deleted file mode 100644 |
1520 |
index 58bce36..00000000 |
1521 |
--- a/dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild |
1522 |
+++ /dev/null |
1523 |
@@ -1,57 +0,0 @@ |
1524 |
-# Copyright 1999-2016 Gentoo Foundation |
1525 |
-# Distributed under the terms of the GNU General Public License v2 |
1526 |
-# $Id$ |
1527 |
- |
1528 |
-EAPI=5 |
1529 |
- |
1530 |
-inherit findlib eutils |
1531 |
- |
1532 |
-DESCRIPTION="A compiler from OCaml bytecode to javascript" |
1533 |
-HOMEPAGE="http://ocsigen.org/js_of_ocaml/" |
1534 |
-SRC_URI="https://github.com/ocsigen/js_of_ocaml/archive/${PV}.tar.gz -> ${P}.tar.gz" |
1535 |
- |
1536 |
-LICENSE="LGPL-2.1-with-linking-exception" |
1537 |
-SLOT="0/${PV}" |
1538 |
-KEYWORDS="~amd64" |
1539 |
-IUSE="+async +ocamlopt doc +deriving +ppx +ppx-deriving +react +xml X" |
1540 |
- |
1541 |
-RDEPEND=" |
1542 |
- >=dev-lang/ocaml-3.12:=[ocamlopt?,X?] |
1543 |
- >=dev-ml/lwt-2.4.4:= |
1544 |
- async? ( dev-ml/async_kernel:= ) |
1545 |
- react? ( dev-ml/react:= dev-ml/reactiveData:= ) |
1546 |
- xml? ( >=dev-ml/tyxml-4:= ) |
1547 |
- ppx? ( dev-ml/ppx_tools:= ) |
1548 |
- ppx-deriving? ( dev-ml/ppx_deriving:= ) |
1549 |
- dev-ml/cmdliner:= |
1550 |
- dev-ml/menhir:= |
1551 |
- dev-ml/ocaml-base64:= |
1552 |
- dev-ml/camlp4:= |
1553 |
- dev-ml/cppo:= |
1554 |
- deriving? ( >=dev-ml/deriving-0.6:= )" |
1555 |
-DEPEND="${RDEPEND} |
1556 |
- dev-ml/ocamlbuild" |
1557 |
- |
1558 |
-src_configure() { |
1559 |
- printf "\n\n" >> Makefile.conf |
1560 |
- use ocamlopt || echo "BEST := byte" >> Makefile.conf |
1561 |
- use ocamlopt || echo "NATDYNLINK := NO" >> Makefile.conf |
1562 |
- use deriving || echo "WITH_DERIVING := NO" >> Makefile.conf |
1563 |
- use X || echo "WITH_GRAPHICS := NO" >> Makefile.conf |
1564 |
- use react || echo "WITH_REACT := NO" >> Makefile.conf |
1565 |
- use ppx || echo "WITH_PPX := NO" >> Makefile.conf |
1566 |
- use ppx-deriving || echo "WITH_PPX_PPX_DERIVING := NO" >> Makefile.conf |
1567 |
- use async || echo "WITH_ASYNC := NO" >> Makefile.conf |
1568 |
-} |
1569 |
- |
1570 |
-src_compile() { |
1571 |
- emake -j1 |
1572 |
- use doc && emake doc |
1573 |
-} |
1574 |
- |
1575 |
-src_install() { |
1576 |
- findlib_src_preinst |
1577 |
- emake BINDIR="${ED}/usr/bin/" install |
1578 |
- dodoc CHANGES README.md |
1579 |
- use doc && dohtml -r doc/api/html/ |
1580 |
-} |