pax_global_header00006660000000000000000000000064142767304400014521gustar00rootroot0000000000000052 comment=ae17630e97220292b9daf613e3bcadd8593f45f3 ppx_deriving_yojson-3.7.0/000077500000000000000000000000001427673044000156275ustar00rootroot00000000000000ppx_deriving_yojson-3.7.0/.gitignore000066400000000000000000000000721427673044000176160ustar00rootroot00000000000000*.native *.byte *.docdir _build *.install pkg/META .merlinppx_deriving_yojson-3.7.0/.travis.yml000066400000000000000000000010671427673044000177440ustar00rootroot00000000000000language: c sudo: false services: - docker install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh script: bash -ex ./.travis-docker.sh env: global: - PINS="ppx_deriving_yojson:. ppx_deriving.dev:git://github.com/ocaml-ppx/ppx_deriving.git" - PACKAGE="ppx_deriving_yojson" - DISTRO="ubuntu-16.04" matrix: - OCAML_VERSION="4.11.0+trunk" OCAML_BETA="enable" - OCAML_VERSION="4.10" - OCAML_VERSION="4.09" - OCAML_VERSION="4.08" - OCAML_VERSION="4.07" - OCAML_VERSION="4.06" - OCAML_VERSION="4.05" ppx_deriving_yojson-3.7.0/CHANGELOG.md000066400000000000000000000075151427673044000174500ustar00rootroot000000000000003.7.0 ----- * Use ounit2 instead of ounit for the tests (#144) Marek Kubica * Update to ppxlib >= 0.26.0 (#142, #146) Sonja Heinze, Antonio Nuno Monteiro * Sanitize the ppx output to be able to use module names shadowing the modules from the standard library (#140) Simmo Saan * Reimplement map_bind to avoid stack overflows on js-of-ocaml (#138) P. Baudin * Add ppxlib as a direct dependency for ppx_deriving_yojson (#136) Hongchang Wu 3.6.1 ----- * Update to ppxlib >= 0.14.0 (#127) Kate Deplaix 3.6.0 ----- * Update to ppx_deriving 5.0 and ppxlib (#121) Rudi Grinberg, Thierry Martinez, Kate Deplaix and Gabriel Scherer * Fix issues when the equality operator `(=)` is shadowed (#126, #128, #131, fixes #79) Martin Slota, Kate Deplaix 3.5.3 ----- * Support for OCaml 4.11 (requires feature from `ppx_deriving.4.5`) (#122) Thierry Martinez * Documentation improvements (#115) Olivier Andrieu 3.5.2 ----- * [@to_yojson], [@from_yojson] to override serialization functions for certain record fields (#107, #108) Chas Emerick * Support for OCaml 4.10 (#112) Kate Deplaix 3.5.1 ----- * Two bugfixes when using [%to_json ], [%of_json ] extensions (error with polymorphic variables, unbound value 'safe_map') (#100, #101) Gabriel Scherer, report by Matt Windsor 3.5 --- * use tail-recursive functions to (de)serialize long lists (#97) Alex Knauth * Support for OCaml 4.08 (#99) Antonio Nuno Monteiro 3.4 --- * compatibility with yojson 1.6.0 (#90, #92) Vadim Radovel and Nathan Rebours 3.3 --- * Make `_exn` functions opt-in (`[@@deriving yojson { exn = true }]`) to preserve backward-compatibility for fully-manual implementations of the [@@deriving yojson] interface. (#86) Gabriel Scherer 3.2 --- * Add `let _ = to_yojson / of_yojson` to generated code to avoid warnings when they aren't used (#68) Steve Bleazard * Fix bug where doing [@@deriving of_yojson] causes an unused rec warning (#68) Steve Bleazard * Add generated `ty_of_yojson_exn` to raise an exception rather than return an error (#57, #68) Steve Bleazard * Port `ppx_deriving_yojson` to `dune` (#69, #85) Rudi Grinberg, Antonio Nuno Monteiro * Added deriver option `fields` to generate a `Yojson_meta` module containing all JSON key names. (#70) Steve Bleazard * Remove cppo that included support for versions no longer supported by `ppx_deriving_yojson` (#75) Rudi Grinberg 3.1 --- * Fix ppx_deriving_yojson.runtime META file (#47) Étienne Millon * Support for inline records in variant types (#50) Gerd Stolpmann * OCaml 4.06 compatibility (#64, #66) Leonid Rozenberg, Gabriel Scherer 3.0 --- * Use Result.result in generated code. * Compatibility with statically linked ppx drivers. * OCaml 4.03 compatibility. 2.3 --- * Adapt to syntactic changes in 4.02.2. * Improve compatibility with libraries that shadow modules from standard library, such as Core. * Allow deserializing float values that appear as integer literals in the input JSON. * Suppress some warnings. 2.2 --- * Add support for open types. 2.1 --- * Handle inheriting from a parametric polymorphic variant type. * Don't leak type variables. 2.0 --- * Update to accomodate syntactic changes in _deriving_ 1.0. * Common helper functions have been extracted into ppx_deriving_yojson.runtime, reducing code size. * Add support for `[@@deriving to_yojson, of_yojson]` and `[%to_yojson:]`, `[%of_yojson:]` shortcuts. * Add support for `[@@deriving yojson { strict = false }]`. 1.1 --- * Add `[@key]`, `[@name]` and `[@default]` attributes. * Add support for `Yojson.Safe.json` values. 1.0 --- * Initial release. ppx_deriving_yojson-3.7.0/CONTRIBUTING.md000066400000000000000000000033561427673044000200670ustar00rootroot00000000000000# Contributing to `ppx_deriving_yojson` ## Setting up This document assumes you have [OPAM](https://opam.ocaml.org/) installed. ### Installing To start building this project you will need to install the packages it depends on. To do so, run the following command: ```shell $ opam install . --deps-only -t ``` ## Developing ### Building & Testing This project uses [dune](http://dune.build/) as its build system. The [Makefile](./Makefile) in this repo provides shorter commands over the `dune` commands. #### Building To build the project, run `make` or `make build`. ### Running Tests `make test` will build and run the tests in the current OPAM switch. ### Cleaning up `make clean` can be used to clean up the build artifacts. ## Cutting a release ### Testing for a release Before cutting a release, it is useful to test this project against all the supported OCaml versions. `make all-supported-ocaml-versions` will do just that, but requires some setting up beforehand. The instructions are as follows: 1. The [`dune-workspace.dev`](./dune-workspace.dev) defines all the OPAM switches that will be tested when running `make all-supported-ocaml-versions`. Make sure you have switches for all those OCaml version, with the appropriate names (e.g., for the build context that `(context (opam (switch 4.07.1)))` defines, make sure you have a switch named `4.07.1`. To find out which OPAM switches you have, run `opam switch list`). 2. For every OPAM switch listed in the Dune workspace file, switch into it and run the installation command at the top of this document. 3. Finally, you can now run `make all-supported-ocaml-versions`, which will build and test this project against all those OCaml versions. ### Making a release - WIPppx_deriving_yojson-3.7.0/LICENSE.txt000066400000000000000000000021001427673044000174430ustar00rootroot00000000000000Copyright (c) 2014-2018 whitequark Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_deriving_yojson-3.7.0/Makefile000066400000000000000000000011021427673044000172610ustar00rootroot00000000000000build: dune build test: dune runtest doc: dune build @doc clean: dune clean .PHONY: build test doc clean VERSION := $$(opam query --version) NAME_VERSION := $$(opam query --name-version) ARCHIVE := $$(opam query --archive) release: git tag -a v$(VERSION) -m "Version $(VERSION)." git push origin v$(VERSION) opam publish prepare $(NAME_VERSION) $(ARCHIVE) opam publish submit $(NAME_VERSION) rm -rf $(NAME_VERSION) .PHONY: release all-supported-ocaml-versions all-supported-ocaml-versions: dune build @install @runtest --workspace dune-workspace.dev ppx_deriving_yojson-3.7.0/README.md000066400000000000000000000176561427673044000171250ustar00rootroot00000000000000[@@deriving yojson] =================== _deriving Yojson_ is a [ppx_deriving][pd] plugin that generates [JSON][] serializers and deserializes that use the [Yojson][] library from an OCaml type definition. Sponsored by [Evil Martians](http://evilmartians.com). [pd]: https://github.com/ocaml-ppx/ppx_deriving [json]: http://tools.ietf.org/html/rfc4627 [yojson]: https://github.com/ocaml-community/yojson Note: [ppx_yojson_conv](https://github.com/janestreet/ppx_yojson_conv) is a more recent deriving extension for Yojson that uses a more durable technical foundation and is more actively maintained. We keep maintaing `ppx_deriving_yojson` for our existing users, but we would recommend that *new projects* start from `ppx_yojson_conv` instead. Installation ------------ _deriving Yojson_ can be installed via [OPAM](https://opam.ocaml.org): $ opam install ppx_deriving_yojson Usage ----- In order to use _deriving yojson_, require the package `ppx_deriving_yojson`. If you are using dune, add `ppx_deriving_json` to the `preprocess` entry, and `ppx_deriving_json.runtime` to your requirements, like so: ``` ... (libraries yojson core ppx_deriving_yojson.runtime) (preprocess (pps ppx_deriving_yojson)) ... ``` Syntax ------ _deriving yojson_ generates two functions per type: ``` ocaml # #require "ppx_deriving_yojson";; # type ty = .. [@@deriving yojson];; val ty_of_yojson : Yojson.Safe.t -> (ty, string) Result.result val ty_to_yojson : ty -> Yojson.Safe.t ``` When the deserializing function returns Error loc, `loc` points to the point in the JSON hierarchy where the error has occurred. It is possible to generate only serializing or deserializing functions by using `[@@deriving to_yojson]` or `[@@deriving of_yojson]`. It is also possible to generate an expression for serializing or deserializing a type by using `[%to_yojson:]` or `[%of_yojson:]`; non-conflicting versions `[%derive.to_yojson:]` or `[%derive.of_yojson:]` are available as well. Custom or overriding serializing or deserializing functions can be provided on a per-field basis via `[@to_yojson]` and `[@of_yojson]` attributes. If the type is called `t`, the functions generated are `{of,to}_yojson` instead of `t_{of,to}_yojson`. Using the option `[@@deriving yojson { exn = true }]` will also generate a function `ty_of_yojson_exn : Yojson.Safe.t -> ty` which raises `Failure err` on error instead of returning an `Error err` result. Semantics --------- _deriving yojson_ handles tuples, records, normal and polymorphic variants; builtin types: `int`, `int32`, `int64`, `nativeint`, `float`, `bool`, `char`, `string`, `bytes`, `ref`, `list`, `array`, `option` and their `Mod.t` aliases. The following table summarizes the correspondence between OCaml types and JSON values: | OCaml type | JSON value | Remarks | | ---------------------- | ---------- | -------------------------------- | | `int`, `int32`, `float`| Number | | | `int64`, `nativeint` | Number | Can exceed range of `double` | | `bool` | Boolean | | | `string`, `bytes` | String | | | `char` | String | Strictly one character in length | | `list`, `array` | Array | | | A tuple | Array | | | `ref` | 'a | | | `option` | Null or 'a | | | A record | Object | | | `Yojson.Safe.t` | any | Identity transformation | | `unit` | Null | | Variants (regular and polymorphic) are represented using arrays; the first element is a string with the name of the constructor, the rest are the arguments. Note that the implicit tuple in a polymorphic variant is flattened. For example: ``` ocaml # type pvs = [ `A | `B of int | `C of int * string ] list [@@deriving yojson];; # type v = A | B of int | C of int * string [@@deriving yojson];; # type vs = v list [@@deriving yojson];; # print_endline (Yojson.Safe.to_string (vs_to_yojson [A; B 42; C (42, "foo")]));; [["A"],["B",42],["C",42,"foo"]] # print_endline (Yojson.Safe.to_string (pvs_to_yojson [`A; `B 42; `C (42, "foo")]));; [["A"],["B",42],["C",42,"foo"]] ``` Record variants are represented in the same way as if the nested structure was defined separately. For example: ```ocaml # type v = X of { v: int } [@@deriving yojson];; # print_endline (Yojson.Safe.to_string (v_to_yojson (X { v = 0 })));; ["X",{"v":0}] ``` Record variants are currently not supported for extensible variant types. By default, objects are deserialized strictly; that is, all keys in the object have to correspond to fields of the record. Passing `strict = false` as an option to the deriver (i.e. `[@@deriving yojson { strict = false }]`) changes the behavior to ignore any unknown fields. ### Options Option attribute names may be prefixed with `yojson.` to avoid conflicts with other derivers. #### [@key] If the JSON object keys differ from OCaml conventions, lexical or otherwise, it is possible to specify the corresponding JSON key implicitly using [@key "field"], e.g.: ``` ocaml type geo = { lat : float [@key "Latitude"]; lon : float [@key "Longitude"]; } [@@deriving yojson] ``` #### [@name] If the JSON variant names differ from OCaml conventions, it is possible to specify the corresponding JSON string explicitly using [@name "constr"], e.g.: ``` ocaml type units = | Metric [@name "metric"] | Imperial [@name "imperial"] [@@deriving yojson] ``` #### [@encoding] Very large `int64` and `nativeint` numbers can wrap when decoded in a runtime which represents all numbers using double-precision floating point, e.g. JavaScript and Lua. It is possible to specify the [@encoding \`string] attribute to encode them as strings. #### [@default] It is possible to specify a default value for fields that can be missing from the JSON object, e.g.: ``` ocaml type pagination = { pages : int; current : (int [@default 0]); } [@@deriving yojson] ``` Fields with default values are not required to be present in inputs and will not be emitted in outputs. #### [@to_yojson] / [@of_yojson] One can provide custom serialization or deserialization functions, either overriding the default derivation or to provide support for abstract, functor, or other types that aren't otherwise amenable to derivation (similar to the `@printer` option provided by [ppx_deriving's `show` plugin](https://github.com/ocaml-ppx/ppx_deriving#plugin-show)): ```ocaml # module StringMap = Map.Make(struct type t = string let compare = compare end);; # let yojson_of_stringmap m = StringMap.bindings m |> [%to_yojson: (string * string) list];; # type page = { number : int [@to_yojson fun i -> `Int (i + 1)] ; bounds : (int * int * int * int) ; attrs : string StringMap.t [@to_yojson yojson_of_stringmap]} [@@deriving to_yojson];; # { number = 0 ; bounds = (0, 0, 792, 612) ; attrs = StringMap.add "foo" "bar" StringMap.empty } |> page_to_yojson |> Yojson.Safe.to_string |> print_endline {"number":1,"bounds":[0,0,792,612],"attrs":[["foo","bar"]]} ``` #### `Yojson_meta` module The `meta` deriver option can be used to generate a module containing all JSON key names, e.g. ```ocaml type foo = { fvalue : float; svalue : string [@key "@svalue_json"]; ivalue : int; } [@@deriving to_yojson { strict = false, meta = true } ] end ``` defines the following module: ```ocaml module Yojson_meta_foo = struct let keys = ["fvalue"; "@svalue_json"; "ivalue"] let _ = keys end ``` When the type is named `t`, the module is named just `Yojson_meta`. License ------- _deriving yojson_ is distributed under the terms of [MIT license](LICENSE.txt). ppx_deriving_yojson-3.7.0/dune-project000066400000000000000000000000531427673044000201470ustar00rootroot00000000000000(lang dune 1.0) (name ppx_deriving_yojson) ppx_deriving_yojson-3.7.0/dune-workspace.dev000066400000000000000000000003201427673044000212510ustar00rootroot00000000000000(lang dune 1.2) ;; This file is used by `make all-supported-ocaml-versions` (context (opam (switch 4.04.2))) (context (opam (switch 4.05.0))) (context (opam (switch 4.06.1))) (context (opam (switch 4.07.1))) ppx_deriving_yojson-3.7.0/pkg/000077500000000000000000000000001427673044000164105ustar00rootroot00000000000000ppx_deriving_yojson-3.7.0/pkg/pkg.ml000066400000000000000000000000561427673044000175240ustar00rootroot00000000000000#use "topfind" #require "topkg-jbuilder.auto" ppx_deriving_yojson-3.7.0/ppx_deriving_yojson.opam000066400000000000000000000015131427673044000226040ustar00rootroot00000000000000opam-version: "2.0" version: "3.7.0" maintainer: "whitequark " authors: [ "whitequark " ] license: "MIT" homepage: "https://github.com/ocaml-ppx/ppx_deriving_yojson" bug-reports: "https://github.com/ocaml-ppx/ppx_deriving_yojson/issues" dev-repo: "git+https://github.com/ocaml-ppx/ppx_deriving_yojson.git" tags: [ "syntax" "json" ] build: [ ["dune" "subst"] {dev} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ "ocaml" {>= "4.05.0"} "dune" {>= "1.0"} "yojson" {>= "1.6.0" & < "2.0.0"} "result" "ppx_deriving" {>= "5.1"} "ppxlib" {>= "0.26.0"} "ounit2" {with-test} ] synopsis: "JSON codec generator for OCaml" description: """ ppx_deriving_yojson is a ppx_deriving plugin that provides a JSON codec generator. """ ppx_deriving_yojson-3.7.0/src/000077500000000000000000000000001427673044000164165ustar00rootroot00000000000000ppx_deriving_yojson-3.7.0/src/dune000066400000000000000000000010401427673044000172670ustar00rootroot00000000000000(library (name ppx_deriving_yojson_runtime) (public_name ppx_deriving_yojson.runtime) (synopsis "Runtime components of [@@deriving yojson]") (modules ppx_deriving_yojson_runtime) (libraries ppx_deriving.runtime result)) (library (name ppx_deriving_yojson) (public_name ppx_deriving_yojson) (synopsis "[@@deriving yojson]") (libraries ppxlib ppx_deriving.api) (preprocess (pps ppxlib.metaquot)) (ppx_runtime_libraries ppx_deriving_yojson_runtime yojson) (modules ppx_deriving_yojson) (kind ppx_deriver) (flags (:standard -w -9))) ppx_deriving_yojson-3.7.0/src/ppx_deriving_yojson.ml000066400000000000000000001156271427673044000230630ustar00rootroot00000000000000open Ppxlib open Ast_helper module Ast_builder_default_loc = struct include Ppx_deriving.Ast_convenience let gen_def_loc f x = let loc = !Ast_helper.default_loc in f ~loc x let lid = gen_def_loc Ast_builder.Default.Located.lident let list = gen_def_loc Ast_builder.Default.elist let pstr = gen_def_loc Ast_builder.Default.pstring let plist = gen_def_loc Ast_builder.Default.plist let lam = gen_def_loc Ast_builder.Default.pexp_fun Nolabel None end open Ast_builder_default_loc let disable_warning_39 () = let loc = !Ast_helper.default_loc in let name = { txt = "ocaml.warning"; loc } in Ast_helper.Attr.mk ~loc name (PStr [%str "-39"]) let mod_mknoloc x = mknoloc (Some x) let deriver = "yojson" let raise_errorf = Ppx_deriving.raise_errorf let argn = Printf.sprintf "arg%d" let attr_int_encoding attrs = match Ppx_deriving.attr ~deriver "encoding" attrs |> Ppx_deriving.Arg.(get_attr ~deriver (enum ["string"; "number"])) with | Some "string" -> `String | Some "number" | None -> `Int | _ -> assert false let attr_string name default attrs = match Ppx_deriving.attr ~deriver name attrs |> Ppx_deriving.Arg.(get_attr ~deriver string) with | Some x -> x | None -> default let attr_key = attr_string "key" let attr_name = attr_string "name" let attr_ser attrs = Ppx_deriving.(attrs |> attr ~deriver "to_yojson" |> Arg.(get_attr ~deriver expr)) let attr_desu attrs = Ppx_deriving.(attrs |> attr ~deriver "of_yojson" |> Arg.(get_attr ~deriver expr)) let attr_default attrs = Ppx_deriving.attr ~deriver "default" attrs |> Ppx_deriving.Arg.(get_attr ~deriver expr) type options = { is_strict: bool; want_meta: bool; want_exn: bool; } let parse_options options = let strict = ref true in let meta = ref false in let exn = ref false in let get_bool = Ppx_deriving.Arg.(get_expr ~deriver bool) in options |> List.iter (fun (name, expr) -> match name with | "strict" -> strict := get_bool expr | "meta" -> meta := get_bool expr | "exn" -> exn := get_bool expr | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); { is_strict = !strict; want_meta = !meta; want_exn = !exn; } let poly_fun names expr = List.fold_right (fun name expr -> let loc = name.Location.loc in let name = name.Location.txt in [%expr fun [%p pvar ("poly_"^name)] -> [%e expr]] ) names expr let type_add_attrs typ attributes = { typ with ptyp_attributes = typ.ptyp_attributes @ attributes } let rec ser_expr_of_typ ~quoter typ = match attr_ser typ.ptyp_attributes with | Some e -> Ppx_deriving.quote ~quoter e | None -> ser_expr_of_only_typ ~quoter typ and ser_expr_of_only_typ ~quoter typ = let loc = typ.ptyp_loc in let attr_int_encoding typ = match attr_int_encoding typ with `String -> "String" | `Int -> "Intlit" in let ser_expr_of_typ = ser_expr_of_typ ~quoter in match typ with | [%type: unit] -> [%expr fun (x:Ppx_deriving_runtime.unit) -> `Null] | [%type: int] -> [%expr fun (x:Ppx_deriving_runtime.int) -> `Int x] | [%type: float] -> [%expr fun (x:Ppx_deriving_runtime.float) -> `Float x] | [%type: bool] -> [%expr fun (x:Ppx_deriving_runtime.bool) -> `Bool x] | [%type: string] -> [%expr fun (x:Ppx_deriving_runtime.string) -> `String x] | [%type: bytes] -> [%expr fun x -> `String (Bytes.to_string x)] | [%type: char] -> [%expr fun x -> `String (String.make 1 x)] | [%type: [%t? typ] ref] -> [%expr fun x -> [%e ser_expr_of_typ typ] !x] | [%type: [%t? typ] list] -> [%expr fun x -> `List (safe_map [%e ser_expr_of_typ typ] x)] | [%type: int32] | [%type: Int32.t] -> [%expr fun x -> `Intlit (Int32.to_string x)] | [%type: int64] | [%type: Int64.t] -> [%expr fun x -> [%e Exp.variant (attr_int_encoding typ.ptyp_attributes) (Some [%expr (Int64.to_string x)])]] | [%type: nativeint] | [%type: Nativeint.t] -> [%expr fun x -> [%e Exp.variant (attr_int_encoding typ.ptyp_attributes) (Some [%expr (Nativeint.to_string x)])]] | [%type: [%t? typ] array] -> [%expr fun x -> `List (Array.to_list (Array.map [%e ser_expr_of_typ typ] x))] | [%type: [%t? typ] option] -> [%expr function None -> `Null | Some x -> [%e ser_expr_of_typ typ] x] | [%type: Yojson.Safe.json] | [%type: Yojson.Safe.t] -> [%expr fun x -> x] | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let ser_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "to_yojson") lid)) in let fwd = app (Ppx_deriving.quote ~quoter ser_fn) (List.map ser_expr_of_typ args) in (* eta-expansion is necessary for let-rec *) [%expr fun x -> [%e fwd] x] | { ptyp_desc = Ptyp_tuple typs } -> [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> `List ([%e list (List.mapi (fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])]; | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun (field: row_field) -> match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case (Pat.variant label None) [%expr `List [`String [%e str (attr_name label attrs)]]] | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case (Pat.variant label (Some (ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)))) [%expr `List ((`String [%e str (attr_name label attrs)]) :: [%e list (List.mapi (fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])] | Rtag(label, false, [typ]) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case (Pat.variant label (Some [%pat? x])) [%expr `List [`String [%e str (attr_name label attrs)]; [%e ser_expr_of_typ typ] x]] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e ser_expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr ([%e evar ("poly_"^name)] : _ -> Yojson.Safe.t)] | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] x; [%e ser_expr_of_typ typ] x] | { ptyp_desc = Ptyp_poly (names, typ) } -> poly_fun names (ser_expr_of_typ typ) | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) (* http://desuchan.net/desu/src/1284751839295.jpg *) let rec desu_fold ~quoter ~loc ~path f typs = typs |> List.mapi (fun i typ -> i, app (desu_expr_of_typ ~quoter ~path typ) [evar (argn i)]) |> List.fold_left (fun x (i, y) -> let loc = x.pexp_loc in [%expr [%e y] >>= fun [%p pvar (argn i)] -> [%e x]]) [%expr Result.Ok [%e f (List.mapi (fun i _ -> evar (argn i)) typs)]] and desu_expr_of_typ ~quoter ~path typ = match attr_desu typ.ptyp_attributes with | Some e -> Ppx_deriving.quote ~quoter e | None -> desu_expr_of_only_typ ~quoter ~path typ and desu_expr_of_only_typ ~quoter ~path typ = let loc = typ.ptyp_loc in let error = [%expr Result.Error [%e str (String.concat "." path)]] in let decode' cases = Exp.function_ ( List.map (fun (pat, exp) -> Exp.case pat exp) cases @ [Exp.case [%pat? _] error]) in let decode pat exp = decode' [pat, exp] in let desu_expr_of_typ = desu_expr_of_typ ~quoter in match typ with | [%type: unit] -> decode [%pat? `Null] [%expr Result.Ok ()] | [%type: int] -> decode [%pat? `Int x] [%expr Result.Ok x] | [%type: float] -> decode' [[%pat? `Int x], [%expr Result.Ok (float_of_int x)]; [%pat? `Intlit x], [%expr Result.Ok (float_of_string x)]; [%pat? `Float x], [%expr Result.Ok x]] | [%type: bool] -> decode [%pat? `Bool x] [%expr Result.Ok x] | [%type: string] -> decode [%pat? `String x] [%expr Result.Ok x] | [%type: bytes] -> decode [%pat? `String x] [%expr Result.Ok (Bytes.of_string x)] | [%type: char] -> decode [%pat? `String x] [%expr if String.length x = 1 then Result.Ok x.[0] else [%e error]] | [%type: int32] | [%type: Int32.t] -> decode' [[%pat? `Int x], [%expr Result.Ok (Int32.of_int x)]; [%pat? `Intlit x], [%expr Result.Ok (Int32.of_string x)]] | [%type: int64] | [%type: Int64.t] -> begin match attr_int_encoding typ.ptyp_attributes with | `String -> decode [%pat? `String x] [%expr Result.Ok (Int64.of_string x)] | `Int -> decode' [[%pat? `Int x], [%expr Result.Ok (Int64.of_int x)]; [%pat? `Intlit x], [%expr Result.Ok (Int64.of_string x)]] end | [%type: nativeint] | [%type: Nativeint.t] -> begin match attr_int_encoding typ.ptyp_attributes with | `String -> decode [%pat? `String x] [%expr Result.Ok (Nativeint.of_string x)] | `Int -> decode' [[%pat? `Int x], [%expr Result.Ok (Nativeint.of_int x)]; [%pat? `Intlit x], [%expr Result.Ok (Nativeint.of_string x)]] end | [%type: [%t? typ] ref] -> [%expr fun x -> [%e desu_expr_of_typ ~path:(path @ ["contents"]) typ] x >|= ref] | [%type: [%t? typ] option] -> [%expr function | `Null -> Result.Ok None | x -> [%e desu_expr_of_typ ~path typ] x >>= fun x -> Result.Ok (Some x)] | [%type: [%t? typ] list] -> decode [%pat? `List xs] [%expr map_bind [%e desu_expr_of_typ ~path typ] [] xs] | [%type: [%t? typ] array] -> decode [%pat? `List xs] [%expr map_bind [%e desu_expr_of_typ ~path typ] [] xs >|= Array.of_list] | [%type: Yojson.Safe.t] | [%type: Yojson.Safe.json] -> [%expr fun x -> Result.Ok x] | { ptyp_desc = Ptyp_tuple typs } -> decode [%pat? `List [%p plist (List.mapi (fun i _ -> pvar (argn i)) typs)]] (desu_fold ~quoter ~loc ~path tuple typs) | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let inherits, tags = List.partition (fun field -> match field.prf_desc with Rinherit _ -> true | _ -> false) fields in let tag_cases = tags |> List.map (fun field -> match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]]] [%expr Result.Ok [%e Exp.variant label None]] | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case [%pat? `List ((`String [%p pstr (attr_name label attrs)]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) typs)])] (desu_fold ~quoter ~loc ~path (fun x -> (Exp.variant label (Some (tuple x)))) typs) | Rtag(label, false, [typ]) -> let label = label.txt in let attrs = field.prf_attributes in Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]; x]] [%expr [%e desu_expr_of_typ ~path typ] x >>= fun x -> Result.Ok [%e Exp.variant label (Some [%expr x])]] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e desu_expr_of_typ ~path typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) and inherits_case = let toplevel_typ = typ in inherits |> List.map (fun field -> match field.prf_desc with | Rinherit typ -> typ | _ -> assert false) |> List.fold_left (fun expr typ -> [%expr match [%e desu_expr_of_typ ~path typ] json with | (Result.Ok result) -> Result.Ok (result :> [%t toplevel_typ]) | Result.Error _ -> [%e expr]]) error |> Exp.case [%pat? _] in [%expr fun (json : Yojson.Safe.t) -> [%e Exp.match_ [%expr json] (tag_cases @ [inherits_case])]] | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let desu_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "of_yojson") lid)) in let fwd = app (Ppx_deriving.quote ~quoter desu_fn) (List.map (desu_expr_of_typ ~path) args) in (* eta-expansion is necessary for recursive groups *) [%expr fun x -> [%e fwd] x] | { ptyp_desc = Ptyp_var name } -> [%expr ([%e evar ("poly_"^name)] : Yojson.Safe.t -> _ error_or)] | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] x; [%e desu_expr_of_typ ~path typ] x] | { ptyp_desc = Ptyp_poly (names, typ) } -> poly_fun names (desu_expr_of_typ ~path typ) | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let sanitize ~quoter decls = Ppx_deriving.sanitize ~quoter ~module_:(Lident "Ppx_deriving_yojson_runtime") decls let ser_type_of_decl ~options ~path:_ type_decl = ignore (parse_options options); let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl in polymorphize [%type: [%t typ] -> Yojson.Safe.t] let ser_str_of_record ~quoter ~loc varname labels = let fields = labels |> List.mapi (fun _i { pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } -> let field = Exp.field (evar varname) (mknoloc (Lident name)) in let result = [%expr [%e str (attr_key name pld_attributes)], [%e ser_expr_of_typ ~quoter @@ type_add_attrs pld_type pld_attributes] [%e field]] in match attr_default (pld_type.ptyp_attributes @ pld_attributes) with | None -> [%expr [%e result] :: fields] | Some default -> let default = [%expr ([%e default] : [%t pld_type])] in [%expr if [%e field] = [%e Ppx_deriving.quote ~quoter default] then fields else [%e result] :: fields]) in let assoc = List.fold_left (fun expr field -> let loc = expr.pexp_loc in [%expr let fields = [%e field] in [%e expr]]) [%expr `Assoc fields] fields in [%expr let fields = [] in [%e assoc]] let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = ignore (parse_options options); let quoter = Ppx_deriving.create_quoter () in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let typ = Ppx_deriving.core_type_of_type_decl type_decl in match type_decl.ptype_kind with | Ptype_open -> begin let to_yojson_name = Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl in let mod_name = Ppx_deriving.mangle_type_decl (`PrefixSuffix ("M", "to_yojson")) type_decl in match type_decl.ptype_manifest with | Some ({ ptyp_desc = Ptyp_constr ({ txt = lid }, _args) } as manifest) -> let ser = ser_expr_of_typ ~quoter manifest in let lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "to_yojson")) lid in let orig_mod = Mod.ident (mknoloc lid) in let poly_ser = polymorphize [%expr ([%e sanitize ~quoter ser] : [%t typ] -> Yojson.Safe.t)] in ([Str.module_ (Mb.mk (mod_mknoloc mod_name) orig_mod)], [Vb.mk (pvar to_yojson_name) poly_ser], []) | Some _ -> raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver | None -> let poly_vars = List.rev (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) in let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl in let ty = Typ.poly poly_vars (polymorphize_ser [%type: [%t typ] -> Yojson.Safe.t]) in let default_fun = let type_path = String.concat "." (path @ [type_decl.ptype_name.txt]) in let e_type_path = Ast_builder.Default.estring ~loc:Location.none type_path in [%expr fun _ -> invalid_arg ("to_yojson: Maybe a [@@deriving yojson] is missing when extending the type "^ [%e e_type_path])] in let poly_fun = polymorphize default_fun in let poly_fun = (Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl) in let mod_name = "M_"^to_yojson_name in let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_to_yojson") in let record = Vb.mk (pvar "f") (Exp.record [lid "f", poly_fun] None) in let flid = lid (Printf.sprintf "%s.f" mod_name) in let field = Exp.field (Exp.ident flid) (flid) in let mod_ = Str.module_ (Mb.mk (mod_mknoloc mod_name) (Mod.structure [ Str.type_ Nonrecursive [typ]; Str.value Nonrecursive [record]; ])) in ([mod_], [Vb.mk (pvar to_yojson_name) [%expr fun x -> [%e field] x]], []) end | kind -> let serializer = match kind, type_decl.ptype_manifest with | Ptype_open, _ -> assert false | Ptype_abstract, Some manifest -> ser_expr_of_typ ~quoter manifest | Ptype_variant constrs, _ -> constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> let json_name = attr_name name' pcd_attributes in match pcd_args with | Pcstr_tuple([]) -> Exp.case (pconstr name' []) [%expr `List [`String [%e str json_name]]] | Pcstr_tuple(args) -> let arg_exprs = List.mapi (fun i typ -> app (ser_expr_of_typ ~quoter typ) [evar (argn i)]) args in Exp.case (pconstr name' (List.mapi (fun i _ -> pvar (argn i)) args)) [%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])] | Pcstr_record labels -> let arg_expr = ser_str_of_record ~quoter ~loc (argn 0) labels in Exp.case (pconstr name' [pvar(argn 0)]) [%expr `List ((`String [%e str json_name]) :: [%e list[arg_expr]])] ) |> Exp.function_ | Ptype_record labels, _ -> [%expr fun x -> [%e ser_str_of_record ~quoter ~loc "x" labels]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver in let ty = ser_type_of_decl ~options ~path type_decl in let fv = Ppx_deriving.free_vars_in_core_type ty in let poly_type = Typ.force_poly @@ Typ.poly fv @@ ty in let var_s = Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl in let var = pvar var_s in ([], [Vb.mk ~attrs:[disable_warning_39 ()] (Pat.constraint_ var poly_type) (polymorphize [%expr ([%e sanitize ~quoter serializer])])], [Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s]]] ] ) let ser_str_of_type_ext ~options ~path:_ ({ ptyext_path = { loc }} as type_ext) = ignore (parse_options options); let quoter = Ppx_deriving.create_quoter () in let serializer = let pats = List.fold_right (fun { pext_name = { txt = name' }; pext_kind; pext_attributes } acc_cases -> match pext_kind with | Pext_rebind _ -> (* nothing to do, since the constructor must be handled in original constructor declaration *) acc_cases | Pext_decl (_, pext_args, _) -> let json_name = attr_name name' pext_attributes in let case = match pext_args with | Pcstr_tuple([]) -> Exp.case (pconstr name' []) [%expr `List [`String [%e str json_name]]] | Pcstr_tuple(args) -> let arg_exprs = List.mapi (fun i typ -> app (ser_expr_of_typ ~quoter typ) [evar (argn i)]) args in Exp.case (pconstr name' (List.mapi (fun i _ -> pvar (argn i)) args)) [%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])] | Pcstr_record _ -> raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver in case :: acc_cases) type_ext.ptyext_constructors [] in let fallback_case = Exp.case [%pat? x] [%expr [%e Ppx_deriving.poly_apply_of_type_ext type_ext [%expr fallback]] x] in Exp.function_ (pats @ [fallback_case]) in let mod_name = let mod_lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "to_yojson")) type_ext.ptyext_path.txt in Longident.name mod_lid in let polymorphize = Ppx_deriving.poly_fun_of_type_ext type_ext in let serializer = polymorphize (sanitize ~quoter serializer) in let flid = lid (Printf.sprintf "%s.f" mod_name) in let set_field = Exp.setfield (Exp.ident flid) flid serializer in let field = Exp.field (Exp.ident flid) (flid) in let body = [%expr let fallback = [%e field] in [%e set_field]] in [Str.value ?loc:None Nonrecursive [Vb.mk (Pat.construct (lid "()") None) body]] let error_or typ = let loc = typ.ptyp_loc in [%type: [%t typ] Ppx_deriving_yojson_runtime.error_or] let desu_type_of_decl_poly ~options ~path:_ type_decl type_ = ignore (parse_options options); let loc = type_decl.ptype_loc in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in polymorphize type_ let desu_type_of_decl ~options ~path type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in desu_type_of_decl_poly ~options ~path type_decl [%type: Yojson.Safe.t -> [%t error_or typ]] let desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels = let top_error = error path in let record = List.fold_left (fun expr i -> let loc = expr.pexp_loc in [%expr [%e evar (argn i)] >>= fun [%p pvar (argn i)] -> [%e expr]] ) ( let r = Exp.record (labels |> List.mapi (fun i { pld_name = { txt = name } } -> mknoloc (Lident name), evar (argn i))) None in [%expr Result.Ok [%e wrap_record r] ] ) (labels |> List.mapi (fun i _ -> i)) in let default_case = if is_strict then top_error else [%expr loop xs _state] in let cases = (labels |> List.mapi (fun i { pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } -> let path = path @ [name] in let thunks = labels |> List.mapi (fun j _ -> if i = j then app (desu_expr_of_typ ~quoter ~path @@ type_add_attrs pld_type pld_attributes) [evar "x"] else evar (argn j)) in Exp.case [%pat? ([%p pstr (attr_key name pld_attributes)], x) :: xs] [%expr loop xs [%e tuple thunks]])) @ [Exp.case [%pat? []] record; Exp.case [%pat? _ :: xs] default_case] and thunks = labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } -> match attr_default (pld_type.ptyp_attributes @ pld_attributes) with | None -> error (path @ [name]) | Some default -> let default = [%expr ([%e default] : [%t pld_type])] in [%expr Result.Ok [%e Ppx_deriving.quote ~quoter default]]) in [%expr function | `Assoc xs -> let rec loop xs ([%p ptuple (List.mapi (fun i _ -> pvar (argn i)) labels)] as _state) = [%e Exp.match_ [%expr xs] cases] in loop xs [%e tuple thunks] | _ -> [%e top_error]] let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let { is_strict; want_exn; _ } = parse_options options in let quoter = Ppx_deriving.create_quoter () in let path = path @ [type_decl.ptype_name.txt] in let error path = [%expr Result.Error [%e str (String.concat "." path)]] in let top_error = error path in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let typ = Ppx_deriving.core_type_of_type_decl type_decl in match type_decl.ptype_kind with | Ptype_open -> begin let of_yojson_name = Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl in let mod_name = Ppx_deriving.mangle_type_decl (`PrefixSuffix ("M", "of_yojson")) type_decl in match type_decl.ptype_manifest with | Some ({ ptyp_desc = Ptyp_constr ({ txt = lid }, _args) } as manifest) -> let desu = desu_expr_of_typ ~quoter ~path manifest in let lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "of_yojson")) lid in let orig_mod = Mod.ident (mknoloc lid) in let poly_desu = polymorphize [%expr ([%e sanitize ~quoter desu] : Yojson.Safe.t -> _)] in ([Str.module_ (Mb.mk (mod_mknoloc mod_name) orig_mod)], [Vb.mk (pvar of_yojson_name) poly_desu], []) | Some _ -> raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver | None -> let poly_vars = List.rev (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) in let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in let ty = Typ.poly poly_vars (polymorphize_desu [%type: Yojson.Safe.t -> [%t error_or typ]]) in let default_fun = Exp.function_ [Exp.case [%pat? _] top_error] in let poly_fun = polymorphize default_fun in let poly_fun = (Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl) in let mod_name = "M_"^of_yojson_name in let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_of_yojson") in let record = Vb.mk (pvar "f") (Exp.record [lid "f", poly_fun] None) in let flid = lid (Printf.sprintf "%s.f" mod_name) in let field = Exp.field (Exp.ident flid) flid in let mod_ = Str.module_ (Mb.mk (mod_mknoloc mod_name) (Mod.structure [ Str.type_ Nonrecursive [typ]; Str.value Nonrecursive [record]; ])) in ([mod_], [Vb.mk (pvar of_yojson_name) [%expr fun x -> [%e field] x]], []) end | kind -> let desurializer = match kind, type_decl.ptype_manifest with | Ptype_open, _ -> assert false | Ptype_abstract, Some manifest -> desu_expr_of_typ ~quoter ~path manifest | Ptype_variant constrs, _ -> let cases = List.map (fun { pcd_loc = loc; pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> match pcd_args with | Pcstr_tuple(args) -> Exp.case [%pat? `List ((`String [%p pstr (attr_name name' pcd_attributes)]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) | Pcstr_record labels -> let wrap_record r = constr name' [r] in let sub = desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels in Exp.case [%pat? `List ((`String [%p pstr (attr_name name' pcd_attributes)]) :: [%p plist [pvar (argn 0)]])] [%expr [%e sub] [%e evar (argn 0)] ] ) constrs in Exp.function_ (cases @ [Exp.case [%pat? _] top_error]) | Ptype_record labels, _ -> desu_str_of_record ~quoter ~loc ~is_strict ~error ~path (fun r -> r) labels | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver in let ty = desu_type_of_decl ~options ~path type_decl in let fv = Ppx_deriving.free_vars_in_core_type ty in let poly_type = Typ.force_poly @@ Typ.poly fv @@ ty in let var_s = Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl in let var = pvar var_s in let var_s_exn = var_s ^ "_exn" in let { ptype_params; _ } = type_decl in let var_s_exn_args = List.mapi (fun i _ -> argn i |> evar) ptype_params in let var_s_exn_args = var_s_exn_args @ [evar "x"] in let var_s_exn_fun = let rec loop = function | [] -> sanitize ~quoter ([%expr match [%e app (evar var_s) var_s_exn_args] with Result.Ok x -> x | Result.Error err -> raise (Failure err)]) | hd::tl -> lam (pvar hd) (loop tl) in loop ((List.mapi (fun i _ -> argn i) ptype_params) @ ["x"]) in ([], [Vb.mk ~attrs:[disable_warning_39 ()] (Pat.constraint_ var poly_type) (polymorphize [%expr ([%e sanitize ~quoter desurializer])]) ], [Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s]]]] @ (if not want_exn then [] else [Str.value Nonrecursive [Vb.mk (pvar var_s_exn) var_s_exn_fun] ;Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s_exn]]]]) ) let desu_str_of_type_ext ~options ~path ({ ptyext_path = { loc } } as type_ext) = ignore(parse_options options); let quoter = Ppx_deriving.create_quoter () in let desurializer = let pats = List.fold_right (fun { pext_name = { txt = name' }; pext_kind; pext_attributes } acc_cases -> match pext_kind with | Pext_rebind _ -> (* nothing to do since it must have been handled in the original constructor declaration *) acc_cases | Pext_decl (_, pext_args, _) -> let case = match pext_args with | Pcstr_tuple(args) -> Exp.case [%pat? `List ((`String [%p pstr (attr_name name' pext_attributes)]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) | Pcstr_record _ -> raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver in case :: acc_cases) type_ext.ptyext_constructors [] in let any_case = Exp.case (Pat.var (mknoloc "x")) (app (Ppx_deriving.poly_apply_of_type_ext type_ext [%expr fallback]) [[%expr x]]) in (pats @ [any_case]) |> Exp.function_ in let mod_name = let mod_lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "of_yojson")) type_ext.ptyext_path.txt in Longident.name mod_lid in let polymorphize = Ppx_deriving.poly_fun_of_type_ext type_ext in let desurializer = sanitize ~quoter (polymorphize desurializer) in let flid = lid (Printf.sprintf "%s.f" mod_name) in let set_field = Exp.setfield (Exp.ident flid) flid desurializer in let field = Exp.field (Exp.ident flid) flid in let body = [%expr let fallback = [%e field] in [%e set_field]] in [Str.value ?loc:None Nonrecursive [Vb.mk (Pat.construct (lid "()") None) body]] let ser_sig_of_type ~options ~path type_decl = let to_yojson = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl)) (ser_type_of_decl ~options ~path type_decl)) in match type_decl.ptype_kind with | Ptype_open -> let mod_name = Ppx_deriving.mangle_type_decl (`PrefixSuffix ("M", "to_yojson")) type_decl in let poly_vars = List.rev (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let loc = typ.ptyp_loc in let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl in let ty = Typ.poly poly_vars (polymorphize_ser [%type: [%t typ] -> Yojson.Safe.t]) in let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_to_yojson") in let record = Val.mk (mknoloc "f") (Typ.constr (lid "t_to_yojson") []) in let mod_ = Sig.module_ (Md.mk (mod_mknoloc mod_name) (Mty.signature [ Sig.type_ Nonrecursive [typ]; Sig.value record; ])) in [mod_; to_yojson] | _ -> [to_yojson] let ser_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] let desu_sig_of_type ~options ~path type_decl = let { want_exn; _ } = parse_options options in let of_yojson = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl)) (desu_type_of_decl ~options ~path type_decl)) in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let loc = typ.ptyp_loc in let of_yojson_exn = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson_exn") type_decl)) (desu_type_of_decl_poly ~options ~path type_decl [%type: Yojson.Safe.t -> [%t typ]])) in match type_decl.ptype_kind with | Ptype_open -> let mod_name = Ppx_deriving.mangle_type_decl (`PrefixSuffix ("M", "of_yojson")) type_decl in let poly_vars = List.rev (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in let ty = Typ.poly poly_vars (polymorphize_desu [%type: Yojson.Safe.t -> [%t error_or typ]]) in let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_of_yojson") in let record = Val.mk (mknoloc "f") (Typ.constr (lid "t_of_yojson") []) in let mod_ = Sig.module_ (Md.mk (mod_mknoloc mod_name) (Mty.signature [ Sig.type_ Nonrecursive [typ]; Sig.value record; ])) in [mod_; of_yojson] | _ -> [of_yojson] @ (if not want_exn then [] else [of_yojson_exn]) let desu_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] let yojson_str_fields ~options ~path:_ type_decl = let { want_meta; _ } = parse_options options in match want_meta, type_decl.ptype_kind with | false, _ | true, Ptype_open -> [] | true, kind -> match kind, type_decl.ptype_manifest with | Ptype_record labels, _ -> let loc = !Ast_helper.default_loc in let fields = labels |> List.map (fun { pld_name = { txt = name }; pld_attributes } -> [%expr [%e str (attr_key name pld_attributes)]]) in let flist = List.fold_right (fun n acc -> [%expr [%e n] :: [%e acc]]) fields [%expr []] in [ Str.module_ (Mb.mk (mod_mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "Yojson_meta") type_decl)) (Mod.structure [ Str.value Nonrecursive [Vb.mk (pvar "keys") [%expr [%e flist]]] ; Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar "keys"]]] ])) ] | _ -> [] let yojson_sig_fields ~options ~path:_ type_decl = let { want_meta; _ } = parse_options options in match want_meta, type_decl.ptype_kind with | false, _ | true, Ptype_open -> [] | true, kind -> match kind, type_decl.ptype_manifest with | Ptype_record _, _ -> let loc = !Ast_helper.default_loc in [ Sig.module_ (Md.mk (mod_mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "Yojson_meta") type_decl)) (Mty.signature [ Sig.value (Val.mk (mknoloc "keys") [%type: string list]) ])) ] | _ -> [] let str_of_type ~options ~path type_decl = let (ser_pre, ser_vals, ser_post) = ser_str_of_type ~options ~path type_decl in let (desu_pre, desu_vals, desu_post) = desu_str_of_type ~options ~path type_decl in let fields_post = yojson_str_fields ~options ~path type_decl in (ser_pre @ desu_pre, ser_vals @ desu_vals, ser_post @ desu_post @ fields_post) let str_of_type_to_yojson ~options ~path type_decl = let (ser_pre, ser_vals, ser_post) = ser_str_of_type ~options ~path type_decl in let fields_post = yojson_str_fields ~options ~path type_decl in (ser_pre, ser_vals, ser_post @ fields_post) let str_of_type_of_yojson ~options ~path type_decl = let (desu_pre, desu_vals, desu_post) = desu_str_of_type ~options ~path type_decl in let fields_post = yojson_str_fields ~options ~path type_decl in (desu_pre, desu_vals, desu_post @ fields_post) let str_of_type_ext ~options ~path type_ext = let ser_vals = ser_str_of_type_ext ~options ~path type_ext in let desu_vals = desu_str_of_type_ext ~options ~path type_ext in ser_vals @ desu_vals let sig_of_type ~options ~path type_decl = (ser_sig_of_type ~options ~path type_decl) @ (desu_sig_of_type ~options ~path type_decl) @ (yojson_sig_fields ~options ~path type_decl) let sig_of_type_to_yojson ~options ~path type_decl = (ser_sig_of_type ~options ~path type_decl) @ (yojson_sig_fields ~options ~path type_decl) let sig_of_type_of_yojson ~options ~path type_decl = (desu_sig_of_type ~options ~path type_decl) @ (yojson_sig_fields ~options ~path type_decl) let sig_of_type_ext ~options ~path type_ext = (ser_sig_of_type_ext ~options ~path type_ext) @ (desu_sig_of_type_ext ~options ~path type_ext) let structure f ~options ~path type_ = let (pre, vals, post) = f ~options ~path type_ in match vals with | [] -> pre @ post | _ -> pre @ [Str.value ?loc:None Recursive vals] @ post let on_str_decls f ~options ~path type_decls = let unzip3 l = List.fold_right (fun (v1, v2, v3) (a1,a2,a3) -> (v1::a1, v2::a2, v3::a3)) l ([],[],[]) in let (pre, vals, post) = unzip3 (List.map (f ~options ~path) type_decls) in (List.concat pre, List.concat vals, List.concat post) let on_sig_decls f ~options ~path type_decls = List.concat (List.map (f ~options ~path) type_decls) (* Note: we are careful to call our sanitize function here, not Ppx_deriving.sanitize. *) let ser_core_expr_of_typ typ = let quoter = Ppx_deriving.create_quoter () in let typ = Ppx_deriving.strong_type_of_type typ in sanitize ~quoter (ser_expr_of_typ ~quoter typ) let desu_core_expr_of_typ typ = let quoter = Ppx_deriving.create_quoter () in let typ = Ppx_deriving.strong_type_of_type typ in sanitize ~quoter (desu_expr_of_typ ~quoter ~path:[] typ) let () = Ppx_deriving.(register (create "yojson" ~type_decl_str:(structure (on_str_decls str_of_type)) ~type_ext_str:str_of_type_ext ~type_decl_sig:(on_sig_decls sig_of_type) ~type_ext_sig:sig_of_type_ext () )); Ppx_deriving.(register (create "to_yojson" ~core_type:ser_core_expr_of_typ ~type_decl_str:(structure (on_str_decls str_of_type_to_yojson)) ~type_ext_str:ser_str_of_type_ext ~type_decl_sig:(on_sig_decls sig_of_type_to_yojson) ~type_ext_sig:ser_sig_of_type_ext () )); Ppx_deriving.(register (create "of_yojson" ~core_type:desu_core_expr_of_typ ~type_decl_str:(structure (on_str_decls str_of_type_of_yojson)) ~type_ext_str:desu_str_of_type_ext ~type_decl_sig:(on_sig_decls sig_of_type_of_yojson) ~type_ext_sig:desu_sig_of_type_ext () )) ppx_deriving_yojson-3.7.0/src/ppx_deriving_yojson_runtime.ml000066400000000000000000000014101427673044000246060ustar00rootroot00000000000000include Ppx_deriving_runtime let (>>=) x f = match x with Result.Ok x -> f x | (Result.Error _) as x -> x let (>|=) x f = x >>= fun x -> Result.Ok (f x) let rec map_bind f acc xs = match xs with | x :: xs -> (* equivalent to [f x >>= fun x -> map_bind f (x :: acc) xs], but do not use [(>>=)] to keep [map_bind] tail-recursive under js-of-ocaml *) (match f x with | ((Result.Error _) as err) -> err | Result.Ok x -> map_bind f (x :: acc) xs) | [] -> Result.Ok (List.rev acc) type 'a error_or = ('a, string) Result.result (** [safe_map f l] returns the same value as [List.map f l], but computes it tail-recursively so that large list lengths don't cause a stack overflow *) let safe_map f l = List.rev (List.rev_map f l) ppx_deriving_yojson-3.7.0/src/ppx_deriving_yojson_runtime.mli000066400000000000000000000016041427673044000247640ustar00rootroot00000000000000type 'a error_or = ('a, string) Result.result val ( >>= ) : 'a error_or -> ('a -> 'b error_or) -> 'b error_or val ( >|= ) : 'a error_or -> ('a -> 'b) -> 'b error_or val map_bind : ('a -> 'b error_or) -> 'b list -> 'a list -> 'b list error_or (** [safe_map f l] returns the same value as [List.map f l], but computes it tail-recursively so that large list lengths don't cause a stack overflow *) val safe_map : ('a -> 'b) -> 'a list -> 'b list val ( = ) : 'a -> 'a -> bool (* NOTE: Used for [@default ...] *) module List : (module type of List) module String : (module type of String) module Bytes : (module type of Bytes) module Int32 : (module type of Int32) module Int64 : (module type of Int64) module Nativeint : (module type of Nativeint) module Array : (module type of Array) module Result : sig type ('a, 'b) result = ('a, 'b) Result.result = | Ok of 'a | Error of 'b end ppx_deriving_yojson-3.7.0/src_test/000077500000000000000000000000001427673044000174555ustar00rootroot00000000000000ppx_deriving_yojson-3.7.0/src_test/dune000066400000000000000000000003561427673044000203370ustar00rootroot00000000000000(executable (name test_ppx_yojson) (libraries ounit2 result) (preprocess (pps ppx_deriving.show ppx_deriving_yojson)) (flags (:standard -w -9-39-27-34-37))) (alias (name runtest) (deps test_ppx_yojson.exe) (action (run %{deps}))) ppx_deriving_yojson-3.7.0/src_test/test_ppx_yojson.ml000066400000000000000000000504321427673044000232620ustar00rootroot00000000000000open OUnit2 type json = [ `Assoc of (string * json) list | `Bool of bool | `Float of float | `Int of int | `Intlit of string | `List of json list | `Null | `String of string | `Tuple of json list | `Variant of string * json option ] [@@deriving show] let show_error_or = let module M = struct type 'a error_or = ('a, string) Result.result [@@deriving show] end in M.show_error_or let assert_roundtrip pp_obj to_json of_json obj str = let json = Yojson.Safe.from_string str in let cleanup json = Yojson.Safe.(json |> to_string |> from_string) in assert_equal ~printer:show_json json (cleanup (to_json obj)); assert_equal ~printer:(show_error_or pp_obj) (Result.Ok obj) (of_json json) let assert_failure pp_obj of_json err str = let json = Yojson.Safe.from_string str in assert_equal ~printer:(show_error_or pp_obj) (Result.Error err) (of_json json) type u = unit [@@deriving show, yojson] type i1 = int [@@deriving show, yojson] type i2 = int32 [@@deriving show, yojson] type i3 = Int32.t [@@deriving show, yojson] type i4 = int64 [@@deriving show, yojson] type i5 = Int64.t [@@deriving show, yojson] type i6 = nativeint [@@deriving show, yojson] type i7 = Nativeint.t [@@deriving show, yojson] type i8 = int64 [@encoding `string] [@@deriving show, yojson] type i9 = nativeint [@encoding `string] [@@deriving show, yojson] type f = float [@@deriving show, yojson] type b = bool [@@deriving show, yojson] type c = char [@@deriving show, yojson] type s = string [@@deriving show, yojson] type y = bytes [@@deriving show, yojson] type xr = int ref [@@deriving show, yojson] type xo = int option [@@deriving show, yojson] type xl = int list [@@deriving show, yojson] type xa = int array [@@deriving show, yojson] type xt = int * int [@@deriving show, yojson] type 'a p = 'a option [@@deriving show, yojson] type pv = [ `A | `B of int | `C of int * string ] [@@deriving show, yojson] type pva = [ `A ] and pvb = [ `B ] [@@deriving show, yojson] type 'a pvc = [ `C of 'a ] [@@deriving show, yojson] type pvd = [ pva | pvb | int pvc ] [@@deriving show, yojson] type v = A | B of int | C of int * string [@@deriving show, yojson] type r = { x : int; y : string } [@@deriving show, yojson] type rv = RA | RB of int | RC of int * string | RD of { z : string } [@@deriving show, yojson] let test_unit _ctxt = assert_roundtrip pp_u u_to_yojson u_of_yojson () "null" let test_int _ctxt = assert_roundtrip pp_i1 i1_to_yojson i1_of_yojson 42 "42"; assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson 42l "42"; assert_roundtrip pp_i3 i3_to_yojson i3_of_yojson 42l "42"; assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson 42L "42"; assert_roundtrip pp_i5 i5_to_yojson i5_of_yojson 42L "42"; assert_roundtrip pp_i6 i6_to_yojson i6_of_yojson 42n "42"; assert_roundtrip pp_i7 i7_to_yojson i7_of_yojson 42n "42"; assert_roundtrip pp_i8 i8_to_yojson i8_of_yojson 42L "\"42\""; assert_roundtrip pp_i9 i9_to_yojson i9_of_yojson 42n "\"42\"" let test_int_edge _ctxt = assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson 0x7fffffffl "2147483647"; assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson (Int32.neg 0x80000000l) "-2147483648"; assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson 0x7fffffffffffffffL "9223372036854775807"; assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson (Int64.neg 0x8000000000000000L) "-9223372036854775808" let test_float _ctxt = assert_roundtrip pp_f f_to_yojson f_of_yojson 1.0 "1.0"; assert_equal ~printer:(show_error_or pp_f) (Result.Ok 1.0) (f_of_yojson (`Int 1)) let test_bool _ctxt = assert_roundtrip pp_b b_to_yojson b_of_yojson true "true"; assert_roundtrip pp_b b_to_yojson b_of_yojson false "false" let test_char _ctxt = assert_roundtrip pp_c c_to_yojson c_of_yojson 'c' "\"c\""; assert_failure pp_c c_of_yojson "Test_ppx_yojson.c" "\"xxx\"" let test_string _ctxt = assert_roundtrip pp_s s_to_yojson s_of_yojson "foo" "\"foo\""; assert_roundtrip pp_y y_to_yojson y_of_yojson (Bytes.of_string "foo") "\"foo\"" let test_ref _ctxt = assert_roundtrip pp_xr xr_to_yojson xr_of_yojson (ref 42) "42" let test_option _ctxt = assert_roundtrip pp_xo xo_to_yojson xo_of_yojson (Some 42) "42"; assert_roundtrip pp_xo xo_to_yojson xo_of_yojson None "null" let test_poly _ctxt = assert_roundtrip pp_xo (([%to_yojson: 'a option] [%to_yojson: int])) (([%of_yojson: 'a option] [%of_yojson: int])) (Some 42) "42" let test_list _ctxt = assert_roundtrip pp_xl xl_to_yojson xl_of_yojson [] "[]"; assert_roundtrip pp_xl xl_to_yojson xl_of_yojson [42; 43] "[42, 43]"; let rec make_list i acc = if i = 0 then (i mod 100 :: acc) else make_list (i - 1) (i mod 100 :: acc) in let lst = make_list (500_000 - 1) [] in let buf = Buffer.create (5_000 * 390 + 4) in Buffer.add_string buf "["; Buffer.add_string buf (string_of_int (List.hd lst)); List.iter (fun x -> Buffer.add_string buf ", "; Buffer.add_string buf (string_of_int x)) (List.tl lst); Buffer.add_string buf "]"; let str = Bytes.to_string (Buffer.to_bytes buf) in assert_roundtrip pp_xl xl_to_yojson xl_of_yojson lst str let test_array _ctxt = assert_roundtrip pp_xa xa_to_yojson xa_of_yojson [||] "[]"; assert_roundtrip pp_xa xa_to_yojson xa_of_yojson [|42; 43|] "[42, 43]" let test_tuple _ctxt = assert_roundtrip pp_xt xt_to_yojson xt_of_yojson (42, 43) "[42, 43]" let test_ptyp _ctxt = assert_roundtrip (pp_p pp_i1) (p_to_yojson i1_to_yojson) (p_of_yojson i1_of_yojson) (Some 42) "42"; assert_roundtrip (pp_p pp_i1) (p_to_yojson i1_to_yojson) (p_of_yojson i1_of_yojson) None "null" let test_pvar _ctxt = assert_roundtrip pp_pv pv_to_yojson pv_of_yojson `A "[\"A\"]"; assert_roundtrip pp_pv pv_to_yojson pv_of_yojson (`B 42) "[\"B\", 42]"; assert_roundtrip pp_pv pv_to_yojson pv_of_yojson (`C (42, "foo")) "[\"C\", 42, \"foo\"]"; assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson `A "[\"A\"]"; assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson `B "[\"B\"]"; assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson (`C 1) "[\"C\", 1]"; assert_equal ~printer:(show_error_or pp_pvd) (Result.Error "Test_ppx_yojson.pvd") (pvd_of_yojson (`List [`String "D"])) let test_var _ctxt = assert_roundtrip pp_v v_to_yojson v_of_yojson A "[\"A\"]"; assert_roundtrip pp_v v_to_yojson v_of_yojson (B 42) "[\"B\", 42]"; assert_roundtrip pp_v v_to_yojson v_of_yojson (C (42, "foo")) "[\"C\", 42, \"foo\"]" let test_rec _ctxt = assert_roundtrip pp_r r_to_yojson r_of_yojson {x=42; y="foo"} "{\"x\":42,\"y\":\"foo\"}" let test_recvar _ctxt = assert_roundtrip pp_rv rv_to_yojson rv_of_yojson RA "[\"RA\"]"; assert_roundtrip pp_rv rv_to_yojson rv_of_yojson (RB 42) "[\"RB\", 42]"; assert_roundtrip pp_rv rv_to_yojson rv_of_yojson (RC(42, "foo")) "[\"RC\", 42, \"foo\"]"; assert_roundtrip pp_rv rv_to_yojson rv_of_yojson (RD{z="foo"}) "[\"RD\", {\"z\": \"foo\"}]" type geo = { lat : float [@key "Latitude"] ; lon : float [@key "Longitude"] ; } [@@deriving yojson, show] let test_key _ctxt = assert_roundtrip pp_geo geo_to_yojson geo_of_yojson {lat=35.6895; lon=139.6917} "{\"Latitude\":35.6895,\"Longitude\":139.6917}" let test_field_err _ctxt = assert_equal ~printer:(show_error_or pp_geo) (Result.Error "Test_ppx_yojson.geo.lat") (geo_of_yojson (`Assoc ["Longitude", (`Float 42.0)])) type id = Yojson.Safe.t [@@deriving yojson] let test_id _ctxt = assert_roundtrip pp_json id_to_yojson id_of_yojson (`Int 42) "42" type custvar = | Tea of string [@name "tea"] | Vodka [@name "vodka"] [@@deriving yojson, show] let test_custvar _ctxt = assert_roundtrip pp_custvar custvar_to_yojson custvar_of_yojson (Tea "oolong") "[\"tea\", \"oolong\"]"; assert_roundtrip pp_custvar custvar_to_yojson custvar_of_yojson Vodka "[\"vodka\"]" type custpvar = [ `Tea of string [@name "tea"] | `Beer of string * float [@name "beer"] | `Vodka [@name "vodka"] ] [@@deriving yojson, show] let test_custpvar _ctxt = assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson (`Tea "earl_grey") "[\"tea\", \"earl_grey\"]"; assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson (`Beer ("guinness", 3.3)) "[\"beer\", \"guinness\", 3.3]"; assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson `Vodka "[\"vodka\"]" type default = { def : int [@default 42]; } [@@deriving yojson, show] let test_default _ctxt = assert_roundtrip pp_default default_to_yojson default_of_yojson { def = 42 } "{}" type bidi = int [@@deriving show, to_yojson, of_yojson] let test_bidi _ctxt = assert_roundtrip pp_bidi bidi_to_yojson bidi_of_yojson 42 "42" let test_shortcut _ctxt = assert_roundtrip pp_i1 [%to_yojson: int] [%of_yojson: int] 42 "42" module CustomConversions = struct module IntMap = Map.Make(struct type t = int let compare = compare end) type mapEncoding = (int * string) list [@@deriving yojson] let map_to_yojson m = mapEncoding_to_yojson @@ IntMap.bindings m let map_of_yojson json = Result.(match mapEncoding_of_yojson json with | Ok lst -> Ok (List.fold_left (fun m (k, v) -> IntMap.add k v m) IntMap.empty lst) | Error s -> Error s) type k = string IntMap.t [@to_yojson map_to_yojson] [@of_yojson map_of_yojson] [@printer fun fmt a -> ()] [@@deriving show, yojson] let test_bare _ctxt = assert_roundtrip pp_k k_to_yojson k_of_yojson IntMap.(add 6 "foo" @@ empty) {|[[6,"foo"]]|} type crecord = { mapping : string IntMap.t [@to_yojson map_to_yojson] [@of_yojson map_of_yojson] [@printer fun fmt a -> ()] } [@@deriving yojson, show] let test_record _ctxt = assert_roundtrip pp_crecord crecord_to_yojson crecord_of_yojson IntMap.{ mapping = add 6 "foo" @@ empty } {|{"mapping":[[6,"foo"]]}|} let suite = "Custom conversion attributes" >::: [ "test_record" >:: test_record ; "test_bare" >:: test_bare ] end type nostrict = { nostrict_field : int; } [@@deriving show, yojson { strict = false }] let test_nostrict _ctxt = assert_equal ~printer:(show_error_or pp_nostrict) (Result.Ok { nostrict_field = 42 }) (nostrict_of_yojson (`Assoc ["nostrict_field", (`Int 42); "some_other_field", (`Int 43)])) module Opentype : sig type 'a opentype = .. [@@deriving yojson] type 'a opentype += A of 'a | B of string list [@@deriving yojson] end = struct type 'a opentype = .. [@@deriving yojson] type 'a opentype += A of 'a | B of string list [@@deriving yojson] end type 'a Opentype.opentype += | C of 'a Opentype.opentype * float | A = Opentype.A [@@deriving yojson] let rec pp_opentype f fmt = function A x -> Format.fprintf fmt "A(%s)" (f x) | Opentype.B l -> Format.fprintf fmt "B(%s)" (String.concat ", " l) | C (x, v) -> Format.pp_print_string fmt "C("; pp_opentype f fmt x; Format.fprintf fmt ", %f)" v | _ -> assert false let test_opentype _ctxt = let pp_ot = pp_opentype string_of_int in let to_yojson = Opentype.opentype_to_yojson i1_to_yojson in let of_yojson = Opentype.opentype_of_yojson i1_of_yojson in assert_roundtrip pp_ot to_yojson of_yojson (Opentype.A 0) "[\"A\", 0]"; assert_roundtrip pp_ot to_yojson of_yojson (Opentype.B ["one"; "two"]) "[\"B\", [ \"one\", \"two\"] ]"; assert_roundtrip pp_ot to_yojson of_yojson (C (Opentype.A 42, 1.2)) "[\"C\", [\"A\", 42], 1.2]" (* This will fail at type-check if we introduce features that increase the default generated signatures. It is representative of user code (there is plenty in OPAM) that uses our generated signatures, but manually implement this restricted function set. For example, the unconditional addition of of_yojson_exn has broken this test. *) type outer_t = int [@@deriving yojson] module Automatic_deriving_in_signature_only : sig type t [@@deriving yojson] end = struct type t = int let of_yojson = outer_t_of_yojson let to_yojson = outer_t_to_yojson end module Warnings = struct module W34 = struct [@@@ocaml.warning "@34"] module M1 : sig type u [@@deriving yojson] end = struct type internal = int list [@@deriving yojson] type u = int list [@@deriving yojson] end (* the deriver for type [u] supposedly use the derivier of type [internal]. Consider for instance the case where [u] is a map, and internal is a list of bindings. *) module M2 : sig type 'a u [@@deriving yojson] end = struct type 'a internal = 'a list [@@deriving yojson] type 'a u = 'a list [@@deriving yojson] end (* the deriver for type [u] supposedly use the derivier of type [internal]. Consider for instance the case where [u] is a map, and internal is a list of bindings. *) (* module M1 : sig type 'a u [@@deriving yojson] end = struct *) (* type 'a internal = .. [@@deriving yojson] (\* Triggers the warning *\) *) (* type 'a internal += A of 'a | B of string list [@@deriving yojson] *) (* type 'a u = 'a list [@@deriving yojson] *) (* end *) end end module TestShadowing = struct module List = struct let map () = () end type t = int list [@@deriving yojson] module Array = struct let to_list () = () end module Bytes = struct let to_string () = () end type v = bytes [@@deriving yojson] end module Test_extension_forms = struct let _ = [%to_yojson: unit], [%of_yojson: unit] let _ = [%to_yojson: int], [%of_yojson: int] let _ = [%to_yojson: int32], [%of_yojson: int32] let _ = [%to_yojson: Int32.t], [%of_yojson: Int32.t] let _ = [%to_yojson: int64], [%of_yojson: int64] let _ = [%to_yojson: Int64.t], [%of_yojson: Int64.t] let _ = [%to_yojson: nativeint], [%of_yojson: nativeint] let _ = [%to_yojson: Nativeint.t], [%of_yojson: Nativeint.t] let _ = [%to_yojson: int64], [%of_yojson: int64] let _ = [%to_yojson: nativeint], [%of_yojson: nativeint] let _ = [%to_yojson: float], [%of_yojson: float] let _ = [%to_yojson: bool], [%of_yojson: bool] let _ = [%to_yojson: char], [%of_yojson: char] let _ = [%to_yojson: string], [%of_yojson: string] let _ = [%to_yojson: bytes], [%of_yojson: bytes] let _ = [%to_yojson: int], [%of_yojson: int] let _ = [%to_yojson: int ref], [%of_yojson: int ref] let _ = [%to_yojson: int option], [%of_yojson: int option] let _ = [%to_yojson: int list], [%of_yojson: int list] let _ = [%to_yojson: int array], [%of_yojson: int array] let _ = [%to_yojson: int * int], [%of_yojson: int * int] let _ = [%to_yojson: 'a option], [%of_yojson: 'a option] let _ = [%to_yojson: [ `A | `B of int | `C of int * string ]], [%of_yojson: [ `A | `B of int | `C of int * string ]] let _ = [%to_yojson: [ `C of 'a ]], [%of_yojson: [ `C of 'a ]] let _ = [%to_yojson: [ pva | pvb | int pvc ]], [%of_yojson: [ pva | pvb | int pvc ]] end (* this test checks that we can derive an _exn deserializer even if we use sub-types that are derived with {exn = false} *) module Test_exn_depends_on_non_exn = struct module M : sig type t [@@deriving yojson { exn = false }] end = struct type t = int [@@deriving yojson { exn = false }] end open M type u = t * t [@@deriving yojson { exn = true }] end module Test_recursive_polyvariant = struct (* Regression test for https://github.com/whitequark/ppx_deriving_yojson/issues/24 *) type a = [ `B of string ] [@@deriving of_yojson] type b = [a | `C of b list] [@@deriving of_yojson] type c = [ a | b | `D of b list] [@@deriving of_yojson] let c_of_yojson yj : c Ppx_deriving_yojson_runtime.error_or = c_of_yojson yj end type 'a recursive1 = { lhs : string ; rhs : 'a } and foo = unit recursive1 and bar = int recursive1 [@@deriving show, yojson] let test_recursive _ctxt = assert_roundtrip (pp_recursive1 pp_i1) (recursive1_to_yojson i1_to_yojson) (recursive1_of_yojson i1_of_yojson) {lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}"; assert_roundtrip pp_foo foo_to_yojson foo_of_yojson {lhs="x"; rhs=()} "{\"lhs\":\"x\",\"rhs\":null}" ; assert_roundtrip pp_bar bar_to_yojson bar_of_yojson {lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}" let test_int_redefined ctxt = let module M = struct type int = Break_things let x = [%to_yojson: int] 1 end in let expected = `Int 1 in assert_equal ~ctxt ~printer:show_json expected M.x (* TODO: Make this work *) (* let test_list_redefined ctxt = let module M = struct type redef_list = | [] | (::) of int * int type t = {field : int list} [@@deriving to_yojson] let x = {field = List.([1;2])} end in let expected = `List [`Int 1; `Int 2] in assert_equal ~ctxt ~printer:show_json expected M.x *) let test_equality_redefined ctxt = let module M = struct module Pervasives = struct let (=) : int -> int -> bool = fun a b -> a = b let _ = 1 = 1 (* just dummy usage of `=` to suppress compiler warning *) let never_gonna_be_in_pervasives = None end let (=) : int -> int -> bool = fun a b -> a = b let _ = 1 = 1 (* just dummy usage of `=` to suppress compiler warning *) type t = {field : int option [@default Pervasives.never_gonna_be_in_pervasives]} [@@deriving to_yojson] let x = {field = Some 42} end in let expected = `Assoc ([("field", `Int (42))]) in assert_equal ~ctxt ~printer:show_json expected M.(to_yojson x) module Sanitize = struct module Result = struct type t = MyResult [@@deriving yojson] end type result_list = Result.t list [@@deriving yojson] (* sanitize [@default ...] *) module List = struct let x = [1; 2] end type t = {field : int list [@default List.x]} [@@deriving to_yojson] type t2 = {my: Result.t [@default MyResult]} [@@deriving yojson] end let suite = "Test ppx_yojson" >::: [ "test_unit" >:: test_unit; "test_int" >:: test_int; "test_int_edge" >:: test_int_edge; "test_float" >:: test_float; "test_bool" >:: test_bool; "test_char" >:: test_char; "test_string" >:: test_string; "test_ref" >:: test_ref; "test_option" >:: test_option; "test_poly" >:: test_poly; "test_list" >:: test_list; "test_array" >:: test_array; "test_tuple" >:: test_tuple; "test_ptyp" >:: test_ptyp; "test_pvar" >:: test_pvar; "test_var" >:: test_var; "test_rec" >:: test_rec; "test_recvar" >:: test_recvar; "test_key" >:: test_key; "test_id" >:: test_id; "test_custvar" >:: test_custvar; "test_custpvar" >:: test_custpvar; "test_field_err" >:: test_field_err; "test_default" >:: test_default; "test_bidi" >:: test_bidi; "test_custom" >: CustomConversions.suite; "test_shortcut" >:: test_shortcut; "test_nostrict" >:: test_nostrict; "test_opentype" >:: test_opentype; "test_recursive" >:: test_recursive; "test_int_redefined" >:: test_int_redefined; "test_equality_redefined" >:: test_equality_redefined; ] let _ = run_test_tt_main suite