Gentoo Archives: gentoo-commits

From: Alexis Ballier <aballier@g.o>
To: gentoo-commits@l.g.o
Subject: [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/
Date: Wed, 07 Sep 2016 09:57:34
Message-Id: 1473242241.915138df1231e929152fc5452e6b1c698b8c4481.aballier@gentoo
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 -}