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)