* [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/
@ 2016-03-01 18:47 Alexis Ballier
0 siblings, 0 replies; 4+ messages in thread
From: Alexis Ballier @ 2016-03-01 18:47 UTC (permalink / raw
To: gentoo-commits
commit: 79ba50f3e692f57b7ee9d4dc8af935f5e851a5a1
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org>
AuthorDate: Tue Mar 1 18:19:59 2016 +0000
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org>
CommitDate: Tue Mar 1 18:47:37 2016 +0000
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=79ba50f3
dev-ml/js_of_ocaml: remove old
Package-Manager: portage-2.2.27
Signed-off-by: Alexis Ballier <aballier <AT> gentoo.org>
dev-ml/js_of_ocaml/Manifest | 1 -
dev-ml/js_of_ocaml/files/tyxml36-2.patch | 30 ------
dev-ml/js_of_ocaml/files/tyxml36.patch | 158 ------------------------------
dev-ml/js_of_ocaml/js_of_ocaml-2.6.ebuild | 52 ----------
4 files changed, 241 deletions(-)
diff --git a/dev-ml/js_of_ocaml/Manifest b/dev-ml/js_of_ocaml/Manifest
index fa92aea..e312923 100644
--- a/dev-ml/js_of_ocaml/Manifest
+++ b/dev-ml/js_of_ocaml/Manifest
@@ -1,2 +1 @@
-DIST js_of_ocaml-2.6.tar.gz 1291882 SHA256 c1f066d09524c6be2d40cfb387de49b337837dcc8f2f746a207f37706ca66460 SHA512 2c4e294b7946757d9b05ec640e130cbee6a0130c03eb3a2188988fb956c1f0e2738c32e97abc461e748e667e7d31e386c5470942df84ddbcf5903d41b133e8c8 WHIRLPOOL abf477caa49edc65b5e577a90dd86641f12b6757e6f2c9034fe08d51cc1ac11209b73e8fdd88de420ed0277d8715bb085c10d29b237854cdebb8a9e36f8e22fe
DIST js_of_ocaml-2.7.tar.gz 1304487 SHA256 52922f55428a1d8a55ec2493c4989152e06efd29a981adf8ac9f343f558854b5 SHA512 ab6e5d16342bf763c10eb5c2e7589610622034eee2ad82aa09c6f68448f155a5c56584702307852b251bde80146c1b7115ed6add1358ad96b130c9dd2b96118b WHIRLPOOL 278c17432fdf9bf670df33479c68705868be39eb4d53f67fc489fe44ac2e7645dd5e2ed3e6e71752a2387b516ce0ab6dc99ac1d870fc75ffdad9df87031e9de4
diff --git a/dev-ml/js_of_ocaml/files/tyxml36-2.patch b/dev-ml/js_of_ocaml/files/tyxml36-2.patch
deleted file mode 100644
index 0f7771c..0000000
--- a/dev-ml/js_of_ocaml/files/tyxml36-2.patch
+++ /dev/null
@@ -1,30 +0,0 @@
-commit f11959da5a630a7dca47497c9543231d9698b406
-Author: Vasilis Papavasileiou <git@vasilis.airpost.net>
-Date: Fri Aug 7 11:16:20 2015 +0200
-
- Tyxml_js: ft constructor in Xml_wrap (forward-compatibility)
-
-diff --git a/lib/tyxml/tyxml_js.ml b/lib/tyxml/tyxml_js.ml
-index 4799600..cdf7cd2 100644
---- a/lib/tyxml/tyxml_js.ml
-+++ b/lib/tyxml/tyxml_js.ml
-@@ -164,6 +164,7 @@ module Html5 = Html5_f.Make(Xml)(Svg)
- module Xml_wrap = struct
- type 'a t = 'a React.signal
- type 'a tlist = 'a ReactiveData.RList.t
-+ type ('a, 'b) ft = 'a -> 'b
- let return = React.S.const
- let fmap f = React.S.map f
- let nil () = ReactiveData.RList.nil
-diff --git a/lib/tyxml/tyxml_js.mli b/lib/tyxml/tyxml_js.mli
-index 8cb33c5..db2183e 100644
---- a/lib/tyxml/tyxml_js.mli
-+++ b/lib/tyxml/tyxml_js.mli
-@@ -50,6 +50,7 @@ module Xml : XML with module W = Xml_wrap.NoWrap
- module Xml_wrap : Xml_wrap.T
- with type 'a t = 'a React.signal
- and type 'a tlist = 'a ReactiveData.RList.t
-+ and type ('a, 'b) ft = 'a -> 'b
-
- module Util : sig
- val update_children : Dom.node Js.t -> Dom.node Js.t ReactiveData.RList.t -> unit
diff --git a/dev-ml/js_of_ocaml/files/tyxml36.patch b/dev-ml/js_of_ocaml/files/tyxml36.patch
deleted file mode 100644
index 34a2aab..0000000
--- a/dev-ml/js_of_ocaml/files/tyxml36.patch
+++ /dev/null
@@ -1,158 +0,0 @@
-commit ebf7150f41c64ac0e18e9f89d1e565b6c3115414
-Author: Vasilis Papavasileiou <git@vasilis.airpost.net>
-Date: Thu Aug 6 11:52:11 2015 +0200
-
- up-to-date version of @drup's new-style wrapping (ocsigen/tyxml#58)
-
-diff --git a/lib/tyxml/tyxml_js.ml b/lib/tyxml/tyxml_js.ml
-index 0143219..4799600 100644
---- a/lib/tyxml/tyxml_js.ml
-+++ b/lib/tyxml/tyxml_js.ml
-@@ -20,8 +20,19 @@
- let js_string_of_float f = (Js.number_of_float f)##toString()
- let js_string_of_int i = (Js.number_of_float (float_of_int i))##toString()
-
-+
-+module type XML =
-+ Xml_sigs.T
-+ with type uri = string
-+ and type event_handler = Dom_html.event Js.t -> bool
-+ and type mouse_event_handler = Dom_html.mouseEvent Js.t -> bool
-+ and type keyboard_event_handler = Dom_html.keyboardEvent Js.t -> bool
-+ and type elt = Dom.node Js.t
-+
-+
- module Xml = struct
-
-+ module W = Xml_wrap.NoWrap
- type 'a wrap = 'a
- type 'a list_wrap = 'a list
-
-@@ -162,7 +173,6 @@ module Xml_wrap = struct
- let append x y = ReactiveData.RList.concat x y
- end
-
--
- module Util = struct
- open ReactiveData
- open RList
-@@ -226,9 +236,23 @@ end
-
-
- module R = struct
-- module Xml_wed = struct
-- type 'a wrap = 'a Xml_wrap.t
-- type 'a list_wrap = 'a Xml_wrap.tlist
-+
-+ let filter_attrib (name,a) on =
-+ match a with
-+ | Xml.Event _ ->
-+ raise (Invalid_argument "filter_attrib not implemented for event handler")
-+ | Xml.Attr a ->
-+ name,
-+ Xml.Attr
-+ (React.S.l2
-+ (fun on a -> if on then a else None) on a)
-+
-+ let attach_attribs = Xml.attach_attribs
-+
-+ module Xml = struct
-+ module W = Xml_wrap
-+ type 'a wrap = 'a W.t
-+ type 'a list_wrap = 'a W.tlist
- type uri = Xml.uri
- let string_of_uri = Xml.string_of_uri
- let uri_of_string = Xml.uri_of_string
-@@ -239,7 +263,7 @@ module R = struct
- type attrib = Xml.attrib
-
- let attr name f s =
-- let a = Xml_wrap.fmap f s in
-+ let a = W.fmap f s in
- name,Xml.Attr a
-
- let float_attrib name s = attr name (fun f -> Some (js_string_of_float f)) s
-@@ -267,7 +291,7 @@ module R = struct
- let leaf = Xml.leaf
- let node ?(a=[]) name l =
- let e = Dom_html.document##createElement(Js.string name) in
-- Xml.attach_attribs e a;
-+ attach_attribs e a;
- Util.update_children (e :> Dom.node Js.t) l;
- (e :> Dom.node Js.t)
- let cdata = Xml.cdata
-@@ -275,30 +299,22 @@ module R = struct
- let cdata_style = Xml.cdata_style
- end
-
-- module Xml_wed_svg = struct
-- include Xml_wed
-+ module Xml_Svg = struct
-+ include Xml
-
- let leaf = Xml_Svg.leaf
-
- let node ?(a = []) name l =
- let e =
- Dom_html.document##createElementNS(Dom_svg.xmlns,Js.string name) in
-- Xml.attach_attribs e a;
-+ attach_attribs e a;
- Util.update_children (e :> Dom.node Js.t) l;
- (e :> Dom.node Js.t)
- end
-
-- module Svg = Svg_f.MakeWrapped(Xml_wrap)(Xml_wed_svg)
-- module Html5 = Html5_f.MakeWrapped(Xml_wrap)(Xml_wed)(Svg)
-- let filter_attrib (name,a) on =
-- match a with
-- | Xml.Event _ ->
-- raise (Invalid_argument "filter_attrib not implemented for event handler")
-- | Xml.Attr a ->
-- name,
-- Xml.Attr
-- (React.S.l2
-- (fun on a -> if on then a else None) on a)
-+ module Svg = Svg_f.Make(Xml_Svg)
-+ module Html5 = Html5_f.Make(Xml)(Svg)
-+
- end
-
- module To_dom = Tyxml_cast.MakeTo(struct
-diff --git a/lib/tyxml/tyxml_js.mli b/lib/tyxml/tyxml_js.mli
-index b3323cc..8cb33c5 100644
---- a/lib/tyxml/tyxml_js.mli
-+++ b/lib/tyxml/tyxml_js.mli
-@@ -37,13 +37,16 @@
- @see <https://ocsigen.org/tyxml/dev/api/Html5_sigs.T> Html5_sigs.T to have a list of available functions to build HTML.
- *)
-
--module Xml : Xml_sigs.T
-+module type XML =
-+ Xml_sigs.T
- with type uri = string
- and type event_handler = Dom_html.event Js.t -> bool
- and type mouse_event_handler = Dom_html.mouseEvent Js.t -> bool
- and type keyboard_event_handler = Dom_html.keyboardEvent Js.t -> bool
- and type elt = Dom.node Js.t
-
-+module Xml : XML with module W = Xml_wrap.NoWrap
-+
- module Xml_wrap : Xml_wrap.T
- with type 'a t = 'a React.signal
- and type 'a tlist = 'a ReactiveData.RList.t
-@@ -57,10 +60,13 @@ module Svg : Svg_sigs.Make(Xml).T
- module Html5 : Html5_sigs.Make(Xml)(Svg).T
-
- module R : sig
-- module Svg : Svg_sigs.MakeWrapped(Xml_wrap)(Xml).T
-+ module Xml : XML with module W = Xml_wrap
-+
-+ module Svg : Svg_sigs.Make(Xml).T
- with type +'a elt = 'a Svg.elt
- and type +'a attrib = 'a Svg.attrib
-- module Html5 : Html5_sigs.MakeWrapped(Xml_wrap)(Xml)(Svg).T
-+
-+ module Html5 : Html5_sigs.Make(Xml)(Svg).T
- with type +'a elt = 'a Html5.elt
- and type +'a attrib = 'a Html5.attrib
- val filter_attrib : 'a Html5.attrib -> bool React.signal -> 'a Html5.attrib
diff --git a/dev-ml/js_of_ocaml/js_of_ocaml-2.6.ebuild b/dev-ml/js_of_ocaml/js_of_ocaml-2.6.ebuild
deleted file mode 100644
index b7fe9c9..0000000
--- a/dev-ml/js_of_ocaml/js_of_ocaml-2.6.ebuild
+++ /dev/null
@@ -1,52 +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"
-
-DEPEND=">=dev-lang/ocaml-3.12:=[ocamlopt?]
- >=dev-ml/lwt-2.4.4:=
- dev-ml/react:=
- dev-ml/reactiveData:=
- >=dev-ml/tyxml-3.6:=
- dev-ml/cmdliner:=
- dev-ml/menhir:=
- dev-ml/ocaml-base64:=
- dev-ml/camlp4:=
- dev-ml/cppo:=
- deriving? ( >=dev-ml/deriving-0.6:= )"
-RDEPEND="${DEPEND}"
-
-src_prepare() {
- epatch \
- "${FILESDIR}/tyxml36.patch" \
- "${FILESDIR}/tyxml36-2.patch"
-}
-
-src_configure() {
- use ocamlopt || echo "BEST := byte" >> Makefile.conf
- use deriving || echo "WITH_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/
-}
^ permalink raw reply related [flat|nested] 4+ messages in thread
* [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/
@ 2016-05-03 9:14 Alexis Ballier
0 siblings, 0 replies; 4+ messages in thread
From: Alexis Ballier @ 2016-05-03 9:14 UTC (permalink / raw
To: gentoo-commits
commit: fde940cd10dd7ac97fa741dc85fcdc5a2e4b5c1f
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org>
AuthorDate: Sun May 1 18:46:12 2016 +0000
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org>
CommitDate: Tue May 3 09:13:52 2016 +0000
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=fde940cd
dev-ml/js_of_ocaml: fix build with ocaml 4.03
Package-Manager: portage-2.2.28
Signed-off-by: Alexis Ballier <aballier <AT> gentoo.org>
dev-ml/js_of_ocaml/files/oc43.patch | 1418 +++++++++++++++++++++++++++++
dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild | 4 +
2 files changed, 1422 insertions(+)
diff --git a/dev-ml/js_of_ocaml/files/oc43.patch b/dev-ml/js_of_ocaml/files/oc43.patch
new file mode 100644
index 0000000..face810
--- /dev/null
+++ b/dev-ml/js_of_ocaml/files/oc43.patch
@@ -0,0 +1,1418 @@
+commit 3e4d39ece5a67bfc17f47c3da8a95ccca789abd5
+Author: Hugo Heuzard <hugo.heuzard@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
index 420e7ae..2de89b9 100644
--- a/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild
+++ b/dev-ml/js_of_ocaml/js_of_ocaml-2.7.ebuild
@@ -31,6 +31,10 @@ RDEPEND="
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
^ permalink raw reply related [flat|nested] 4+ messages in thread
* [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/
@ 2016-09-07 9:57 Alexis Ballier
0 siblings, 0 replies; 4+ messages in thread
From: Alexis Ballier @ 2016-09-07 9:57 UTC (permalink / raw
To: gentoo-commits
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.heuzard@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/
-}
^ permalink raw reply related [flat|nested] 4+ messages in thread
* [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/
@ 2017-04-02 8:38 Alexis Ballier
0 siblings, 0 replies; 4+ messages in thread
From: Alexis Ballier @ 2017-04-02 8:38 UTC (permalink / raw
To: gentoo-commits
commit: a94a3df89153fa514be328be032071c2d41545e7
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org>
AuthorDate: Sat Apr 1 21:50:21 2017 +0000
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org>
CommitDate: Sun Apr 2 08:38:03 2017 +0000
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=a94a3df8
dev-ml/js_of_ocaml: Fix build with latest ppx tools.
Package-Manager: Portage-2.3.5, Repoman-2.3.2
dev-ml/js_of_ocaml/files/ppx.patch | 11 +++++++++++
dev-ml/js_of_ocaml/js_of_ocaml-2.8.4.ebuild | 4 ++++
2 files changed, 15 insertions(+)
diff --git a/dev-ml/js_of_ocaml/files/ppx.patch b/dev-ml/js_of_ocaml/files/ppx.patch
new file mode 100644
index 00000000000..c46293f546d
--- /dev/null
+++ b/dev-ml/js_of_ocaml/files/ppx.patch
@@ -0,0 +1,11 @@
+Index: js_of_ocaml-2.8.4/lib/ppx_driver/ppx_js_driver.ml
+===================================================================
+--- js_of_ocaml-2.8.4.orig/lib/ppx_driver/ppx_js_driver.ml
++++ js_of_ocaml-2.8.4/lib/ppx_driver/ppx_js_driver.ml
+@@ -1,5 +1,5 @@
+ let () =
+ let js_mapper = Ppx_js.js_mapper [] in
+- Ppx_driver.register_transformation "js_of_ocaml"
++ Ppx_driver.register_transformation_using_ocaml_current_ast "js_of_ocaml"
+ ~impl:(js_mapper.Ast_mapper.structure js_mapper)
+ ~intf:(js_mapper.Ast_mapper.signature js_mapper)
diff --git a/dev-ml/js_of_ocaml/js_of_ocaml-2.8.4.ebuild b/dev-ml/js_of_ocaml/js_of_ocaml-2.8.4.ebuild
index a68da44990b..11d4b7ce009 100644
--- a/dev-ml/js_of_ocaml/js_of_ocaml-2.8.4.ebuild
+++ b/dev-ml/js_of_ocaml/js_of_ocaml-2.8.4.ebuild
@@ -40,6 +40,10 @@ RDEPEND="
deriving? ( >=dev-ml/deriving-0.6:= )"
DEPEND="${RDEPEND}"
+src_prepare() {
+ epatch "${FILESDIR}/ppx.patch"
+}
+
src_configure() {
printf "\n\n" >> Makefile.conf
use ocamlopt || echo "BEST := byte" >> Makefile.conf
^ permalink raw reply related [flat|nested] 4+ messages in thread
end of thread, other threads:[~2017-04-02 8:38 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2016-09-07 9:57 [gentoo-commits] repo/gentoo:master commit in: dev-ml/js_of_ocaml/, dev-ml/js_of_ocaml/files/ Alexis Ballier
-- strict thread matches above, loose matches on Subject: below --
2017-04-02 8:38 Alexis Ballier
2016-05-03 9:14 Alexis Ballier
2016-03-01 18:47 Alexis Ballier
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox