commit: 915138df1231e929152fc5452e6b1c698b8c4481 Author: Alexis Ballier <aballier <AT> gentoo <DOT> org> AuthorDate: Wed Sep 7 09:53:00 2016 +0000 Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org> CommitDate: Wed Sep 7 09:57:21 2016 +0000 URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=915138df
dev-ml/js_of_ocaml: remove old Package-Manager: portage-2.3.0 dev-ml/js_of_ocaml/Manifest | 2 - dev-ml/js_of_ocaml/files/oc43.patch | 1418 ----------------------------- dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild | 59 -- dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild | 57 -- 4 files changed, 1536 deletions(-) diff --git a/dev-ml/js_of_ocaml/Manifest b/dev-ml/js_of_ocaml/Manifest index 1e574d2..470a36f 100644 --- a/dev-ml/js_of_ocaml/Manifest +++ b/dev-ml/js_of_ocaml/Manifest @@ -1,3 +1 @@ -DIST js_of_ocaml-2.7.tar.gz 1304487 SHA256 52922f55428a1d8a55ec2493c4989152e06efd29a981adf8ac9f343f558854b5 SHA512 ab6e5d16342bf763c10eb5c2e7589610622034eee2ad82aa09c6f68448f155a5c56584702307852b251bde80146c1b7115ed6add1358ad96b130c9dd2b96118b WHIRLPOOL 278c17432fdf9bf670df33479c68705868be39eb4d53f67fc489fe44ac2e7645dd5e2ed3e6e71752a2387b516ce0ab6dc99ac1d870fc75ffdad9df87031e9de4 DIST js_of_ocaml-2.8.1.tar.gz 1329825 SHA256 954ed80b3f37e10666e36ffa3c1d846e1913b8c7be9f0af79889f829b1333e1e SHA512 bce4b173c29396ce7f28f12afd3185cdf402150a7390b9f5a21f14f71e72b3e5ae16234ed65e9d7b18ed2c0de524b658495d62d4673dfe3e61d5f0556b5a125c WHIRLPOOL ac66e7fa70e7365dc5a404d95b9f14186d727756df3aaebfa5d433237d33cb1f070ad74db12136b2a2b2db75b3eac127729343838f361000f962f2a5bc309d79 -DIST js_of_ocaml-2.8.tar.gz 1330364 SHA256 98564d9a36025edb5edd9d58c565fc7b38a3b49f9b8e32d7dc29289d443894b0 SHA512 914b2a1a452acd494c3373fa65e858c2747bd7d946d6077320429160d4172f627978a0b4ee526fc6e39378dffc9c965b81e5a1f16eba1f60529e4a6b5f474c1e WHIRLPOOL cfb71c97c3c43e873dc1f83b26ccacf93be846940596e99f004e6539c5bfa15e810d290b254c4bfecce65133dc6b79247c3cb2cd301297b6062ac6526147f94d diff --git a/dev-ml/js_of_ocaml/files/oc43.patch b/dev-ml/js_of_ocaml/files/oc43.patch deleted file mode 100644 index face810..00000000 --- a/dev-ml/js_of_ocaml/files/oc43.patch +++ /dev/null @@ -1,1418 +0,0 @@ -commit 3e4d39ece5a67bfc17f47c3da8a95ccca789abd5 -Author: Hugo Heuzard <hugo.heuz...@gmail.com> -Date: Mon Mar 28 23:35:47 2016 +0100 - - Deriving_json for ocaml 4.03 - - move - -diff --git a/.gitignore b/.gitignore -index 71e4ccf..ccbb796 100644 ---- a/.gitignore -+++ b/.gitignore -@@ -58,6 +58,7 @@ benchmarks/results - benchmarks/config - lib/deriving_json/deriving_Json_lexer.ml - lib/ppx/ppx_js.ml -+lib/ppx/ppx_deriving_json.ml - lib/ppx/ppx_js - Makefile.local - -diff --git a/lib/ppx/ppx_deriving_json.cppo.ml b/lib/ppx/ppx_deriving_json.cppo.ml -new file mode 100644 -index 0000000..814ed99 ---- /dev/null -+++ b/lib/ppx/ppx_deriving_json.cppo.ml -@@ -0,0 +1,711 @@ -+(* Js_of_ocaml -+ * http://www.ocsigen.org -+ * Copyright Vasilis Papavasileiou 2015 -+ * -+ * This program is free software; you can redistribute it and/or modify -+ * it under the terms of the GNU Lesser General Public License as published by -+ * the Free Software Foundation, with linking exception; -+ * either version 2.1 of the License, or (at your option) any later version. -+ * -+ * This program is distributed in the hope that it will be useful, -+ * but WITHOUT ANY WARRANTY; without even the implied warranty of -+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ * GNU Lesser General Public License for more details. -+ * -+ * You should have received a copy of the GNU Lesser General Public License -+ * along with this program; if not, write to the Free Software -+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -+ *) -+ -+let deriver = "json" -+ -+(* Copied (and adapted) this from ppx_deriving repo (commit -+ e2079fa8f3460055bf990461f295c6c4b391fafc) ; we get an empty set of -+ let bindings with ppx_deriving 3.0 *) -+let sanitize expr = [%expr -+ (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] -+ -+let var_ptuple l = -+ List.map Ast_convenience.pvar l |> Ast_helper.Pat.tuple -+ -+let map_loc f {Location.txt; loc} = -+ {Location.txt = f txt; loc} -+ -+let suffix_lid {Location.txt; loc} ~suffix = -+ let txt = Ppx_deriving.mangle_lid (`Suffix suffix) txt in -+ Ast_helper.Exp.ident {txt; loc} ~loc -+ -+let suffix_decl ({Parsetree.ptype_loc = loc} as d) ~suffix = -+ (let s = -+ Ppx_deriving.mangle_type_decl (`Suffix suffix) d |> -+ Longident.parse -+ in -+ Location.mkloc s loc) |> Ast_helper.Exp.ident ~loc -+ -+let suffix_decl_p ({Parsetree.ptype_loc = loc} as d) ~suffix = -+ (let s = Ppx_deriving.mangle_type_decl (`Suffix suffix) d in -+ Location.mkloc s loc) |> Ast_helper.Pat.var ~loc -+ -+let rec fresh_vars ?(acc = []) n = -+ if n <= 0 then -+ List.rev acc -+ else -+ let acc = Ppx_deriving.fresh_var acc :: acc in -+ fresh_vars ~acc (n - 1) -+ -+let unreachable_case () = -+ Ast_helper.Exp.case [%pat? _ ] [%expr assert false] -+ -+let label_of_constructor = map_loc (fun c -> Longident.Lident c) -+ -+let wrap_write r ~pattern = [%expr fun buf [%p pattern] -> [%e r]] -+ -+let buf_expand r = [%expr fun buf -> [%e r]] -+ -+let seqlist = function -+ | h :: l -> -+ let f acc e = [%expr [%e acc]; [%e e]] in -+ List.fold_left f h l -+ | [] -> -+ [%expr ()] -+ -+let check_record_fields = -+ List.iter @@ function -+ | {Parsetree.pld_mutable = Mutable} -> -+ Location.raise_errorf -+ "%s cannot be derived for mutable records" deriver -+ | {pld_type = {ptyp_desc = Ptyp_poly _}} -> -+ Location.raise_errorf -+ "%s cannot be derived for polymorphic records" deriver -+ | _ -> -+ () -+ -+let maybe_tuple_type = function -+ | [y] -> y -+ | l -> Ast_helper.Typ.tuple l -+ -+let rec write_tuple_contents l ly ~tag ~poly = -+ let e = -+ let f v y = -+ let arg = Ast_convenience.evar v in -+ let e = write_body_of_type y ~arg ~poly in -+ [%expr Buffer.add_string buf ","; [%e e]] -+ in -+ List.map2 f l ly |> seqlist -+ and s = Ast_convenience.str ("[" ^ string_of_int tag) in [%expr -+ Buffer.add_string buf [%e s]; -+ [%e e]; -+ Buffer.add_string buf "]"] -+ -+and write_body_of_tuple_type l ~arg ~poly ~tag = -+ let n = List.length l in -+ let vars = fresh_vars n in -+ let e = write_tuple_contents vars l ~tag ~poly -+ and p = var_ptuple vars in -+ [%expr let [%p p] = [%e arg] in [%e e]] -+ -+and write_poly_case r ~arg ~poly = -+ match r with -+ | Parsetree.Rtag (label, _, _, l) -> -+ let i = Ppx_deriving.hash_variant label -+ and n = List.length l in -+ let v = Ppx_deriving.fresh_var [] in -+ let lhs = -+ (if n = 0 then None else Some (Ast_convenience.pvar v)) |> -+ Ast_helper.Pat.variant label -+ and rhs = -+ match l with -+ | [] -> -+ let e = Ast_convenience.int i in -+ [%expr Deriving_Json.Json_int.write buf [%e e]] -+ | _ -> -+ let l = [[%type: int]; maybe_tuple_type l] -+ and arg = Ast_helper.Exp.tuple Ast_convenience.[int i; evar v] in -+ write_body_of_tuple_type l ~arg ~poly ~tag:0 -+ in -+ Ast_helper.Exp.case lhs rhs -+ | Rinherit ({ptyp_desc = Ptyp_constr (lid, _)} as y) -> -+ Ast_helper.Exp.case (Ast_helper.Pat.type_ lid) -+ (write_body_of_type y ~arg ~poly) -+ | Rinherit {ptyp_loc} -> -+ Location.raise_errorf ~loc:ptyp_loc -+ "%s write case cannot be derived" deriver -+ -+and write_body_of_type y ~arg ~poly = -+ match y with -+ | [%type: unit] -> -+ [%expr Deriving_Json.Json_unit.write buf [%e arg]] -+ | [%type: int] -> -+ [%expr Deriving_Json.Json_int.write buf [%e arg]] -+ | [%type: int32] | [%type: Int32.t] -> -+ [%expr Deriving_Json.Json_int32.write buf [%e arg]] -+ | [%type: int64] | [%type: Int64.t] -> -+ [%expr Deriving_Json.Json_int64.write buf [%e arg]] -+ | [%type: nativeint] | [%type: Nativeint.t] -> -+ [%expr Deriving_Json.Json_nativeint.write buf [%e arg]] -+ | [%type: float] -> -+ [%expr Deriving_Json.Json_float.write buf [%e arg]] -+ | [%type: bool] -> -+ [%expr Deriving_Json.Json_bool.write buf [%e arg]] -+ | [%type: char] -> -+ [%expr Deriving_Json.Json_char.write buf [%e arg]] -+ | [%type: string] -> -+ [%expr Deriving_Json.Json_string.write buf [%e arg]] -+ | [%type: bytes] -> -+ [%expr Deriving_Json.Json_bytes.write buf [%e arg]] -+ | [%type: [%t? y] list] -> -+ let e = write_of_type y ~poly in -+ [%expr Deriving_Json.write_list [%e e] buf [%e arg]] -+ | [%type: [%t? y] ref] -> -+ let e = write_of_type y ~poly in -+ [%expr Deriving_Json.write_ref [%e e] buf [%e arg]] -+ | [%type: [%t? y] option] -> -+ let e = write_of_type y ~poly in -+ [%expr Deriving_Json.write_option [%e e] buf [%e arg]] -+ | [%type: [%t? y] array] -> -+ let e = write_of_type y ~poly in -+ [%expr Deriving_Json.write_array [%e e] buf [%e arg]] -+ | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> -+ [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf [%e arg]] -+ | { Parsetree.ptyp_desc = Ptyp_tuple l } -> -+ write_body_of_tuple_type l ~arg ~poly ~tag:0 -+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> -+ List.map (write_poly_case ~arg ~poly) l @ [unreachable_case ()] |> -+ Ast_helper.Exp.match_ arg -+ | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> -+ let e = suffix_lid lid ~suffix:"to_json" -+ and l = List.map (write_of_type ~poly) l in -+ [%expr [%e Ast_convenience.app e l] buf [%e arg]] -+ | { Parsetree.ptyp_loc } -> -+ Location.raise_errorf ~loc:ptyp_loc -+ "%s_write cannot be derived for %s" -+ deriver (Ppx_deriving.string_of_core_type y) -+ -+and write_of_type y ~poly = -+ let v = "a" in -+ let arg = Ast_convenience.evar v -+ and pattern = Ast_convenience.pvar v in -+ wrap_write (write_body_of_type y ~arg ~poly) ~pattern -+ -+and write_of_record ?(tag=0) d l = -+ let pattern = -+ let l = -+ let f {Parsetree.pld_name} = -+ label_of_constructor pld_name, -+ Ast_helper.Pat.var pld_name -+ in -+ List.map f l -+ in -+ Ast_helper.Pat.record l Asttypes.Closed -+ and e = -+ let l = -+ let f {Parsetree.pld_name = {txt}} = txt in -+ List.map f l -+ and ly = -+ let f {Parsetree.pld_type} = pld_type in -+ List.map f l -+ in -+ write_tuple_contents l ly ~tag ~poly:true -+ in -+ wrap_write e ~pattern -+ -+let recognize_case_of_constructor i l = -+ let lhs = -+ match l with -+ | [] -> [%pat? `Cst [%p Ast_convenience.pint i]] -+ | _ -> [%pat? `NCst [%p Ast_convenience.pint i]] -+ in -+ Ast_helper.Exp.case lhs [%expr true] -+ -+let recognize_body_of_poly_variant l ~loc = -+ let l = -+ let f = function -+ | Parsetree.Rtag (label, _, _, l) -> -+ let i = Ppx_deriving.hash_variant label in -+ recognize_case_of_constructor i l -+ | Rinherit {ptyp_desc = Ptyp_constr (lid, _)} -> -+ let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] in -+ Ast_helper.Exp.case ~guard [%pat? x] [%expr true] -+ | _ -> -+ Location.raise_errorf ~loc -+ "%s_recognize cannot be derived" deriver -+ and default = Ast_helper.Exp.case [%pat? _] [%expr false] in -+ List.map f l @ [default] -+ in -+ Ast_helper.Exp.function_ l -+ -+let tag_error_case ?(typename="") () = -+ let y = Ast_convenience.str typename in -+ Ast_helper.Exp.case -+ [%pat? _] -+ [%expr Deriving_Json_lexer.tag_error ~typename:[%e y] buf] -+ -+let maybe_tuple_type = function -+ | [y] -> y -+ | l -> Ast_helper.Typ.tuple l -+ -+let rec read_poly_case ?decl y = function -+ | Parsetree.Rtag (label, _, _, l) -> -+ let i = Ppx_deriving.hash_variant label |> Ast_convenience.pint in -+ (match l with -+ | [] -> -+ Ast_helper.Exp.case [%pat? `Cst [%p i]] -+ (Ast_helper.Exp.variant label None) -+ | l -> -+ Ast_helper.Exp.case [%pat? `NCst [%p i]] [%expr -+ Deriving_Json_lexer.read_comma buf; -+ let v = [%e read_body_of_type ?decl (maybe_tuple_type l)] in -+ Deriving_Json_lexer.read_rbracket buf; -+ [%e Ast_helper.Exp.variant label (Some [%expr v])]]) -+ | Rinherit {ptyp_desc = Ptyp_constr (lid, l)} -> -+ let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] -+ and e = -+ let e = suffix_lid lid ~suffix:"of_json_with_tag" -+ and l = List.map (read_of_type ?decl) l in -+ [%expr ([%e Ast_convenience.app e l] buf x :> [%t y])] -+ in -+ Ast_helper.Exp.case ~guard [%pat? x] e -+ | Rinherit {ptyp_loc} -> -+ Location.raise_errorf ~loc:ptyp_loc -+ "%s read case cannot be derived" deriver -+ -+and read_of_poly_variant ?decl l y ~loc = -+ List.map (read_poly_case ?decl y) l @ [tag_error_case ()] |> -+ Ast_helper.Exp.function_ |> -+ buf_expand -+ -+and read_tuple_contents ?decl l ~f = -+ let n = List.length l in -+ let lv = fresh_vars n in -+ let f v y acc = -+ let e = read_body_of_type ?decl y in [%expr -+ Deriving_Json_lexer.read_comma buf; -+ let [%p Ast_convenience.pvar v] = [%e e] in -+ [%e acc]] -+ and acc = List.map Ast_convenience.evar lv |> f in -+ let acc = [%expr Deriving_Json_lexer.read_rbracket buf; [%e acc]] in -+ List.fold_right2 f lv l acc -+ -+and read_body_of_tuple_type ?decl l = [%expr -+ Deriving_Json_lexer.read_lbracket buf; -+ ignore (Deriving_Json_lexer.read_tag_1 0 buf); -+ [%e read_tuple_contents ?decl l ~f:Ast_helper.Exp.tuple]] -+ -+and read_of_record_raw ?decl l = -+ let f = -+ let f {Parsetree.pld_name} e = label_of_constructor pld_name, e in -+ fun l' -> Ast_helper.Exp.record (List.map2 f l l') None -+ and l = -+ let f {Parsetree.pld_type} = pld_type in -+ List.map f l -+ in -+ read_tuple_contents l ?decl ~f -+ -+and read_of_record decl l = -+ let e = read_of_record_raw ~decl l in -+ [%expr -+ Deriving_Json_lexer.read_lbracket buf; -+ ignore (Deriving_Json_lexer.read_tag_2 0 254 buf); -+ [%e e]] |> buf_expand -+ -+and read_body_of_type ?decl y = -+ let poly = match decl with Some _ -> true | _ -> false in -+ match y with -+ | [%type: unit] -> -+ [%expr Deriving_Json.Json_unit.read buf] -+ | [%type: int] -> -+ [%expr Deriving_Json.Json_int.read buf] -+ | [%type: int32] | [%type: Int32.t] -> -+ [%expr Deriving_Json.Json_int32.read buf] -+ | [%type: int64] | [%type: Int64.t] -> -+ [%expr Deriving_Json.Json_int64.read buf] -+ | [%type: nativeint] | [%type: Nativeint.t] -> -+ [%expr Deriving_Json.Json_nativeint.read buf] -+ | [%type: float] -> -+ [%expr Deriving_Json.Json_float.read buf] -+ | [%type: bool] -> -+ [%expr Deriving_Json.Json_bool.read buf] -+ | [%type: char] -> -+ [%expr Deriving_Json.Json_char.read buf] -+ | [%type: string] -> -+ [%expr Deriving_Json.Json_string.read buf] -+ | [%type: bytes] -> -+ [%expr Deriving_Json.Json_bytes.read buf] -+ | [%type: [%t? y] list] -> -+ [%expr Deriving_Json.read_list [%e read_of_type ?decl y] buf] -+ | [%type: [%t? y] ref] -> -+ [%expr Deriving_Json.read_ref [%e read_of_type ?decl y] buf] -+ | [%type: [%t? y] option] -> -+ [%expr Deriving_Json.read_option [%e read_of_type ?decl y] buf] -+ | [%type: [%t? y] array] -> -+ [%expr Deriving_Json.read_array [%e read_of_type ?decl y] buf] -+ | { Parsetree.ptyp_desc = Ptyp_tuple l } -> -+ read_body_of_tuple_type l ?decl -+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> -+ let e = -+ (match decl with -+ | Some decl -> -+ let e = suffix_decl decl ~suffix:"of_json_with_tag" -+ and l = -+ let {Parsetree.ptype_params = l} = decl -+ and f (y, _) = read_of_type y ~decl in -+ List.map f l -+ in -+ Ast_convenience.app e l -+ | None -> -+ read_of_poly_variant l y ~loc) -+ and tag = [%expr Deriving_Json_lexer.read_vcase buf] in -+ [%expr [%e e] buf [%e tag]] -+ | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> -+ [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf] -+ | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> -+ let e = suffix_lid lid ~suffix:"of_json" -+ and l = List.map (read_of_type ?decl) l in -+ [%expr [%e Ast_convenience.app e l] buf] -+ | { Parsetree.ptyp_loc } -> -+ Location.raise_errorf ~loc:ptyp_loc -+ "%s_read cannot be derived for %s" deriver -+ (Ppx_deriving.string_of_core_type y) -+ -+and read_of_type ?decl y = -+ read_body_of_type ?decl y |> buf_expand -+ -+let json_of_type ?decl y = -+ let read = read_of_type ?decl y -+ and write = -+ let poly = match decl with Some _ -> true | _ -> false in -+ write_of_type y ~poly in -+ [%expr Deriving_Json.make [%e write] [%e read]] -+ -+let fun_str_wrap d e y ~f ~suffix = -+ let e = Ppx_deriving.poly_fun_of_type_decl d e |> sanitize -+ and v = suffix_decl_p d ~suffix -+ and y = Ppx_deriving.poly_arrow_of_type_decl f d y in -+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -+ -+let read_str_wrap d e = -+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] -+ and suffix = "of_json" in -+ let y = f (Ppx_deriving.core_type_of_type_decl d) in -+ fun_str_wrap d e y ~f ~suffix -+ -+let read_tag_str_wrap d e = -+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] -+ and suffix = "of_json_with_tag" -+ and y = -+ let y = Ppx_deriving.core_type_of_type_decl d in -+ [%type: Deriving_Json_lexer.lexbuf -> -+ [`NCst of int | `Cst of int] -> [%t y]] -+ in -+ fun_str_wrap d e y ~f ~suffix -+ -+let write_str_wrap d e = -+ let f y = [%type: Buffer.t -> [%t y] -> unit] -+ and suffix = "to_json" in -+ let y = -+ let y = Ppx_deriving.core_type_of_type_decl d in -+ (match d with -+ | {ptype_manifest = -+ Some {ptyp_desc = Parsetree.Ptyp_variant (_, _, _)}} -> -+ [%type: [> [%t y]]] -+ | _ -> -+ y) |> f -+ in -+ fun_str_wrap d e y ~f ~suffix -+ -+let recognize_str_wrap d e = -+ let v = suffix_decl_p d ~suffix:"recognize" -+ and y = [%type: [`NCst of int | `Cst of int] -> bool] in -+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -+ -+let json_poly_type d = -+ let f y = [%type: [%t y] Deriving_Json.t] in -+ let y = f (Ppx_deriving.core_type_of_type_decl d) in -+ Ppx_deriving.poly_arrow_of_type_decl f d y -+ -+let json_str_wrap d e = -+ let v = suffix_decl_p d ~suffix:"json" -+ and e = Ppx_deriving.(poly_fun_of_type_decl d e) -+ and y = json_poly_type d in -+ Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -+ -+let json_str d = -+ let write = -+ let f acc id = -+ let poly = Ast_convenience.evar ("poly_" ^ id) in -+ [%expr [%e acc] (Deriving_Json.write [%e poly])] -+ and acc = suffix_decl d ~suffix:"to_json" in -+ Ppx_deriving.fold_left_type_decl f acc d -+ and read = -+ let f acc id = -+ let poly = Ast_convenience.evar ("poly_" ^ id) in -+ [%expr [%e acc] (Deriving_Json.read [%e poly])] -+ and acc = suffix_decl d ~suffix:"of_json" in -+ Ppx_deriving.fold_left_type_decl f acc d -+ in -+ [%expr Deriving_Json.make [%e write] [%e read]] |> -+ json_str_wrap d -+ -+let write_decl_of_type d y = -+ (let e = -+ let arg = Ast_convenience.evar "a" in -+ write_body_of_type y ~arg ~poly:true -+ in -+ [%expr fun buf a -> [%e e]]) |> write_str_wrap d -+ -+let read_decl_of_type decl y = -+ read_body_of_type y ~decl |> buf_expand |> read_str_wrap decl -+ -+let json_decls_of_type decl y = -+ let recognize, read_tag = -+ match y with -+ | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); -+ ptyp_loc = loc } -> -+ Some (recognize_body_of_poly_variant l ~loc -+ |> recognize_str_wrap decl), -+ Some (read_of_poly_variant l y ~decl ~loc -+ |> read_tag_str_wrap decl) -+ | _ -> -+ None, None -+ in -+ write_decl_of_type decl y, -+ read_decl_of_type decl y, -+ json_str decl, -+ recognize, read_tag -+ -+let write_case (i, i', l) {Parsetree.pcd_name; pcd_args; pcd_loc} = -+ let i, i', lhs, rhs = -+ match pcd_args with -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_tuple [] | Pcstr_record [] -> -+#else -+ | [] -> -+#endif -+ i + 1, -+ i', -+ None, -+ [%expr Deriving_Json.Json_int.write buf -+ [%e Ast_convenience.int i]] -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_tuple ([ _ ] as args) -> -+#else -+ | [ _ ] as args -> -+#endif -+ let v = Ppx_deriving.fresh_var [] in -+ i, -+ i' + 1, -+ Some (Ast_convenience.pvar v), -+ write_tuple_contents [v] args ~tag:i' ~poly:true -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_tuple args -> -+#else -+ | args -> -+#endif -+ let vars = fresh_vars (List.length args) in -+ i, -+ i' + 1, -+ Some (var_ptuple vars), -+ write_tuple_contents vars args ~tag:i' ~poly:true -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_record args -> -+ let vars = fresh_vars (List.length args) in -+ i, -+ i' + 1, -+ Some (var_ptuple vars), -+ write_of_record vars args ~tag:i' -+#endif -+ in -+ i, i', -+ Ast_helper. -+ (Exp.case (Pat.construct (label_of_constructor pcd_name) lhs) -+ rhs) :: l -+ -+let write_decl_of_variant d l = -+ (let _, _, l = List.fold_left write_case (0, 0, []) l in -+ Ast_helper.Exp.function_ l) |> buf_expand |> -+ write_str_wrap d -+ -+let read_case ?decl (i, i', l) -+ {Parsetree.pcd_name; pcd_args; pcd_loc} = -+ match pcd_args with -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_tuple [] | Pcstr_record [] -> -+#else -+ | [] -> -+#endif -+ i + 1, i', -+ Ast_helper.Exp.case -+ [%pat? `Cst [%p Ast_convenience.pint i]] -+ (Ast_helper.Exp.construct (label_of_constructor pcd_name) None) -+ :: l -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_tuple pcd_args -> -+#else -+ | pcd_args -> -+#endif -+ let f l = -+ let args = -+ match l with -+ | [] -> None -+ | [e] -> Some e -+ | l -> Some (Ast_helper.Exp.tuple l) -+ in Ast_helper.Exp.construct (label_of_constructor pcd_name) args -+ in -+ let expr = read_tuple_contents ?decl pcd_args ~f in -+ let case = Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']] expr in -+ i, i' + 1, case :: l -+#if OCAML_VERSION >= (4, 03, 0) -+ | Pcstr_record pcd_args -> -+ let expr = read_of_record_raw ?decl pcd_args in -+ let case = Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']] expr in -+ i, i' + 1, case :: l -+#endif -+ -+let read_decl_of_variant decl l = -+ (let _, _, l = List.fold_left (read_case ~decl) (0, 0, []) l -+ and e = [%expr Deriving_Json_lexer.read_case buf] in -+ Ast_helper.Exp.match_ e (l @ [tag_error_case ()])) |> -+ buf_expand |> -+ read_str_wrap decl -+ -+let json_decls_of_variant d l = -+ write_decl_of_variant d l, read_decl_of_variant d l, json_str d, -+ None, None -+ -+let write_decl_of_record d l = -+ write_of_record d l |> write_str_wrap d -+ -+let read_decl_of_record d l = -+ read_of_record d l |> read_str_wrap d -+ -+let json_decls_of_record d l = -+ check_record_fields l; -+ write_decl_of_record d l, read_decl_of_record d l, json_str d, -+ None, None -+ -+let json_str_of_decl ({Parsetree.ptype_loc} as d) = -+ Ast_helper.with_default_loc ptype_loc @@ fun () -> -+ match d with -+ | { Parsetree.ptype_manifest = Some y } -> -+ json_decls_of_type d y -+ | { ptype_kind = Ptype_variant l } -> -+ json_decls_of_variant d l -+ | { ptype_kind = Ptype_record l } -> -+ json_decls_of_record d l -+ | _ -> -+ Location.raise_errorf "%s cannot be derived for %s" deriver -+ (Ppx_deriving.mangle_type_decl (`Suffix "") d) -+ -+let read_sig_of_decl ({Parsetree.ptype_loc} as d) = -+ (let s = -+ let s = Ppx_deriving.mangle_type_decl (`Suffix "of_json") d in -+ Location.mkloc s ptype_loc -+ and y = -+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in -+ let y = f (Ppx_deriving.core_type_of_type_decl d) in -+ Ppx_deriving.poly_arrow_of_type_decl f d y -+ in -+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -+ -+let recognize_sig_of_decl ({Parsetree.ptype_loc} as d) = -+ (let s = -+ let s = Ppx_deriving.mangle_type_decl (`Suffix "recognize") d in -+ Location.mkloc s ptype_loc -+ and y = [%type: [ `NCst of int | `Cst of int ] -> bool] in -+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -+ -+let read_with_tag_sig_of_decl ({Parsetree.ptype_loc} as d) = -+ (let s = -+ let s = -+ Ppx_deriving.mangle_type_decl (`Suffix "of_json_with_tag") d -+ in -+ Location.mkloc s ptype_loc -+ and y = -+ let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in -+ let y = -+ let y = Ppx_deriving.core_type_of_type_decl d in -+ f [%type: [ `NCst of int | `Cst of int ] -> [%t y]] -+ in -+ Ppx_deriving.poly_arrow_of_type_decl f d y -+ in -+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -+ -+let write_sig_of_decl ({Parsetree.ptype_loc} as d) = -+ (let s = -+ let s = Ppx_deriving.mangle_type_decl (`Suffix "to_json") d in -+ Location.mkloc s ptype_loc -+ and y = -+ let f y = [%type: Buffer.t -> [%t y] -> unit] in -+ let y = f (Ppx_deriving.core_type_of_type_decl d) in -+ Ppx_deriving.poly_arrow_of_type_decl f d y -+ in -+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -+ -+let json_sig_of_decl ({Parsetree.ptype_loc} as d) = -+ (let s = -+ let s = Ppx_deriving.mangle_type_decl (`Suffix "json") d in -+ Location.mkloc s ptype_loc -+ and y = -+ let f y = [%type: [%t y] Deriving_Json.t] in -+ let y = f (Ppx_deriving.core_type_of_type_decl d) in -+ Ppx_deriving.poly_arrow_of_type_decl f d y -+ in -+ Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -+ -+let sigs_of_decl ({Parsetree.ptype_loc} as d) = -+ Ast_helper.with_default_loc ptype_loc @@ fun () -> -+ let l = [ -+ read_sig_of_decl d; -+ write_sig_of_decl d; -+ json_sig_of_decl d -+ ] in -+ match d with -+ | { Parsetree.ptype_manifest = -+ Some {Parsetree.ptyp_desc = Parsetree.Ptyp_variant _}} -> -+ read_with_tag_sig_of_decl d :: recognize_sig_of_decl d :: l -+ | _ -> -+ l -+ -+let register_for_expr s f = -+ let core_type ({Parsetree.ptyp_loc} as y) = -+ let f () = f y |> sanitize in -+ Ast_helper.with_default_loc ptyp_loc f -+ in -+ Ppx_deriving.(create s ~core_type () |> register) -+ -+let _ = -+ register_for_expr "of_json" @@ fun y -> [%expr -+ fun s -> -+ [%e read_of_type y] -+ (Deriving_Json_lexer.init_lexer (Lexing.from_string s))] -+ -+let _ = -+ register_for_expr "to_json" @@ fun y -> [%expr -+ fun x -> -+ let buf = Buffer.create 50 in -+ [%e write_of_type y ~poly:false] buf x; -+ Buffer.contents buf] -+ -+let _ = -+ let core_type ({Parsetree.ptyp_loc} as y) = -+ let f () = json_of_type y |> sanitize in -+ Ast_helper.with_default_loc ptyp_loc f -+ and type_decl_str ~options ~path l = -+ let lw, lr, lj, lp, lrv = -+ let f d (lw, lr, lj, lp, lrv) = -+ let w, r, j, p, rv = json_str_of_decl d in -+ w :: lw, r :: lr, j :: lj, -+ (match p with Some p -> p :: lp | None -> lp), -+ (match rv with Some rv -> rv :: lrv | None -> lrv) -+ and acc = [], [], [], [], [] in -+ List.fold_right f l acc -+ and f = Ast_helper.Str.value Asttypes.Recursive -+ and f' = Ast_helper.Str.value Asttypes.Nonrecursive in -+ let l = [f (lrv @ lr); f lw; f' lj] in -+ match lp with [] -> l | _ -> f lp :: l -+ and type_decl_sig ~options ~path l = -+ List.map sigs_of_decl l |> List.flatten -+ in -+ Ppx_deriving. -+ (create "json" ~core_type ~type_decl_str ~type_decl_sig () -+ |> register) -diff --git a/lib/ppx/ppx_deriving_json.ml b/lib/ppx/ppx_deriving_json.ml -deleted file mode 100644 -index e96ce3f..0000000 ---- a/lib/ppx/ppx_deriving_json.ml -+++ /dev/null -@@ -1,675 +0,0 @@ --(* Js_of_ocaml -- * http://www.ocsigen.org -- * Copyright Vasilis Papavasileiou 2015 -- * -- * This program is free software; you can redistribute it and/or modify -- * it under the terms of the GNU Lesser General Public License as published by -- * the Free Software Foundation, with linking exception; -- * either version 2.1 of the License, or (at your option) any later version. -- * -- * This program is distributed in the hope that it will be useful, -- * but WITHOUT ANY WARRANTY; without even the implied warranty of -- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- * GNU Lesser General Public License for more details. -- * -- * You should have received a copy of the GNU Lesser General Public License -- * along with this program; if not, write to the Free Software -- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- *) -- --let deriver = "json" -- --(* Copied (and adapted) this from ppx_deriving repo (commit -- e2079fa8f3460055bf990461f295c6c4b391fafc) ; we get an empty set of -- let bindings with ppx_deriving 3.0 *) --let sanitize expr = [%expr -- (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] -- --let var_ptuple l = -- List.map Ast_convenience.pvar l |> Ast_helper.Pat.tuple -- --let map_loc f {Location.txt; loc} = -- {Location.txt = f txt; loc} -- --let suffix_lid {Location.txt; loc} ~suffix = -- let txt = Ppx_deriving.mangle_lid (`Suffix suffix) txt in -- Ast_helper.Exp.ident {txt; loc} ~loc -- --let suffix_decl ({Parsetree.ptype_loc = loc} as d) ~suffix = -- (let s = -- Ppx_deriving.mangle_type_decl (`Suffix suffix) d |> -- Longident.parse -- in -- Location.mkloc s loc) |> Ast_helper.Exp.ident ~loc -- --let suffix_decl_p ({Parsetree.ptype_loc = loc} as d) ~suffix = -- (let s = Ppx_deriving.mangle_type_decl (`Suffix suffix) d in -- Location.mkloc s loc) |> Ast_helper.Pat.var ~loc -- --let rec fresh_vars ?(acc = []) n = -- if n <= 0 then -- List.rev acc -- else -- let acc = Ppx_deriving.fresh_var acc :: acc in -- fresh_vars ~acc (n - 1) -- --let unreachable_case () = -- Ast_helper.Exp.case [%pat? _ ] [%expr assert false] -- --let label_of_constructor = map_loc (fun c -> Longident.Lident c) -- --let wrap_write r ~pattern = [%expr fun buf [%p pattern] -> [%e r]] -- --let buf_expand r = [%expr fun buf -> [%e r]] -- --let seqlist = function -- | h :: l -> -- let f acc e = [%expr [%e acc]; [%e e]] in -- List.fold_left f h l -- | [] -> -- [%expr ()] -- --let check_record_fields = -- List.iter @@ function -- | {Parsetree.pld_mutable = Mutable} -> -- Location.raise_errorf -- "%s cannot be derived for mutable records" deriver -- | {pld_type = {ptyp_desc = Ptyp_poly _}} -> -- Location.raise_errorf -- "%s cannot be derived for polymorphic records" deriver -- | _ -> -- () -- --let maybe_tuple_type = function -- | [y] -> y -- | l -> Ast_helper.Typ.tuple l -- --let rec write_tuple_contents l ly tag ~poly = -- let e = -- let f v y = -- let arg = Ast_convenience.evar v in -- let e = write_body_of_type y ~arg ~poly in -- [%expr Buffer.add_string buf ","; [%e e]] -- in -- List.map2 f l ly |> seqlist -- and s = Ast_convenience.str ("[" ^ string_of_int tag) in [%expr -- Buffer.add_string buf [%e s]; -- [%e e]; -- Buffer.add_string buf "]"] -- --and write_body_of_tuple_type l ~arg ~poly ~tag = -- let n = List.length l in -- let vars = fresh_vars n in -- let e = write_tuple_contents vars l tag ~poly -- and p = var_ptuple vars in -- [%expr let [%p p] = [%e arg] in [%e e]] -- --and write_poly_case r ~arg ~poly = -- match r with -- | Parsetree.Rtag (label, _, _, l) -> -- let i = Ppx_deriving.hash_variant label -- and n = List.length l in -- let v = Ppx_deriving.fresh_var [] in -- let lhs = -- (if n = 0 then None else Some (Ast_convenience.pvar v)) |> -- Ast_helper.Pat.variant label -- and rhs = -- match l with -- | [] -> -- let e = Ast_convenience.int i in -- [%expr Deriving_Json.Json_int.write buf [%e e]] -- | _ -> -- let l = [[%type: int]; maybe_tuple_type l] -- and arg = Ast_helper.Exp.tuple Ast_convenience.[int i; evar v] in -- write_body_of_tuple_type l ~arg ~poly ~tag:0 -- in -- Ast_helper.Exp.case lhs rhs -- | Rinherit ({ptyp_desc = Ptyp_constr (lid, _)} as y) -> -- Ast_helper.Exp.case (Ast_helper.Pat.type_ lid) -- (write_body_of_type y ~arg ~poly) -- | Rinherit {ptyp_loc} -> -- Location.raise_errorf ~loc:ptyp_loc -- "%s write case cannot be derived" deriver -- --and write_body_of_type y ~arg ~poly = -- match y with -- | [%type: unit] -> -- [%expr Deriving_Json.Json_unit.write buf [%e arg]] -- | [%type: int] -> -- [%expr Deriving_Json.Json_int.write buf [%e arg]] -- | [%type: int32] | [%type: Int32.t] -> -- [%expr Deriving_Json.Json_int32.write buf [%e arg]] -- | [%type: int64] | [%type: Int64.t] -> -- [%expr Deriving_Json.Json_int64.write buf [%e arg]] -- | [%type: nativeint] | [%type: Nativeint.t] -> -- [%expr Deriving_Json.Json_nativeint.write buf [%e arg]] -- | [%type: float] -> -- [%expr Deriving_Json.Json_float.write buf [%e arg]] -- | [%type: bool] -> -- [%expr Deriving_Json.Json_bool.write buf [%e arg]] -- | [%type: char] -> -- [%expr Deriving_Json.Json_char.write buf [%e arg]] -- | [%type: string] -> -- [%expr Deriving_Json.Json_string.write buf [%e arg]] -- | [%type: bytes] -> -- [%expr Deriving_Json.Json_bytes.write buf [%e arg]] -- | [%type: [%t? y] list] -> -- let e = write_of_type y ~poly in -- [%expr Deriving_Json.write_list [%e e] buf [%e arg]] -- | [%type: [%t? y] ref] -> -- let e = write_of_type y ~poly in -- [%expr Deriving_Json.write_ref [%e e] buf [%e arg]] -- | [%type: [%t? y] option] -> -- let e = write_of_type y ~poly in -- [%expr Deriving_Json.write_option [%e e] buf [%e arg]] -- | [%type: [%t? y] array] -> -- let e = write_of_type y ~poly in -- [%expr Deriving_Json.write_array [%e e] buf [%e arg]] -- | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> -- [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf [%e arg]] -- | { Parsetree.ptyp_desc = Ptyp_tuple l } -> -- write_body_of_tuple_type l ~arg ~poly ~tag:0 -- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> -- List.map (write_poly_case ~arg ~poly) l @ [unreachable_case ()] |> -- Ast_helper.Exp.match_ arg -- | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> -- let e = suffix_lid lid ~suffix:"to_json" -- and l = List.map (write_of_type ~poly) l in -- [%expr [%e Ast_convenience.app e l] buf [%e arg]] -- | { Parsetree.ptyp_loc } -> -- Location.raise_errorf ~loc:ptyp_loc -- "%s_write cannot be derived for %s" -- deriver (Ppx_deriving.string_of_core_type y) -- --and write_of_type y ~poly = -- let v = "a" in -- let arg = Ast_convenience.evar v -- and pattern = Ast_convenience.pvar v in -- wrap_write (write_body_of_type y ~arg ~poly) ~pattern -- --and write_of_record d l = -- let pattern = -- let l = -- let f {Parsetree.pld_name} = -- label_of_constructor pld_name, -- Ast_helper.Pat.var pld_name -- in -- List.map f l -- in -- Ast_helper.Pat.record l Asttypes.Closed -- and e = -- let l = -- let f {Parsetree.pld_name = {txt}} = txt in -- List.map f l -- and ly = -- let f {Parsetree.pld_type} = pld_type in -- List.map f l -- in -- write_tuple_contents l ly 0 ~poly:true -- in -- wrap_write e ~pattern -- --let recognize_case_of_constructor i l = -- let lhs = -- match l with -- | [] -> [%pat? `Cst [%p Ast_convenience.pint i]] -- | _ -> [%pat? `NCst [%p Ast_convenience.pint i]] -- in -- Ast_helper.Exp.case lhs [%expr true] -- --let recognize_body_of_poly_variant l ~loc = -- let l = -- let f = function -- | Parsetree.Rtag (label, _, _, l) -> -- let i = Ppx_deriving.hash_variant label in -- recognize_case_of_constructor i l -- | Rinherit {ptyp_desc = Ptyp_constr (lid, _)} -> -- let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] in -- Ast_helper.Exp.case ~guard [%pat? x] [%expr true] -- | _ -> -- Location.raise_errorf ~loc -- "%s_recognize cannot be derived" deriver -- and default = Ast_helper.Exp.case [%pat? _] [%expr false] in -- List.map f l @ [default] -- in -- Ast_helper.Exp.function_ l -- --let tag_error_case ?(typename="") () = -- let y = Ast_convenience.str typename in -- Ast_helper.Exp.case -- [%pat? _] -- [%expr Deriving_Json_lexer.tag_error ~typename:[%e y] buf] -- --let maybe_tuple_type = function -- | [y] -> y -- | l -> Ast_helper.Typ.tuple l -- --let rec read_poly_case ?decl y = function -- | Parsetree.Rtag (label, _, _, l) -> -- let i = Ppx_deriving.hash_variant label |> Ast_convenience.pint in -- (match l with -- | [] -> -- Ast_helper.Exp.case [%pat? `Cst [%p i]] -- (Ast_helper.Exp.variant label None) -- | l -> -- Ast_helper.Exp.case [%pat? `NCst [%p i]] [%expr -- Deriving_Json_lexer.read_comma buf; -- let v = [%e read_body_of_type ?decl (maybe_tuple_type l)] in -- Deriving_Json_lexer.read_rbracket buf; -- [%e Ast_helper.Exp.variant label (Some [%expr v])]]) -- | Rinherit {ptyp_desc = Ptyp_constr (lid, l)} -> -- let guard = [%expr [%e suffix_lid lid ~suffix:"recognize"] x] -- and e = -- let e = suffix_lid lid ~suffix:"of_json_with_tag" -- and l = List.map (read_of_type ?decl) l in -- [%expr ([%e Ast_convenience.app e l] buf x :> [%t y])] -- in -- Ast_helper.Exp.case ~guard [%pat? x] e -- | Rinherit {ptyp_loc} -> -- Location.raise_errorf ~loc:ptyp_loc -- "%s read case cannot be derived" deriver -- --and read_of_poly_variant ?decl l y ~loc = -- List.map (read_poly_case ?decl y) l @ [tag_error_case ()] |> -- Ast_helper.Exp.function_ |> -- buf_expand -- --and read_tuple_contents ?decl l ~f = -- let n = List.length l in -- let lv = fresh_vars n in -- let f v y acc = -- let e = read_body_of_type ?decl y in [%expr -- Deriving_Json_lexer.read_comma buf; -- let [%p Ast_convenience.pvar v] = [%e e] in -- [%e acc]] -- and acc = List.map Ast_convenience.evar lv |> f in -- let acc = [%expr Deriving_Json_lexer.read_rbracket buf; [%e acc]] in -- List.fold_right2 f lv l acc -- --and read_body_of_tuple_type ?decl l = [%expr -- Deriving_Json_lexer.read_lbracket buf; -- ignore (Deriving_Json_lexer.read_tag_1 0 buf); -- [%e read_tuple_contents ?decl l ~f:Ast_helper.Exp.tuple]] -- --and read_of_record decl l = -- let e = -- let f = -- let f {Parsetree.pld_name} e = label_of_constructor pld_name, e in -- fun l' -> Ast_helper.Exp.record (List.map2 f l l') None -- and l = -- let f {Parsetree.pld_type} = pld_type in -- List.map f l -- in -- read_tuple_contents l ~decl ~f -- in [%expr -- Deriving_Json_lexer.read_lbracket buf; -- ignore (Deriving_Json_lexer.read_tag_2 0 254 buf); -- [%e e]] |> buf_expand -- --and read_body_of_type ?decl y = -- let poly = match decl with Some _ -> true | _ -> false in -- match y with -- | [%type: unit] -> -- [%expr Deriving_Json.Json_unit.read buf] -- | [%type: int] -> -- [%expr Deriving_Json.Json_int.read buf] -- | [%type: int32] | [%type: Int32.t] -> -- [%expr Deriving_Json.Json_int32.read buf] -- | [%type: int64] | [%type: Int64.t] -> -- [%expr Deriving_Json.Json_int64.read buf] -- | [%type: nativeint] | [%type: Nativeint.t] -> -- [%expr Deriving_Json.Json_nativeint.read buf] -- | [%type: float] -> -- [%expr Deriving_Json.Json_float.read buf] -- | [%type: bool] -> -- [%expr Deriving_Json.Json_bool.read buf] -- | [%type: char] -> -- [%expr Deriving_Json.Json_char.read buf] -- | [%type: string] -> -- [%expr Deriving_Json.Json_string.read buf] -- | [%type: bytes] -> -- [%expr Deriving_Json.Json_bytes.read buf] -- | [%type: [%t? y] list] -> -- [%expr Deriving_Json.read_list [%e read_of_type ?decl y] buf] -- | [%type: [%t? y] ref] -> -- [%expr Deriving_Json.read_ref [%e read_of_type ?decl y] buf] -- | [%type: [%t? y] option] -> -- [%expr Deriving_Json.read_option [%e read_of_type ?decl y] buf] -- | [%type: [%t? y] array] -> -- [%expr Deriving_Json.read_array [%e read_of_type ?decl y] buf] -- | { Parsetree.ptyp_desc = Ptyp_tuple l } -> -- read_body_of_tuple_type l ?decl -- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); ptyp_loc = loc } -> -- let e = -- (match decl with -- | Some decl -> -- let e = suffix_decl decl ~suffix:"of_json_with_tag" -- and l = -- let {Parsetree.ptype_params = l} = decl -- and f (y, _) = read_of_type y ~decl in -- List.map f l -- in -- Ast_convenience.app e l -- | None -> -- read_of_poly_variant l y ~loc) -- and tag = [%expr Deriving_Json_lexer.read_vcase buf] in -- [%expr [%e e] buf [%e tag]] -- | { Parsetree.ptyp_desc = Ptyp_var v } when poly -> -- [%expr [%e Ast_convenience.evar ("poly_" ^ v)] buf] -- | { Parsetree.ptyp_desc = Ptyp_constr (lid, l) } -> -- let e = suffix_lid lid ~suffix:"of_json" -- and l = List.map (read_of_type ?decl) l in -- [%expr [%e Ast_convenience.app e l] buf] -- | { Parsetree.ptyp_loc } -> -- Location.raise_errorf ~loc:ptyp_loc -- "%s_read cannot be derived for %s" deriver -- (Ppx_deriving.string_of_core_type y) -- --and read_of_type ?decl y = -- read_body_of_type ?decl y |> buf_expand -- --let json_of_type ?decl y = -- let read = read_of_type ?decl y -- and write = -- let poly = match decl with Some _ -> true | _ -> false in -- write_of_type y ~poly in -- [%expr Deriving_Json.make [%e write] [%e read]] -- --let fun_str_wrap d e y ~f ~suffix = -- let e = Ppx_deriving.poly_fun_of_type_decl d e |> sanitize -- and v = suffix_decl_p d ~suffix -- and y = Ppx_deriving.poly_arrow_of_type_decl f d y in -- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -- --let read_str_wrap d e = -- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] -- and suffix = "of_json" in -- let y = f (Ppx_deriving.core_type_of_type_decl d) in -- fun_str_wrap d e y ~f ~suffix -- --let read_tag_str_wrap d e = -- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] -- and suffix = "of_json_with_tag" -- and y = -- let y = Ppx_deriving.core_type_of_type_decl d in -- [%type: Deriving_Json_lexer.lexbuf -> -- [`NCst of int | `Cst of int] -> [%t y]] -- in -- fun_str_wrap d e y ~f ~suffix -- --let write_str_wrap d e = -- let f y = [%type: Buffer.t -> [%t y] -> unit] -- and suffix = "to_json" in -- let y = -- let y = Ppx_deriving.core_type_of_type_decl d in -- (match d with -- | {ptype_manifest = -- Some {ptyp_desc = Parsetree.Ptyp_variant (_, _, _)}} -> -- [%type: [> [%t y]]] -- | _ -> -- y) |> f -- in -- fun_str_wrap d e y ~f ~suffix -- --let recognize_str_wrap d e = -- let v = suffix_decl_p d ~suffix:"recognize" -- and y = [%type: [`NCst of int | `Cst of int] -> bool] in -- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -- --let json_poly_type d = -- let f y = [%type: [%t y] Deriving_Json.t] in -- let y = f (Ppx_deriving.core_type_of_type_decl d) in -- Ppx_deriving.poly_arrow_of_type_decl f d y -- --let json_str_wrap d e = -- let v = suffix_decl_p d ~suffix:"json" -- and e = Ppx_deriving.(poly_fun_of_type_decl d e) -- and y = json_poly_type d in -- Ast_helper.(Vb.mk (Pat.constraint_ v y) e) -- --let json_str d = -- let write = -- let f acc id = -- let poly = Ast_convenience.evar ("poly_" ^ id) in -- [%expr [%e acc] (Deriving_Json.write [%e poly])] -- and acc = suffix_decl d ~suffix:"to_json" in -- Ppx_deriving.fold_left_type_decl f acc d -- and read = -- let f acc id = -- let poly = Ast_convenience.evar ("poly_" ^ id) in -- [%expr [%e acc] (Deriving_Json.read [%e poly])] -- and acc = suffix_decl d ~suffix:"of_json" in -- Ppx_deriving.fold_left_type_decl f acc d -- in -- [%expr Deriving_Json.make [%e write] [%e read]] |> -- json_str_wrap d -- --let write_decl_of_type d y = -- (let e = -- let arg = Ast_convenience.evar "a" in -- write_body_of_type y ~arg ~poly:true -- in -- [%expr fun buf a -> [%e e]]) |> write_str_wrap d -- --let read_decl_of_type decl y = -- read_body_of_type y ~decl |> buf_expand |> read_str_wrap decl -- --let json_decls_of_type decl y = -- let recognize, read_tag = -- match y with -- | { Parsetree.ptyp_desc = Ptyp_variant (l, _, _); -- ptyp_loc = loc } -> -- Some (recognize_body_of_poly_variant l ~loc -- |> recognize_str_wrap decl), -- Some (read_of_poly_variant l y ~decl ~loc -- |> read_tag_str_wrap decl) -- | _ -> -- None, None -- in -- write_decl_of_type decl y, -- read_decl_of_type decl y, -- json_str decl, -- recognize, read_tag -- --let write_case (i, i', l) {Parsetree.pcd_name; pcd_args; pcd_loc} = -- let n = List.length pcd_args in -- let vars = fresh_vars n in -- let i, i', lhs, rhs = -- match vars with -- | [] -> -- i + 1, -- i', -- None, -- [%expr Deriving_Json.Json_int.write buf -- [%e Ast_convenience.int i]] -- | [v] -> -- i, -- i' + 1, -- Some (Ast_convenience.pvar v), -- write_tuple_contents vars pcd_args i' ~poly:true -- | _ -> -- i, -- i' + 1, -- Some (var_ptuple vars), -- write_tuple_contents vars pcd_args i' ~poly:true -- in -- i, i', -- Ast_helper. -- (Exp.case (Pat.construct (label_of_constructor pcd_name) lhs) -- rhs) :: l -- --let write_decl_of_variant d l = -- (let _, _, l = List.fold_left write_case (0, 0, []) l in -- Ast_helper.Exp.function_ l) |> buf_expand |> -- write_str_wrap d -- --let read_case ?decl (i, i', l) -- {Parsetree.pcd_name; pcd_args; pcd_loc} = -- match pcd_args with -- | [] -> -- i + 1, i', -- Ast_helper.Exp.case -- [%pat? `Cst [%p Ast_convenience.pint i]] -- (Ast_helper.Exp.construct (label_of_constructor pcd_name) None) -- :: l -- | _ -> -- i, i' + 1, -- ((let f l = -- (match l with -- | [] -> None -- | [e] -> Some e -- | l -> Some (Ast_helper.Exp.tuple l)) |> -- Ast_helper.Exp.construct (label_of_constructor pcd_name) -- in -- read_tuple_contents ?decl pcd_args ~f) |> -- Ast_helper.Exp.case [%pat? `NCst [%p Ast_convenience.pint i']]) -- :: l -- --let read_decl_of_variant decl l = -- (let _, _, l = List.fold_left (read_case ~decl) (0, 0, []) l -- and e = [%expr Deriving_Json_lexer.read_case buf] in -- Ast_helper.Exp.match_ e (l @ [tag_error_case ()])) |> -- buf_expand |> -- read_str_wrap decl -- --let json_decls_of_variant d l = -- write_decl_of_variant d l, read_decl_of_variant d l, json_str d, -- None, None -- --let write_decl_of_record d l = -- write_of_record d l |> write_str_wrap d -- --let read_decl_of_record d l = -- read_of_record d l |> read_str_wrap d -- --let json_decls_of_record d l = -- check_record_fields l; -- write_decl_of_record d l, read_decl_of_record d l, json_str d, -- None, None -- --let json_str_of_decl ({Parsetree.ptype_loc} as d) = -- Ast_helper.with_default_loc ptype_loc @@ fun () -> -- match d with -- | { Parsetree.ptype_manifest = Some y } -> -- json_decls_of_type d y -- | { ptype_kind = Ptype_variant l } -> -- json_decls_of_variant d l -- | { ptype_kind = Ptype_record l } -> -- json_decls_of_record d l -- | _ -> -- Location.raise_errorf "%s cannot be derived for %s" deriver -- (Ppx_deriving.mangle_type_decl (`Suffix "") d) -- --let read_sig_of_decl ({Parsetree.ptype_loc} as d) = -- (let s = -- let s = Ppx_deriving.mangle_type_decl (`Suffix "of_json") d in -- Location.mkloc s ptype_loc -- and y = -- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in -- let y = f (Ppx_deriving.core_type_of_type_decl d) in -- Ppx_deriving.poly_arrow_of_type_decl f d y -- in -- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -- --let recognize_sig_of_decl ({Parsetree.ptype_loc} as d) = -- (let s = -- let s = Ppx_deriving.mangle_type_decl (`Suffix "recognize") d in -- Location.mkloc s ptype_loc -- and y = [%type: [ `NCst of int | `Cst of int ] -> bool] in -- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -- --let read_with_tag_sig_of_decl ({Parsetree.ptype_loc} as d) = -- (let s = -- let s = -- Ppx_deriving.mangle_type_decl (`Suffix "of_json_with_tag") d -- in -- Location.mkloc s ptype_loc -- and y = -- let f y = [%type: Deriving_Json_lexer.lexbuf -> [%t y]] in -- let y = -- let y = Ppx_deriving.core_type_of_type_decl d in -- f [%type: [ `NCst of int | `Cst of int ] -> [%t y]] -- in -- Ppx_deriving.poly_arrow_of_type_decl f d y -- in -- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -- --let write_sig_of_decl ({Parsetree.ptype_loc} as d) = -- (let s = -- let s = Ppx_deriving.mangle_type_decl (`Suffix "to_json") d in -- Location.mkloc s ptype_loc -- and y = -- let f y = [%type: Buffer.t -> [%t y] -> unit] in -- let y = f (Ppx_deriving.core_type_of_type_decl d) in -- Ppx_deriving.poly_arrow_of_type_decl f d y -- in -- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -- --let json_sig_of_decl ({Parsetree.ptype_loc} as d) = -- (let s = -- let s = Ppx_deriving.mangle_type_decl (`Suffix "json") d in -- Location.mkloc s ptype_loc -- and y = -- let f y = [%type: [%t y] Deriving_Json.t] in -- let y = f (Ppx_deriving.core_type_of_type_decl d) in -- Ppx_deriving.poly_arrow_of_type_decl f d y -- in -- Ast_helper.Val.mk s y) |> Ast_helper.Sig.value -- --let sigs_of_decl ({Parsetree.ptype_loc} as d) = -- Ast_helper.with_default_loc ptype_loc @@ fun () -> -- let l = [ -- read_sig_of_decl d; -- write_sig_of_decl d; -- json_sig_of_decl d -- ] in -- match d with -- | { Parsetree.ptype_manifest = -- Some {Parsetree.ptyp_desc = Parsetree.Ptyp_variant _}} -> -- read_with_tag_sig_of_decl d :: recognize_sig_of_decl d :: l -- | _ -> -- l -- --let register_for_expr s f = -- let core_type ({Parsetree.ptyp_loc} as y) = -- let f () = f y |> sanitize in -- Ast_helper.with_default_loc ptyp_loc f -- in -- Ppx_deriving.(create s ~core_type () |> register) -- --let _ = -- register_for_expr "of_json" @@ fun y -> [%expr -- fun s -> -- [%e read_of_type y] -- (Deriving_Json_lexer.init_lexer (Lexing.from_string s))] -- --let _ = -- register_for_expr "to_json" @@ fun y -> [%expr -- fun x -> -- let buf = Buffer.create 50 in -- [%e write_of_type y ~poly:false] buf x; -- Buffer.contents buf] -- --let _ = -- let core_type ({Parsetree.ptyp_loc} as y) = -- let f () = json_of_type y |> sanitize in -- Ast_helper.with_default_loc ptyp_loc f -- and type_decl_str ~options ~path l = -- let lw, lr, lj, lp, lrv = -- let f d (lw, lr, lj, lp, lrv) = -- let w, r, j, p, rv = json_str_of_decl d in -- w :: lw, r :: lr, j :: lj, -- (match p with Some p -> p :: lp | None -> lp), -- (match rv with Some rv -> rv :: lrv | None -> lrv) -- and acc = [], [], [], [], [] in -- List.fold_right f l acc -- and f = Ast_helper.Str.value Asttypes.Recursive -- and f' = Ast_helper.Str.value Asttypes.Nonrecursive in -- let l = [f (lrv @ lr); f lw; f' lj] in -- match lp with [] -> l | _ -> f lp :: l -- and type_decl_sig ~options ~path l = -- List.map sigs_of_decl l |> List.flatten -- in -- Ppx_deriving. -- (create "json" ~core_type ~type_decl_str ~type_decl_sig () -- |> register) 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 deleted file mode 100644 index 2de89b9..00000000 --- a/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild +++ /dev/null @@ -1,59 +0,0 @@ -# Copyright 1999-2015 Gentoo Foundation -# Distributed under the terms of the GNU General Public License v2 -# $Id$ - -EAPI=5 - -inherit findlib eutils - -DESCRIPTION="A compiler from OCaml bytecode to javascript" -HOMEPAGE="http://ocsigen.org/js_of_ocaml/"; -SRC_URI="https://github.com/ocsigen/js_of_ocaml/archive/${PV}.tar.gz -> ${P}.tar.gz" - -LICENSE="LGPL-2.1-with-linking-exception" -SLOT="0/${PV}" -KEYWORDS="~amd64" -IUSE="+ocamlopt doc +deriving +ppx +ppx-deriving +react +xml X" - -RDEPEND=" - >=dev-lang/ocaml-3.12:=[ocamlopt?,X?] - >=dev-ml/lwt-2.4.4:= - react? ( dev-ml/react:= dev-ml/reactiveData:= ) - xml? ( >=dev-ml/tyxml-3.6:= ) - ppx? ( dev-ml/ppx_tools:= ) - ppx-deriving? ( dev-ml/ppx_deriving:= ) - dev-ml/cmdliner:= - dev-ml/menhir:= - dev-ml/ocaml-base64:= - dev-ml/camlp4:= - dev-ml/cppo:= - deriving? ( >=dev-ml/deriving-0.6:= )" -DEPEND="${RDEPEND} - dev-ml/ocamlbuild" - -src_prepare() { - has_version '>=dev-lang/ocaml-4.03' && epatch "${FILESDIR}/oc43.patch" -} - -src_configure() { - printf "\n\n" >> Makefile.conf - use ocamlopt || echo "BEST := byte" >> Makefile.conf - use ocamlopt || echo "NATDYNLINK := NO" >> Makefile.conf - use deriving || echo "WITH_DERIVING := NO" >> Makefile.conf - use X || echo "WITH_GRAPHICS := NO" >> Makefile.conf - use react || echo "WITH_REACT := NO" >> Makefile.conf - use ppx || echo "WITH_PPX := NO" >> Makefile.conf - use ppx-deriving || echo "WITH_PPX_PPX_DERIVING := NO" >> Makefile.conf -} - -src_compile() { - emake - use doc && emake doc -} - -src_install() { - findlib_src_preinst - emake BINDIR="${ED}/usr/bin/" install - dodoc CHANGES README.md - use doc && dohtml -r doc/api/html/ -} 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 deleted file mode 100644 index 58bce36..00000000 --- a/dev-ml/js_of_ocaml/js_of_ocaml-2.8.ebuild +++ /dev/null @@ -1,57 +0,0 @@ -# Copyright 1999-2016 Gentoo Foundation -# Distributed under the terms of the GNU General Public License v2 -# $Id$ - -EAPI=5 - -inherit findlib eutils - -DESCRIPTION="A compiler from OCaml bytecode to javascript" -HOMEPAGE="http://ocsigen.org/js_of_ocaml/"; -SRC_URI="https://github.com/ocsigen/js_of_ocaml/archive/${PV}.tar.gz -> ${P}.tar.gz" - -LICENSE="LGPL-2.1-with-linking-exception" -SLOT="0/${PV}" -KEYWORDS="~amd64" -IUSE="+async +ocamlopt doc +deriving +ppx +ppx-deriving +react +xml X" - -RDEPEND=" - >=dev-lang/ocaml-3.12:=[ocamlopt?,X?] - >=dev-ml/lwt-2.4.4:= - async? ( dev-ml/async_kernel:= ) - react? ( dev-ml/react:= dev-ml/reactiveData:= ) - xml? ( >=dev-ml/tyxml-4:= ) - ppx? ( dev-ml/ppx_tools:= ) - ppx-deriving? ( dev-ml/ppx_deriving:= ) - dev-ml/cmdliner:= - dev-ml/menhir:= - dev-ml/ocaml-base64:= - dev-ml/camlp4:= - dev-ml/cppo:= - deriving? ( >=dev-ml/deriving-0.6:= )" -DEPEND="${RDEPEND} - dev-ml/ocamlbuild" - -src_configure() { - printf "\n\n" >> Makefile.conf - use ocamlopt || echo "BEST := byte" >> Makefile.conf - use ocamlopt || echo "NATDYNLINK := NO" >> Makefile.conf - use deriving || echo "WITH_DERIVING := NO" >> Makefile.conf - use X || echo "WITH_GRAPHICS := NO" >> Makefile.conf - use react || echo "WITH_REACT := NO" >> Makefile.conf - use ppx || echo "WITH_PPX := NO" >> Makefile.conf - use ppx-deriving || echo "WITH_PPX_PPX_DERIVING := NO" >> Makefile.conf - use async || echo "WITH_ASYNC := NO" >> Makefile.conf -} - -src_compile() { - emake -j1 - use doc && emake doc -} - -src_install() { - findlib_src_preinst - emake BINDIR="${ED}/usr/bin/" install - dodoc CHANGES README.md - use doc && dohtml -r doc/api/html/ -}
