├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE.txt ├── Makefile ├── README.md ├── dune-project ├── dune-workspace.dev ├── pkg └── pkg.ml ├── ppx_deriving_yojson.opam ├── src ├── dune ├── ppx_deriving_yojson.ml ├── ppx_deriving_yojson.mli ├── ppx_deriving_yojson_runtime.ml └── ppx_deriving_yojson_runtime.mli └── src_test ├── dune └── test_ppx_yojson.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.native 2 | *.byte 3 | *.docdir 4 | _build 5 | *.install 6 | pkg/META 7 | .merlin -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 6 | script: bash -ex ./.travis-docker.sh 7 | env: 8 | global: 9 | - PINS="ppx_deriving_yojson:. ppx_deriving.dev:git://github.com/ocaml-ppx/ppx_deriving.git" 10 | - PACKAGE="ppx_deriving_yojson" 11 | - DISTRO="ubuntu-16.04" 12 | matrix: 13 | - OCAML_VERSION="4.11.0+trunk" OCAML_BETA="enable" 14 | - OCAML_VERSION="4.10" 15 | - OCAML_VERSION="4.09" 16 | - OCAML_VERSION="4.08" 17 | - OCAML_VERSION="4.07" 18 | - OCAML_VERSION="4.06" 19 | - OCAML_VERSION="4.05" 20 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 3.10.0 2 | ------ 3 | 4 | * Bump to ppxlib.0.36.0, 5.2 AST 5 | (#160) 6 | @patricoferris 7 | * Fix more `Poly_typ ([], ...)` nodes generation 8 | #160 9 | @NathanReb 10 | 11 | 3.9.1 12 | ----- 13 | 14 | * Fix generation of unnecessary `Poly_typ ([], ...)` nodes when deriving 15 | de/serializer for open types. These are rejected by OCaml 5.3 onward. 16 | (#162) 17 | @NathanReb 18 | 19 | 3.9.0 20 | ----- 21 | 22 | * Expose Deriving.t values to allow definition of external Deriving aliases 23 | (#159) 24 | @NathanReb 25 | 26 | 3.8.0 27 | ----- 28 | 29 | * Port deriver to ppxlib 30 | (#149) 31 | Simmo Saan 32 | 33 | 3.7.0 34 | ----- 35 | 36 | * Use ounit2 instead of ounit for the tests 37 | (#144) 38 | Marek Kubica 39 | * Update to ppxlib >= 0.26.0 40 | (#142, #146) 41 | Sonja Heinze, Antonio Nuno Monteiro 42 | * Sanitize the ppx output to be able to use module names shadowing the modules from the standard library 43 | (#140) 44 | Simmo Saan 45 | * Reimplement map_bind to avoid stack overflows on js-of-ocaml 46 | (#138) 47 | P. Baudin 48 | * Add ppxlib as a direct dependency for ppx_deriving_yojson 49 | (#136) 50 | Hongchang Wu 51 | 52 | 3.6.1 53 | ----- 54 | 55 | * Update to ppxlib >= 0.14.0 56 | (#127) 57 | Kate Deplaix 58 | 59 | 3.6.0 60 | ----- 61 | 62 | * Update to ppx_deriving 5.0 and ppxlib 63 | (#121) 64 | Rudi Grinberg, Thierry Martinez, Kate Deplaix and Gabriel Scherer 65 | 66 | * Fix issues when the equality operator `(=)` is shadowed 67 | (#126, #128, #131, fixes #79) 68 | Martin Slota, Kate Deplaix 69 | 70 | 3.5.3 71 | ----- 72 | 73 | * Support for OCaml 4.11 (requires feature from `ppx_deriving.4.5`) 74 | (#122) 75 | Thierry Martinez 76 | * Documentation improvements 77 | (#115) 78 | Olivier Andrieu 79 | 80 | 3.5.2 81 | ----- 82 | 83 | * [@to_yojson], [@from_yojson] to override serialization functions 84 | for certain record fields 85 | (#107, #108) 86 | Chas Emerick 87 | * Support for OCaml 4.10 88 | (#112) 89 | Kate Deplaix 90 | 91 | 3.5.1 92 | ----- 93 | 94 | * Two bugfixes when using [%to_json ], [%of_json ] extensions 95 | (error with polymorphic variables, unbound value 'safe_map') 96 | (#100, #101) 97 | Gabriel Scherer, report by Matt Windsor 98 | 99 | 3.5 100 | --- 101 | 102 | * use tail-recursive functions to (de)serialize long lists 103 | (#97) 104 | Alex Knauth 105 | * Support for OCaml 4.08 106 | (#99) 107 | Antonio Nuno Monteiro 108 | 109 | 3.4 110 | --- 111 | 112 | * compatibility with yojson 1.6.0 113 | (#90, #92) 114 | Vadim Radovel and Nathan Rebours 115 | 116 | 3.3 117 | --- 118 | 119 | * Make `_exn` functions opt-in (`[@@deriving yojson { exn = true }]`) 120 | to preserve backward-compatibility for fully-manual implementations 121 | of the [@@deriving yojson] interface. 122 | (#86) 123 | Gabriel Scherer 124 | 125 | 3.2 126 | --- 127 | 128 | * Add `let _ = to_yojson / of_yojson` to generated code to avoid warnings when 129 | they aren't used 130 | (#68) 131 | Steve Bleazard 132 | * Fix bug where doing [@@deriving of_yojson] causes an unused rec warning 133 | (#68) 134 | Steve Bleazard 135 | * Add generated `ty_of_yojson_exn` to raise an exception rather than return an 136 | error 137 | (#57, #68) 138 | Steve Bleazard 139 | * Port `ppx_deriving_yojson` to `dune` 140 | (#69, #85) 141 | Rudi Grinberg, Antonio Nuno Monteiro 142 | * Added deriver option `fields` to generate a `Yojson_meta` module containing 143 | all JSON key names. 144 | (#70) 145 | Steve Bleazard 146 | * Remove cppo that included support for versions no longer supported by 147 | `ppx_deriving_yojson` 148 | (#75) 149 | Rudi Grinberg 150 | 151 | 3.1 152 | --- 153 | 154 | * Fix ppx_deriving_yojson.runtime META file 155 | (#47) 156 | Étienne Millon 157 | * Support for inline records in variant types 158 | (#50) 159 | Gerd Stolpmann 160 | * OCaml 4.06 compatibility 161 | (#64, #66) 162 | Leonid Rozenberg, Gabriel Scherer 163 | 164 | 3.0 165 | --- 166 | 167 | * Use Result.result in generated code. 168 | * Compatibility with statically linked ppx drivers. 169 | * OCaml 4.03 compatibility. 170 | 171 | 2.3 172 | --- 173 | 174 | * Adapt to syntactic changes in 4.02.2. 175 | * Improve compatibility with libraries that shadow modules 176 | from standard library, such as Core. 177 | * Allow deserializing float values that appear as integer 178 | literals in the input JSON. 179 | * Suppress some warnings. 180 | 181 | 2.2 182 | --- 183 | 184 | * Add support for open types. 185 | 186 | 2.1 187 | --- 188 | 189 | * Handle inheriting from a parametric polymorphic variant type. 190 | * Don't leak type variables. 191 | 192 | 2.0 193 | --- 194 | 195 | * Update to accomodate syntactic changes in _deriving_ 1.0. 196 | * Common helper functions have been extracted into 197 | ppx_deriving_yojson.runtime, reducing code size. 198 | * Add support for `[@@deriving to_yojson, of_yojson]` 199 | and `[%to_yojson:]`, `[%of_yojson:]` shortcuts. 200 | * Add support for `[@@deriving yojson { strict = false }]`. 201 | 202 | 1.1 203 | --- 204 | 205 | * Add `[@key]`, `[@name]` and `[@default]` attributes. 206 | * Add support for `Yojson.Safe.json` values. 207 | 208 | 1.0 209 | --- 210 | 211 | * Initial release. 212 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to `ppx_deriving_yojson` 2 | 3 | ## Setting up 4 | 5 | This document assumes you have [OPAM](https://opam.ocaml.org/) installed. 6 | 7 | ### Installing 8 | 9 | To start building this project you will need to install the packages it depends 10 | on. To do so, run the following command: 11 | 12 | ```shell 13 | $ opam install . --deps-only -t 14 | ``` 15 | 16 | ## Developing 17 | 18 | ### Building & Testing 19 | 20 | This project uses [dune](http://dune.build/) as its build system. The 21 | [Makefile](./Makefile) in this repo provides shorter commands over the `dune` 22 | commands. 23 | 24 | #### Building 25 | 26 | To build the project, run `make` or `make build`. 27 | 28 | ### Running Tests 29 | 30 | `make test` will build and run the tests in the current OPAM switch. 31 | 32 | ### Cleaning up 33 | 34 | `make clean` can be used to clean up the build artifacts. 35 | 36 | ## Cutting a release 37 | 38 | ### Testing for a release 39 | 40 | Before cutting a release, it is useful to test this project against all the 41 | supported OCaml versions. `make all-supported-ocaml-versions` will do just that, 42 | but requires some setting up beforehand. The instructions are as follows: 43 | 44 | 1. The [`dune-workspace.dev`](./dune-workspace.dev) defines all the OPAM 45 | switches that will be tested when running `make 46 | all-supported-ocaml-versions`. Make sure you have switches for all those 47 | OCaml version, with the appropriate names (e.g., for the build context that 48 | `(context (opam (switch 4.07.1)))` defines, make sure you have a switch named 49 | `4.07.1`. To find out which OPAM switches you have, run `opam switch list`). 50 | 2. For every OPAM switch listed in the Dune workspace file, switch into it and 51 | run the installation command at the top of this document. 52 | 3. Finally, you can now run `make all-supported-ocaml-versions`, which will 53 | build and test this project against all those OCaml versions. 54 | 55 | ### Making a release 56 | 57 | - WIP -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2018 whitequark 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | dune build 3 | 4 | test: 5 | dune runtest 6 | 7 | doc: 8 | dune build @doc 9 | 10 | clean: 11 | dune clean 12 | 13 | .PHONY: build test doc clean 14 | 15 | VERSION := $$(opam query --version) 16 | NAME_VERSION := $$(opam query --name-version) 17 | ARCHIVE := $$(opam query --archive) 18 | 19 | release: 20 | git tag -a v$(VERSION) -m "Version $(VERSION)." 21 | git push origin v$(VERSION) 22 | opam publish prepare $(NAME_VERSION) $(ARCHIVE) 23 | opam publish submit $(NAME_VERSION) 24 | rm -rf $(NAME_VERSION) 25 | 26 | .PHONY: release all-supported-ocaml-versions 27 | 28 | all-supported-ocaml-versions: 29 | dune build @install @runtest --workspace dune-workspace.dev 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [@@deriving yojson] 2 | =================== 3 | 4 | _deriving Yojson_ is a [ppx_deriving][pd] plugin that generates 5 | [JSON][] serializers and deserializes that use the [Yojson][] library 6 | from an OCaml type definition. 7 | 8 | Sponsored by [Evil Martians](http://evilmartians.com). 9 | 10 | [pd]: https://github.com/ocaml-ppx/ppx_deriving 11 | [json]: http://tools.ietf.org/html/rfc4627 12 | [yojson]: https://github.com/ocaml-community/yojson 13 | 14 | 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. 15 | We keep maintaing `ppx_deriving_yojson` for our existing users, but we would recommend that *new projects* start from `ppx_yojson_conv` instead. 16 | 17 | Installation 18 | ------------ 19 | 20 | _deriving Yojson_ can be installed via [OPAM](https://opam.ocaml.org): 21 | 22 | $ opam install ppx_deriving_yojson 23 | 24 | Usage 25 | ----- 26 | 27 | In order to use _deriving yojson_, require the package `ppx_deriving_yojson`. 28 | 29 | If you are using dune, add `ppx_deriving_json` to the `preprocess` entry, and `ppx_deriving_json.runtime` to your requirements, like so: 30 | 31 | ``` 32 | ... 33 | (libraries yojson core ppx_deriving_yojson.runtime) 34 | (preprocess (pps ppx_deriving_yojson)) 35 | ... 36 | ``` 37 | 38 | Syntax 39 | ------ 40 | 41 | _deriving yojson_ generates two functions per type: 42 | 43 | ``` ocaml 44 | # #require "ppx_deriving_yojson";; 45 | # type ty = .. [@@deriving yojson];; 46 | val ty_of_yojson : Yojson.Safe.t -> (ty, string) Result.result 47 | val ty_to_yojson : ty -> Yojson.Safe.t 48 | ``` 49 | 50 | When the deserializing function returns Error loc, `loc` points to the point in the JSON hierarchy where the error has occurred. 51 | 52 | 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. 53 | 54 | If the type is called `t`, the functions generated are `{of,to}_yojson` instead of `t_{of,to}_yojson`. 55 | 56 | 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. 57 | 58 | Semantics 59 | --------- 60 | 61 | _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. 62 | 63 | The following table summarizes the correspondence between OCaml types and JSON values: 64 | 65 | | OCaml type | JSON value | Remarks | 66 | | ---------------------- | ---------- | -------------------------------- | 67 | | `int`, `int32`, `float`| Number | | 68 | | `int64`, `nativeint` | Number | Can exceed range of `double` | 69 | | `bool` | Boolean | | 70 | | `string`, `bytes` | String | | 71 | | `char` | String | Strictly one character in length | 72 | | `list`, `array` | Array | | 73 | | A tuple | Array | | 74 | | `ref` | 'a | | 75 | | `option` | Null or 'a | | 76 | | A record | Object | | 77 | | `Yojson.Safe.t` | any | Identity transformation | 78 | | `unit` | Null | | 79 | 80 | 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: 81 | 82 | ``` ocaml 83 | # type pvs = [ `A | `B of int | `C of int * string ] list [@@deriving yojson];; 84 | # type v = A | B of int | C of int * string [@@deriving yojson];; 85 | # type vs = v list [@@deriving yojson];; 86 | # print_endline (Yojson.Safe.to_string (vs_to_yojson [A; B 42; C (42, "foo")]));; 87 | [["A"],["B",42],["C",42,"foo"]] 88 | # print_endline (Yojson.Safe.to_string (pvs_to_yojson [`A; `B 42; `C (42, "foo")]));; 89 | [["A"],["B",42],["C",42,"foo"]] 90 | ``` 91 | 92 | Record variants are represented in the same way as if the nested structure was defined separately. For example: 93 | 94 | ```ocaml 95 | # type v = X of { v: int } [@@deriving yojson];; 96 | # print_endline (Yojson.Safe.to_string (v_to_yojson (X { v = 0 })));; 97 | ["X",{"v":0}] 98 | ``` 99 | 100 | Record variants are currently not supported for extensible variant types. 101 | 102 | 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. 103 | 104 | ### Options 105 | 106 | Option attribute names may be prefixed with `yojson.` to avoid conflicts with other derivers. 107 | 108 | #### [@key] 109 | 110 | 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.: 111 | 112 | ``` ocaml 113 | type geo = { 114 | lat : float [@key "Latitude"]; 115 | lon : float [@key "Longitude"]; 116 | } 117 | [@@deriving yojson] 118 | ``` 119 | 120 | #### [@name] 121 | 122 | If the JSON variant names differ from OCaml conventions, it is possible to specify the corresponding JSON string explicitly using [@name "constr"], e.g.: 123 | 124 | ``` ocaml 125 | type units = 126 | | Metric [@name "metric"] 127 | | Imperial [@name "imperial"] 128 | [@@deriving yojson] 129 | ``` 130 | 131 | #### [@encoding] 132 | 133 | 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. 134 | 135 | #### [@default] 136 | 137 | It is possible to specify a default value for fields that can be missing from the JSON object, e.g.: 138 | 139 | ``` ocaml 140 | type pagination = { 141 | pages : int; 142 | current : (int [@default 0]); 143 | } [@@deriving yojson] 144 | ``` 145 | 146 | Fields with default values are not required to be present in inputs and will not be emitted in outputs. 147 | 148 | #### [@to_yojson] / [@of_yojson] 149 | 150 | One can provide custom serialization or deserialization functions, either 151 | overriding the default derivation or to provide support for abstract, functor, 152 | or other types that aren't otherwise amenable to derivation (similar to the 153 | `@printer` option provided by [ppx_deriving's `show` plugin](https://github.com/ocaml-ppx/ppx_deriving#plugin-show)): 154 | 155 | ```ocaml 156 | # module StringMap = Map.Make(struct type t = string let compare = compare end);; 157 | # let yojson_of_stringmap m = StringMap.bindings m 158 | |> [%to_yojson: (string * string) list];; 159 | # type page = { number : int [@to_yojson fun i -> `Int (i + 1)] 160 | ; bounds : (int * int * int * int) 161 | ; attrs : string StringMap.t [@to_yojson yojson_of_stringmap]} 162 | [@@deriving to_yojson];; 163 | # { number = 0 164 | ; bounds = (0, 0, 792, 612) 165 | ; attrs = StringMap.add "foo" "bar" StringMap.empty } 166 | |> page_to_yojson 167 | |> Yojson.Safe.to_string 168 | |> print_endline 169 | 170 | {"number":1,"bounds":[0,0,792,612],"attrs":[["foo","bar"]]} 171 | ``` 172 | 173 | #### `Yojson_meta` module 174 | 175 | The `meta` deriver option can be used to generate a module containing all JSON key names, e.g. 176 | 177 | ```ocaml 178 | type foo = { 179 | fvalue : float; 180 | svalue : string [@key "@svalue_json"]; 181 | ivalue : int; 182 | } [@@deriving to_yojson { strict = false; meta = true } ] 183 | end 184 | ``` 185 | 186 | defines the following module: 187 | 188 | ```ocaml 189 | module Yojson_meta_foo = struct 190 | let keys = ["fvalue"; "@svalue_json"; "ivalue"] 191 | let _ = keys 192 | end 193 | ``` 194 | 195 | When the type is named `t`, the module is named just `Yojson_meta`. 196 | 197 | License 198 | ------- 199 | 200 | _deriving yojson_ is distributed under the terms of [MIT license](LICENSE.txt). 201 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name ppx_deriving_yojson) 3 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.2) 2 | ;; This file is used by `make all-supported-ocaml-versions` 3 | (context (opam (switch 4.04.2))) 4 | (context (opam (switch 4.05.0))) 5 | (context (opam (switch 4.06.1))) 6 | (context (opam (switch 4.07.1))) 7 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #use "topfind" 2 | #require "topkg-jbuilder.auto" 3 | -------------------------------------------------------------------------------- /ppx_deriving_yojson.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "whitequark " 3 | authors: [ "whitequark " ] 4 | license: "MIT" 5 | homepage: "https://github.com/ocaml-ppx/ppx_deriving_yojson" 6 | bug-reports: "https://github.com/ocaml-ppx/ppx_deriving_yojson/issues" 7 | dev-repo: "git+https://github.com/ocaml-ppx/ppx_deriving_yojson.git" 8 | tags: [ "syntax" "json" ] 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 13 | ] 14 | depends: [ 15 | "ocaml" {>= "4.05.0"} 16 | "dune" {>= "1.0"} 17 | "yojson" {>= "1.6.0"} 18 | "ppx_deriving" {>= "6.1"} 19 | "ppxlib" {>= "0.36.0"} 20 | "ounit2" {with-test} 21 | ] 22 | synopsis: 23 | "JSON codec generator for OCaml" 24 | description: """ 25 | ppx_deriving_yojson is a ppx_deriving plugin that provides 26 | a JSON codec generator. 27 | """ 28 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_deriving_yojson_runtime) 3 | (public_name ppx_deriving_yojson.runtime) 4 | (synopsis "Runtime components of [@@deriving yojson]") 5 | (modules ppx_deriving_yojson_runtime) 6 | (libraries ppx_deriving.runtime)) 7 | 8 | (library 9 | (name ppx_deriving_yojson) 10 | (public_name ppx_deriving_yojson) 11 | (synopsis "[@@deriving yojson]") 12 | (libraries ppxlib ppx_deriving.api) 13 | (preprocess (pps ppxlib.metaquot)) 14 | (ppx_runtime_libraries ppx_deriving_yojson_runtime yojson) 15 | (modules ppx_deriving_yojson) 16 | (kind ppx_deriver) 17 | (flags (:standard -w -9))) 18 | -------------------------------------------------------------------------------- /src/ppx_deriving_yojson.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_helper 3 | 4 | module Ast_builder_default_loc = struct 5 | include Ppx_deriving.Ast_convenience 6 | 7 | let gen_def_loc f x = 8 | let loc = !Ast_helper.default_loc in 9 | f ~loc x 10 | 11 | let lid = gen_def_loc Ast_builder.Default.Located.lident 12 | let list = gen_def_loc Ast_builder.Default.elist 13 | let pstr = gen_def_loc Ast_builder.Default.pstring 14 | let plist = gen_def_loc Ast_builder.Default.plist 15 | let lam = gen_def_loc Ast_builder.Default.pexp_fun Nolabel None 16 | end 17 | 18 | open Ast_builder_default_loc 19 | 20 | let disable_warning_39 () = 21 | let loc = !Ast_helper.default_loc in 22 | let name = { txt = "ocaml.warning"; loc } in 23 | Ast_helper.Attr.mk ~loc name (PStr [%str "-39"]) 24 | 25 | 26 | let mod_mknoloc x = mknoloc (Some x) 27 | 28 | let deriver = "yojson" 29 | let raise_errorf = Ppx_deriving.raise_errorf 30 | 31 | let argn = Printf.sprintf "arg%d" 32 | let ct_attr_int_encoding = Attribute.declare "deriving.yojson.encoding" Attribute.Context.core_type 33 | Ast_pattern.(single_expr_payload (pexp_variant (map0 (string "string") ~f:`String) (none) ||| pexp_variant (map0 (string "number") ~f:`Int) (none))) (fun enc -> enc) 34 | 35 | let label_attr_key = Attribute.declare "deriving.yojson.key" Attribute.Context.label_declaration 36 | Ast_pattern.(single_expr_payload (estring __)) (fun s -> s) 37 | let attr_name context = Attribute.declare "deriving.yojson.name" context 38 | Ast_pattern.(single_expr_payload (estring __)) (fun s -> s) 39 | let rtag_attr_name = attr_name Attribute.Context.rtag 40 | let constr_attr_name = attr_name Attribute.Context.constructor_declaration 41 | let ext_attr_name = attr_name Attribute.Context.extension_constructor 42 | 43 | let ct_attr_ser = Attribute.declare "deriving.yojson.to_yojson" Attribute.Context.core_type 44 | Ast_pattern.(single_expr_payload __) (fun e -> e) 45 | let ct_attr_desu = Attribute.declare "deriving.yojson.of_yojson" Attribute.Context.core_type 46 | Ast_pattern.(single_expr_payload __) (fun e -> e) 47 | 48 | let attr_default context = Attribute.declare "deriving.yojson.default" context 49 | Ast_pattern.(single_expr_payload __) (fun e -> e) 50 | let attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type) 51 | 52 | let get_label_attribute (label_attr, ct_attr) label = 53 | match Attribute.get label_attr label with 54 | | Some _ as v -> v 55 | | None -> Attribute.get ct_attr label.pld_type 56 | 57 | type options = { 58 | is_strict: bool; 59 | want_meta: bool; 60 | want_exn: bool; 61 | } 62 | 63 | let args () = Deriving.Args.(empty +> arg "strict" (ebool __) +> arg "meta" (ebool __) +> arg "exn" (ebool __)) 64 | 65 | let poly_fun names expr = 66 | List.fold_right (fun name expr -> 67 | let loc = name.Location.loc in 68 | let name = name.Location.txt in 69 | [%expr fun [%p pvar ("poly_"^name)] -> [%e expr]] 70 | ) names expr 71 | 72 | let type_add_attrs typ attributes = 73 | { typ with ptyp_attributes = typ.ptyp_attributes @ attributes } 74 | 75 | let rec ser_expr_of_typ ~quoter typ = 76 | match Attribute.get ct_attr_ser typ with 77 | | Some e -> Ppx_deriving.quote ~quoter e 78 | | None -> ser_expr_of_only_typ ~quoter typ 79 | and ser_expr_of_only_typ ~quoter typ = 80 | let loc = typ.ptyp_loc in 81 | let attr_int_encoding typ = 82 | match Attribute.get ct_attr_int_encoding typ with Some `String -> "String" | Some `Int | None -> "Intlit" 83 | in 84 | let ser_expr_of_typ = ser_expr_of_typ ~quoter in 85 | match typ with 86 | | [%type: unit] -> [%expr fun (x:Ppx_deriving_runtime.unit) -> `Null] 87 | | [%type: int] -> [%expr fun (x:Ppx_deriving_runtime.int) -> `Int x] 88 | | [%type: float] -> [%expr fun (x:Ppx_deriving_runtime.float) -> `Float x] 89 | | [%type: bool] -> [%expr fun (x:Ppx_deriving_runtime.bool) -> `Bool x] 90 | | [%type: string] -> [%expr fun (x:Ppx_deriving_runtime.string) -> `String x] 91 | | [%type: bytes] -> [%expr fun x -> `String (Bytes.to_string x)] 92 | | [%type: char] -> [%expr fun x -> `String (String.make 1 x)] 93 | | [%type: [%t? typ] ref] -> [%expr fun x -> [%e ser_expr_of_typ typ] !x] 94 | | [%type: [%t? typ] list] -> [%expr fun x -> `List (safe_map [%e ser_expr_of_typ typ] x)] 95 | | [%type: int32] | [%type: Int32.t] -> 96 | [%expr fun x -> `Intlit (Int32.to_string x)] 97 | | [%type: int64] | [%type: Int64.t] -> 98 | [%expr fun x -> [%e Exp.variant (attr_int_encoding typ) 99 | (Some [%expr (Int64.to_string x)])]] 100 | | [%type: nativeint] | [%type: Nativeint.t] -> 101 | [%expr fun x -> [%e Exp.variant (attr_int_encoding typ) 102 | (Some [%expr (Nativeint.to_string x)])]] 103 | | [%type: [%t? typ] array] -> 104 | [%expr fun x -> `List (Array.to_list (Array.map [%e ser_expr_of_typ typ] x))] 105 | | [%type: [%t? typ] option] -> 106 | [%expr function None -> `Null | Some x -> [%e ser_expr_of_typ typ] x] 107 | | [%type: Yojson.Safe.json] 108 | | [%type: Yojson.Safe.t] -> [%expr fun x -> x] 109 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> 110 | let ser_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "to_yojson") lid)) in 111 | let fwd = app (Ppx_deriving.quote ~quoter ser_fn) (List.map ser_expr_of_typ args) in 112 | (* eta-expansion is necessary for let-rec *) 113 | [%expr fun x -> [%e fwd] x] 114 | 115 | | { ptyp_desc = Ptyp_tuple typs } -> 116 | [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> 117 | `List ([%e 118 | list (List.mapi (fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])]; 119 | | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> 120 | let cases = 121 | fields |> List.map (fun (field: row_field) -> 122 | match field.prf_desc with 123 | | Rtag(label, true (*empty*), []) -> 124 | let label = label.txt in 125 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 126 | Exp.case (Pat.variant label None) 127 | [%expr `List [`String [%e str name]]] 128 | | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> 129 | let label = label.txt in 130 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 131 | Exp.case (Pat.variant label (Some (ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)))) 132 | [%expr `List ((`String [%e str name]) :: [%e 133 | list (List.mapi 134 | (fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])] 135 | | Rtag(label, false, [typ]) -> 136 | let label = label.txt in 137 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 138 | Exp.case (Pat.variant label (Some [%pat? x])) 139 | [%expr `List [`String [%e str name]; 140 | [%e ser_expr_of_typ typ] x]] 141 | | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> 142 | Exp.case [%pat? [%p Pat.type_ tname] as x] 143 | [%expr [%e ser_expr_of_typ typ] x] 144 | | _ -> 145 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 146 | deriver (Ppx_deriving.string_of_core_type typ)) 147 | in 148 | Exp.function_ cases 149 | | { ptyp_desc = Ptyp_var name } -> [%expr ([%e evar ("poly_"^name)] : _ -> Yojson.Safe.t)] 150 | | { ptyp_desc = Ptyp_alias (typ, name) } -> 151 | [%expr fun x -> [%e evar ("poly_"^name.txt)] x; [%e ser_expr_of_typ typ] x] 152 | | { ptyp_desc = Ptyp_poly (names, typ) } -> 153 | poly_fun names (ser_expr_of_typ typ) 154 | | { ptyp_loc } -> 155 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 156 | deriver (Ppx_deriving.string_of_core_type typ) 157 | 158 | (* http://desuchan.net/desu/src/1284751839295.jpg *) 159 | let rec desu_fold ~quoter ~loc ~path f typs = 160 | typs |> 161 | List.mapi (fun i typ -> i, app (desu_expr_of_typ ~quoter ~path typ) [evar (argn i)]) |> 162 | List.fold_left (fun x (i, y) -> 163 | let loc = x.pexp_loc in 164 | [%expr [%e y] >>= fun [%p pvar (argn i)] -> [%e x]]) 165 | [%expr Ok [%e f (List.mapi (fun i _ -> evar (argn i)) typs)]] 166 | and desu_expr_of_typ ~quoter ~path typ = 167 | match Attribute.get ct_attr_desu typ with 168 | | Some e -> Ppx_deriving.quote ~quoter e 169 | | None -> desu_expr_of_only_typ ~quoter ~path typ 170 | and desu_expr_of_only_typ ~quoter ~path typ = 171 | let loc = typ.ptyp_loc in 172 | let error = [%expr Error [%e str (String.concat "." path)]] in 173 | let decode' cases = 174 | Exp.function_ ( 175 | List.map (fun (pat, exp) -> Exp.case pat exp) cases @ 176 | [Exp.case [%pat? _] error]) 177 | in 178 | let decode pat exp = decode' [pat, exp] in 179 | let desu_expr_of_typ = desu_expr_of_typ ~quoter in 180 | match typ with 181 | | [%type: unit] -> decode [%pat? `Null] [%expr Ok ()] 182 | | [%type: int] -> decode [%pat? `Int x] [%expr Ok x] 183 | | [%type: float] -> 184 | decode' [[%pat? `Int x], [%expr Ok (float_of_int x)]; 185 | [%pat? `Intlit x], [%expr Ok (float_of_string x)]; 186 | [%pat? `Float x], [%expr Ok x]] 187 | | [%type: bool] -> decode [%pat? `Bool x] [%expr Ok x] 188 | | [%type: string] -> decode [%pat? `String x] [%expr Ok x] 189 | | [%type: bytes] -> decode [%pat? `String x] [%expr Ok (Bytes.of_string x)] 190 | | [%type: char] -> 191 | decode [%pat? `String x] [%expr if String.length x = 1 then Ok x.[0] else [%e error]] 192 | | [%type: int32] | [%type: Int32.t] -> 193 | decode' [[%pat? `Int x], [%expr Ok (Int32.of_int x)]; 194 | [%pat? `Intlit x], [%expr Ok (Int32.of_string x)]] 195 | | [%type: int64] | [%type: Int64.t] -> 196 | begin match Attribute.get ct_attr_int_encoding typ with 197 | | Some `String -> 198 | decode [%pat? `String x] [%expr Ok (Int64.of_string x)] 199 | | Some `Int | None -> 200 | decode' [[%pat? `Int x], [%expr Ok (Int64.of_int x)]; 201 | [%pat? `Intlit x], [%expr Ok (Int64.of_string x)]] 202 | end 203 | | [%type: nativeint] | [%type: Nativeint.t] -> 204 | begin match Attribute.get ct_attr_int_encoding typ with 205 | | Some `String -> 206 | decode [%pat? `String x] [%expr Ok (Nativeint.of_string x)] 207 | | Some `Int | None -> 208 | decode' [[%pat? `Int x], [%expr Ok (Nativeint.of_int x)]; 209 | [%pat? `Intlit x], [%expr Ok (Nativeint.of_string x)]] 210 | end 211 | | [%type: [%t? typ] ref] -> 212 | [%expr fun x -> [%e desu_expr_of_typ ~path:(path @ ["contents"]) typ] x >|= ref] 213 | | [%type: [%t? typ] option] -> 214 | [%expr function 215 | | `Null -> Ok None 216 | | x -> [%e desu_expr_of_typ ~path typ] x >>= fun x -> Ok (Some x)] 217 | | [%type: [%t? typ] list] -> 218 | decode [%pat? `List xs] 219 | [%expr map_bind [%e desu_expr_of_typ ~path typ] [] xs] 220 | | [%type: [%t? typ] array] -> 221 | decode [%pat? `List xs] 222 | [%expr map_bind [%e desu_expr_of_typ ~path typ] [] xs >|= Array.of_list] 223 | | [%type: Yojson.Safe.t] 224 | | [%type: Yojson.Safe.json] -> [%expr fun x -> Ok x] 225 | | { ptyp_desc = Ptyp_tuple typs } -> 226 | decode [%pat? `List [%p plist (List.mapi (fun i _ -> pvar (argn i)) typs)]] 227 | (desu_fold ~quoter ~loc ~path tuple typs) 228 | | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> 229 | let inherits, tags = List.partition (fun field -> 230 | match field.prf_desc with 231 | Rinherit _ -> true 232 | | _ -> false) fields 233 | in 234 | let tag_cases = tags |> List.map (fun field -> 235 | match field.prf_desc with 236 | | Rtag(label, true (*empty*), []) -> 237 | let label = label.txt in 238 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 239 | Exp.case [%pat? `List [`String [%p pstr name]]] 240 | [%expr Ok [%e Exp.variant label None]] 241 | | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> 242 | let label = label.txt in 243 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 244 | Exp.case [%pat? `List ((`String [%p pstr name]) :: [%p 245 | plist (List.mapi (fun i _ -> pvar (argn i)) typs)])] 246 | (desu_fold ~quoter ~loc ~path (fun x -> (Exp.variant label (Some (tuple x)))) typs) 247 | | Rtag(label, false, [typ]) -> 248 | let label = label.txt in 249 | let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in 250 | Exp.case [%pat? `List [`String [%p pstr name]; x]] 251 | [%expr [%e desu_expr_of_typ ~path typ] x >>= fun x -> 252 | Ok [%e Exp.variant label (Some [%expr x])]] 253 | | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> 254 | Exp.case [%pat? [%p Pat.type_ tname] as x] 255 | [%expr [%e desu_expr_of_typ ~path typ] x] 256 | | _ -> 257 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 258 | deriver (Ppx_deriving.string_of_core_type typ)) 259 | and inherits_case = 260 | let toplevel_typ = typ in 261 | inherits 262 | |> List.map (fun field -> 263 | match field.prf_desc with 264 | | Rinherit typ -> typ 265 | | _ -> assert false) 266 | |> List.fold_left (fun expr typ -> [%expr 267 | match [%e desu_expr_of_typ ~path typ] json with 268 | | (Ok result) -> Ok (result :> [%t toplevel_typ]) 269 | | Error _ -> [%e expr]]) error 270 | |> Exp.case [%pat? _] 271 | in 272 | [%expr fun (json : Yojson.Safe.t) -> 273 | [%e Exp.match_ [%expr json] (tag_cases @ [inherits_case])]] 274 | | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> 275 | let desu_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Suffix "of_yojson") lid)) in 276 | let fwd = app (Ppx_deriving.quote ~quoter desu_fn) (List.map (desu_expr_of_typ ~path) args) in 277 | (* eta-expansion is necessary for recursive groups *) 278 | [%expr fun x -> [%e fwd] x] 279 | | { ptyp_desc = Ptyp_var name } -> 280 | [%expr ([%e evar ("poly_"^name)] : Yojson.Safe.t -> _ error_or)] 281 | | { ptyp_desc = Ptyp_alias (typ, name) } -> 282 | [%expr fun x -> [%e evar ("poly_"^name.txt)] x; [%e desu_expr_of_typ ~path typ] x] 283 | | { ptyp_desc = Ptyp_poly (names, typ) } -> 284 | poly_fun names (desu_expr_of_typ ~path typ) 285 | | { ptyp_loc } -> 286 | raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" 287 | deriver (Ppx_deriving.string_of_core_type typ) 288 | 289 | let sanitize ~quoter decls = 290 | Ppx_deriving.sanitize ~quoter ~module_:(Lident "Ppx_deriving_yojson_runtime") decls 291 | 292 | let ser_type_of_decl ~options:_ ~path:_ type_decl = 293 | let loc = type_decl.ptype_loc in 294 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 295 | let polymorphize = Ppx_deriving.poly_arrow_of_type_decl 296 | (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl in 297 | polymorphize [%type: [%t typ] -> Yojson.Safe.t] 298 | 299 | let ser_str_of_record ~quoter ~loc varname labels = 300 | let fields = 301 | labels |> List.mapi (fun _i ({ pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } as label) -> 302 | let field = Exp.field (evar varname) (mknoloc (Lident name)) in 303 | let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in 304 | let result = [%expr [%e str key], 305 | [%e ser_expr_of_typ ~quoter @@ type_add_attrs pld_type pld_attributes] [%e field]] in 306 | match get_label_attribute attr_default label with 307 | | None -> 308 | [%expr [%e result] :: fields] 309 | | Some default -> 310 | let default = [%expr ([%e default] : [%t pld_type])] in 311 | [%expr if [%e field] = [%e Ppx_deriving.quote ~quoter default] then fields else [%e result] :: fields]) 312 | in 313 | let assoc = 314 | List.fold_left 315 | (fun expr field -> 316 | let loc = expr.pexp_loc in 317 | [%expr let fields = [%e field] in [%e expr]]) 318 | [%expr `Assoc fields] fields 319 | in 320 | [%expr let fields = [] in [%e assoc]] 321 | 322 | let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 323 | let quoter = Ppx_deriving.create_quoter () in 324 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 325 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 326 | match type_decl.ptype_kind with 327 | | Ptype_open -> begin 328 | let to_yojson_name = Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl in 329 | let mod_name = Ppx_deriving.mangle_type_decl 330 | (`PrefixSuffix ("M", "to_yojson")) type_decl 331 | in 332 | match type_decl.ptype_manifest with 333 | | Some ({ ptyp_desc = Ptyp_constr ({ txt = lid }, _args) } as manifest) -> 334 | let ser = ser_expr_of_typ ~quoter manifest in 335 | let lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "to_yojson")) lid in 336 | let orig_mod = Mod.ident (mknoloc lid) in 337 | let poly_ser = polymorphize [%expr ([%e sanitize ~quoter ser] : [%t typ] -> Yojson.Safe.t)] in 338 | ([Str.module_ (Mb.mk (mod_mknoloc mod_name) orig_mod)], 339 | [Vb.mk (pvar to_yojson_name) poly_ser], 340 | []) 341 | | Some _ -> 342 | raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver 343 | | None -> 344 | let poly_vars = List.rev 345 | (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) 346 | in 347 | let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl 348 | (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl 349 | in 350 | let mono_ty = [%type: [%t typ] -> Yojson.Safe.t] in 351 | let ty = 352 | Ast_builder.Default.ptyp_poly ~loc poly_vars (polymorphize_ser mono_ty) 353 | in 354 | let default_fun = 355 | let type_path = String.concat "." (path @ [type_decl.ptype_name.txt]) in 356 | let e_type_path = Ast_builder.Default.estring ~loc:Location.none type_path in 357 | [%expr fun _ -> 358 | invalid_arg ("to_yojson: Maybe a [@@deriving yojson] is missing when extending the type "^ 359 | [%e e_type_path])] 360 | in 361 | let poly_fun = polymorphize default_fun in 362 | let poly_fun = 363 | (Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl) 364 | in 365 | let mod_name = "M_"^to_yojson_name in 366 | let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) 367 | (mknoloc "t_to_yojson") 368 | in 369 | let record = Vb.mk (pvar "f") (Exp.record [lid "f", poly_fun] None) in 370 | let flid = lid (Printf.sprintf "%s.f" mod_name) in 371 | let field = Exp.field (Exp.ident flid) (flid) in 372 | let mod_ = 373 | Str.module_ (Mb.mk (mod_mknoloc mod_name) 374 | (Mod.structure [ 375 | Str.type_ Nonrecursive [typ]; 376 | Str.value Nonrecursive [record]; 377 | ])) 378 | in 379 | ([mod_], 380 | [Vb.mk (pvar to_yojson_name) [%expr fun x -> [%e field] x]], 381 | []) 382 | end 383 | | kind -> 384 | let serializer = 385 | match kind, type_decl.ptype_manifest with 386 | | Ptype_open, _ -> assert false 387 | | Ptype_abstract, Some manifest -> ser_expr_of_typ ~quoter manifest 388 | | Ptype_variant constrs, _ -> 389 | constrs 390 | |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; _ } as constr) -> 391 | let json_name = match Attribute.get constr_attr_name constr with Some s -> s | None -> name' in 392 | match pcd_args with 393 | | Pcstr_tuple([]) -> 394 | Exp.case 395 | (pconstr name' []) 396 | [%expr `List [`String [%e str json_name]]] 397 | | Pcstr_tuple(args) -> 398 | let arg_exprs = 399 | List.mapi (fun i typ -> app (ser_expr_of_typ ~quoter typ) [evar (argn i)]) args 400 | in 401 | Exp.case 402 | (pconstr name' (List.mapi (fun i _ -> pvar (argn i)) args)) 403 | [%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])] 404 | | Pcstr_record labels -> 405 | let arg_expr = ser_str_of_record ~quoter ~loc (argn 0) labels in 406 | Exp.case 407 | (pconstr name' [pvar(argn 0)]) 408 | [%expr `List ((`String [%e str json_name]) :: [%e list[arg_expr]])] 409 | ) 410 | |> Exp.function_ 411 | | Ptype_record labels, _ -> 412 | [%expr fun x -> [%e ser_str_of_record ~quoter ~loc "x" labels]] 413 | | Ptype_abstract, None -> 414 | raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver 415 | in 416 | let ty = ser_type_of_decl ~options ~path type_decl in 417 | let fv = Ppx_deriving.free_vars_in_core_type ty in 418 | let poly_type = Ast_builder.Default.ptyp_poly ~loc fv ty in 419 | let var_s = Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl in 420 | let var = pvar var_s in 421 | ([], 422 | [Vb.mk 423 | ~attrs:[disable_warning_39 ()] 424 | (Pat.constraint_ var poly_type) 425 | (polymorphize [%expr ([%e sanitize ~quoter serializer])])], 426 | [Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s]]] ] 427 | ) 428 | 429 | let ser_str_of_type_ext ~options:_ ~path:_ ({ ptyext_path = { loc }} as type_ext) = 430 | let quoter = Ppx_deriving.create_quoter () in 431 | let serializer = 432 | let pats = 433 | List.fold_right (fun ({ pext_name = { txt = name' }; pext_kind; _ } as ext) acc_cases -> 434 | match pext_kind with 435 | | Pext_rebind _ -> 436 | (* nothing to do, since the constructor must be handled in original 437 | constructor declaration *) 438 | acc_cases 439 | | Pext_decl (_, pext_args, _) -> 440 | let json_name = match Attribute.get ext_attr_name ext with Some s -> s | None -> name' in 441 | let case = 442 | match pext_args with 443 | | Pcstr_tuple([]) -> 444 | Exp.case 445 | (pconstr name' []) 446 | [%expr `List [`String [%e str json_name]]] 447 | | Pcstr_tuple(args) -> 448 | let arg_exprs = 449 | List.mapi (fun i typ -> app (ser_expr_of_typ ~quoter typ) [evar (argn i)]) args 450 | in 451 | Exp.case 452 | (pconstr name' (List.mapi (fun i _ -> pvar (argn i)) args)) 453 | [%expr `List ((`String [%e str json_name]) :: [%e list arg_exprs])] 454 | | Pcstr_record _ -> 455 | raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver 456 | in 457 | case :: acc_cases) type_ext.ptyext_constructors [] 458 | in 459 | let fallback_case = 460 | Exp.case [%pat? x] 461 | [%expr [%e Ppx_deriving.poly_apply_of_type_ext type_ext [%expr fallback]] x] 462 | in 463 | Exp.function_ (pats @ [fallback_case]) 464 | in 465 | let mod_name = 466 | let mod_lid = 467 | Ppx_deriving.mangle_lid 468 | (`PrefixSuffix ("M", "to_yojson")) type_ext.ptyext_path.txt 469 | in 470 | Longident.name mod_lid 471 | in 472 | let polymorphize = Ppx_deriving.poly_fun_of_type_ext type_ext in 473 | let serializer = polymorphize (sanitize ~quoter serializer) in 474 | let flid = lid (Printf.sprintf "%s.f" mod_name) in 475 | let set_field = Exp.setfield (Exp.ident flid) flid serializer in 476 | let field = Exp.field (Exp.ident flid) (flid) in 477 | let body = [%expr let fallback = [%e field] in [%e set_field]] in 478 | [Str.value ?loc:None Nonrecursive [Vb.mk (Pat.construct (lid "()") None) body]] 479 | 480 | let error_or typ = 481 | let loc = typ.ptyp_loc in 482 | [%type: [%t typ] Ppx_deriving_yojson_runtime.error_or] 483 | 484 | let desu_type_of_decl_poly ~options:_ ~path:_ type_decl type_ = 485 | let loc = type_decl.ptype_loc in 486 | let polymorphize = Ppx_deriving.poly_arrow_of_type_decl 487 | (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in 488 | polymorphize type_ 489 | 490 | let desu_type_of_decl ~options ~path type_decl = 491 | let loc = type_decl.ptype_loc in 492 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 493 | desu_type_of_decl_poly ~options ~path type_decl [%type: Yojson.Safe.t -> [%t error_or typ]] 494 | 495 | 496 | let desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels = 497 | let top_error = error path in 498 | let record = 499 | List.fold_left 500 | (fun expr i -> 501 | let loc = expr.pexp_loc in 502 | [%expr [%e evar (argn i)] >>= fun [%p pvar (argn i)] -> [%e expr]] 503 | ) 504 | ( let r = 505 | Exp.record (labels |> 506 | List.mapi (fun i { pld_name = { txt = name } } -> 507 | mknoloc (Lident name), evar (argn i))) 508 | None in 509 | [%expr Ok [%e wrap_record r] ] ) 510 | (labels |> List.mapi (fun i _ -> i)) in 511 | let default_case = if is_strict then top_error else [%expr loop xs _state] in 512 | let cases = 513 | (labels |> List.mapi (fun i ({ pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } as label) -> 514 | let path = path @ [name] in 515 | let thunks = labels |> List.mapi (fun j _ -> 516 | if i = j 517 | then app (desu_expr_of_typ ~quoter ~path @@ type_add_attrs pld_type pld_attributes) [evar "x"] 518 | else evar (argn j)) in 519 | let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in 520 | Exp.case [%pat? ([%p pstr key], x) :: xs] 521 | [%expr loop xs [%e tuple thunks]])) @ 522 | [Exp.case [%pat? []] record; 523 | Exp.case [%pat? _ :: xs] default_case] 524 | and thunks = 525 | labels |> List.map (fun ({ pld_name = { txt = name }; pld_type; _ } as label) -> 526 | match get_label_attribute attr_default label with 527 | | None -> error (path @ [name]) 528 | | Some default -> 529 | let default = [%expr ([%e default] : [%t pld_type])] in 530 | [%expr Ok [%e Ppx_deriving.quote ~quoter default]]) 531 | in 532 | [%expr 533 | function 534 | | `Assoc xs -> 535 | let rec loop xs ([%p ptuple (List.mapi (fun i _ -> pvar (argn i)) labels)] as _state) = 536 | [%e Exp.match_ [%expr xs] cases] 537 | in loop xs [%e tuple thunks] 538 | | _ -> [%e top_error]] 539 | 540 | 541 | let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 542 | let { is_strict; want_exn; _ } = options in 543 | let quoter = Ppx_deriving.create_quoter () in 544 | let path = path @ [type_decl.ptype_name.txt] in 545 | let error path = [%expr Error [%e str (String.concat "." path)]] in 546 | let top_error = error path in 547 | let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in 548 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 549 | match type_decl.ptype_kind with 550 | | Ptype_open -> begin 551 | let of_yojson_name = Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl in 552 | let mod_name = Ppx_deriving.mangle_type_decl 553 | (`PrefixSuffix ("M", "of_yojson")) type_decl 554 | in 555 | match type_decl.ptype_manifest with 556 | | Some ({ ptyp_desc = Ptyp_constr ({ txt = lid }, _args) } as manifest) -> 557 | let desu = desu_expr_of_typ ~quoter ~path manifest in 558 | let lid = Ppx_deriving.mangle_lid (`PrefixSuffix ("M", "of_yojson")) lid in 559 | let orig_mod = Mod.ident (mknoloc lid) in 560 | let poly_desu = polymorphize [%expr ([%e sanitize ~quoter desu] : Yojson.Safe.t -> _)] in 561 | ([Str.module_ (Mb.mk (mod_mknoloc mod_name) orig_mod)], 562 | [Vb.mk (pvar of_yojson_name) poly_desu], 563 | []) 564 | | Some _ -> 565 | raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver 566 | | None -> 567 | let poly_vars = List.rev 568 | (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) 569 | in 570 | let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl 571 | (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in 572 | let mono_ty = [%type: Yojson.Safe.t -> [%t error_or typ]] in 573 | let ty = 574 | Ast_builder.Default.ptyp_poly ~loc poly_vars (polymorphize_desu mono_ty) 575 | in 576 | let default_fun = Exp.function_ [Exp.case [%pat? _] top_error] in 577 | let poly_fun = polymorphize default_fun in 578 | let poly_fun = 579 | (Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl) 580 | in 581 | let mod_name = "M_"^of_yojson_name in 582 | let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty]) 583 | (mknoloc "t_of_yojson") in 584 | let record = Vb.mk (pvar "f") (Exp.record [lid "f", poly_fun] None) in 585 | let flid = lid (Printf.sprintf "%s.f" mod_name) in 586 | let field = Exp.field (Exp.ident flid) flid in 587 | let mod_ = 588 | Str.module_ (Mb.mk (mod_mknoloc mod_name) 589 | (Mod.structure [ 590 | Str.type_ Nonrecursive [typ]; 591 | Str.value Nonrecursive [record]; 592 | ])) 593 | in 594 | ([mod_], 595 | [Vb.mk (pvar of_yojson_name) [%expr fun x -> [%e field] x]], 596 | []) 597 | end 598 | | kind -> 599 | let desurializer = 600 | match kind, type_decl.ptype_manifest with 601 | | Ptype_open, _ -> assert false 602 | | Ptype_abstract, Some manifest -> 603 | desu_expr_of_typ ~quoter ~path manifest 604 | | Ptype_variant constrs, _ -> 605 | let cases = List.map (fun ({ pcd_loc = loc; pcd_name = { txt = name' }; pcd_args; _ } as constr') -> 606 | match pcd_args with 607 | | Pcstr_tuple(args) -> 608 | let name = match Attribute.get constr_attr_name constr' with Some s -> s | None -> name' in 609 | Exp.case 610 | [%pat? `List ((`String [%p pstr name]) :: 611 | [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] 612 | (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) 613 | | Pcstr_record labels -> 614 | let wrap_record r = constr name' [r] in 615 | let sub = 616 | desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels in 617 | let name = match Attribute.get constr_attr_name constr' with Some s -> s | None -> name' in 618 | Exp.case 619 | [%pat? `List ((`String [%p pstr name]) :: 620 | [%p plist [pvar (argn 0)]])] 621 | [%expr [%e sub] [%e evar (argn 0)] ] 622 | ) constrs 623 | in 624 | Exp.function_ (cases @ [Exp.case [%pat? _] top_error]) 625 | | Ptype_record labels, _ -> 626 | desu_str_of_record ~quoter ~loc ~is_strict ~error ~path (fun r -> r) labels 627 | | Ptype_abstract, None -> 628 | raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver 629 | in 630 | let ty = desu_type_of_decl ~options ~path type_decl in 631 | let fv = Ppx_deriving.free_vars_in_core_type ty in 632 | let poly_type = Ast_builder.Default.ptyp_poly ~loc fv ty in 633 | let var_s = Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl in 634 | let var = pvar var_s in 635 | let var_s_exn = var_s ^ "_exn" in 636 | let { ptype_params; _ } = type_decl in 637 | let var_s_exn_args = List.mapi (fun i _ -> argn i |> evar) ptype_params in 638 | let var_s_exn_args = var_s_exn_args @ [evar "x"] in 639 | let var_s_exn_fun = 640 | let rec loop = function 641 | | [] -> sanitize ~quoter ([%expr match [%e app (evar var_s) var_s_exn_args] with Ok x -> x | Error err -> raise (Failure err)]) 642 | | hd::tl -> lam (pvar hd) (loop tl) 643 | in 644 | loop ((List.mapi (fun i _ -> argn i) ptype_params) @ ["x"]) 645 | in 646 | ([], 647 | [Vb.mk ~attrs:[disable_warning_39 ()] 648 | (Pat.constraint_ var poly_type) 649 | (polymorphize [%expr ([%e sanitize ~quoter desurializer])]) ], 650 | [Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s]]]] 651 | @ 652 | (if not want_exn then [] 653 | else 654 | [Str.value Nonrecursive [Vb.mk (pvar var_s_exn) var_s_exn_fun] 655 | ;Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s_exn]]]]) 656 | ) 657 | 658 | let desu_str_of_type_ext ~options:_ ~path ({ ptyext_path = { loc } } as type_ext) = 659 | let quoter = Ppx_deriving.create_quoter () in 660 | let desurializer = 661 | let pats = 662 | List.fold_right (fun ({ pext_name = { txt = name' }; pext_kind; _ } as ext) acc_cases -> 663 | match pext_kind with 664 | | Pext_rebind _ -> 665 | (* nothing to do since it must have been handled in the original 666 | constructor declaration *) 667 | acc_cases 668 | | Pext_decl (_, pext_args, _) -> 669 | let case = 670 | match pext_args with 671 | | Pcstr_tuple(args) -> 672 | let name = match Attribute.get ext_attr_name ext with Some s -> s | None -> name' in 673 | Exp.case 674 | [%pat? `List ((`String [%p pstr name]) :: 675 | [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] 676 | (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) 677 | | Pcstr_record _ -> 678 | raise_errorf ~loc "%s: record variants are not supported in extensible types" deriver 679 | in 680 | case :: acc_cases) 681 | type_ext.ptyext_constructors [] 682 | in 683 | let any_case = Exp.case (Pat.var (mknoloc "x")) 684 | (app (Ppx_deriving.poly_apply_of_type_ext type_ext [%expr fallback]) 685 | [[%expr x]]) 686 | in 687 | (pats @ [any_case]) |> Exp.function_ 688 | in 689 | let mod_name = 690 | let mod_lid = 691 | Ppx_deriving.mangle_lid 692 | (`PrefixSuffix ("M", "of_yojson")) type_ext.ptyext_path.txt 693 | in 694 | Longident.name mod_lid 695 | in 696 | let polymorphize = Ppx_deriving.poly_fun_of_type_ext type_ext in 697 | let desurializer = sanitize ~quoter (polymorphize desurializer) in 698 | let flid = lid (Printf.sprintf "%s.f" mod_name) in 699 | let set_field = Exp.setfield (Exp.ident flid) flid desurializer in 700 | let field = Exp.field (Exp.ident flid) flid in 701 | let body = [%expr let fallback = [%e field] in [%e set_field]] in 702 | [Str.value ?loc:None Nonrecursive [Vb.mk (Pat.construct (lid "()") None) body]] 703 | 704 | let ser_sig_of_type ~options ~path type_decl = 705 | let to_yojson = 706 | Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl)) 707 | (ser_type_of_decl ~options ~path type_decl)) 708 | in 709 | match type_decl.ptype_kind with 710 | | Ptype_open -> 711 | let mod_name = Ppx_deriving.mangle_type_decl 712 | (`PrefixSuffix ("M", "to_yojson")) type_decl 713 | in 714 | let poly_vars = List.rev 715 | (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) 716 | in 717 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 718 | let loc = typ.ptyp_loc in 719 | let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl 720 | (fun var -> [%type: [%t var] -> Yojson.Safe.t]) type_decl 721 | in 722 | let mono_ty = [%type: [%t typ] -> Yojson.Safe.t] in 723 | let ty = 724 | Ast_builder.Default.ptyp_poly ~loc poly_vars (polymorphize_ser mono_ty) 725 | in 726 | let typ = Type.mk ~kind:(Ptype_record 727 | [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_to_yojson") 728 | in 729 | let record = Val.mk (mknoloc "f") (Typ.constr (lid "t_to_yojson") []) in 730 | let mod_ = 731 | Sig.module_ (Md.mk (mod_mknoloc mod_name) 732 | (Mty.signature [ 733 | Sig.type_ Nonrecursive [typ]; 734 | Sig.value record; 735 | ])) 736 | in 737 | [mod_; to_yojson] 738 | | _ -> [to_yojson] 739 | 740 | 741 | let ser_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] 742 | 743 | let desu_sig_of_type ~options ~path type_decl = 744 | let { want_exn; _ } = options in 745 | let of_yojson = 746 | Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl)) 747 | (desu_type_of_decl ~options ~path type_decl)) 748 | in 749 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 750 | let loc = typ.ptyp_loc in 751 | let of_yojson_exn = 752 | Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson_exn") type_decl)) 753 | (desu_type_of_decl_poly ~options ~path type_decl [%type: Yojson.Safe.t -> [%t typ]])) 754 | in 755 | match type_decl.ptype_kind with 756 | | Ptype_open -> 757 | let mod_name = Ppx_deriving.mangle_type_decl 758 | (`PrefixSuffix ("M", "of_yojson")) type_decl 759 | in 760 | let poly_vars = List.rev 761 | (Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl) 762 | in 763 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 764 | let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl 765 | (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in 766 | let mono_ty = [%type: Yojson.Safe.t -> [%t error_or typ]] in 767 | let ty = 768 | Ast_builder.Default.ptyp_poly ~loc poly_vars (polymorphize_desu mono_ty) 769 | in 770 | let typ = Type.mk ~kind:(Ptype_record 771 | [Type.field ~mut:Mutable (mknoloc "f") ty]) (mknoloc "t_of_yojson") 772 | in 773 | let record = Val.mk (mknoloc "f") (Typ.constr (lid "t_of_yojson") []) in 774 | let mod_ = 775 | Sig.module_ (Md.mk (mod_mknoloc mod_name) 776 | (Mty.signature [ 777 | Sig.type_ Nonrecursive [typ]; 778 | Sig.value record; 779 | ])) 780 | in 781 | [mod_; of_yojson] 782 | | _ -> 783 | [of_yojson] 784 | @ (if not want_exn then [] else [of_yojson_exn]) 785 | 786 | let desu_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] 787 | 788 | let yojson_str_fields ~options ~path:_ type_decl = 789 | let { want_meta; _ } = options in 790 | match want_meta, type_decl.ptype_kind with 791 | | false, _ | true, Ptype_open -> [] 792 | | true, kind -> 793 | match kind, type_decl.ptype_manifest with 794 | | Ptype_record labels, _ -> 795 | let loc = !Ast_helper.default_loc in 796 | let fields = 797 | labels |> List.map (fun ({ pld_name = { txt = name }; _ } as label) -> 798 | let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in 799 | [%expr [%e str key]]) 800 | in 801 | let flist = List.fold_right (fun n acc -> [%expr [%e n] :: [%e acc]]) 802 | fields [%expr []] 803 | in 804 | [ 805 | Str.module_ (Mb.mk (mod_mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "Yojson_meta") type_decl)) 806 | (Mod.structure [ 807 | Str.value Nonrecursive [Vb.mk (pvar "keys") [%expr [%e flist]]] 808 | ; Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar "keys"]]] 809 | ])) 810 | ] 811 | | _ -> [] 812 | 813 | let yojson_sig_fields ~options ~path:_ type_decl = 814 | let { want_meta; _ } = options in 815 | match want_meta, type_decl.ptype_kind with 816 | | false, _ | true, Ptype_open -> [] 817 | | true, kind -> 818 | match kind, type_decl.ptype_manifest with 819 | | Ptype_record _, _ -> 820 | let loc = !Ast_helper.default_loc in 821 | [ 822 | Sig.module_ (Md.mk (mod_mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "Yojson_meta") type_decl)) 823 | (Mty.signature [ 824 | Sig.value (Val.mk (mknoloc "keys") [%type: string list]) ])) 825 | ] 826 | | _ -> [] 827 | 828 | let str_of_type ~options ~path type_decl = 829 | let (ser_pre, ser_vals, ser_post) = ser_str_of_type ~options ~path type_decl in 830 | let (desu_pre, desu_vals, desu_post) = desu_str_of_type ~options ~path type_decl in 831 | let fields_post = yojson_str_fields ~options ~path type_decl in 832 | (ser_pre @ desu_pre, ser_vals @ desu_vals, ser_post @ desu_post @ fields_post) 833 | 834 | let str_of_type_to_yojson ~options ~path type_decl = 835 | let (ser_pre, ser_vals, ser_post) = ser_str_of_type ~options ~path type_decl in 836 | let fields_post = yojson_str_fields ~options ~path type_decl in 837 | (ser_pre, ser_vals, ser_post @ fields_post) 838 | 839 | let str_of_type_of_yojson ~options ~path type_decl = 840 | let (desu_pre, desu_vals, desu_post) = desu_str_of_type ~options ~path type_decl in 841 | let fields_post = yojson_str_fields ~options ~path type_decl in 842 | (desu_pre, desu_vals, desu_post @ fields_post) 843 | 844 | let str_of_type_ext ~options ~path type_ext = 845 | let ser_vals = ser_str_of_type_ext ~options ~path type_ext in 846 | let desu_vals = desu_str_of_type_ext ~options ~path type_ext in 847 | ser_vals @ desu_vals 848 | 849 | let sig_of_type ~options ~path type_decl = 850 | (ser_sig_of_type ~options ~path type_decl) @ 851 | (desu_sig_of_type ~options ~path type_decl) @ 852 | (yojson_sig_fields ~options ~path type_decl) 853 | 854 | let sig_of_type_to_yojson ~options ~path type_decl = 855 | (ser_sig_of_type ~options ~path type_decl) @ 856 | (yojson_sig_fields ~options ~path type_decl) 857 | 858 | let sig_of_type_of_yojson ~options ~path type_decl = 859 | (desu_sig_of_type ~options ~path type_decl) @ 860 | (yojson_sig_fields ~options ~path type_decl) 861 | 862 | let sig_of_type_ext ~options ~path type_ext = 863 | (ser_sig_of_type_ext ~options ~path type_ext) @ 864 | (desu_sig_of_type_ext ~options ~path type_ext) 865 | 866 | let structure f ~options ~path type_ = 867 | let (pre, vals, post) = f ~options ~path type_ in 868 | match vals with 869 | | [] -> pre @ post 870 | | _ -> pre @ [Str.value ?loc:None Recursive vals] @ post 871 | 872 | let on_str_decls f ~options ~path type_decls = 873 | let unzip3 l = 874 | List.fold_right (fun (v1, v2, v3) (a1,a2,a3) -> (v1::a1, v2::a2, v3::a3)) l ([],[],[]) 875 | in 876 | let (pre, vals, post) = unzip3 (List.map (f ~options ~path) type_decls) in 877 | (List.concat pre, List.concat vals, List.concat post) 878 | 879 | let on_sig_decls f ~options ~path type_decls = 880 | List.concat (List.map (f ~options ~path) type_decls) 881 | 882 | (* Note: we are careful to call our sanitize function here, not Ppx_deriving.sanitize. *) 883 | let ser_core_expr_of_typ typ = 884 | let quoter = Ppx_deriving.create_quoter () in 885 | let typ = Ppx_deriving.strong_type_of_type typ in 886 | sanitize ~quoter (ser_expr_of_typ ~quoter typ) 887 | 888 | let desu_core_expr_of_typ typ = 889 | let quoter = Ppx_deriving.create_quoter () in 890 | let typ = Ppx_deriving.strong_type_of_type typ in 891 | sanitize ~quoter (desu_expr_of_typ ~quoter ~path:[] typ) 892 | 893 | let make_gen f = 894 | let f' ~ctxt x strict meta exn = 895 | let is_strict = match strict with 896 | | Some strict -> strict 897 | | None -> true (* by default *) 898 | in 899 | let want_meta = match meta with 900 | | Some meta -> meta 901 | | None -> false (* by default *) 902 | in 903 | let want_exn = match exn with 904 | | Some exn -> exn 905 | | None -> false (* by default *) 906 | in 907 | let options = { is_strict; want_meta; want_exn } in 908 | let path = 909 | let code_path = Expansion_context.Deriver.code_path ctxt in 910 | (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) 911 | (* Ppx_deriving.module_from_input_name ported to ppxlib. *) 912 | let main_module_path = match Expansion_context.Deriver.input_name ctxt with 913 | | "" 914 | | "_none_" -> [] 915 | | input_name -> 916 | match Filename.chop_suffix input_name ".ml" with 917 | | exception _ -> 918 | (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) 919 | [] 920 | | path -> 921 | [String.capitalize_ascii (Filename.basename path)] 922 | in 923 | main_module_path @ Code_path.submodule_path code_path 924 | in 925 | f ~options ~path x 926 | in 927 | Deriving.Generator.V2.make (args ()) f' 928 | 929 | let to_yojson: Deriving.t = 930 | Deriving.add 931 | "to_yojson" 932 | ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 933 | structure (on_str_decls str_of_type_to_yojson) ~options ~path type_decls 934 | )) 935 | ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 936 | on_sig_decls sig_of_type_to_yojson ~options ~path type_decls 937 | )) 938 | ~str_type_ext:(make_gen ser_str_of_type_ext) 939 | ~sig_type_ext:(make_gen ser_sig_of_type_ext) 940 | 941 | let of_yojson: Deriving.t = 942 | Deriving.add 943 | "of_yojson" 944 | ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 945 | structure (on_str_decls str_of_type_of_yojson) ~options ~path type_decls 946 | )) 947 | ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 948 | on_sig_decls sig_of_type_of_yojson ~options ~path type_decls 949 | )) 950 | ~str_type_ext:(make_gen desu_str_of_type_ext) 951 | ~sig_type_ext:(make_gen desu_sig_of_type_ext) 952 | 953 | (* Not just alias because yojson also has meta (without its own deriver name) *) 954 | let yojson: Deriving.t = 955 | Deriving.add 956 | "yojson" 957 | ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 958 | structure (on_str_decls str_of_type) ~options ~path type_decls 959 | )) 960 | ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> 961 | on_sig_decls sig_of_type ~options ~path type_decls 962 | )) 963 | ~str_type_ext:(make_gen str_of_type_ext) 964 | ~sig_type_ext:(make_gen sig_of_type_ext) 965 | 966 | (* custom extensions such that "derive"-prefixed also works *) 967 | let to_derive_extension = 968 | Extension.V3.declare "ppx_deriving_yojson.derive.to_yojson" Extension.Context.expression 969 | Ast_pattern.(ptyp __) (fun ~ctxt:_ -> ser_core_expr_of_typ) 970 | let of_derive_extension = 971 | Extension.V3.declare "ppx_deriving_yojson.derive.of_yojson" Extension.Context.expression 972 | Ast_pattern.(ptyp __) (fun ~ctxt:_ -> desu_core_expr_of_typ) 973 | let _derive_transformation = 974 | Driver.register_transformation 975 | deriver 976 | ~rules:[ 977 | Context_free.Rule.extension to_derive_extension; 978 | Context_free.Rule.extension of_derive_extension; 979 | ] 980 | -------------------------------------------------------------------------------- /src/ppx_deriving_yojson.mli: -------------------------------------------------------------------------------- 1 | val to_yojson : Ppxlib.Deriving.t 2 | 3 | val of_yojson : Ppxlib.Deriving.t 4 | 5 | val yojson : Ppxlib.Deriving.t 6 | -------------------------------------------------------------------------------- /src/ppx_deriving_yojson_runtime.ml: -------------------------------------------------------------------------------- 1 | include Ppx_deriving_runtime 2 | 3 | let (>>=) x f = 4 | match x with Ok x -> f x | (Error _) as x -> x 5 | 6 | let (>|=) x f = 7 | x >>= fun x -> Ok (f x) 8 | 9 | let rec map_bind f acc xs = 10 | match xs with 11 | | x :: xs -> 12 | (* equivalent to [f x >>= fun x -> map_bind f (x :: acc) xs], 13 | but do not use [(>>=)] to keep [map_bind] tail-recursive 14 | under js-of-ocaml *) 15 | (match f x with 16 | | ((Error _) as err) -> err 17 | | Ok x -> map_bind f (x :: acc) xs) 18 | | [] -> Ok (List.rev acc) 19 | 20 | type 'a error_or = ('a, string) result 21 | 22 | (** [safe_map f l] returns the same value as [List.map f l], but 23 | computes it tail-recursively so that large list lengths don't 24 | cause a stack overflow *) 25 | let safe_map f l = List.rev (List.rev_map f l) 26 | -------------------------------------------------------------------------------- /src/ppx_deriving_yojson_runtime.mli: -------------------------------------------------------------------------------- 1 | type 'a error_or = ('a, string) result 2 | 3 | val ( >>= ) : 'a error_or -> ('a -> 'b error_or) -> 'b error_or 4 | val ( >|= ) : 'a error_or -> ('a -> 'b) -> 'b error_or 5 | val map_bind : ('a -> 'b error_or) -> 'b list -> 'a list -> 'b list error_or 6 | 7 | (** [safe_map f l] returns the same value as [List.map f l], but 8 | computes it tail-recursively so that large list lengths don't 9 | cause a stack overflow *) 10 | val safe_map : ('a -> 'b) -> 'a list -> 'b list 11 | 12 | val ( = ) : 'a -> 'a -> bool (* NOTE: Used for [@default ...] *) 13 | module List : (module type of List) 14 | module String : (module type of String) 15 | module Bytes : (module type of Bytes) 16 | module Int32 : (module type of Int32) 17 | module Int64 : (module type of Int64) 18 | module Nativeint : (module type of Nativeint) 19 | module Array : (module type of Array) 20 | module Result : sig 21 | type ('a, 'b) t = ('a, 'b) result = 22 | | Ok of 'a 23 | | Error of 'b 24 | 25 | type nonrec ('a, 'b) result = ('a, 'b) result = 26 | | Ok of 'a 27 | | Error of 'b 28 | end 29 | -------------------------------------------------------------------------------- /src_test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_ppx_yojson) 3 | (libraries ounit2) 4 | (preprocess 5 | (pps ppx_deriving.show ppx_deriving_yojson)) 6 | (flags 7 | (:standard -w -9-39-27-34-37))) 8 | 9 | (alias 10 | (name runtest) 11 | (deps test_ppx_yojson.exe) 12 | (action (run %{deps}))) 13 | -------------------------------------------------------------------------------- /src_test/test_ppx_yojson.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | type json = 4 | [ `Assoc of (string * json) list 5 | | `Bool of bool 6 | | `Float of float 7 | | `Int of int 8 | | `Intlit of string 9 | | `List of json list 10 | | `Null 11 | | `String of string 12 | | `Tuple of json list 13 | | `Variant of string * json option ] 14 | [@@deriving show] 15 | 16 | let show_error_or = 17 | let module M = struct 18 | type 'a error_or = ('a, string) result [@@deriving show] 19 | end in 20 | M.show_error_or 21 | 22 | let show_keys keys = 23 | Format.asprintf "[%a]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt "; ") Format.pp_print_string) keys 24 | 25 | let assert_roundtrip pp_obj to_json of_json obj str = 26 | let json = Yojson.Safe.from_string str in 27 | let cleanup json = Yojson.Safe.(json |> to_string |> from_string) in 28 | assert_equal ~printer:show_json json (cleanup (to_json obj)); 29 | assert_equal ~printer:(show_error_or pp_obj) (Ok obj) (of_json json) 30 | 31 | let assert_failure pp_obj of_json err str = 32 | let json = Yojson.Safe.from_string str in 33 | assert_equal ~printer:(show_error_or pp_obj) (Error err) (of_json json) 34 | 35 | type u = unit [@@deriving show, yojson] 36 | type i1 = int [@@deriving show, yojson] 37 | type i2 = int32 [@@deriving show, yojson] 38 | type i3 = Int32.t [@@deriving show, yojson] 39 | type i4 = int64 [@@deriving show, yojson] 40 | type i5 = Int64.t [@@deriving show, yojson] 41 | type i6 = nativeint [@@deriving show, yojson] 42 | type i7 = Nativeint.t [@@deriving show, yojson] 43 | type i8 = int64 [@encoding `string] [@@deriving show, yojson] 44 | type i9 = nativeint [@encoding `string] [@@deriving show, yojson] 45 | type f = float [@@deriving show, yojson] 46 | type b = bool [@@deriving show, yojson] 47 | type c = char [@@deriving show, yojson] 48 | type s = string [@@deriving show, yojson] 49 | type y = bytes [@@deriving show, yojson] 50 | type xr = int ref [@@deriving show, yojson] 51 | type xo = int option [@@deriving show, yojson] 52 | type xl = int list [@@deriving show, yojson] 53 | type xa = int array [@@deriving show, yojson] 54 | type xt = int * int [@@deriving show, yojson] 55 | 56 | type 'a p = 'a option 57 | [@@deriving show, yojson] 58 | type pv = [ `A | `B of int | `C of int * string ] 59 | [@@deriving show, yojson] 60 | type pva = [ `A ] and pvb = [ `B ] 61 | [@@deriving show, yojson] 62 | type 'a pvc = [ `C of 'a ] 63 | [@@deriving show, yojson] 64 | type pvd = [ pva | pvb | int pvc ] 65 | [@@deriving show, yojson] 66 | 67 | type v = A | B of int | C of int * string 68 | [@@deriving show, yojson] 69 | type r = { x : int; y : string } 70 | [@@deriving show, yojson { meta = true }] 71 | type rv = RA | RB of int | RC of int * string | RD of { z : string } 72 | [@@deriving show, yojson] 73 | 74 | let test_unit _ctxt = 75 | assert_roundtrip pp_u u_to_yojson u_of_yojson 76 | () "null" 77 | 78 | let test_int _ctxt = 79 | assert_roundtrip pp_i1 i1_to_yojson i1_of_yojson 80 | 42 "42"; 81 | assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson 82 | 42l "42"; 83 | assert_roundtrip pp_i3 i3_to_yojson i3_of_yojson 84 | 42l "42"; 85 | assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson 86 | 42L "42"; 87 | assert_roundtrip pp_i5 i5_to_yojson i5_of_yojson 88 | 42L "42"; 89 | assert_roundtrip pp_i6 i6_to_yojson i6_of_yojson 90 | 42n "42"; 91 | assert_roundtrip pp_i7 i7_to_yojson i7_of_yojson 92 | 42n "42"; 93 | assert_roundtrip pp_i8 i8_to_yojson i8_of_yojson 94 | 42L "\"42\""; 95 | assert_roundtrip pp_i9 i9_to_yojson i9_of_yojson 96 | 42n "\"42\"" 97 | 98 | let test_int_edge _ctxt = 99 | assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson 100 | 0x7fffffffl "2147483647"; 101 | assert_roundtrip pp_i2 i2_to_yojson i2_of_yojson 102 | (Int32.neg 0x80000000l) "-2147483648"; 103 | assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson 104 | 0x7fffffffffffffffL "9223372036854775807"; 105 | assert_roundtrip pp_i4 i4_to_yojson i4_of_yojson 106 | (Int64.neg 0x8000000000000000L) "-9223372036854775808" 107 | 108 | let test_float _ctxt = 109 | assert_roundtrip pp_f f_to_yojson f_of_yojson 110 | 1.0 "1.0"; 111 | assert_equal ~printer:(show_error_or pp_f) 112 | (Ok 1.0) 113 | (f_of_yojson (`Int 1)) 114 | 115 | let test_bool _ctxt = 116 | assert_roundtrip pp_b b_to_yojson b_of_yojson 117 | true "true"; 118 | assert_roundtrip pp_b b_to_yojson b_of_yojson 119 | false "false" 120 | 121 | let test_char _ctxt = 122 | assert_roundtrip pp_c c_to_yojson c_of_yojson 123 | 'c' "\"c\""; 124 | assert_failure pp_c c_of_yojson 125 | "Test_ppx_yojson.c" "\"xxx\"" 126 | 127 | let test_string _ctxt = 128 | assert_roundtrip pp_s s_to_yojson s_of_yojson 129 | "foo" "\"foo\""; 130 | assert_roundtrip pp_y y_to_yojson y_of_yojson 131 | (Bytes.of_string "foo") "\"foo\"" 132 | 133 | let test_ref _ctxt = 134 | assert_roundtrip pp_xr xr_to_yojson xr_of_yojson 135 | (ref 42) "42" 136 | 137 | let test_option _ctxt = 138 | assert_roundtrip pp_xo xo_to_yojson xo_of_yojson 139 | (Some 42) "42"; 140 | assert_roundtrip pp_xo xo_to_yojson xo_of_yojson 141 | None "null" 142 | 143 | let test_poly _ctxt = 144 | assert_roundtrip pp_xo 145 | (([%to_yojson: 'a option] [%to_yojson: int])) 146 | (([%of_yojson: 'a option] [%of_yojson: int])) 147 | (Some 42) "42" 148 | 149 | let test_list _ctxt = 150 | assert_roundtrip pp_xl xl_to_yojson xl_of_yojson 151 | [] "[]"; 152 | assert_roundtrip pp_xl xl_to_yojson xl_of_yojson 153 | [42; 43] "[42, 43]"; 154 | let rec make_list i acc = 155 | if i = 0 156 | then (i mod 100 :: acc) 157 | else make_list (i - 1) (i mod 100 :: acc) in 158 | let lst = make_list (500_000 - 1) [] in 159 | let buf = Buffer.create (5_000 * 390 + 4) in 160 | Buffer.add_string buf "["; 161 | Buffer.add_string buf (string_of_int (List.hd lst)); 162 | List.iter (fun x -> Buffer.add_string buf ", "; Buffer.add_string buf (string_of_int x)) (List.tl lst); 163 | Buffer.add_string buf "]"; 164 | let str = Bytes.to_string (Buffer.to_bytes buf) in 165 | assert_roundtrip pp_xl xl_to_yojson xl_of_yojson lst str 166 | 167 | let test_array _ctxt = 168 | assert_roundtrip pp_xa xa_to_yojson xa_of_yojson 169 | [||] "[]"; 170 | assert_roundtrip pp_xa xa_to_yojson xa_of_yojson 171 | [|42; 43|] "[42, 43]" 172 | 173 | let test_tuple _ctxt = 174 | assert_roundtrip pp_xt xt_to_yojson xt_of_yojson 175 | (42, 43) "[42, 43]" 176 | 177 | let test_ptyp _ctxt = 178 | assert_roundtrip (pp_p pp_i1) (p_to_yojson i1_to_yojson) (p_of_yojson i1_of_yojson) 179 | (Some 42) "42"; 180 | assert_roundtrip (pp_p pp_i1) (p_to_yojson i1_to_yojson) (p_of_yojson i1_of_yojson) 181 | None "null" 182 | 183 | let test_pvar _ctxt = 184 | assert_roundtrip pp_pv pv_to_yojson pv_of_yojson 185 | `A "[\"A\"]"; 186 | assert_roundtrip pp_pv pv_to_yojson pv_of_yojson 187 | (`B 42) "[\"B\", 42]"; 188 | assert_roundtrip pp_pv pv_to_yojson pv_of_yojson 189 | (`C (42, "foo")) "[\"C\", 42, \"foo\"]"; 190 | assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson 191 | `A "[\"A\"]"; 192 | assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson 193 | `B "[\"B\"]"; 194 | assert_roundtrip pp_pvd pvd_to_yojson pvd_of_yojson 195 | (`C 1) "[\"C\", 1]"; 196 | assert_equal ~printer:(show_error_or pp_pvd) 197 | (Error "Test_ppx_yojson.pvd") 198 | (pvd_of_yojson (`List [`String "D"])) 199 | 200 | let test_var _ctxt = 201 | assert_roundtrip pp_v v_to_yojson v_of_yojson 202 | A "[\"A\"]"; 203 | assert_roundtrip pp_v v_to_yojson v_of_yojson 204 | (B 42) "[\"B\", 42]"; 205 | assert_roundtrip pp_v v_to_yojson v_of_yojson 206 | (C (42, "foo")) "[\"C\", 42, \"foo\"]" 207 | 208 | let test_rec _ctxt = 209 | assert_roundtrip pp_r r_to_yojson r_of_yojson 210 | {x=42; y="foo"} "{\"x\":42,\"y\":\"foo\"}"; 211 | assert_equal ~printer:show_keys ["x"; "y"] Yojson_meta_r.keys 212 | 213 | let test_recvar _ctxt = 214 | assert_roundtrip pp_rv rv_to_yojson rv_of_yojson 215 | RA "[\"RA\"]"; 216 | assert_roundtrip pp_rv rv_to_yojson rv_of_yojson 217 | (RB 42) "[\"RB\", 42]"; 218 | assert_roundtrip pp_rv rv_to_yojson rv_of_yojson 219 | (RC(42, "foo")) "[\"RC\", 42, \"foo\"]"; 220 | assert_roundtrip pp_rv rv_to_yojson rv_of_yojson 221 | (RD{z="foo"}) "[\"RD\", {\"z\": \"foo\"}]" 222 | 223 | type geo = { 224 | lat : float [@key "Latitude"] ; 225 | lon : float [@key "Longitude"] ; 226 | } 227 | [@@deriving yojson { meta = true }, show] 228 | let test_key _ctxt = 229 | assert_roundtrip pp_geo geo_to_yojson geo_of_yojson 230 | {lat=35.6895; lon=139.6917} 231 | "{\"Latitude\":35.6895,\"Longitude\":139.6917}"; 232 | assert_equal ~printer:show_keys ["Latitude"; "Longitude"] Yojson_meta_geo.keys 233 | 234 | let test_field_err _ctxt = 235 | assert_equal ~printer:(show_error_or pp_geo) 236 | (Error "Test_ppx_yojson.geo.lat") 237 | (geo_of_yojson (`Assoc ["Longitude", (`Float 42.0)])) 238 | 239 | type id = Yojson.Safe.t [@@deriving yojson] 240 | let test_id _ctxt = 241 | assert_roundtrip pp_json id_to_yojson id_of_yojson 242 | (`Int 42) "42" 243 | 244 | type custvar = 245 | | Tea of string [@name "tea"] 246 | | Vodka [@name "vodka"] 247 | [@@deriving yojson, show] 248 | let test_custvar _ctxt = 249 | assert_roundtrip pp_custvar custvar_to_yojson custvar_of_yojson 250 | (Tea "oolong") "[\"tea\", \"oolong\"]"; 251 | assert_roundtrip pp_custvar custvar_to_yojson custvar_of_yojson 252 | Vodka "[\"vodka\"]" 253 | 254 | type custpvar = 255 | [ `Tea of string [@name "tea"] 256 | | `Beer of string * float [@name "beer"] 257 | | `Vodka [@name "vodka"] 258 | ] [@@deriving yojson, show] 259 | let test_custpvar _ctxt = 260 | assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson 261 | (`Tea "earl_grey") "[\"tea\", \"earl_grey\"]"; 262 | assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson 263 | (`Beer ("guinness", 3.3)) "[\"beer\", \"guinness\", 3.3]"; 264 | assert_roundtrip pp_custpvar custpvar_to_yojson custpvar_of_yojson 265 | `Vodka "[\"vodka\"]" 266 | 267 | type default = { 268 | def : int [@default 42]; 269 | } [@@deriving yojson, show] 270 | let test_default _ctxt = 271 | assert_roundtrip pp_default default_to_yojson default_of_yojson 272 | { def = 42 } "{}" 273 | 274 | type bidi = int [@@deriving show, to_yojson, of_yojson] 275 | let test_bidi _ctxt = 276 | assert_roundtrip pp_bidi bidi_to_yojson bidi_of_yojson 277 | 42 "42" 278 | 279 | let test_shortcut _ctxt = 280 | assert_roundtrip pp_i1 [%to_yojson: int] [%of_yojson: int] 281 | 42 "42" 282 | 283 | module CustomConversions = struct 284 | 285 | module IntMap = Map.Make(struct type t = int let compare = compare end) 286 | type mapEncoding = (int * string) list [@@deriving yojson] 287 | let map_to_yojson m = mapEncoding_to_yojson @@ IntMap.bindings m 288 | let map_of_yojson json = 289 | (match mapEncoding_of_yojson json with 290 | | Ok lst -> Ok (List.fold_left (fun m (k, v) -> IntMap.add k v m) IntMap.empty lst) 291 | | Error s -> Error s) 292 | 293 | type k = string IntMap.t [@to_yojson map_to_yojson] 294 | [@of_yojson map_of_yojson] 295 | [@printer fun fmt a -> ()] 296 | [@@deriving show, yojson] 297 | let test_bare _ctxt = 298 | assert_roundtrip pp_k k_to_yojson k_of_yojson 299 | IntMap.(add 6 "foo" @@ empty) 300 | {|[[6,"foo"]]|} 301 | 302 | type crecord = { 303 | mapping : string IntMap.t [@to_yojson map_to_yojson] 304 | [@of_yojson map_of_yojson] 305 | [@printer fun fmt a -> ()] 306 | } [@@deriving yojson, show] 307 | 308 | let test_record _ctxt = 309 | assert_roundtrip pp_crecord crecord_to_yojson crecord_of_yojson 310 | IntMap.{ mapping = add 6 "foo" @@ empty } 311 | {|{"mapping":[[6,"foo"]]}|} 312 | 313 | let suite = "Custom conversion attributes" >::: 314 | [ "test_record" >:: test_record 315 | ; "test_bare" >:: test_bare ] 316 | end 317 | 318 | type nostrict = { 319 | nostrict_field : int; 320 | } 321 | [@@deriving show, yojson { strict = false }] 322 | let test_nostrict _ctxt = 323 | assert_equal ~printer:(show_error_or pp_nostrict) 324 | (Ok { nostrict_field = 42 }) 325 | (nostrict_of_yojson (`Assoc ["nostrict_field", (`Int 42); 326 | "some_other_field", (`Int 43)])) 327 | 328 | module Opentype : 329 | sig 330 | type 'a opentype = .. [@@deriving yojson] 331 | type 'a opentype += A of 'a | B of string list [@@deriving yojson] 332 | end = 333 | struct 334 | type 'a opentype = .. [@@deriving yojson] 335 | type 'a opentype += A of 'a | B of string list [@@deriving yojson] 336 | end 337 | type 'a Opentype.opentype += 338 | | C of 'a Opentype.opentype * float 339 | | A = Opentype.A 340 | [@@deriving yojson] 341 | let rec pp_opentype f fmt = function 342 | A x -> Format.fprintf fmt "A(%s)" (f x) 343 | | Opentype.B l -> Format.fprintf fmt "B(%s)" (String.concat ", " l) 344 | | C (x, v) -> 345 | Format.pp_print_string fmt "C("; 346 | pp_opentype f fmt x; 347 | Format.fprintf fmt ", %f)" v 348 | | _ -> assert false 349 | 350 | let test_opentype _ctxt = 351 | let pp_ot = pp_opentype string_of_int in 352 | let to_yojson = Opentype.opentype_to_yojson i1_to_yojson in 353 | let of_yojson = Opentype.opentype_of_yojson i1_of_yojson in 354 | assert_roundtrip pp_ot to_yojson of_yojson 355 | (Opentype.A 0) "[\"A\", 0]"; 356 | assert_roundtrip pp_ot to_yojson of_yojson 357 | (Opentype.B ["one"; "two"]) "[\"B\", [ \"one\", \"two\"] ]"; 358 | assert_roundtrip pp_ot to_yojson of_yojson 359 | (C (Opentype.A 42, 1.2)) "[\"C\", [\"A\", 42], 1.2]" 360 | 361 | type paramless_opentype = .. [@@deriving yojson] 362 | 363 | 364 | (* This will fail at type-check if we introduce features that increase 365 | the default generated signatures. It is representative of user code 366 | (there is plenty in OPAM) that uses our generated signatures, but 367 | manually implement this restricted function set. 368 | 369 | For example, the unconditional addition of of_yojson_exn has broken 370 | this test. *) 371 | type outer_t = int [@@deriving yojson] 372 | module Automatic_deriving_in_signature_only 373 | : sig type t [@@deriving yojson] end 374 | = struct 375 | type t = int 376 | let of_yojson = outer_t_of_yojson 377 | let to_yojson = outer_t_to_yojson 378 | end 379 | 380 | module Warnings = struct 381 | 382 | module W34 = struct 383 | 384 | [@@@ocaml.warning "@34"] 385 | 386 | 387 | module M1 : sig type u [@@deriving yojson] end = struct 388 | type internal = int list [@@deriving yojson] 389 | type u = int list [@@deriving yojson] 390 | end 391 | (* the deriver for type [u] supposedly use the derivier of type 392 | [internal]. Consider for instance the case where [u] is a map, 393 | and internal is a list of bindings. *) 394 | module M2 : sig type 'a u [@@deriving yojson] end = struct 395 | type 'a internal = 'a list [@@deriving yojson] 396 | type 'a u = 'a list [@@deriving yojson] 397 | end 398 | 399 | (* the deriver for type [u] supposedly use the derivier of type 400 | [internal]. Consider for instance the case where [u] is a map, 401 | and internal is a list of bindings. *) 402 | (* module M1 : sig type 'a u [@@deriving yojson] end = struct *) 403 | (* type 'a internal = .. [@@deriving yojson] (\* Triggers the warning *\) *) 404 | (* type 'a internal += A of 'a | B of string list [@@deriving yojson] *) 405 | (* type 'a u = 'a list [@@deriving yojson] *) 406 | (* end *) 407 | end 408 | 409 | end 410 | 411 | 412 | module TestShadowing = struct 413 | module List = struct 414 | let map () = () 415 | end 416 | 417 | type t = int list [@@deriving yojson] 418 | 419 | module Array = struct 420 | let to_list () = () 421 | end 422 | 423 | module Bytes = struct 424 | let to_string () = () 425 | end 426 | 427 | type v = bytes [@@deriving yojson] 428 | 429 | end 430 | 431 | module Test_extension_forms = struct 432 | let _ = [%to_yojson: unit], [%of_yojson: unit] 433 | let _ = [%to_yojson: int], [%of_yojson: int] 434 | let _ = [%to_yojson: int32], [%of_yojson: int32] 435 | let _ = [%to_yojson: Int32.t], [%of_yojson: Int32.t] 436 | let _ = [%to_yojson: int64], [%of_yojson: int64] 437 | let _ = [%to_yojson: Int64.t], [%of_yojson: Int64.t] 438 | let _ = [%to_yojson: nativeint], [%of_yojson: nativeint] 439 | let _ = [%to_yojson: Nativeint.t], [%of_yojson: Nativeint.t] 440 | let _ = [%to_yojson: int64], [%of_yojson: int64] 441 | let _ = [%to_yojson: nativeint], [%of_yojson: nativeint] 442 | let _ = [%to_yojson: float], [%of_yojson: float] 443 | let _ = [%to_yojson: bool], [%of_yojson: bool] 444 | let _ = [%to_yojson: char], [%of_yojson: char] 445 | let _ = [%to_yojson: string], [%of_yojson: string] 446 | let _ = [%to_yojson: bytes], [%of_yojson: bytes] 447 | let _ = [%to_yojson: int], [%of_yojson: int] 448 | let _ = [%to_yojson: int ref], [%of_yojson: int ref] 449 | let _ = [%to_yojson: int option], [%of_yojson: int option] 450 | let _ = [%to_yojson: int list], [%of_yojson: int list] 451 | let _ = [%to_yojson: int array], [%of_yojson: int array] 452 | let _ = [%to_yojson: int * int], [%of_yojson: int * int] 453 | 454 | let _ = [%to_yojson: 'a option], 455 | [%of_yojson: 'a option] 456 | let _ = [%to_yojson: [ `A | `B of int | `C of int * string ]], 457 | [%of_yojson: [ `A | `B of int | `C of int * string ]] 458 | let _ = [%to_yojson: [ `C of 'a ]], 459 | [%of_yojson: [ `C of 'a ]] 460 | let _ = [%to_yojson: [ pva | pvb | int pvc ]], 461 | [%of_yojson: [ pva | pvb | int pvc ]] 462 | end 463 | 464 | (* this test checks that we can derive an _exn deserializer 465 | even if we use sub-types that are derived with {exn = false} *) 466 | module Test_exn_depends_on_non_exn = struct 467 | module M : sig 468 | type t [@@deriving yojson { exn = false }] 469 | end = struct 470 | type t = int [@@deriving yojson { exn = false }] 471 | end 472 | open M 473 | type u = t * t [@@deriving yojson { exn = true }] 474 | end 475 | 476 | module Test_recursive_polyvariant = struct 477 | (* Regression test for 478 | https://github.com/whitequark/ppx_deriving_yojson/issues/24 *) 479 | type a = [ `B of string ] 480 | [@@deriving of_yojson] 481 | type b = [a | `C of b list] 482 | [@@deriving of_yojson] 483 | type c = [ a | b | `D of b list] 484 | [@@deriving of_yojson] 485 | let c_of_yojson yj : c Ppx_deriving_yojson_runtime.error_or = c_of_yojson yj 486 | end 487 | 488 | type 'a recursive1 = { lhs : string ; rhs : 'a } 489 | and foo = unit recursive1 490 | and bar = int recursive1 491 | [@@deriving show, yojson] 492 | 493 | let test_recursive _ctxt = 494 | assert_roundtrip (pp_recursive1 pp_i1) 495 | (recursive1_to_yojson i1_to_yojson) 496 | (recursive1_of_yojson i1_of_yojson) 497 | {lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}"; 498 | 499 | assert_roundtrip pp_foo foo_to_yojson foo_of_yojson 500 | {lhs="x"; rhs=()} "{\"lhs\":\"x\",\"rhs\":null}" ; 501 | 502 | assert_roundtrip pp_bar bar_to_yojson bar_of_yojson 503 | {lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}" 504 | 505 | let test_int_redefined ctxt = 506 | let module M = struct 507 | type int = Break_things 508 | 509 | let x = [%to_yojson: int] 1 510 | end 511 | in 512 | let expected = `Int 1 in 513 | assert_equal ~ctxt ~printer:show_json expected M.x 514 | 515 | (* TODO: Make this work *) 516 | (* 517 | let test_list_redefined ctxt = 518 | let module M = struct 519 | type redef_list = 520 | | [] 521 | | (::) of int * int 522 | 523 | type t = {field : int list} [@@deriving to_yojson] 524 | let x = {field = List.([1;2])} 525 | end 526 | in 527 | let expected = `List [`Int 1; `Int 2] in 528 | assert_equal ~ctxt ~printer:show_json expected M.x 529 | *) 530 | 531 | let test_equality_redefined ctxt = 532 | let module M = struct 533 | module Pervasives = struct 534 | let (=) : int -> int -> bool = fun a b -> a = b 535 | let _ = 1 = 1 (* just dummy usage of `=` to suppress compiler warning *) 536 | 537 | let never_gonna_be_in_pervasives = None 538 | end 539 | let (=) : int -> int -> bool = fun a b -> a = b 540 | let _ = 1 = 1 (* just dummy usage of `=` to suppress compiler warning *) 541 | 542 | type t = {field : int option [@default Pervasives.never_gonna_be_in_pervasives]} [@@deriving to_yojson] 543 | let x = {field = Some 42} 544 | end 545 | in 546 | let expected = `Assoc ([("field", `Int (42))]) in 547 | assert_equal ~ctxt ~printer:show_json expected M.(to_yojson x) 548 | 549 | module Sanitize = 550 | struct 551 | module Result = 552 | struct 553 | type t = MyResult [@@deriving yojson] 554 | end 555 | 556 | type result_list = Result.t list [@@deriving yojson] 557 | 558 | (* sanitize [@default ...] *) 559 | module List = struct let x = [1; 2] end 560 | type t = {field : int list [@default List.x]} [@@deriving to_yojson] 561 | 562 | type t2 = {my: Result.t [@default MyResult]} [@@deriving yojson] 563 | end 564 | 565 | let suite = "Test ppx_yojson" >::: [ 566 | "test_unit" >:: test_unit; 567 | "test_int" >:: test_int; 568 | "test_int_edge" >:: test_int_edge; 569 | "test_float" >:: test_float; 570 | "test_bool" >:: test_bool; 571 | "test_char" >:: test_char; 572 | "test_string" >:: test_string; 573 | "test_ref" >:: test_ref; 574 | "test_option" >:: test_option; 575 | "test_poly" >:: test_poly; 576 | "test_list" >:: test_list; 577 | "test_array" >:: test_array; 578 | "test_tuple" >:: test_tuple; 579 | "test_ptyp" >:: test_ptyp; 580 | "test_pvar" >:: test_pvar; 581 | "test_var" >:: test_var; 582 | "test_rec" >:: test_rec; 583 | "test_recvar" >:: test_recvar; 584 | "test_key" >:: test_key; 585 | "test_id" >:: test_id; 586 | "test_custvar" >:: test_custvar; 587 | "test_custpvar" >:: test_custpvar; 588 | "test_field_err" >:: test_field_err; 589 | "test_default" >:: test_default; 590 | "test_bidi" >:: test_bidi; 591 | "test_custom" >: CustomConversions.suite; 592 | "test_shortcut" >:: test_shortcut; 593 | "test_nostrict" >:: test_nostrict; 594 | "test_opentype" >:: test_opentype; 595 | "test_recursive" >:: test_recursive; 596 | "test_int_redefined" >:: test_int_redefined; 597 | "test_equality_redefined" >:: test_equality_redefined; 598 | ] 599 | 600 | let _ = 601 | run_test_tt_main suite 602 | --------------------------------------------------------------------------------