pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=a7bd88b633aca26d3fea44d30e135c0f13194cde ppx_yojson_conv-0.17.0/000077500000000000000000000000001461647336100150475ustar00rootroot00000000000000ppx_yojson_conv-0.17.0/.gitignore000066400000000000000000000000411461647336100170320ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_yojson_conv-0.17.0/.ocamlformat000066400000000000000000000000231461647336100173470ustar00rootroot00000000000000profile=janestreet ppx_yojson_conv-0.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100172770ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_yojson_conv-0.17.0/LICENSE.md000066400000000000000000000021461461647336100164560ustar00rootroot00000000000000The MIT License Copyright (c) 2019--2024 Jane Street Group, LLC 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_yojson_conv-0.17.0/Makefile000066400000000000000000000004031461647336100165040ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_yojson_conv-0.17.0/README.org000066400000000000000000000300021461647336100165100ustar00rootroot00000000000000#+TITLE: ppx\_yojson\_conv * [@@deriving yojson] =ppx_yojson_conv= is a PPX syntax extension that generates code for converting OCaml types to and from Yojson.Safe, as defined in the [[https://github.com/ocaml-community/yojson][=yojson=]] library. Yojson.Safe are defined by the following type: #+begin_src ocaml type t = [ `Null | `Bool of bool | `Int of int | `Intlit of string | `Float of float | `String of string | `Assoc of (string * t) list | `List of t list | `Tuple of t list | `Variant of string * t option ] #+end_src and are rendered as normal json format. =ppx_yojson_conv= fits into the [[https://github.com/whitequark/ppx_deriving][=ppx_deriving=]] framework, so you can invoke it the same way you invoke any other deriving plug-in. Thus, we can write #+begin_src ocaml type int_pair = (int * int) [@@deriving yojson] #+end_src to get two values defined automatically, =yojson_of_int_pair= and =int_pair_of_yojson=. If we only want one direction, we can write one of the following. #+begin_src ocaml type int_pair = (int * int) [@@deriving yojson_of] type int_pair = (int * int) [@@deriving of_yojson] #+end_src Note that Yojson-converters for primitive types like =int= need to be brought into scope in order for the ppx to use them, for example by adding =open Ppx_yojson_conv_lib.Yojson_conv.Primitives= at the beginning of the file. It's also possible to construct converters based on type expressions, /i.e./: #+begin_src ocaml [%yojson_of: (int * string) list] [1,"one"; 2,"two"] |> Yojson.Safe.to_string;; => {|[[1,"one"],[2,"two"]]|} [%yojson_of: (int * string) list] [1,"one"; 2,"two"] |> [%of_yojson: (int * string) list];; => [1,"one"; 2,"two"] #+end_src For =%yojson_of=, we can also omit the conversion of some types by putting underscores for that type name. #+begin_src ocaml [%yojson_of: (int * _) list] [1,"one"; 2,"two"] |> Yojson.Safe.to_string;; => {|[[1,"_"],[2,"_"]]|} #+end_src ** Conversion rules In the following, we'll review the serialization rules for different OCaml types. *** Basic types For numbers like =int=, =int32=, =int64=, the value is stored as =`Int value=. For =float= number, the value is stored as =`Float value=. For the types =char= or =string=, the value is stored as =`String str= where =str= is respectively a one character string or the string itself. *** Lists and arrays OCaml-lists and arrays are represented as Yojson.Safe lists. *** Tuples and unit OCaml tuples are treated as lists of values in the same order as in the tuple. The type =unit= is treated as Yojson =`Null=. /e.g./: #+begin_src ocaml (3.14, "foo", "bar bla", 27) => [3.14, "foo", "bar bla", 27] #+end_src *** Options With options, =None= is treated as Yojson =`Null=, and =Some= is treated as the value contained, as shown below. #+begin_src ocaml None => `Null Some value => value #+end_src The rules for variants are described below. *** Records Records are represented as Yojson =`Assoc (string * t) list=, where item of the list is a key-value pair. Each pair consists of the name of the record field (first element), and its value (second element). /e.g./: #+begin_src ocaml { foo = (3,4); bar = "some string"; } => {"foo":[3,4],"bar":"some string"} #+end_src Type specifications of records allow the use of several attributes. The attribute =yojson.option= indicates that a record field should be optional. /e.g./: #+begin_src ocaml type t = { x : int option; y : int option [@yojson.option]; } [@@deriving yojson] #+end_src The following examples show how this works. #+begin_src ocaml { x = Some 1; y = Some 2; } => {"x":1,"y":2} { x = None ; y = None; } => {"x":null} #+end_src When the JSON object keys differ from the ocaml field names, users can specify the corresponding JSON key implicitly using =[@key "field"]=, for example: #+begin_src ocaml type t = { typ : float [@key "type"]; class_ : float [@key "CLASS"]; } [@@deriving yojson, yojson_fields] #+end_src The =yojson_fields= attribute generates the list of JSON keys from a record type, for example: #+begin_src ocaml type ty = { x : float [@key "a"]; y : float [@key "b"]; z : float } [@@deriving yojson_fields] #+end_src generates the list below, and the list will not be generated for the signature. #+begin_src ocaml yojson_fields_of_ty = ["a"; "b"; "z"] #+end_src Note that ppx_deriving_yojson support duplicated fields, while our library does not. **** Defaults More complex default values can be specified explicitly using several constructs, /e.g./: #+begin_src ocaml type t = { a : int [@default 42]; b : int [@default 3] [@yojson_drop_default (=)]; c : int [@default 3] [@yojson_drop_if fun x -> x = 3]; d : int list } [@@deriving yojson] #+end_src The =@default= annotation lets one specify a default value to be selected if the field is not specified, when converting from Yojson.Safe. The =@yojson_drop_default= annotation implies that the field will be dropped when generating the Yojson.Safe if the value being serialized is equal to the default according to the specified equality function. =@yojson_drop_if= is like =@yojson_drop_default=, except that it lets you specify the condition under which the field is dropped. ***** Specifying equality for [@yojson_drop_default] The equality used by [@yojson_drop_default] is customizable. There are several ways to specify the equality function: #+begin_src ocaml type t = { a : u [@default u0] [@yojson_drop_default (=)]; (* explicit user-provided function *) b : u [@default u0] [@yojson_drop_default.compare]; (* uses [%compare.equal: u] *) c : u [@default u0] [@yojson_drop_default.equal]; (* uses [%equal: u] *) d : u [@default u0] [@yojson_drop_default.yojson]; (* compares yojson representations *) e : u [@default u0] [@yojson_drop_default]; (* deprecated. uses polymorphic equality. *) } [@@deriving yojson] #+end_src **** Allowing extra fields The =@yojson.allow_extra_fields= annotation lets one specify that the yojson-converters should silently ignore extra fields, instead of raising. This applies only to the record to which the annotation is attached, and not to deeper yojson converters that may be called during conversion of a yojson to the record. #+begin_src ocaml type t = { a: int } [@@deriving yojson] {"a":1,"b":2} => exception type t = { a: int } [@@deriving yojson] [@@yojson.allow_extra_fields] {"a":1,"b":2} => {a = 1} type t = A of { a : int } [@yojson.allow_extra_fields] [@@deriving yojson] ["A", {"a":1,"b":2}] => A {a = 0} #+end_src *** Variants Constant constructors in variants are represented as a list with one string, which is the name of the contructor. Constructors with arguments are represented as lists, the first element being the constructor name, the rest being its arguments. For example: #+begin_src ocaml type t = A | B of int * float * t [@@deriving yojson] B (42, 3.14, B (-1, 2.72, A)) => ["B",42,3.14,["B",-1,2.72,["A"]]] #+end_src The above example also demonstrates recursion in data structures. if the JSON variant names differ from OCaml conventions, users can specify the corresponding JSON string explicitly using =[@name "constr"]=, for example: #+begin_src ocaml type t = | Typ [@name "type"] | Class [@name "class"] [@@deriving yojson] #+end_src *** Polymorphic variants Polymorphic variants behave almost the same as ordinary variants. The notable difference is that polymorphic variant constructors must always start with an either lower- or uppercase character, matching the way it was specified in the type definition. This is because OCaml distinguishes between upper and lowercase variant constructors. Note that type specifications containing unions of variant types are also supported by the Yojson converter, for example as in: #+begin_src ocaml type ab = [ `A | `B ] [@@deriving yojson] type cd = [ `C | `D ] [@@deriving yojson] type abcd = [ ab | cd ] [@@deriving yojson] #+end_src However, because `ppx_yojson_conv` needs to generate additional code to support inclusions of polymorphic variants, `ppx_yojson_conv` needs to know when processing a type definition whether it might be included in a polymorphic variant. `ppx_yojson_conv` will only generate the extra code automatically in the common case where the type definition is syntactically a polymorphic variant like in the example above. Otherwise, you will need to indicate it by using `[@@deriving yojson_poly]` (resp `of_yosjon_poly`) instead of `[@@deriving yojson]` (resp `of_yojson`): #+begin_src ocaml type ab = [ `A | `B ] [@@deriving yojson] type alias_of_ab = ab [@@deriving yojson_poly] type abcd = [ ab | `C | `D ] [@@deriving yojson] #+end_src *** Polymorphic values There is nothing special about polymorphic values as long as there are conversion functions for the type parameters. /e.g./: #+begin_src ocaml type 'a t = A | B of 'a [@@deriving yojson] type foo = int t [@@deriving yojson] #+end_src In the above case the conversion functions will behave as if =foo= had been defined as a monomorphic version of =t= with ='a= replaced by =int= on the right hand side. If a data structure is indeed polymorphic and you want to convert it, you will have to supply the conversion functions for the type parameters at runtime. If you wanted to convert a value of type ='a t= as in the above example, you would have to write something like this: #+begin_src ocaml yojson_of_t yojson_of_a v #+end_src where =yojson_of_a=, which may also be named differently in this particular case, is a function that converts values of type ='a= to a Yojson. Types with more than one parameter require passing conversion functions for those parameters in the order of their appearance on the left hand side of the type definition. *** Opaque values Opaque values are ones for which we do not want to perform conversions. This may be, because we do not have Yojson converters for them, or because we do not want to apply them in a particular type context. /e.g./ to hide large, unimportant parts of configurations. To prevent the preprocessor from generating calls to converters, simply apply the attribute =yojson.opaque= to the type, /e.g./: #+begin_src ocaml type foo = int * (stuff [@yojson.opaque]) [@@deriving yojson] #+end_src Thus, there is no need to specify converters for type =stuff=, and if there are any, they will not be used in this particular context. Needless to say, it is not possible to convert such a Yojson back to the original value. Here is an example conversion: #+begin_src ocaml (42, some_stuff) => [42,""] #+end_src *** Exceptions Unlike Sexp deriver, we are not handling exceptions in the yojson derivier. *** Hash tables The Stdlib's Hash tables, which are abstract values in OCaml, are represented as association lists, /i.e./ lists of key-value pairs, /e.g./: #+begin_src scheme [["foo",3],["bar",4]] #+end_src Reading in the above Yojson as hash table mapping strings to integers (=(string, int) Hashtbl.t=) will map =foo= to =42= and =bar= to =3=. Note that the order of elements in the list may matter, because the OCaml-implementation of hash tables keeps duplicates. Bindings will be inserted into the hash table in the order of appearance. Therefore, the last binding of a key will be the "visible" one, the others are "hidden". See the OCaml documentation on hash tables for details. ** A note about signatures In signatures, =ppx_yojson_conv= tries to generate an include of a named interface, instead of a list of value bindings. That is: #+begin_src ocaml type 'a t [@@deriving yojson] #+end_src will generate: #+begin_src ocaml include Yojsonable.S1 with type 'a t := 'a t #+end_src instead of: #+begin_src ocaml val t_of_yojson : (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a t val yojson_of_t : ('a -> Yojson.Safe.t) -> 'a t -> Yojson.Safe.t #+end_src There are however a number of limitations: - the type has to be named t - the type can only have up to 3 parameters - there shouldn't be any constraint on the type parameters If these aren't met, then =ppx_yojson_conv= will simply generate a list of value bindings. ppx_yojson_conv-0.17.0/dune000066400000000000000000000000001461647336100157130ustar00rootroot00000000000000ppx_yojson_conv-0.17.0/dune-project000066400000000000000000000000211461647336100173620ustar00rootroot00000000000000(lang dune 3.11) ppx_yojson_conv-0.17.0/expander/000077500000000000000000000000001461647336100166555ustar00rootroot00000000000000ppx_yojson_conv-0.17.0/expander/attrs.ml000066400000000000000000000120401461647336100203410ustar00rootroot00000000000000open! Base open! Ppxlib let default = Attribute.declare "yojson.default" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) ;; let drop_default = Attribute.declare "yojson.yojson_drop_default" Attribute.Context.label_declaration Ast_pattern.(pstr (alt_option (pstr_eval __ nil ^:: nil) nil)) (fun x -> x) ;; let drop_default_equal = Attribute.declare "yojson.@yojson_drop_default.equal" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let drop_default_compare = Attribute.declare "yojson.@yojson_drop_default.compare" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let drop_default_yojson = Attribute.declare "yojson.@yojson_drop_default.yojson" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let drop_if = Attribute.declare "yojson.yojson_drop_if" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) ;; let opaque = Attribute.declare "yojson.opaque" Attribute.Context.core_type Ast_pattern.(pstr nil) () ;; let option = Attribute.declare "yojson.option" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let allow_extra_fields_td = Attribute.declare "yojson.allow_extra_fields" Attribute.Context.type_declaration Ast_pattern.(pstr nil) () ;; let allow_extra_fields_cd = Attribute.declare "yojson.allow_extra_fields" Attribute.Context.constructor_declaration Ast_pattern.(pstr nil) () ;; let yojson_key = Attribute.declare "yojson.key" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) (fun x -> x) ;; let yojson_variant_name = Attribute.declare "yojson.name" Attribute.Context.constructor_declaration Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) (fun x -> x) ;; let yojson_polymorphic_variant_name = Attribute.declare "yojson.name" Attribute.Context.rtag Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) (fun x -> x) ;; let invalid_attribute ~loc attr description = Location.raise_errorf ~loc "ppx_yojson_conv: [@%s] is only allowed on type [%s]." (Attribute.name attr) description ;; let fail_if_allow_extra_field_cd ~loc x = if Option.is_some (Attribute.get allow_extra_fields_cd x) then Location.raise_errorf ~loc "ppx_yojson_conv: [@@allow_extra_fields] is only allowed on inline records." ;; let fail_if_allow_extra_field_td ~loc x = if Option.is_some (Attribute.get allow_extra_fields_td x) then ( match x.ptype_kind with | Ptype_variant cds when List.exists cds ~f:(fun cd -> match cd.pcd_args with | Pcstr_record _ -> true | _ -> false) -> Location.raise_errorf ~loc "ppx_yojson_conv: [@@@@allow_extra_fields] only works on records. For inline \ records, do: type t = A of { a : int } [@@allow_extra_fields] | B [@@@@deriving \ yojson]" | _ -> Location.raise_errorf ~loc "ppx_yojson_conv: [@@@@allow_extra_fields] is only allowed on records.") ;; module Record_field_handler = struct type common = [ `yojson_option of core_type ] let get_attribute attr ld ~f = Option.map (Attribute.get attr ld) ~f:(fun x -> f x, Attribute.name attr) ;; let create ~loc getters ld = let common_getters = [ (fun ld -> match Attribute.get option ld with | Some () -> (match ld.pld_type with | [%type: [%t? ty] option] -> Some (`yojson_option ty, "[@yojson.option]") | _ -> invalid_attribute ~loc option "_ option") | None -> None) ] in match List.filter_map (getters @ common_getters) ~f:(fun f -> f ld) with | [] -> None | [ (v, _) ] -> Some v | _ :: _ :: _ as attributes -> Location.raise_errorf ~loc "The following elements are mutually exclusive: %s" (String.concat ~sep:" " (List.map attributes ~f:snd)) ;; module Of_yojson = struct type t = [ common | `default of expression ] let create ~loc ld = create ~loc [ get_attribute default ~f:(fun default -> `default default) ] ld ;; end module Yojson_of = struct type t = [ common | `drop_default of [ `no_arg | `compare | `equal | `yojson | `func of expression ] | `drop_if of expression | `keep ] let create ~loc ld = create ~loc [ get_attribute drop_default ~f:(function | None -> `drop_default `no_arg | Some e -> `drop_default (`func e)) ; get_attribute drop_default_equal ~f:(fun () -> `drop_default `equal) ; get_attribute drop_default_compare ~f:(fun () -> `drop_default `compare) ; get_attribute drop_default_yojson ~f:(fun () -> `drop_default `yojson) ; get_attribute drop_if ~f:(fun x -> `drop_if x) ] ld |> Option.value ~default:`keep ;; end end ppx_yojson_conv-0.17.0/expander/attrs.mli000066400000000000000000000024771461647336100205270ustar00rootroot00000000000000open! Base open! Ppxlib val default : (label_declaration, expression) Attribute.t val yojson_key : (label_declaration, string) Attribute.t val yojson_variant_name : (constructor_declaration, string) Attribute.t val yojson_polymorphic_variant_name : (row_field, string) Attribute.t val drop_default : (label_declaration, expression option) Attribute.t val drop_if : (label_declaration, expression) Attribute.t val opaque : (core_type, unit) Attribute.t val allow_extra_fields_td : (type_declaration, unit) Attribute.t val allow_extra_fields_cd : (constructor_declaration, unit) Attribute.t val invalid_attribute : loc:Location.t -> (_, _) Attribute.t -> string -> 'a val fail_if_allow_extra_field_cd : loc:Location.t -> constructor_declaration -> unit val fail_if_allow_extra_field_td : loc:Location.t -> type_declaration -> unit module Record_field_handler : sig type common = [ `yojson_option of core_type ] module Of_yojson : sig type t = [ common | `default of expression ] val create : loc:Location.t -> label_declaration -> t option end module Yojson_of : sig type t = [ common | `drop_default of [ `no_arg | `compare | `equal | `yojson | `func of expression ] | `drop_if of expression | `keep ] val create : loc:Location.t -> label_declaration -> t end end ppx_yojson_conv-0.17.0/expander/dune000066400000000000000000000002771461647336100175410ustar00rootroot00000000000000(library (name ppx_yojson_conv_expander) (public_name ppx_yojson_conv.expander) (libraries base ppxlib) (ppx_runtime_libraries ppx_yojson_conv_lib) (preprocess (pps ppxlib.metaquot))) ppx_yojson_conv-0.17.0/expander/label_with_name.ml000066400000000000000000000006631461647336100223260ustar00rootroot00000000000000open! Base type t = { label : string ; name_override : string option } let create ~label ~name_override = { label; name_override } let of_constructor_declaration (cd : Ppxlib.constructor_declaration) = let label = cd.pcd_name.txt in let name_override = Ppxlib.Attribute.get Attrs.yojson_variant_name cd in create ~label ~name_override ;; let label t = t.label let name t = Option.value t.name_override ~default:t.label ppx_yojson_conv-0.17.0/expander/label_with_name.mli000066400000000000000000000003061461647336100224710ustar00rootroot00000000000000open! Base type t val create : label:string -> name_override:string option -> t val of_constructor_declaration : Ppxlib.constructor_declaration -> t val label : t -> string val name : t -> string ppx_yojson_conv-0.17.0/expander/ppx_yojson_conv_expander.ml000066400000000000000000001762721461647336100243510ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default module Attrs = Attrs let ( --> ) lhs rhs = case ~guard:None ~lhs ~rhs (* Simplifies match cases, for readability of the generated code. It's not obvious we can stick this in ppx_core, as (match e1 with p -> e2) and (let p = e1 in e2) are not typed exactly the same (type inference goes in different order, meaning type disambiguation differs). *) let pexp_match ~loc expr cases = match cases with | [ { pc_lhs; pc_guard = None; pc_rhs } ] -> (match pc_lhs, expr with | ( { ppat_attributes = []; ppat_desc = Ppat_var { txt = ident; _ }; _ } , { pexp_attributes = []; pexp_desc = Pexp_ident { txt = Lident ident'; _ }; _ } ) when String.equal ident ident' -> pc_rhs | _ -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:pc_lhs ~expr ] pc_rhs) | _ -> pexp_match ~loc expr cases ;; module Fun_or_match = struct type t = | Fun of expression | Match of case list let expr ~loc t = match t with | Fun f -> f | Match cases -> pexp_function ~loc cases ;; let unroll ~loc e t = match t with | Fun f -> eapply ~loc f [ e ] | Match cases -> pexp_match ~loc e cases ;; let map_tmp_vars ~loc ts = let vars = List.mapi ts ~f:(fun i _ -> "v" ^ Int.to_string i) in let bindings = List.map2_exn vars ts ~f:(fun var t -> let expr = unroll ~loc (evar ~loc var) t in value_binding ~loc ~pat:(pvar ~loc var) ~expr) in bindings, List.map vars ~f:(pvar ~loc), List.map vars ~f:(evar ~loc) ;; end (* A renaming is a mapping from type variable name to type variable name. In definitions such as: type 'a t = | A : -> 'b t | B of 'a we generate a function that takes an yojson_of parameter named after 'a, but 'a is not in scope in when handling the constructor A (because A is a gadt constructor). Instead the type variables in scope are the ones defined in the return type of A, namely 'b. There could be less or more type variable in cases such as: type _ less = Less : int less type _ more = More : ('a * 'a) more If for instance, is ['b * 'c], when we find 'b, we will look for ['b] in the renaming and find ['a] (only in that gadt branch, it could be something else in other branches), at which point we can call the previously bound yojson_of parameter named after 'a. If we can't find a resulting name, like when looking up ['c] in the renaming, then we assume the variable is existentially quantified and treat it as [_] (which is ok, assuming there are no constraints). *) module Renaming : sig type t val identity : t val add_universally_bound : t -> string loc -> t type binding_kind = | Universally_bound of string | Existentially_bound val binding_kind : t -> string -> binding_kind val of_gadt : string list -> constructor_declaration -> t end = struct type error = string Loc.t type t = (string, error) Result.t Map.M(String).t option let identity = None type binding_kind = | Universally_bound of string | Existentially_bound let add_universally_bound (t : t) name : t = let name = name.txt in match t with | None -> None | Some map -> Some (Map.set ~key:name ~data:(Ok name) map) ;; let binding_kind t var = match t with | None -> Universally_bound var | Some map -> (match Map.find map var with | None -> Existentially_bound | Some (Ok value) -> Universally_bound value | Some (Error { loc; txt }) -> Location.raise_errorf ~loc "%s" txt) ;; (* Return a map translating type variables appearing in the return type of a GADT constructor to their name in the type parameter list. For instance: {[ type ('a, 'b) t = X : 'x * 'y -> ('x, 'y) t ]} will produce: {[ "x" -> Ok "a" "y" -> Ok "b" ]} If a variable appears twice in the return type it will map to [Error _]. If a variable cannot be mapped to a parameter of the type declaration, it will map to [Error] (for instance [A : 'a -> 'a list t]). It returns None on user error, to let the typer give the error message *) let of_gadt = (* Add all type variables of a type to a map. *) let add_typevars = object inherit [(string, error) Result.t Map.M(String).t] Ast_traverse.fold as super method! core_type ty map = match ty.ptyp_desc with | Ptyp_var var -> let error = { loc = ty.ptyp_loc ; txt = "ppx_yojson_conv: variable is not a parameter of the type constructor" } in Map.set map ~key:var ~data:(Error error) | _ -> super#core_type ty map end in let aux map tp_name tp_in_return_type = match tp_in_return_type.ptyp_desc with | Ptyp_var var -> let data = if Map.mem map var then ( let loc = tp_in_return_type.ptyp_loc in Error { loc; txt = "ppx_yojson_conv: duplicate variable" }) else Ok tp_name in Map.set map ~key:var ~data | _ -> add_typevars#core_type tp_in_return_type map in fun tps cd -> match cd.pcd_res with | None -> None | Some ty -> (match ty.ptyp_desc with | Ptyp_constr (_, params) -> if List.length params <> List.length tps then None else Some (Stdlib.ListLabels.fold_left2 tps params ~init:(Map.empty (module String)) ~f:aux) | _ -> None) ;; end (* Utility functions *) let replace_variables_by_underscores = let map = object inherit Ast_traverse.map as super method! core_type_desc = function | Ptyp_var _ -> Ptyp_any | t -> super#core_type_desc t end in map#core_type ;; let rigid_type_var ~type_name x = let prefix = "rigid_" in if String.equal x type_name || String.is_prefix x ~prefix then prefix ^ x ^ "_of_type_" ^ type_name else x ;; let make_type_rigid ~type_name = let map = object inherit Ast_traverse.map as super method! core_type ty = let ptyp_desc = match ty.ptyp_desc with | Ptyp_var s -> Ptyp_constr (Located.lident ~loc:ty.ptyp_loc (rigid_type_var ~type_name s), []) | desc -> super#core_type_desc desc in { ty with ptyp_desc } end in map#core_type ;; (* Generates the quantified type [ ! 'a .. 'z . (make_mono_type t ('a .. 'z)) ] or [type a .. z. make_mono_type t (a .. z)] when [use_rigid_variables] is true. Annotation are needed for non regular recursive datatypes and gadt when the return type of constructors are constrained. Unfortunately, putting rigid variables everywhere does not work because of certains types with constraints. We thus only use rigid variables for sum types, which includes all GADTs. *) let tvars_of_core_type : core_type -> string list = let tvars = object inherit [string list] Ast_traverse.fold as super method! core_type x acc = match x.ptyp_desc with | Ptyp_var x -> if List.mem acc x ~equal:String.equal then acc else x :: acc | _ -> super#core_type x acc end in fun typ -> List.rev (tvars#core_type typ []) ;; let constrained_function_binding (* placing a suitably polymorphic or rigid type constraint on the pattern or body *) (loc : Location.t) (td : type_declaration) (typ : core_type) ~(tps : string loc list) ~(func_name : string) (body : expression) = let vars = tvars_of_core_type typ in let has_vars = match vars with | [] -> false | _ :: _ -> true in let pat = let pat = pvar ~loc func_name in if not has_vars then pat else ( let vars = List.map ~f:(fun txt -> { txt; loc }) vars in ppat_constraint ~loc pat (ptyp_poly ~loc vars typ)) in let body = let use_rigid_variables = match td.ptype_kind with | Ptype_variant _ -> true | _ -> false in if use_rigid_variables then ( let type_name = td.ptype_name.txt in List.fold_right tps ~f:(fun tp body -> pexp_newtype ~loc { txt = rigid_type_var ~type_name tp.txt; loc = tp.loc } body) ~init:(pexp_constraint ~loc body (make_type_rigid ~type_name typ))) else if has_vars then body else pexp_constraint ~loc body typ in value_binding ~loc ~pat ~expr:body ;; let really_recursive rec_flag tds = (object inherit type_is_recursive rec_flag tds as super method! core_type ctype = match ctype with | _ when Option.is_some (Attribute.get ~mark_as_seen:false Attrs.opaque ctype) -> () | [%type: [%t? _] yojson_opaque] -> () | _ -> super#core_type ctype end) #go () ;; (* Generates the signature for type conversion to Yojsons *) module Sig_generate_yojson_of = struct let type_of_yojson_of ~loc t = [%type: [%t t] -> Ppx_yojson_conv_lib.Yojson.Safe.t] let mk_type td = combinator_type_of_type_declaration td ~f:type_of_yojson_of let mk_sig ~loc:_ ~path:_ (_rf, tds) = List.map tds ~f:(fun td -> let loc = td.ptype_loc in psig_value ~loc (value_description ~loc ~name:(Located.map (( ^ ) "yojson_of_") td.ptype_name) ~type_:(mk_type td) ~prim:[])) ;; end (* Generates the signature for type conversion from Yojsons *) module Sig_generate_of_yojson = struct let type_of_of_yojson ~loc t = [%type: Ppx_yojson_conv_lib.Yojson.Safe.t -> [%t t]] let mk_type td = combinator_type_of_type_declaration td ~f:type_of_of_yojson let sig_of_td with_poly td = let of_yojson_type = mk_type td in let loc = { td.ptype_loc with loc_ghost = true } in let of_yojson_item = psig_value ~loc (value_description ~loc ~name:(Located.map (fun s -> s ^ "_of_yojson") td.ptype_name) ~type_:of_yojson_type ~prim:[]) in match with_poly, is_polymorphic_variant td ~sig_:true with | true, `Surely_not -> Location.raise_errorf ~loc "Sig_generate_of_yojson.sig_of_td: yojson_poly annotation but type is surely not \ a polymorphic variant" | false, (`Surely_not | `Maybe) -> [ of_yojson_item ] | (true | false), `Definitely | true, `Maybe -> [ of_yojson_item ; psig_value ~loc (value_description ~loc ~name:(Located.map (fun s -> "__" ^ s ^ "_of_yojson__") td.ptype_name) ~type_:of_yojson_type ~prim:[]) ] ;; let mk_sig ~poly ~loc:_ ~path:_ (_rf, tds) = List.concat_map tds ~f:(sig_of_td poly) end module Str_generate_yojson_of = struct (* Handling of record defaults *) let yojson_of_type_constr ~loc id args = type_constr_conv ~loc id ~f:(fun s -> "yojson_of_" ^ s) args ;; (* Conversion of types *) let rec yojson_of_type ~(typevar_handling : [ `ok of Renaming.t | `disallowed_in_type_expr ]) typ : Fun_or_match.t = let loc = { typ.ptyp_loc with loc_ghost = true } in match typ with | _ when Option.is_some (Attribute.get Attrs.opaque typ) -> Fun [%expr Ppx_yojson_conv_lib.Yojson_conv.yojson_of_opaque] | [%type: _] -> Fun [%expr fun _ -> `String "_"] | [%type: [%t? _] yojson_opaque] -> Fun [%expr Ppx_yojson_conv_lib.Yojson_conv.yojson_of_opaque] | { ptyp_desc = Ptyp_tuple tp; _ } -> Match [ yojson_of_tuple ~typevar_handling (loc, tp) ] | { ptyp_desc = Ptyp_var parm; _ } -> (match typevar_handling with | `disallowed_in_type_expr -> Location.raise_errorf ~loc "Type variables not allowed in [%%yojson_of: ]. Please use locally abstract \ types instead." | `ok renaming -> (match Renaming.binding_kind renaming parm with | Universally_bound parm -> Fun (evar ~loc ("_of_" ^ parm)) | Existentially_bound -> yojson_of_type ~typevar_handling [%type: _])) | { ptyp_desc = Ptyp_constr (id, args); _ } -> Fun (yojson_of_type_constr ~loc id (List.map args ~f:(fun tp -> Fun_or_match.expr ~loc (yojson_of_type ~typevar_handling tp)))) | { ptyp_desc = Ptyp_arrow (_, _, _); _ } -> Fun [%expr fun _f -> Ppx_yojson_conv_lib.Yojson_conv.yojson_of_fun Ppx_yojson_conv_lib.ignore] | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> yojson_of_variant ~typevar_handling (loc, row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> yojson_of_poly ~typevar_handling parms poly_tp | { ptyp_desc = Ptyp_object (_, _); _ } | { ptyp_desc = Ptyp_class (_, _); _ } | { ptyp_desc = Ptyp_alias (_, _); _ } | { ptyp_desc = Ptyp_package _; _ } | { ptyp_desc = Ptyp_extension _; _ } -> Location.raise_errorf ~loc "Type unsupported for ppx [yojson_of] conversion" (* Conversion of tuples *) and yojson_of_tuple ~typevar_handling (loc, tps) = let fps = List.map ~f:(fun tp -> yojson_of_type ~typevar_handling tp) tps in let bindings, pvars, evars = Fun_or_match.map_tmp_vars ~loc fps in let in_expr = [%expr `List [%e elist ~loc evars]] in let expr = pexp_let ~loc Nonrecursive bindings in_expr in ppat_tuple ~loc pvars --> expr (* Conversion of variant types *) and yojson_of_variant ~typevar_handling ((loc, row_fields) : Location.t * row_field list) : Fun_or_match.t = let item row = let name_override = Attribute.get Attrs.yojson_polymorphic_variant_name row in match row.prf_desc with | Rtag (cnstr, true, []) -> let label = Label_with_name.create ~label:cnstr.txt ~name_override in ppat_variant ~loc (Label_with_name.label label) None --> [%expr `List [ `String [%e estring ~loc (Label_with_name.name label)] ]] | Rtag (cnstr, false, [ tp ]) -> let label = Label_with_name.create ~label:cnstr.txt ~name_override in let args = match tp.ptyp_desc with | Ptyp_tuple tps -> tps | _ -> [ tp ] in let cnstr_expr = [%expr `String [%e estring ~loc (Label_with_name.name label)]] in let yojson_of_args = List.map ~f:(yojson_of_type ~typevar_handling) args in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc yojson_of_args in let patt = match patts with | [ patt ] -> patt | _ -> ppat_tuple ~loc patts in ppat_variant (Label_with_name.label label) ~loc (Some patt) --> pexp_let ~loc Nonrecursive bindings [%expr `List [%e elist ~loc (cnstr_expr :: vars)]] | Rinherit { ptyp_desc = Ptyp_constr (id, []); _ } -> ppat_alias ~loc (ppat_type ~loc id) (Loc.make "v" ~loc) --> yojson_of_type_constr ~loc id [ [%expr v] ] | Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) -> Location.raise_errorf ~loc "unsupported: yojson_of_variant/Rtag/&" | Rinherit ({ ptyp_desc = Ptyp_constr (id, _ :: _); _ } as typ) -> let call = Fun_or_match.expr ~loc (yojson_of_type ~typevar_handling typ) in ppat_alias ~loc (ppat_type ~loc id) (Loc.make "v" ~loc) --> [%expr [%e call] v] | Rinherit _ -> Location.raise_errorf ~loc "unsupported: yojson_of_variant/Rinherit/non-id" (* impossible?*) | Rtag (_, false, []) -> assert false in Match (List.map ~f:item row_fields) (* Polymorphic record fields *) and yojson_of_poly ~typevar_handling parms tp = let loc = tp.ptyp_loc in match typevar_handling with | `disallowed_in_type_expr -> (* Should be impossible because [yojson_of_poly] is only called on polymorphic record fields and record type definitions can't occur in type expressions. *) Location.raise_errorf ~loc "polymorphic type in a type expression" | `ok renaming -> let bindings = let mk_binding parm = value_binding ~loc ~pat:(pvar ~loc ("_of_" ^ parm.txt)) ~expr:[%expr Ppx_yojson_conv_lib.Yojson_conv.yojson_of_opaque] in List.map ~f:mk_binding parms in let renaming = List.fold_left parms ~init:renaming ~f:Renaming.add_universally_bound in (match yojson_of_type ~typevar_handling:(`ok renaming) tp with | Fun fun_expr -> Fun (pexp_let ~loc Nonrecursive bindings fun_expr) | Match matchings -> Match [ [%pat? arg] --> pexp_let ~loc Nonrecursive bindings (pexp_match ~loc [%expr arg] matchings) ]) ;; (* Conversion of record types *) let mk_rec_patt loc patt name = let p = Loc.make (Longident.Lident name) ~loc, pvar ~loc ("v_" ^ name) in patt @ [ p ] ;; type is_empty_expr = | Inspect_value of (location -> expression -> expression) | Inspect_yojson of (cnv_expr:expression -> location -> expression -> expression) let yojson_of_record_field ~renaming patt expr name tp ?yojson_of is_empty_expr key = let loc = { tp.ptyp_loc with loc_ghost = true } in let patt = mk_rec_patt loc patt name in let cnv_expr = match yojson_of_type ~typevar_handling:(`ok renaming) tp with | Fun exp -> exp | Match matchings -> [%expr fun el -> [%e pexp_match ~loc [%expr el] matchings]] in let cnv_expr = match yojson_of with | None -> cnv_expr | Some yojson_of -> [%expr [%e yojson_of] [%e cnv_expr]] in let expr = let v_name = "v_" ^ name in [%expr let bnds = [%e match is_empty_expr with | Inspect_value is_empty_expr -> [%expr if [%e is_empty_expr loc (evar ~loc v_name)] then bnds else ( let arg = [%e cnv_expr] [%e evar ~loc v_name] in let bnd = [%e estring ~loc key], arg in bnd :: bnds)] | Inspect_yojson is_empty_expr -> [%expr let arg = [%e cnv_expr] [%e evar ~loc v_name] in if [%e is_empty_expr ~cnv_expr loc [%expr arg]] then bnds else ( let bnd = [%e estring ~loc key], arg in bnd :: bnds)]] in [%e expr]] in patt, expr ;; let disallow_type_variables_and_recursive_occurrences ~types_being_defined ~loc ~why tp = let disallow_variables = let iter = object inherit Ast_traverse.iter as super method! core_type_desc = function | Ptyp_var v -> Location.raise_errorf ~loc "[@yojson_drop_default.%s] was used, but the type of the field contains \ a type variable: '%s.\n\ Comparison is not avaiable for type variables.\n\ Consider using [@yojson_drop_if _] or [@yojson_drop_default.yojson] \ instead." (match why with | `compare -> "compare" | `equal -> "equal") v | t -> super#core_type_desc t end in iter#core_type in let disallow_recursive_occurrences = match types_being_defined with | `Nonrecursive -> fun _ -> () | `Recursive types_being_defined -> let iter = object inherit Ast_traverse.iter as super method! core_type_desc = function | Ptyp_constr ({ loc = _; txt = Lident s }, _) as t -> if Set.mem types_being_defined s then Location.raise_errorf ~loc "[@yojson_drop_default.%s] was used, but the type of the field \ contains a type defined in the current recursive block: %s.\n\ This is not supported.\n\ Consider using [@yojson_drop_if _] or [@yojson_drop_default.yojson] \ instead." (match why with | `compare -> "compare" | `equal -> "equal") s; super#core_type_desc t | t -> super#core_type_desc t end in iter#core_type in disallow_variables tp; disallow_recursive_occurrences tp ;; let yojson_of_default_field ~types_being_defined how ~renaming patt expr name tp ?yojson_of default key = let is_empty = match how with | `yojson -> Inspect_yojson (fun ~cnv_expr loc yojson_expr -> [%expr Ppx_yojson_conv_lib.poly_equal ([%e cnv_expr] [%e default]) [%e yojson_expr]]) | (`no_arg | `func _ | `compare | `equal) as how -> let equality_f loc = match how with | `no_arg -> [%expr Ppx_yojson_conv_lib.poly_equal [@ocaml.ppwarning "[@yojson_drop_default] is deprecated: \ please use one of:\n\ - [@yojson_drop_default f] and give an \ explicit equality function ([f = \ Poly.(=)] corresponds to the old \ behavior)\n\ - [@yojson_drop_default.compare] if the \ type supports [%compare]\n\ - [@yojson_drop_default.equal] if the \ type supports [%equal]\n\ - [@yojson_drop_default.yojson] if you \ want to compare the yojson \ representations\n"]] | `func f -> f | `compare -> disallow_type_variables_and_recursive_occurrences ~types_being_defined ~why:`compare ~loc tp; [%expr [%compare.equal: [%t tp]]] | `equal -> disallow_type_variables_and_recursive_occurrences ~types_being_defined ~why:`equal ~loc tp; [%expr [%equal: [%t tp]]] in Inspect_value (fun loc expr -> [%expr [%e equality_f loc] [%e default] [%e expr]]) in yojson_of_record_field ~renaming patt expr name tp ?yojson_of is_empty key ;; let yojson_of_label_declaration_list ~types_being_defined ~renaming loc flds ~wrap_expr = let coll ((patt : (Longident.t loc * pattern) list), expr) ld = let name = ld.pld_name.txt in let key = Option.value ~default:ld.pld_name.txt (Attribute.get Attrs.yojson_key ld) in let loc = { ld.pld_name.loc with loc_ghost = true } in match Attrs.Record_field_handler.Yojson_of.create ~loc ld with | `yojson_option tp -> let patt = mk_rec_patt loc patt name in let vname = [%expr v] in let cnv_expr = Fun_or_match.unroll ~loc vname (yojson_of_type ~typevar_handling:(`ok renaming) tp) in let expr = [%expr let bnds = match [%e evar ~loc ("v_" ^ name)] with | Ppx_yojson_conv_lib.Option.None -> bnds | Ppx_yojson_conv_lib.Option.Some v -> let arg = [%e cnv_expr] in let bnd = [%e estring ~loc key], arg in bnd :: bnds in [%e expr]] in patt, expr | `drop_default how -> let tp = ld.pld_type in (match Attribute.get Attrs.default ld with | None -> Location.raise_errorf ~loc "no default to drop" | Some default -> yojson_of_default_field ~types_being_defined how ~renaming patt expr name tp default key) | `drop_if test -> let tp = ld.pld_type in yojson_of_record_field ~renaming patt expr name tp (Inspect_value (fun loc expr -> [%expr [%e test] [%e expr]])) key | `keep as test -> let tp = ld.pld_type in let patt = mk_rec_patt loc patt name in let vname = evar ~loc ("v_" ^ name) in let cnv_expr = Fun_or_match.unroll ~loc vname (yojson_of_type ~typevar_handling:(`ok renaming) tp) in let bnds = match test with | `keep -> [%expr let arg = [%e cnv_expr] in ([%e estring ~loc key], arg) :: bnds] | `omit_nil -> [%expr match [%e cnv_expr] with | `Null -> bnds | arg -> ([%e estring ~loc key], arg) :: bnds] in ( patt , [%expr let bnds = [%e bnds] in [%e expr]] ) in let init_expr = wrap_expr [%expr bnds] in let patt, expr = List.fold_left ~f:coll ~init:([], init_expr) flds in ( ppat_record ~loc patt Closed , [%expr let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in [%e expr]] ) ;; (* Conversion of sum types *) let branch_sum ~types_being_defined renaming ~loc constr_lid constr_str args = match args with | Pcstr_record lds -> let cnstr_expr = [%expr `String [%e constr_str]] in let patt, expr = yojson_of_label_declaration_list ~types_being_defined ~renaming loc lds ~wrap_expr:(fun expr -> [%expr `List [ [%e cnstr_expr]; `Assoc [%e expr] ]]) in ppat_construct ~loc constr_lid (Some patt) --> expr | Pcstr_tuple pcd_args -> (match pcd_args with | [] -> ppat_construct ~loc constr_lid None --> [%expr `List [ `String [%e constr_str] ]] | args -> let yojson_of_args = List.map ~f:(yojson_of_type ~typevar_handling:(`ok renaming)) args in let cnstr_expr = [%expr `String [%e constr_str]] in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc yojson_of_args in let patt = match patts with | [ patt ] -> patt | _ -> ppat_tuple ~loc patts in ppat_construct ~loc constr_lid (Some patt) --> pexp_let ~loc Nonrecursive bindings [%expr `List [%e elist ~loc (cnstr_expr :: vars)]]) ;; let yojson_of_sum ~types_being_defined tps cds = Fun_or_match.Match (List.map cds ~f:(fun cd -> let renaming = Renaming.of_gadt tps cd in let constr_lid = Located.map lident cd.pcd_name in let constr_name = let label = Label_with_name.of_constructor_declaration cd in Label_with_name.name label |> estring ~loc:cd.pcd_name.loc in branch_sum ~types_being_defined renaming ~loc:cd.pcd_loc constr_lid constr_name cd.pcd_args)) ;; (* Empty type *) let yojson_of_nil loc = Fun_or_match.Fun [%expr fun _v -> assert false] (* Generate code from type definitions *) let yojson_of_td ~types_being_defined td = let td = name_type_params_in_td td in let tps = List.map td.ptype_params ~f:get_type_param_name in let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in let body = let body = match td.ptype_kind with | Ptype_variant cds -> yojson_of_sum ~types_being_defined (List.map tps ~f:(fun x -> x.txt)) cds | Ptype_record lds -> let renaming = Renaming.identity in let patt, expr = yojson_of_label_declaration_list ~renaming loc lds ~types_being_defined ~wrap_expr:(fun expr -> [%expr `Assoc [%e expr]]) in Match [ patt --> expr ] | Ptype_open -> Location.raise_errorf ~loc "ppx_yojson_conv: open types not supported" | Ptype_abstract -> (match td.ptype_manifest with | None -> yojson_of_nil loc | Some ty -> yojson_of_type ~typevar_handling:(`ok Renaming.identity) ty) in let is_private_alias = match td.ptype_kind, td.ptype_manifest, td.ptype_private with | Ptype_abstract, Some _, Private -> true | _ -> false in if is_private_alias then ( (* Replace all type variable by _ to avoid generalization problems *) let ty_src = core_type_of_type_declaration td |> replace_variables_by_underscores in let manifest = match td.ptype_manifest with | Some manifest -> manifest | None -> Location.raise_errorf ~loc "yojson_of_td/no-manifest" in let ty_dst = replace_variables_by_underscores manifest in let coercion = [%expr (v : [%t ty_src] :> [%t ty_dst])] in match body with | Fun fun_expr -> [%expr fun v -> [%e eapply ~loc fun_expr [ coercion ]]] | Match matchings -> [%expr fun v -> [%e pexp_match ~loc coercion matchings]]) else ( match body with (* Prevent violation of value restriction and problems with recursive types by eta-expanding function definitions *) | Fun fun_expr -> [%expr fun v -> [%e eapply ~loc fun_expr [ [%expr v] ]]] | Match matchings -> pexp_function ~loc matchings) in let typ = Sig_generate_yojson_of.mk_type td in let func_name = "yojson_of_" ^ type_name in let body = let patts = List.map tps ~f:(fun id -> pvar ~loc ("_of_" ^ id.txt)) in let rec_flag = match types_being_defined with | `Recursive _ -> Recursive | `Nonrecursive -> Nonrecursive in eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts body) in [ constrained_function_binding loc td typ ~tps ~func_name body ] ;; let yojson_of_tds ~loc ~path:_ (rec_flag, tds) = let rec_flag = really_recursive rec_flag tds in let types_being_defined = match rec_flag with | Nonrecursive -> `Nonrecursive | Recursive -> `Recursive (Set.of_list (module String) (List.map tds ~f:(fun td -> td.ptype_name.txt))) in let bindings = List.concat_map tds ~f:(yojson_of_td ~types_being_defined) in pstr_value_list ~loc rec_flag bindings ;; end module Str_generate_yojson_fields = struct let yojson_fields_of_label_declaration_list loc flds = let coll ld = let key = Option.value ~default:ld.pld_name.txt (Attribute.get Attrs.yojson_key ld) in let loc = ld.pld_name.loc in estring ~loc key in elist ~loc (List.map ~f:coll flds) ;; let yojson_fields_of_td td = let td = name_type_params_in_td td in let tps = List.map td.ptype_params ~f:get_type_param_name in let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in let body = match td.ptype_kind with | Ptype_record lds -> yojson_fields_of_label_declaration_list loc lds | Ptype_variant _ | Ptype_open | Ptype_abstract -> Location.raise_errorf ~loc "ppx_yojson_conv: yojson_fields only works on records" in let typ = [%type: string list] in let func_name = "yojson_fields_of_" ^ type_name in let body = let patts = List.map tps ~f:(fun id -> pvar ~loc ("_fields_of_" ^ id.txt)) in eta_reduce_if_possible (eabstract ~loc patts body) in constrained_function_binding loc td typ ~tps ~func_name body ;; let yojson_fields_of_tds ~loc ~path:_ (_, tds) = pstr_value_list ~loc Nonrecursive (List.map tds ~f:yojson_fields_of_td) ;; end module Str_generate_of_yojson = struct (* Utility functions for polymorphic variants *) (* Handle backtracking when variants do not match *) let handle_no_variant_match loc expr = [ [%pat? Ppx_yojson_conv_lib.Yojson_conv_error.No_variant_match] --> expr ] ;; (* Generate code depending on whether to generate a match for the last case of matching a variant *) let handle_variant_match_last loc ~match_last matches = match match_last, matches with | true, [ { pc_lhs = _; pc_guard = None; pc_rhs = expr } ] | _, [ { pc_lhs = [%pat? _]; pc_guard = None; pc_rhs = expr } ] -> expr | _ -> pexp_match ~loc [%expr atom] matches ;; (* Generate code for matching malformed Yojsons *) let mk_variant_other_matches loc ~rev_els call = let coll_structs acc (loc, label) = (pstring ~loc (Label_with_name.name label) --> match call with | `ptag_no_args -> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.ptag_no_args _tp_loc _yojson] | `ptag_takes_args -> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.ptag_takes_args _tp_loc _yojson]) :: acc in let exc_no_variant_match = [%pat? _] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.no_variant_match ()] in List.fold_left ~f:coll_structs ~init:[ exc_no_variant_match ] rev_els ;; (* Split the row fields of a variant type into lists of atomic variants, structured variants, atomic variants + included variant types, and structured variants + included variant types. *) let split_row_field ~loc (atoms, structs, ainhs, sinhs) row_field = let name_override = Attribute.get Attrs.yojson_polymorphic_variant_name row_field in match row_field.prf_desc with | Rtag (cnstr, true, []) -> let label = Label_with_name.create ~label:cnstr.txt ~name_override in let tpl = loc, label in tpl :: atoms, structs, `A tpl :: ainhs, sinhs | Rtag (cnstr, false, [ tp ]) -> let label = Label_with_name.create ~label:cnstr.txt ~name_override in let loc = tp.ptyp_loc in atoms, (loc, label) :: structs, ainhs, `S (loc, label, tp, row_field) :: sinhs | Rinherit inh -> let iinh = `I inh in atoms, structs, iinh :: ainhs, iinh :: sinhs | Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) -> Location.raise_errorf ~loc "split_row_field/&" | Rtag (_, false, []) -> assert false ;; let type_constr_of_yojson ?(internal = false) ~loc id args = type_constr_conv id args ~loc ~f:(fun s -> let s = s ^ "_of_yojson" in if internal then "__" ^ s ^ "__" else s) ;; (* Conversion of types *) let rec type_of_yojson ~typevar_handling ?full_type ?(internal = false) typ : Fun_or_match.t = let loc = { typ.ptyp_loc with loc_ghost = true } in match typ with | _ when Option.is_some (Attribute.get Attrs.opaque typ) -> Fun [%expr Ppx_yojson_conv_lib.Yojson_conv.opaque_of_yojson] | [%type: [%t? _] yojson_opaque] | [%type: _] -> Fun [%expr Ppx_yojson_conv_lib.Yojson_conv.opaque_of_yojson] | { ptyp_desc = Ptyp_tuple tp; _ } -> Match (tuple_of_yojson ~typevar_handling (loc, tp)) | { ptyp_desc = Ptyp_var parm; _ } -> (match typevar_handling with | `ok -> Fun (evar ~loc ("_of_" ^ parm)) | `disallowed_in_type_expr -> Location.raise_errorf ~loc "Type variables not allowed in [%%of_yojson: ]. Please use locally abstract \ types instead.") | { ptyp_desc = Ptyp_constr (id, args); _ } -> let args = List.map args ~f:(fun arg -> Fun_or_match.expr ~loc (type_of_yojson ~typevar_handling arg)) in Fun (type_constr_of_yojson ~loc ~internal id args) | { ptyp_desc = Ptyp_arrow (_, _, _); _ } -> Fun [%expr Ppx_yojson_conv_lib.Yojson_conv.fun_of_yojson] | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> variant_of_yojson ~typevar_handling ?full_type (loc, row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> poly_of_yojson ~typevar_handling parms poly_tp | { ptyp_desc = Ptyp_object (_, _); _ } | { ptyp_desc = Ptyp_class (_, _); _ } | { ptyp_desc = Ptyp_alias (_, _); _ } | { ptyp_desc = Ptyp_package _; _ } | { ptyp_desc = Ptyp_extension _; _ } -> Location.raise_errorf ~loc "Type unsupported for ppx [of_yojson] conversion" (* Conversion of tuples *) and tuple_of_yojson ~typevar_handling (loc, tps) = let fps = List.map ~f:(type_of_yojson ~typevar_handling) tps in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc fps in let n = List.length fps in [ [%pat? `List [%p plist ~loc patts]] --> pexp_let ~loc Nonrecursive bindings (pexp_tuple ~loc vars) ; [%pat? yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.tuple_of_size_n_expected _tp_loc [%e eint ~loc n] yojson] ] (* Generate code for matching included variant types *) and handle_variant_inh ~typevar_handling full_type ~match_last other_matches inh = let loc = inh.ptyp_loc in let func_expr = type_of_yojson ~typevar_handling ~internal:true inh in let app : Fun_or_match.t = let fun_expr = Fun_or_match.expr ~loc func_expr in Fun [%expr [%e fun_expr] _yojson] in let match_exc = handle_no_variant_match loc (handle_variant_match_last loc ~match_last other_matches) in let new_other_matches = [ [%pat? _] --> pexp_try ~loc [%expr ([%e Fun_or_match.expr ~loc app] :> [%t replace_variables_by_underscores full_type])] match_exc ] in new_other_matches, true (* Generate code for matching atomic variants *) and mk_variant_match_atom ~typevar_handling loc full_type ~rev_atoms_inhs ~rev_structs = let coll (other_matches, match_last) = function | `A (loc, label) -> let new_match = pstring ~loc (Label_with_name.name label) --> pexp_variant ~loc (Label_with_name.label label) None in new_match :: other_matches, false | `I inh -> handle_variant_inh ~typevar_handling full_type ~match_last other_matches inh in let other_matches = mk_variant_other_matches loc ~rev_els:rev_structs `ptag_takes_args in let match_atoms_inhs, match_last = List.fold_left ~f:coll ~init:(other_matches, false) rev_atoms_inhs in handle_variant_match_last loc ~match_last match_atoms_inhs (* Variant conversions *) (* Match arguments of constructors (variants or sum types) *) and mk_cnstr_args_match ~typevar_handling ~loc ~is_variant label tps = let cnstr_label = Label_with_name.label label in let cnstr vars_expr = if is_variant then pexp_variant ~loc cnstr_label (Some vars_expr) else pexp_construct ~loc (Located.lident ~loc cnstr_label) (Some vars_expr) in let bindings, patts, good_arg_match = let fps = List.map ~f:(type_of_yojson ~typevar_handling) tps in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc fps in let good_arg_match = let vars_expr = match vars with | [ var_expr ] -> var_expr | _ -> pexp_tuple ~loc vars in cnstr vars_expr in bindings, patts, good_arg_match in [%expr match yojson_args with | [%p plist ~loc patts] -> [%e pexp_let ~loc Nonrecursive bindings good_arg_match] | _ -> [%e if is_variant then [%expr Ppx_yojson_conv_lib.Yojson_conv_error.ptag_incorrect_n_args _tp_loc _tag _yojson] else [%expr Ppx_yojson_conv_lib.Yojson_conv_error.stag_incorrect_n_args _tp_loc _tag _yojson]]] (* Generate code for matching structured variants *) and mk_variant_match_struct ~typevar_handling loc full_type ~rev_structs_inhs ~rev_atoms = let has_structs_ref = ref false in let coll (other_matches, match_last) = function | `S (loc, label, tp, _row) -> has_structs_ref := true; let args = match tp.ptyp_desc with | Ptyp_tuple tps -> tps | _ -> [ tp ] in let expr = mk_cnstr_args_match ~typevar_handling ~loc:tp.ptyp_loc ~is_variant:true label args in let new_match = [%pat? [%p pstring ~loc (Label_with_name.name label)] as _tag] --> expr in new_match :: other_matches, false | `I inh -> handle_variant_inh ~typevar_handling full_type ~match_last other_matches inh in let other_matches = mk_variant_other_matches loc ~rev_els:rev_atoms `ptag_no_args in let match_structs_inhs, match_last = List.fold_left ~f:coll ~init:(other_matches, false) rev_structs_inhs in handle_variant_match_last loc ~match_last match_structs_inhs, !has_structs_ref (* Generate code for handling atomic and structured variants (i.e. not included variant types) *) and handle_variant_tag ~typevar_handling loc full_type row_field_list = let rev_atoms, rev_structs, rev_atoms_inhs, rev_structs_inhs = List.fold_left ~f:(split_row_field ~loc) ~init:([], [], [], []) row_field_list in let match_struct, has_structs = mk_variant_match_struct ~typevar_handling loc full_type ~rev_structs_inhs ~rev_atoms in let maybe_yojson_args_patt = if has_structs then [%pat? yojson_args] else [%pat? _] in [ [%pat? `List [ `String atom ] as _yojson] --> mk_variant_match_atom ~typevar_handling loc full_type ~rev_atoms_inhs ~rev_structs ; [%pat? `List (`String atom :: [%p maybe_yojson_args_patt]) as _yojson] --> match_struct ; [%pat? `List (`List _ :: _) as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.nested_list_invalid_poly_var _tp_loc yojson] ; [%pat? `List [] as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.empty_list_invalid_poly_var _tp_loc yojson] ; [%pat? _ as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.unexpected_stag _tp_loc yojson] ] (* Generate matching code for variants *) and variant_of_yojson ~typevar_handling ?full_type (loc, row_fields) = let is_contained, full_type = match full_type with | None -> true, ptyp_variant ~loc row_fields Closed None | Some full_type -> false, full_type in let top_match = match row_fields with | { prf_desc = Rinherit inh; _ } :: rest -> let rec loop inh row_fields = let call = [%expr ([%e Fun_or_match.expr ~loc (type_of_yojson ~typevar_handling ~internal:true inh)] yojson :> [%t replace_variables_by_underscores full_type])] in match row_fields with | [] -> call | h :: t -> let expr = match h.prf_desc with | Rinherit inh -> loop inh t | _ -> let rftag_matches = handle_variant_tag ~typevar_handling loc full_type row_fields in pexp_match ~loc [%expr yojson] rftag_matches in pexp_try ~loc call (handle_no_variant_match loc expr) in [ [%pat? yojson] --> loop inh rest ] | _ :: _ -> handle_variant_tag ~typevar_handling loc full_type row_fields | [] -> assert false (* impossible *) in if is_contained then Fun [%expr fun yojson -> try [%e pexp_match ~loc [%expr yojson] top_match] with | Ppx_yojson_conv_lib.Yojson_conv_error.No_variant_match -> Ppx_yojson_conv_lib.Yojson_conv_error.no_matching_variant_found _tp_loc yojson] else Match top_match and poly_of_yojson ~typevar_handling parms tp = let loc = tp.ptyp_loc in let bindings = let mk_binding parm = value_binding ~loc ~pat:(pvar ~loc ("_of_" ^ parm.txt)) ~expr: [%expr fun yojson -> Ppx_yojson_conv_lib.Yojson_conv_error.record_poly_field_value _tp_loc yojson] in List.map ~f:mk_binding parms in match type_of_yojson ~typevar_handling tp with | Fun fun_expr -> Fun (pexp_let ~loc Nonrecursive bindings fun_expr) | Match matchings -> Match [ [%pat? arg] --> pexp_let ~loc Nonrecursive bindings (pexp_match ~loc [%expr arg] matchings) ] ;; (* Generate code for extracting record fields *) let mk_extract_fields ~typevar_handling ~allow_extra_fields (loc, flds) = let rec loop inits no_args args = function | [] -> inits, no_args, args | ld :: more_flds -> let loc = ld.pld_name.loc in let nm = ld.pld_name.txt in let key = Option.value ~default:nm (Attribute.get Attrs.yojson_key ld) in (match Attrs.Record_field_handler.Of_yojson.create ~loc ld, ld.pld_type with | Some (`yojson_option tp), _ | (None | Some (`default _)), tp -> let inits = [%expr Ppx_yojson_conv_lib.Option.None] :: inits in let unrolled = Fun_or_match.unroll ~loc [%expr _field_yojson] (type_of_yojson ~typevar_handling tp) in let args = (pstring ~loc key --> [%expr match Ppx_yojson_conv_lib.( ! ) [%e evar ~loc (nm ^ "_field")] with | Ppx_yojson_conv_lib.Option.None -> let fvalue = [%e unrolled] in [%e evar ~loc (nm ^ "_field")] := Ppx_yojson_conv_lib.Option.Some fvalue | Ppx_yojson_conv_lib.Option.Some _ -> duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates]) :: args in loop inits no_args args more_flds) in let handle_extra = [ ([%pat? _] --> if allow_extra_fields then [%expr ()] else [%expr if Ppx_yojson_conv_lib.( ! ) Ppx_yojson_conv_lib.Yojson_conv.record_check_extra_fields then extra := field_name :: Ppx_yojson_conv_lib.( ! ) extra else ()]) ] in loop [] handle_extra handle_extra (List.rev flds) ;; (* Generate code for handling the result of matching record fields *) let mk_handle_record_match_result has_poly (loc, flds) ~wrap_expr = let has_nonopt_fields = ref false in let res_tpls, bi_lst, good_patts = let rec loop ((res_tpls, bi_lst, good_patts) as acc) = function | ({ pld_name = { txt = nm; loc }; _ } as ld) :: more_flds -> let fld = [%expr Ppx_yojson_conv_lib.( ! ) [%e evar ~loc (nm ^ "_field")]] in let mk_default loc = bi_lst, [%pat? [%p pvar ~loc (nm ^ "_value")]] :: good_patts in let new_bi_lst, new_good_patts = match Attrs.Record_field_handler.Of_yojson.create ~loc ld with | Some (`default _ | `yojson_option _) -> mk_default loc | None -> has_nonopt_fields := true; ( [%expr Ppx_yojson_conv_lib.poly_equal [%e fld] Ppx_yojson_conv_lib.Option.None , [%e estring ~loc nm]] :: bi_lst , [%pat? Ppx_yojson_conv_lib.Option.Some [%p pvar ~loc (nm ^ "_value")]] :: good_patts ) in let acc = [%expr [%e fld]] :: res_tpls, new_bi_lst, new_good_patts in loop acc more_flds | [] -> acc in loop ([], [], []) (List.rev flds) in let match_good_expr = if has_poly then ( let cnvt = function | { pld_name = { txt = nm; _ }; _ } -> evar ~loc (nm ^ "_value") in match List.map ~f:cnvt flds with | [ match_good_expr ] -> match_good_expr | match_good_exprs -> pexp_tuple ~loc match_good_exprs) else ( let cnvt ld = let nm = ld.pld_name.txt in let value = match Attrs.Record_field_handler.Of_yojson.create ~loc ld with | Some (`default default) -> [%expr match [%e evar ~loc (nm ^ "_value")] with | Ppx_yojson_conv_lib.Option.None -> [%e default] | Ppx_yojson_conv_lib.Option.Some v -> v] | Some (`yojson_option _) | None -> evar ~loc (nm ^ "_value") in Located.lident ~loc nm, value in wrap_expr (pexp_record ~loc (List.map ~f:cnvt flds) None)) in let expr, patt = match res_tpls, good_patts with | [ res_expr ], [ res_patt ] -> res_expr, res_patt | _ -> pexp_tuple ~loc res_tpls, ppat_tuple ~loc good_patts in if !has_nonopt_fields then pexp_match ~loc expr [ patt --> match_good_expr ; [%pat? _] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.record_undefined_elements _tp_loc yojson [%e elist ~loc bi_lst]] ] else pexp_match ~loc expr [ patt --> match_good_expr ] ;; (* Generate code for converting record fields *) let mk_cnv_fields ~typevar_handling ~allow_extra_fields has_poly (loc, flds) ~wrap_expr = let expr_ref_inits, _mc_no_args_fields, mc_fields_with_args = mk_extract_fields ~typevar_handling ~allow_extra_fields (loc, flds) in let field_refs = List.map2_exn flds expr_ref_inits ~f:(fun { pld_name = { txt = name; loc }; _ } init -> value_binding ~loc ~pat:(pvar ~loc (name ^ "_field")) ~expr:[%expr ref [%e init]]) in pexp_let ~loc Nonrecursive (field_refs @ [ value_binding ~loc ~pat:[%pat? duplicates] ~expr:[%expr ref []] ; value_binding ~loc ~pat:[%pat? extra] ~expr:[%expr ref []] ]) [%expr let rec iter = [%e pexp_function ~loc [ [%pat? (field_name, _field_yojson) :: tail] --> [%expr [%e pexp_match ~loc [%expr field_name] mc_fields_with_args]; iter tail] ; [%pat? []] --> [%expr ()] ]] in iter field_yojsons; match Ppx_yojson_conv_lib.( ! ) duplicates with | _ :: _ -> Ppx_yojson_conv_lib.Yojson_conv_error.record_duplicate_fields _tp_loc (Ppx_yojson_conv_lib.( ! ) duplicates) yojson | [] -> (match Ppx_yojson_conv_lib.( ! ) extra with | _ :: _ -> Ppx_yojson_conv_lib.Yojson_conv_error.record_extra_fields _tp_loc (Ppx_yojson_conv_lib.( ! ) extra) yojson | [] -> [%e mk_handle_record_match_result has_poly (loc, flds) ~wrap_expr])] ;; let is_poly (_, flds) = List.exists flds ~f:(function | { pld_type = { ptyp_desc = Ptyp_poly _; _ }; _ } -> true | _ -> false) ;; let label_declaration_list_of_yojson ~typevar_handling ~allow_extra_fields loc flds ~wrap_expr = let has_poly = is_poly (loc, flds) in let cnv_fields = mk_cnv_fields ~typevar_handling ~allow_extra_fields has_poly (loc, flds) ~wrap_expr in if has_poly then ( let patt = let pats = List.map flds ~f:(fun { pld_name = { txt = name; loc }; _ } -> pvar ~loc name) in match pats with | [ pat ] -> pat | pats -> ppat_tuple ~loc pats in let record_def = wrap_expr (pexp_record ~loc (List.map flds ~f:(fun { pld_name = { txt = name; loc }; _ } -> Located.lident ~loc name, evar ~loc name)) None) in pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:patt ~expr:cnv_fields ] record_def) else cnv_fields ;; (* Generate matching code for records *) let record_of_yojson ~typevar_handling ~allow_extra_fields (loc, flds) : Fun_or_match.t = Match [ [%pat? `Assoc field_yojsons as yojson] --> label_declaration_list_of_yojson ~typevar_handling ~allow_extra_fields loc flds ~wrap_expr:(fun x -> x) ; [%pat? _ as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom _tp_loc yojson] ] ;; (* Sum type conversions *) (* Generate matching code for well-formed Yojsons wrt. sum types *) let mk_good_sum_matches ~typevar_handling (loc, cds) = List.map cds ~f:(fun (cd, label) -> let cnstr_label = Label_with_name.label label in let cnstr_name = Label_with_name.name label in match cd with | { pcd_args = Pcstr_record fields; _ } -> let expr = label_declaration_list_of_yojson ~typevar_handling ~allow_extra_fields: (Option.is_some (Attribute.get Attrs.allow_extra_fields_cd cd)) loc fields ~wrap_expr:(fun e -> pexp_construct ~loc (Located.lident ~loc cnstr_label) (Some e)) in [%pat? `List [ `String ([%p pstring ~loc cnstr_name] as _tag); `Assoc field_yojsons ] as yojson] --> expr | { pcd_args = Pcstr_tuple []; _ } -> Attrs.fail_if_allow_extra_field_cd ~loc cd; [%pat? `List [ `String [%p pstring ~loc cnstr_name] ]] --> pexp_construct ~loc (Located.lident ~loc cnstr_label) None | { pcd_args = Pcstr_tuple (_ :: _ as tps); _ } -> Attrs.fail_if_allow_extra_field_cd ~loc cd; [%pat? `List (`String ([%p pstring ~loc cnstr_name] as _tag) :: yojson_args) as _yojson] --> mk_cnstr_args_match ~typevar_handling ~loc ~is_variant:false label tps) ;; (* Generate matching code for malformed Yojsons with good tags wrt. sum types *) let mk_bad_sum_matches (loc, cds) = List.map cds ~f:(fun (cd, label) -> let cnstr_name = Label_with_name.name label in match cd with | { pcd_args = Pcstr_tuple []; _ } -> [%pat? `List (`String [%p pstring ~loc cnstr_name] :: _) as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.stag_no_args _tp_loc yojson] | { pcd_args = Pcstr_tuple (_ :: _) | Pcstr_record _; _ } -> [%pat? `String [%p pstring ~loc cnstr_name] as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.stag_takes_args _tp_loc yojson]) ;; (* Generate matching code for sum types *) let sum_of_yojson ~typevar_handling (loc, alts) : Fun_or_match.t = let alts = List.map alts ~f:(fun cd -> cd, Label_with_name.of_constructor_declaration cd) in Match (List.concat [ mk_good_sum_matches ~typevar_handling (loc, alts) ; mk_bad_sum_matches (loc, alts) ; [ [%pat? `List (`List _ :: _) as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.nested_list_invalid_sum _tp_loc yojson] ; [%pat? `List [] as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.empty_list_invalid_sum _tp_loc yojson] ; [%pat? _ as yojson] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.unexpected_stag _tp_loc yojson] ] ]) ;; (* Empty type *) let nil_of_yojson loc : Fun_or_match.t = Fun [%expr fun yojson -> Ppx_yojson_conv_lib.Yojson_conv_error.empty_type _tp_loc yojson] ;; (* Generate code from type definitions *) let td_of_yojson ~typevar_handling ~loc:_ ~poly ~path ~rec_flag td = let td = name_type_params_in_td td in let tps = List.map td.ptype_params ~f:get_type_param_name in let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in let full_type = core_type_of_type_declaration td |> replace_variables_by_underscores in let is_private = match td.ptype_private with | Private -> true | Public -> false in if is_private then Location.raise_errorf ~loc "of_yojson is not supported for private type"; let create_internal_function = match is_polymorphic_variant td ~sig_:false with | `Definitely -> true | `Maybe -> poly | `Surely_not -> if poly then Location.raise_errorf ~loc "yojson_poly annotation on a type that is surely not a polymorphic variant"; false in let body = let body = match td.ptype_kind with | Ptype_variant alts -> Attrs.fail_if_allow_extra_field_td ~loc td; sum_of_yojson ~typevar_handling (td.ptype_loc, alts) | Ptype_record lbls -> record_of_yojson ~typevar_handling ~allow_extra_fields: (Option.is_some (Attribute.get Attrs.allow_extra_fields_td td)) (loc, lbls) | Ptype_open -> Location.raise_errorf ~loc "ppx_yojson_conv: open types not supported" | Ptype_abstract -> Attrs.fail_if_allow_extra_field_td ~loc td; (match td.ptype_manifest with | None -> nil_of_yojson td.ptype_loc | Some ty -> type_of_yojson ~full_type ~typevar_handling ~internal:create_internal_function ty) in match body with (* Prevent violation of value restriction and problems with recursive types by eta-expanding function definitions *) | Fun fun_expr -> [%expr fun t -> [%e eapply ~loc fun_expr [ [%expr t] ]]] | Match matchings -> pexp_function ~loc matchings in let external_name = type_name ^ "_of_yojson" in let internal_name = "__" ^ type_name ^ "_of_yojson__" in let arg_patts, arg_exprs = List.unzip (List.map ~f:(fun tp -> let name = "_of_" ^ tp.txt in pvar ~loc name, evar ~loc name) tps) in let bind_tp_loc_in = let full_type_name = Printf.sprintf "%s.%s" path type_name in fun e -> match e with | { pexp_desc = Pexp_ident _; _ } -> (* we definitely don't use the string, so clean up the generated code a bit *) e | _ -> [%expr let _tp_loc = [%e estring ~loc full_type_name] in [%e e]] in let internal_fun_body = if create_internal_function then Some (bind_tp_loc_in (eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body))) else None in let external_fun_body = let need_tp_loc, body_below_lambdas = if create_internal_function then ( let no_variant_match_mc = [ [%pat? Ppx_yojson_conv_lib.Yojson_conv_error.No_variant_match] --> [%expr Ppx_yojson_conv_lib.Yojson_conv_error.no_matching_variant_found _tp_loc yojson] ] in let internal_call = let internal_expr = evar ~loc internal_name in eapply ~loc internal_expr (arg_exprs @ [ [%expr yojson] ]) in let try_with = pexp_try ~loc internal_call no_variant_match_mc in false, bind_tp_loc_in [%expr fun yojson -> [%e try_with]]) else true, body in let body_with_lambdas = eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body_below_lambdas) in if need_tp_loc then bind_tp_loc_in body_with_lambdas else body_with_lambdas in let mk_binding func_name body = let typ = Sig_generate_of_yojson.mk_type td in constrained_function_binding loc td typ ~tps ~func_name body in let internal_bindings = match internal_fun_body with | None -> [] | Some body -> [ mk_binding internal_name body ] in let external_binding = mk_binding external_name external_fun_body in internal_bindings, [ external_binding ] ;; (* Generate code from type definitions *) let tds_of_yojson ~loc ~poly ~path (rec_flag, tds) = let typevar_handling = `ok in let singleton = match tds with | [ _ ] -> true | _ -> false in if singleton then ( let rec_flag = really_recursive rec_flag tds in match rec_flag with | Recursive -> let bindings = List.concat_map tds ~f:(fun td -> let internals, externals = td_of_yojson ~typevar_handling ~loc ~poly ~path ~rec_flag td in internals @ externals) in pstr_value_list ~loc Recursive bindings | Nonrecursive -> List.concat_map tds ~f:(fun td -> let internals, externals = td_of_yojson ~typevar_handling ~loc ~poly ~path ~rec_flag td in pstr_value_list ~loc Nonrecursive internals @ pstr_value_list ~loc Nonrecursive externals)) else ( let bindings = List.concat_map tds ~f:(fun td -> let internals, externals = td_of_yojson ~typevar_handling ~poly ~loc ~path ~rec_flag td in internals @ externals) in pstr_value_list ~loc rec_flag bindings) ;; let type_of_yojson ~typevar_handling ~path ctyp = let loc = { ctyp.ptyp_loc with loc_ghost = true } in let fp = type_of_yojson ~typevar_handling ctyp in let body = match fp with | Fun fun_expr -> [%expr [%e fun_expr] yojson] | Match matchings -> pexp_match ~loc [%expr yojson] matchings in let full_type_name = Printf.sprintf "%s line %i: %s" path loc.loc_start.pos_lnum (string_of_core_type ctyp) in [%expr fun yojson -> let _tp_loc = [%e estring ~loc full_type_name] in [%e body]] ;; end module Yojson_of = struct let type_extension ty = Sig_generate_yojson_of.type_of_yojson_of ~loc:{ ty.ptyp_loc with loc_ghost = true } ty ;; let core_type ty = Str_generate_yojson_of.yojson_of_type ~typevar_handling:`disallowed_in_type_expr ty |> Fun_or_match.expr ~loc:{ ty.ptyp_loc with loc_ghost = true } ;; let sig_type_decl = Sig_generate_yojson_of.mk_sig let str_type_decl = Str_generate_yojson_of.yojson_of_tds end module Yojson_fields = struct let str_type_decl = Str_generate_yojson_fields.yojson_fields_of_tds end module Of_yojson = struct let type_extension ty = Sig_generate_of_yojson.type_of_of_yojson ~loc:{ ty.ptyp_loc with loc_ghost = true } ty ;; let core_type = Str_generate_of_yojson.type_of_yojson ~typevar_handling:`disallowed_in_type_expr ;; let sig_type_decl = Sig_generate_of_yojson.mk_sig let str_type_decl = Str_generate_of_yojson.tds_of_yojson end module Sig_yojson = struct let mk_sig ~loc ~path decls = Sig_generate_yojson_of.mk_sig ~loc ~path decls @ Sig_generate_of_yojson.mk_sig ~poly:false ~loc ~path decls ;; let sig_type_decl ~loc ~path ((_rf, tds) as decls) = match mk_named_sig ~loc ~sg_name:"Ppx_yojson_conv_lib.Yojsonable.S" ~handle_polymorphic_variant:false tds with | Some include_infos -> [ psig_include ~loc include_infos ] | None -> mk_sig ~loc ~path decls ;; end ppx_yojson_conv-0.17.0/expander/ppx_yojson_conv_expander.mli000066400000000000000000000024021461647336100245010ustar00rootroot00000000000000open Ppxlib module Attrs : sig val default : (label_declaration, expression) Attribute.t val drop_default : (label_declaration, expression option) Attribute.t val drop_if : (label_declaration, expression) Attribute.t end module Yojson_of : sig val type_extension : core_type -> core_type val core_type : core_type -> expression val sig_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> signature val str_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure end module Yojson_fields : sig val str_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure end module Of_yojson : sig val type_extension : core_type -> core_type val core_type : path:string -> core_type -> expression val sig_type_decl : poly:bool -> loc:Location.t -> path:string -> rec_flag * type_declaration list -> signature val str_type_decl : loc:Location.t -> poly:bool -> path:string -> rec_flag * type_declaration list -> structure end module Sig_yojson : sig val sig_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> signature end ppx_yojson_conv-0.17.0/ppx_yojson_conv.opam000066400000000000000000000016221461647336100211630ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_yojson_conv" bug-reports: "https://github.com/janestreet/ppx_yojson_conv/issues" dev-repo: "git+https://github.com/janestreet/ppx_yojson_conv.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_yojson_conv/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppx_js_style" {>= "v0.17" & < "v0.18"} "ppx_yojson_conv_lib" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "[@@deriving] plugin to generate Yojson conversion functions" description: " Part of the Jane Street's PPX rewriters collection. " ppx_yojson_conv-0.17.0/src/000077500000000000000000000000001461647336100156365ustar00rootroot00000000000000ppx_yojson_conv-0.17.0/src/dune000066400000000000000000000002451461647336100165150ustar00rootroot00000000000000(library (name ppx_yojson_conv) (public_name ppx_yojson_conv) (kind ppx_deriver) (libraries ppxlib ppx_yojson_conv_expander) (preprocess (pps ppx_js_style))) ppx_yojson_conv-0.17.0/src/ppx_yojson_conv.ml000066400000000000000000000057311461647336100214330ustar00rootroot00000000000000(* yojson_conv: Preprocessing Module for Automated Yojson Conversions *) open Ppxlib module Attrs = Ppx_yojson_conv_expander.Attrs module Yojson_of = struct module E = Ppx_yojson_conv_expander.Yojson_of let name = "yojson_of" let str_type_decl = Deriving.Generator.make_noarg E.str_type_decl ~attributes: [ Attribute.T Attrs.default ; Attribute.T Attrs.drop_default ; Attribute.T Attrs.drop_if ] ;; let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl let extension ~loc:_ ~path:_ ctyp = E.core_type ctyp let deriver = Deriving.add name ~str_type_decl ~sig_type_decl ~extension let () = Driver.register_transformation name ~rules: [ Context_free.Rule.extension (Extension.declare name Core_type Ast_pattern.(ptyp __) (fun ~loc:_ ~path:_ ty -> E.type_extension ty)) ] ;; end module Yojson_fields = struct module E = Ppx_yojson_conv_expander.Yojson_fields let name = "yojson_fields" let str_type_decl = Deriving.Generator.make_noarg E.str_type_decl ~attributes:[] let deriver = Deriving.add name ~str_type_decl end module Of_yojson = struct module E = Ppx_yojson_conv_expander.Of_yojson let name = "of_yojson" let str_type_decl = Deriving.Generator.make_noarg (E.str_type_decl ~poly:false) ~attributes:[ Attribute.T Attrs.default ] ;; let sig_type_decl = Deriving.Generator.make_noarg (E.sig_type_decl ~poly:false) let extension ~loc:_ ~path ctyp = E.core_type ~path ctyp let deriver = Deriving.add name ~str_type_decl ~sig_type_decl ~extension let () = Driver.register_transformation name ~rules: [ Context_free.Rule.extension (Extension.declare name Core_type Ast_pattern.(ptyp __) (fun ~loc:_ ~path:_ ty -> E.type_extension ty)) ] ;; end module Of_yojson_poly = struct module E = Ppx_yojson_conv_expander.Of_yojson let str_type_decl = Deriving.Generator.make_noarg (E.str_type_decl ~poly:true) ~attributes:[ Attribute.T Attrs.default ] ;; let sig_type_decl = Deriving.Generator.make_noarg (E.sig_type_decl ~poly:true) let deriver = Deriving.add "of_yojson_poly" ~sig_type_decl ~str_type_decl end let yojson_of = Yojson_of.deriver let yojson_fields_of = Yojson_fields.deriver let of_yojson = Of_yojson.deriver let of_yojson_poly = Of_yojson_poly.deriver module Yojson_in_sig = struct module E = Ppx_yojson_conv_expander.Sig_yojson let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl let deriver = Deriving.add "ppx_yojson_conv: let this be a string that wouldn't parse if put in the source" ~sig_type_decl ;; end let yojson = Deriving.add_alias "yojson" [ yojson_of; of_yojson ] ~sig_type_decl:[ Yojson_in_sig.deriver ] ;; let yojson_poly = Deriving.add_alias "yojson_poly" [ yojson_of; of_yojson_poly ] ppx_yojson_conv-0.17.0/src/ppx_yojson_conv.mli000066400000000000000000000002721461647336100215770ustar00rootroot00000000000000open Ppxlib val of_yojson : Deriving.t val yojson_of : Deriving.t val yojson_fields_of : Deriving.t val yojson : Deriving.t val of_yojson_poly : Deriving.t val yojson_poly : Deriving.t ppx_yojson_conv-0.17.0/test/000077500000000000000000000000001461647336100160265ustar00rootroot00000000000000ppx_yojson_conv-0.17.0/test/dune000066400000000000000000000002631461647336100167050ustar00rootroot00000000000000(library (name ppx_yojson_conv_test) (libraries base expect_test_helpers_core base_yojson) (flags :standard -w -30) (preprocess (pps ppx_jane ppx_yojson_conv ppx_compare))) ppx_yojson_conv-0.17.0/test/errors.mlt000066400000000000000000000100621461647336100200570ustar00rootroot00000000000000open Base_yojson type t = int [@@deriving yojson] [@@yojson.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: [@@allow_extra_fields] is only allowed on records. |}] type 'a t = 'a option = | None | Some of 'a [@@deriving yojson] [@@yojson.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: [@@allow_extra_fields] is only allowed on records. |}] type 'a t = Some of { a : int } [@@deriving yojson] [@@yojson.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: [@@allow_extra_fields] only works on records. For inline records, do: type t = A of { a : int } [@allow_extra_fields] | B [@@deriving yojson] |}] type 'a t = | Some of { a : int } | None [@yojson.allow_extra_fields] [@@deriving yojson] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: [@allow_extra_fields] is only allowed on inline records. |}] type t = | Non | Som of { next : t [@default Non] [@yojson_drop_default.equal] } [@@deriving yojson] [%%expect {| Line _, characters _-_: Error: [@yojson_drop_default.equal] was used, but the type of the field contains a type defined in the current recursive block: t. This is not supported. Consider using [@yojson_drop_if _] or [@yojson_drop_default.yojson] instead. |}] type nonrec 'a t = { foo : 'a option [@default None] [@yojson_drop_default.equal] } [@@deriving yojson] [%%expect {| Line _, characters _-_: Error: [@yojson_drop_default.equal] was used, but the type of the field contains a type variable: 'a. Comparison is not avaiable for type variables. Consider using [@yojson_drop_if _] or [@yojson_drop_default.yojson] instead. |}] open Base type t = { a : int [@default 8] [@yojson_drop_default] } [@@deriving yojson_of] [%%expect {| Line _, characters _-_: Error (warning 22 [preprocessor]): [@yojson_drop_default] is deprecated: please use one of: - [@yojson_drop_default f] and give an explicit equality function ([f = Poly.(=)] corresponds to the old behavior) - [@yojson_drop_default.compare] if the type supports [%compare] - [@yojson_drop_default.equal] if the type supports [%equal] - [@yojson_drop_default.yojson] if you want to compare the yojson representations |}] type t = { x : unit [@yojson.opaque] } [@@deriving yojson_of] type t = { x : unit [@yojson.opaque] } [@@deriving of_yojson] [%%expect {| Line _, characters _-_: Error: Attribute `yojson.opaque' was not used. Hint: `yojson.opaque' is available for core types but is used here in the context of a label declaration. Did you put it at the wrong level? Line _, characters _-_: Error: Attribute `yojson.opaque' was not used. Hint: `yojson.opaque' is available for core types but is used here in the context of a label declaration. Did you put it at the wrong level? |}] type t = { x : unit [@yojson.option] } [@@deriving yojson_of] type t = { x : unit [@yojson.option] } [@@deriving of_yojson] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: [@yojson.option] is only allowed on type [_ option]. Line _, characters _-_: Error: ppx_yojson_conv: [@yojson.option] is only allowed on type [_ option]. |}] type t = int [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] type t = A [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] type t = [ `A | `B ] [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] type t = int * int [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] type t = { x : u } and vvv = int and u = { y : t } [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] type t = string list [@@deriving yojson_fields] [%%expect {| Line _, characters _-_: Error: ppx_yojson_conv: yojson_fields only works on records |}] ppx_yojson_conv-0.17.0/test/examples.mlt000066400000000000000000000017221461647336100203640ustar00rootroot00000000000000module Position_for_polymorphic_variant_errors = struct type t1 = [ `A ] [@@deriving of_yojson] type t2 = [ `B ] [@@deriving of_yojson] type t3 = A of [ t1 | t2 ] [@@deriving of_yojson] let (_ : t3) = t3_of_yojson (`List [ `String "A"; `String "C" ]) end [%%expect {| Exception: (Of_yojson_error "examples.mlt.Position_for_polymorphic_variant_errors.t1_of_yojson: unexpected variant constructor" "\"C\"") |}] let _ = [%yojson_of: 'a] [%%expect {| Line _, characters _-_: Error: Type variables not allowed in [%yojson_of: ]. Please use locally abstract types instead. |}] let _ = [%of_yojson: 'a] [%%expect {| Line _, characters _-_: Error: Type variables not allowed in [%of_yojson: ]. Please use locally abstract types instead. |}] let (_ : _) = [%yojson (() : 'a)] [%%expect {| Line _, characters _-_: Error: Extension `yojson' was not translated |}] type 'a t = | None | Something_else of { value : 'a } [@@deriving yojson] [%%expect {| |}] ppx_yojson_conv-0.17.0/test/nonrec_test.ml000066400000000000000000000042611461647336100207060ustar00rootroot00000000000000open Ppx_yojson_conv_lib.Yojson_conv.Primitives type t = float [@@deriving yojson] module M : sig type t = float list [@@deriving yojson] end = struct type nonrec t = t list [@@deriving yojson] end type 'a u = 'a [@@deriving yojson] module M2 : sig type 'a u = 'a list [@@deriving yojson] end = struct type nonrec 'a u = 'a u list [@@deriving yojson] end type 'a v = 'a w and 'a w = A of 'a v [@@deriving yojson] type 'a v_ = 'a v [@@deriving yojson] type 'a w_ = 'a w [@@deriving yojson] module M3 : sig type 'a v = 'a w_ [@@deriving yojson] type 'a w = 'a v_ [@@deriving yojson] end = struct type nonrec 'a v = 'a w and 'a w = 'a v [@@deriving yojson] end type t0 = A of t0 [@@deriving yojson] module B : sig type nonrec t0 = t0 [@@deriving yojson] end = struct type nonrec t0 = t0 = A of t0 [@@deriving yojson] end type t1 = A of t2 and t2 = B of t1 [@@deriving yojson] module C : sig type nonrec t1 = t1 [@@deriving yojson] type nonrec t2 = t2 [@@deriving yojson] end = struct type nonrec t1 = t1 = A of t2 and t2 = t2 = B of t1 [@@deriving yojson] end type 'a v1 = A of 'a v2 and 'a v2 = B of 'a v1 [@@deriving yojson] module D : sig type nonrec 'a v1 = 'a v1 [@@deriving yojson] type nonrec 'a v2 = 'a v2 [@@deriving yojson] end = struct type nonrec 'a v1 = 'a v1 = A of 'a v2 and 'a v2 = 'a v2 = B of 'a v1 [@@deriving yojson] end type +'a w1 module E = struct type nonrec +'a w1 = 'a w1 end type 'a y1 = A of 'a y2 and 'a y2 = B of 'a y1 module F : sig type nonrec 'a y2 = B of 'a y1 type nonrec 'a y1 = 'a y1 end = struct type nonrec 'a y1 = 'a y1 = A of 'a y2 and 'a y2 = B of 'a y1 end type z1 = A of z1 module G : sig module A : sig type z2 = A of z2 end module B : sig type z2 = A of z2 end module C : sig type z2 = A of z2 end end = struct type z2 = z1 = A of z1 module A = struct type nonrec z2 = z1 = A of z2 end module B = struct type nonrec z2 = z2 = A of z2 end module C = struct type nonrec z2 = z2 = A of z1 end end type ('a, 'b) zz = A of 'a * 'b module H = struct type nonrec ('a, 'b) zz = ('a, 'b) zz = A of 'a * 'b end module I = struct type nonrec 'a zz = ('a, 'a) zz end ppx_yojson_conv-0.17.0/test/ppx_yojson_test.ml000066400000000000000000001222601461647336100216320ustar00rootroot00000000000000open Base open Base_yojson open Expect_test_helpers_core (* Module names below are used in error messages being tested. *) [@@@warning "-unused-module"] include struct [@@@ocaml.warning "-32"] let ( ! ) _x = `Shadowed let ignore _x = `Shadowed let ( = ) _ _ = `Shadowed end module Fields = struct type ty = { x : int ; y : int [@key "some"] ; z : int [@key "some"] } [@@deriving yojson_fields] let%expect_test _ = print_s [%sexp (yojson_fields_of_ty : string list)]; [%expect {| (x some some) |}] ;; end module Option = struct type ty = { x : int option option ; y : int option option } [@@deriving yojson] let%expect_test _ = let open Poly in let a = { x = None; y = Some None } in let b = yojson_of_ty a in let c = ty_of_yojson b in if None = c.x then Stdio.print_endline "x = None"; if None = c.y then Stdio.print_endline "y = None"; [%expect {| x = None y = None |}] ;; end module Default_omit = struct type ty = { x : int option ; y : int option [@default None] [@yojson_drop_default.equal] ; z : int [@default 0] [@yojson_drop_default.equal] ; b : int [@default 0] [@yojson_drop_default.equal] } [@@deriving yojson, equal] let ( = ) = equal_ty let%expect_test _ = let value = { x = None; y = None; z = 0; b = 1 } in let yojson = yojson_of_ty value in let yojson' = `Assoc [ "x", `Null; "y", `Null; "z", `Int 0; "b", `Int 1 ] in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (ty_of_yojson yojson = value); require [%here] (ty_of_yojson yojson' = value); [%expect {| (Assoc ((x Null) (b (Int 1)))) |}] ;; end module Tuple = struct type poly = int * float * string [@@deriving yojson, equal] let ( = ) = equal_poly let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_poly value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (poly_of_yojson yojson = value)) [ 1, 1., "string"; 1, 2., "example" ]; [%expect {| (List ( (Int 1) (Float 1) (String string))) (List ( (Int 1) (Float 2) (String example))) |}] ;; end module Types = struct type t = int * int32 * int64 * bool * int ref * nativeint * bytes * char * unit * float [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value)) [ ( 1 , Int32.of_int_exn 1 , Int64.of_int 1 , true , ref 1 , Nativeint.of_int 1 , Bytes.of_string "baddecaf" , 'c' , () , 1. ) ]; [%expect {| (List ( (Int 1) (Intlit 1) (Intlit 1) (Bool true) (Int 1) (Intlit 1) (String baddecaf) (String c) Null (Float 1))) |}] ;; type lt = int lazy_t [@@deriving yojson] let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_lt value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (Yojson.Safe.equal (yojson_of_lt value) yojson); require [%here] Poly.(lt_of_yojson yojson = value)) [ lazy 1 ]; [%expect {| (Int 1) |}] ;; type opt = int option [@@deriving yojson, equal] let ( = ) = equal_opt let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_opt value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (Yojson.Safe.equal (yojson_of_opt value) yojson); require [%here] (opt_of_yojson yojson = value)) [ Some 1; None ]; [%expect {| (Int 1) Null |}] ;; let%expect_test _ = List.iter ~f:(fun value -> let yojson = [%yojson_of: int list] value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] Poly.([%yojson_of: int list] value = yojson); require [%here] Poly.([%of_yojson: int list] yojson = value)) [ []; [ 1 ]; [ 1; 2 ] ]; [%expect {| (List ()) (List ((Int 1))) (List ( (Int 1) (Int 2))) |}] ;; let%expect_test _ = List.iter ~f:(fun value -> let yojson = [%yojson_of: int array] value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] Poly.([%of_yojson: int array] yojson = value)) [ [||]; [| 1 |]; [| 1; 2 |] ]; [%expect {| (List ()) (List ((Int 1))) (List ( (Int 1) (Int 2))) |}] ;; let%expect_test _ = List.iter ~f:(fun yojson -> let value = [%of_yojson: float] yojson in print_s ([%sexp_of: float] value); require [%here] Poly.([%of_yojson: float] yojson = value)) [ `Float 1.; `Int 1; `Intlit "1" ]; [%expect {| 1 1 1 |}] ;; let%expect_test _ = List.iter ~f:(fun yojson -> let value = [%of_yojson: int32] yojson in print_s ([%sexp_of: int32] value); require [%here] Poly.([%of_yojson: int32] yojson = value)) [ `Int 1; `Intlit "1" ]; [%expect {| 1 1 |}] ;; let%expect_test _ = List.iter ~f:(fun yojson -> let value = [%of_yojson: int64] yojson in print_s ([%sexp_of: int64] value); require [%here] Poly.([%of_yojson: int64] yojson = value)) [ `Int 1; `Intlit "1" ]; [%expect {| 1 1 |}] ;; let%expect_test _ = List.iter ~f:(fun yojson -> let value = [%of_yojson: nativeint] yojson in print_s ([%sexp_of: nativeint] value); require [%here] Poly.([%of_yojson: nativeint] yojson = value)) [ `Int 1; `Intlit "1" ]; [%expect {| 1 1 |}] ;; let%expect_test _ = let open Stdlib in let tbl = Hashtbl.create 10 in let _ = Hashtbl.add tbl "key_1" "value_1" in let _ = Hashtbl.add tbl "key_2" "value_2" in let _ = Hashtbl.add tbl "key_3" "value_3" in let yojson = [%yojson_of: (string, string) hashtbl] tbl in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] ([%of_yojson: (string, string) hashtbl] yojson = tbl); [%expect {| (List ( (List ((String key_1) (String value_1))) (List ((String key_2) (String value_2))) (List ((String key_3) (String value_3))))) |}] ;; end module Sum_and_polymorphic_variants = struct type poly = [ `No_arg | `No_arg_with_renaming [@name "zero_arg"] | `One_arg of int | `One_arg_with_renaming of int [@name "one_arg"] | `One_tuple of int * string | `Two_args of int * string ] [@@deriving yojson, equal] let ( = ) = equal_poly let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_poly value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (poly_of_yojson yojson = value)) [ `No_arg ; `No_arg_with_renaming ; `One_arg 1 ; `One_arg_with_renaming 1 ; `One_tuple (1, "a") ; `Two_args (1, "a") ]; [%expect {| (List ((String No_arg))) (List ((String zero_arg))) (List ( (String One_arg) (Int 1))) (List ( (String one_arg) (Int 1))) (List ( (String One_tuple) (Int 1) (String a))) (List ( (String Two_args) (Int 1) (String a))) |}] ;; type nominal = | No_arg | One_arg of int | One_tuple of (int * string) | Two_args of int * string [@@deriving yojson, equal] let ( = ) = equal_nominal let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_nominal value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (nominal_of_yojson yojson = value)) [ No_arg; One_arg 1; One_tuple (1, "a"); Two_args (1, "a") ]; [%expect {| (List ((String No_arg))) (List ( (String One_arg) (Int 1))) (List ( (String One_tuple) (List ( (Int 1) (String a))))) (List ( (String Two_args) (Int 1) (String a))) |}] ;; end module Name = struct type nominal = | Con_1 [@name "Name_1"] | Con_2 of int [@name "Name_2"] | Con_3 of (int * string) [@name "Name_3"] | Con_4 of int * string [@name "Name_4"] | Con_5 of { a : int } [@name "name_5"] | Con_6 of { b : int } [@name ""] [@@deriving yojson, equal] let ( = ) = equal_nominal let%expect_test _ = List.iter ~f:(fun value -> let yojson = yojson_of_nominal value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (nominal_of_yojson yojson = value)) [ Con_1; Con_2 2; Con_3 (1, "a"); Con_4 (1, "a"); Con_5 { a = 1 }; Con_6 { b = 1 } ]; [%expect {| (List ((String Name_1))) (List ( (String Name_2) (Int 2))) (List ( (String Name_3) (List ( (Int 1) (String a))))) (List ( (String Name_4) (Int 1) (String a))) (List ((String name_5) (Assoc ((a (Int 1)))))) (List ((String "") (Assoc ((b (Int 1)))))) |}] ;; end module Records = struct type t = { a : int ; b : (float * string) list option } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let t = { a = 2; b = Some [ 1., "a"; 2.3, "b" ] } in let yojson = yojson_of_t t in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = t); [%expect {| (Assoc ( (a (Int 2)) (b ( List ( (List ((Float 1) (String a))) (List ((Float 2.3) (String b)))))))) |}] ;; end module Keys = struct type t = { name_a : int [@key "key_a"] ; name_b : int option [@key "key_b"] ; name_c : int option [@key "key_c"] [@yojson.option] ; name_d : int option [@key "key_d"] [@default None] [@yojson_drop_default.equal] ; name_e : int [@key ""] } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let t = { name_a = 1; name_b = Some 2; name_c = Some 3; name_d = Some 4; name_e = 5 } in let yojson = yojson_of_t t in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = t); [%expect {| (Assoc ( (key_a (Int 1)) (key_b (Int 2)) (key_c (Int 3)) (key_d (Int 4)) ("" (Int 5)))) |}] ;; end module Inline_records = struct type t = | A of { a : int ; b : (float * string) list option } | B of int [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let t = A { a = 2; b = Some [ 1., "a"; 2.3, "b" ] } in let yojson = yojson_of_t t in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = t); [%expect {| (List ( (String A) (Assoc ( (a (Int 2)) (b ( List ( (List ((Float 1) (String a))) (List ((Float 2.3) (String b)))))))))) |}] ;; let%expect_test _ = let t = B 100 in let yojson = yojson_of_t t in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = t); [%expect {| (List ( (String B) (Int 100))) |}] ;; end module User_specified_conversion = struct type my_float = float let yojson_of_my_float n = `Float n let my_float_of_yojson = float_of_yojson let%expect_test _ = let my_float : my_float = 1.2 in let yojson = yojson_of_my_float my_float in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] Float.(my_float_of_yojson yojson = my_float); [%expect {| (Float 1.2) |}] ;; end module Abstract_types_are_allowed_in_structures : sig type t [@@deriving yojson] end = struct type t [@@deriving yojson] end module Manifest_types = struct type a = { t : int } type b = a = { t : int } [@@deriving yojson] end module Function_types : sig type t1 = int -> unit [@@deriving yojson] type t2 = label:int -> ?optional:int -> unit -> unit [@@deriving yojson] end = struct type t1 = int -> unit [@@deriving yojson] type t2 = label:int -> ?optional:int -> unit -> unit [@@deriving yojson] end module No_unused_rec = struct type r = { r : int } [@@deriving yojson] end module Field_name_should_not_be_rewritten = struct open No_unused_rec type nonrec r = { r : r } let _ = fun (r : r) -> r.r end module Polymorphic_variant_inclusion = struct type sub1 = [ `C1 | `C2 ] [@@deriving yojson, equal] type 'b sub2 = [ `C4 | `C5 of 'b ] [@@deriving yojson, equal] type ('a, 'b) t = [ sub1 | `C3 of [ `Nested of 'a ] | 'b sub2 | `C6 ] option [@@deriving yojson, equal] let%expect_test _ = let cases : (string * string, float) t list = [ None ; Some `C1 ; Some `C2 ; Some (`C3 (`Nested ("a", "b"))) ; Some `C4 ; Some (`C5 1.5) ; Some `C6 ] in List.iter ~f:(fun t -> let yojson = [%yojson_of: (string * string, float) t] t in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] ([%equal: (string * string, float) t] ([%of_yojson: (string * string, float) t] yojson) t)) cases; [%expect {| Null (List ((String C1))) (List ((String C2))) (List ( (String C3) (List ( (String Nested) (List ( (String a) (String b))))))) (List ((String C4))) (List ( (String C5) (Float 1.5))) (List ((String C6))) |}] ;; type sub1_alias = sub1 [@@deriving yojson_poly, equal] type u = [ `A | sub1_alias | `D ] [@@deriving yojson, equal] let ( = ) = equal_u let%expect_test _ = let cases : u list = [ `A; `C1; `C2; `D ] in List.iter ~f:(fun u -> let yojson = [%yojson_of: u] u in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] ([%of_yojson: u] yojson = u)) cases; [%expect {| (List ((String A))) (List ((String C1))) (List ((String C2))) (List ((String D))) |}] ;; end module Polymorphic_record_field = struct type 'x t = { poly : 'a 'b. 'a list ; maybe_x : 'x option } [@@deriving yojson] let%expect_test _ = let t x = { poly = []; maybe_x = Some x } in let yojson = yojson_of_t yojson_of_int (t 1) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] Poly.(t_of_yojson int_of_yojson yojson = t 1); require [%here] Poly.(yojson_of_t yojson_of_int (t 1) = yojson); [%expect {| (Assoc ((poly (List ())) (maybe_x (Int 1)))) |}] ;; end module No_unused_value_warnings : sig end = struct module No_warning : sig type t = [ `A ] [@@deriving yojson] end = struct type t = [ `A ] [@@deriving yojson] end include struct [@@@warning "-unused-module"] module Empty = struct end end module No_warning2 (_ : sig type t [@@deriving yojson] end) = struct end (* this one can't be handled (what if Empty was a functor, huh?) *) (* module No_warning3(X : sig type t with yojson end) = Empty *) module type S = sig type t = [ `A ] [@@deriving yojson] end module No_warning4 : S = struct type t = [ `A ] [@@deriving yojson] end module No_warning5 : S = ( ( struct type t = [ `A ] [@@deriving yojson] end : S) : S) module Nested_functors (_ : sig type t [@@deriving yojson] end) (_ : sig type t [@@deriving yojson] end) = struct end let () = let module M : sig type t [@@deriving yojson] end = struct type t [@@deriving yojson] end in () ;; module Include = struct include ( struct type t = int [@@deriving yojson] end : sig type t [@@deriving yojson] end with type t := int) end end module Default = struct type t = { a : int [@default 2] [@yojson_drop_default.equal] } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let yojson = yojson_of_t { a = 1 } in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = { a = 1 }); [%expect {| (Assoc ((a (Int 1)))) |}] ;; let%expect_test _ = let yojson = yojson_of_t { a = 2 } in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = { a = 2 }); require [%here] (t_of_yojson (`Assoc [ "a", `Int 2 ]) = { a = 2 }); [%expect {| (Assoc ()) |}] ;; end module Type_alias = struct (* checking that the [as 'a] is supported and ignored in signatures, that it still exports the yojson_of_t__ when needed *) module B : sig type a = [ `A ] type t = [ `A ] as 'a constraint 'a = a [@@deriving yojson, equal] end = struct type a = [ `A ] [@@deriving yojson, equal] type t = [ `A ] [@@deriving yojson, equal] end let ( = ) = B.equal let%expect_test _ = let yojson = B.yojson_of_t `A in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (`A = B.t_of_yojson yojson); [%expect {| (List ((String A))) |}] ;; module B2 = struct type t = [ B.t | `B ] [@@deriving yojson] end module C : sig type t = int as 'a [@@deriving yojson] end = struct type t = int [@@deriving yojson] end module D : sig type t = 'a constraint 'a = int [@@deriving yojson] end = struct type t = int [@@deriving yojson] end end module Tricky_variants = struct (* Checking that the generated code compiles (there used to be a problem with subtyping constraints preventing proper generalization). *) type t = [ `a ] [@@deriving yojson] type 'a u = [ t | `b of 'a ] * int [@@deriving yojson] end module Drop_default = struct open! Base open Expect_test_helpers_core type t = { a : int } [@@deriving equal] let test ?cr t_of_yojson yojson_of_t = let ( = ) : Yojson.t -> Yojson.t -> bool = Yojson.equal in require ?cr [%here] ((`Assoc [ "a", `Int 1 ] : Yojson.t) = yojson_of_t { a = 1 }); require ?cr [%here] ((`Assoc [] : Yojson.t) = yojson_of_t { a = 2 }); let ( = ) = equal in require ?cr [%here] (t_of_yojson (`Assoc [ "a", `Int 1 ] : Yojson.t) = { a = 1 }); require ?cr [%here] (t_of_yojson (`Assoc [] : Yojson.t) = { a = 2 }) ;; type my_int = int [@@deriving yojson] module Poly = struct type nonrec t = t = { a : my_int [@default 2] [@yojson_drop_default ( = )] } [@@deriving yojson] let%expect_test _ = test t_of_yojson yojson_of_t; [%expect {| |}] ;; end module Equal = struct let equal_my_int = equal_int type nonrec t = t = { a : my_int [@default 2] [@yojson_drop_default.equal] } [@@deriving yojson] let%expect_test _ = test t_of_yojson yojson_of_t; [%expect {| |}] ;; end module Compare = struct let compare_my_int = compare_int type nonrec t = t = { a : my_int [@default 2] [@yojson_drop_default.compare] } [@@deriving yojson] let%expect_test _ = test t_of_yojson yojson_of_t; [%expect {| |}] ;; end module Yojson = struct type nonrec t = t = { a : my_int [@default 2] [@yojson_drop_default.yojson] } [@@deriving yojson] let%expect_test _ = test t_of_yojson yojson_of_t; [%expect {| |}] ;; end end module Drop_if = struct type t = { a : int [@default 2] [@yojson_drop_if fun x -> Int.(x % 2 = 0)] } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let value = { a = 2 } in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); require [%here] (t_of_yojson (`Assoc [ "a", `Int 2 ]) = value); [%expect {| (Assoc ()) |}] ;; let%expect_test _ = let value = { a = 1 } in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (Assoc ((a (Int 1)))) |}] ;; type u = { a : int [@yojson_drop_if fun x -> (* pa_type_conv used to drop parens altogether, causing type errors in the following code *) let pair = x, 2 in match Some pair with | None -> true | Some (x, y) -> Poly.(x = y)] } [@@deriving yojson] end module Omit_nil = struct type natural_option = int [@@deriving equal] let yojson_of_natural_option i = if i >= 0 then yojson_of_int i else `Null let natural_option_of_yojson = function | `Null -> -1 | yojson -> int_of_yojson yojson ;; type t = { a : natural_option [@default -1] [@yojson_drop_default.equal] } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let value = { a = 1 } in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (Assoc ((a (Int 1)))) |}] ;; let%expect_test _ = let value = { a = -1 } in let yojson = yojson_of_t value in let yojson' = `Assoc [] in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); require [%here] (t_of_yojson yojson' = value); [%expect {| (Assoc ()) |}] ;; type t2 = A of { a : int option [@yojson.option] } [@@deriving yojson, equal] let ( = ) = equal_t2 let%expect_test _ = let value = A { a = None } in let yojson = yojson_of_t2 value in let yojson' = `List [ `String "A"; `Assoc [] ] in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t2_of_yojson yojson = value); require [%here] (t2_of_yojson yojson' = value); [%expect {| (List ((String A) (Assoc ()))) |}] ;; let%expect_test _ = let value = A { a = Some 1 } in let yojson = yojson_of_t2 value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t2_of_yojson yojson = value); [%expect {| (List ((String A) (Assoc ((a (Int 1)))))) |}] ;; end module No_unused_rec_warning = struct type r = { field : r -> unit } [@@deriving yojson_of] end module True_and_false = struct type t = | True | False [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let value = True in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (List ((String True))) |}] ;; let%expect_test _ = let value = False in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (List ((String False))) |}] ;; type u = | True of int | False of int [@@deriving yojson, equal] let ( = ) = equal_u let%expect_test _ = let value = True 1 in let yojson = yojson_of_u value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (u_of_yojson yojson = value); [%expect {| (List ( (String True) (Int 1))) |}] ;; let%expect_test _ = let value = False 0 in let yojson = yojson_of_u value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (u_of_yojson yojson = value); [%expect {| (List ( (String False) (Int 0))) |}] ;; type v = [ `True | `False of int ] [@@deriving yojson, equal] let ( = ) = equal_v let%expect_test _ = let value = `True in let yojson = yojson_of_v value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (v_of_yojson yojson = value); [%expect {| (List ((String True))) |}] ;; let%expect_test _ = let value = `False 0 in let yojson = yojson_of_v value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (v_of_yojson yojson = value); [%expect {| (List ( (String False) (Int 0))) |}] ;; end module Gadt = struct (* plain type without argument *) type 'a s = Packed : 'a s [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: int s] Packed in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ((String Packed))) |}] ;; (* two kind of existential variables *) type 'a t = Packed : 'a * _ * ('b[@yojson.opaque]) -> 'a t [@warning "-3"] [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: int t] (Packed (2, "asd", 1.)) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ( (String Packed) (Int 2) (String _) (String ))) |}] ;; (* Safe.to_channel stderr ([%yojson_of: int t] (Packed (2, "asd", 1.))) *) (* plain type with argument *) type 'a u = A : 'a -> 'a u [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: int u] (A 2) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ( (String A) (Int 2))) |}] ;; (* recursive *) type v = A : v option -> v [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: v] (A (Some (A None))) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ((String A) (List ((String A) Null)))) |}] ;; (* implicit existential variable *) type w = A : 'a * int * ('a -> string) -> w [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: w] (A (1., 2, Float.to_string)) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ( (String A) (String _) (Int 2) (String ))) |}] ;; (* tricky variable naming *) type 'a x = A : 'a -> 'b x [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: int x] (A 1.) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ( (String A) (String _))) |}] ;; (* interaction with inline record *) type _ x2 = A : { x : 'c } -> 'c x2 [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: int x2] (A { x = 1 }) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ((String A) (Assoc ((x (Int 1)))))) |}] ;; (* unused but colliding variables *) type (_, _) y = A : ('a, 'a) y [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: (int, int) y] A in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ((String A))) |}] ;; (* making sure we're not reversing parameters *) type (_, _) z = A : ('a * 'b) -> ('a, 'b) z [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: (int, string) z] (A (1, "a")) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ( (String A) (List ( (Int 1) (String a))))) |}] ;; (* interaction with universal quantifiers *) type _ z2 = A : { x : 'c. 'c option } -> 'c z2 [@@deriving yojson_of] let%expect_test _ = let yojson = [%yojson_of: unit z2] (A { x = None }) in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); [%expect {| (List ((String A) (Assoc ((x Null))))) |}] ;; end module Anonymous_variable = struct type _ t = int [@@deriving yojson] let%expect_test _ = let yojson = [%yojson_of: _ t] 2 in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] Poly.([%of_yojson: _ t] yojson = 2); [%expect {| (Int 2) |}] ;; (* making sure we don't generate signatures like (_ -> Safe.t) -> _ t -> Safe.t which are too general *) module M : sig type _ t [@@deriving yojson] end = struct type 'a t = 'a [@@deriving yojson] end end module Record_field_disambiguation = struct type a = { fl : float ; b : b } and b = { fl : int } [@@deriving yojson] end module Private = struct type t = private int [@@deriving yojson_of] type ('a, 'b) u = private t [@@deriving yojson_of] type ('a, 'b, 'c) v = private ('a, 'b) u [@@deriving yojson_of] end module Nonregular_types = struct type 'a nonregular = | Leaf of 'a | Branch of ('a * 'a) nonregular [@@deriving yojson] type 'a variant = [ `A of 'a ] [@@deriving yojson] type ('a, 'b) nonregular_with_variant = | Branch of ([ | 'a list variant ], 'b) nonregular_with_variant [@@deriving yojson] end module Opaque = struct type t = (int[@yojson.opaque]) list [@@deriving yojson] let%expect_test _ = let value = [ 1; 2 ] in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require_does_raise [%here] (fun () -> t_of_yojson yojson); [%expect {| (List ( (String ) (String ))) (Of_yojson_error "opaque_of_yojson: cannot convert opaque values" "\"\"") |}] ;; type u = ([ `A of int ][@yojson.opaque]) [@@deriving yojson] let%expect_test _ = let value = `A 1 in let yojson = yojson_of_u value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require_does_raise [%here] (fun () -> u_of_yojson yojson); [%expect {| (String ) (Of_yojson_error "opaque_of_yojson: cannot convert opaque values" "\"\"") |}] ;; end module Optional = struct type t = { optional : int option [@yojson.option] } [@@deriving yojson, equal] let ( = ) = equal let%expect_test _ = let value = { optional = None } in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (Assoc ()) |}] ;; let%expect_test _ = let value = { optional = Some 5 } in let yojson = yojson_of_t value in print_s (Yojson.Safe.Alternate_sexp.sexp_of_t yojson); require [%here] (t_of_yojson yojson = value); [%expect {| (Assoc ((optional (Int 5)))) |}] ;; end module Variance = struct type (+'a, -'b, 'c, +_, -_, _) t [@@deriving yojson] end module Clash = struct (* Same name for type-var and type-name; must be careful when introducing rigid type names. *) type 'hey hey = Hey of 'hey [@@deriving yojson] type 'hey rigid_hey = Hey of 'hey [@@deriving yojson] type ('foo, 'rigid_foo) foo = Foo of 'foo [@@deriving yojson] type 'rigid_bar rigid_rigid_bar = Bar [@@deriving yojson] end module Applicative_functor_types = struct module Bidirectional_map = struct type ('k1, 'k2) t module S (K1 : sig type t end) (K2 : sig type t end) = struct type nonrec t = (K1.t, K2.t) t end module type Of_yojsonable = sig type t [@@deriving of_yojson] end let s__t_of_yojson (type k1 k2) (module _ : Of_yojsonable with type t = k1) (module _ : Of_yojsonable with type t = k2) (_ : Yojson.t) : (k1, k2) t = assert false ;; end module Int = struct type t = int [@@deriving of_yojson] end module String = struct type t = string [@@deriving of_yojson] end module M : sig type t = Bidirectional_map.S(String)(Int).t [@@deriving of_yojson] end = struct type t = Bidirectional_map.S(String)(Int).t [@@deriving of_yojson] end end module Type_extensions = struct let (_ : [%yojson_of: int]) = [%yojson_of: int] let (_ : [%of_yojson: int]) = [%of_yojson: int] end module Allow_extra_fields = struct module M1 = struct type t1 = { a : int } [@@deriving yojson, equal] type t2 = t1 = { a : int } [@@deriving yojson, equal] [@@yojson.allow_extra_fields] let ( = ) = equal_t2 let%expect_test _ = let yojson = Yojson.from_string {|{"a":1}|} in let yojson_extra = Yojson.from_string {|{"a":1,"b":2}|} in require [%here] (t2_of_yojson yojson = t2_of_yojson yojson_extra); require [%here] (t1_of_yojson yojson = t2_of_yojson yojson); require_does_raise [%here] (fun () -> t1_of_yojson yojson_extra); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Allow_extra_fields.M1.t1_of_yojson: extra fields: b" "{\"a\":1,\"b\":2}") |}] ;; end module M2 = struct type t1 = A of { a : int list } [@@deriving yojson, equal] type t2 = t1 = A of { a : int list } [@yojson.allow_extra_fields] [@@deriving yojson, equal] let ( = ) = equal_t2 let%expect_test _ = let yojson = Yojson.from_string {|["A",{"a":[0]}]|} in let yojson_extra = Yojson.from_string {|["A",{"a":[0],"b":"1"}]|} in require [%here] (t2_of_yojson yojson = t2_of_yojson yojson_extra); require [%here] (t1_of_yojson yojson = t2_of_yojson yojson); require_does_raise [%here] (fun () -> t1_of_yojson yojson_extra); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Allow_extra_fields.M2.t1_of_yojson: extra fields: b" "[\"A\",{\"a\":[0],\"b\":\"1\"}]") |}] ;; end end module Exceptions = struct module Variant = struct type t = | A [@name "AA"] | B of int | C of { a : int } | D of int * string [@@deriving yojson] let%expect_test _ = let wrong_constr_name = `List [ `String "Z" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_constr_name); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: unexpected variant constructor" "[\"Z\"]") |}] ;; let%expect_test _ = let wrong_constr_name = `List [ `String "A" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_constr_name); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: unexpected variant constructor" "[\"A\"]") |}] ;; let%expect_test _ = let wrong_constr_name = `List [ `String "AA" ] in require_does_not_raise [%here] (fun () -> Base.ignore (t_of_yojson wrong_constr_name)); [%expect {| |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "B"; `Float 1. ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "int_of_yojson: integer needed" 1.0) |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "B"; `Intlit "1" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "int_of_yojson: integer needed" 1) |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "C"; `String "string" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: unexpected variant constructor" "[\"C\",\"string\"]") |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "C"; `Assoc [ "b", `Int 1 ] ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: extra fields: b" "[\"C\",{\"b\":1}]") |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "D"; `Int 1; `Float 1. ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "string_of_yojson: string needed" 1.0) |}] ;; let%expect_test _ = let wrong_arg_num = `List [ `String "D"; `List [ `Int 1; `Float 1. ] ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_num); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: sum tag \"D\" has incorrect number of arguments" "[\"D\",[1,1.0]]") |}] ;; let%expect_test _ = let wrong_arg_num = `List [ `String "D"; `Int 1; `Float 1.; `String "str" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_num); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Variant.t_of_yojson: sum tag \"D\" has incorrect number of arguments" "[\"D\",1,1.0,\"str\"]") |}] ;; end module Sum = struct type t = [ `A | `B of int | `D of int * string ] [@@deriving yojson] let%expect_test _ = let wrong_constr_name = `List [ `String "Z" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_constr_name); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Sum.t_of_yojson: no matching variant found" "[\"Z\"]") |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "B"; `Float 1. ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "int_of_yojson: integer needed" 1.0) |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "B"; `Intlit "1" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "int_of_yojson: integer needed" 1) |}] ;; let%expect_test _ = let wrong_arg_type = `List [ `String "D"; `Int 1; `Float 1. ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_type); [%expect {| (Of_yojson_error "string_of_yojson: string needed" 1.0) |}] ;; let%expect_test _ = let wrong_arg_num = `List [ `String "D"; `List [ `Int 1; `Float 1. ] ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_num); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Sum.t_of_yojson: polymorphic variant tag \"D\" has incorrect number of arguments" "[\"D\",[1,1.0]]") |}] ;; let%expect_test _ = let wrong_arg_num = `List [ `String "D"; `Int 1; `Float 1.; `String "str" ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_arg_num); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Sum.t_of_yojson: polymorphic variant tag \"D\" has incorrect number of arguments" "[\"D\",1,1.0,\"str\"]") |}] ;; end module Record = struct type t = { a : int [@key "A"] ; b : string ; c : float ; d : int option ; e : int option [@default None] ; f : int [@default 0] } [@@deriving yojson] let%expect_test _ = let wrong_field_name = `Assoc [ "a", `Int 1 ; "b", `String "str" ; "c", `Float 1. ; "d", `Null ; "e", `Int 1 ; "f", `Int 1 ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_field_name); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Record.t_of_yojson: extra fields: a" "{\"a\":1,\"b\":\"str\",\"c\":1.0,\"d\":null,\"e\":1,\"f\":1}") |}] ;; let%expect_test _ = let wrong_field_type = `Assoc [ "A", `String "A" ; "b", `String "str" ; "c", `Float 1. ; "d", `Null ; "e", `Int 1 ; "f", `Int 1 ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_field_type); [%expect {| (Of_yojson_error "int_of_yojson: integer needed" "\"A\"") |}] ;; let%expect_test _ = let wrong_field_number = `Assoc [ "A", `Int 1; "b", `String "str"; "c", `Float 1. ] in require_does_raise [%here] (fun () -> t_of_yojson wrong_field_number); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Record.t_of_yojson: the following record elements were undefined: d" "{\"A\":1,\"b\":\"str\",\"c\":1.0}") |}] ;; let%expect_test _ = let duplicate_fields = `Assoc [ "A", `Int 1 ; "b", `String "str" ; "c", `Float 1. ; "d", `Null ; "e", `Int 1 ; "f", `Int 1 ; "f", `Int 1 ] in require_does_raise [%here] (fun () -> t_of_yojson duplicate_fields); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Record.t_of_yojson: duplicate fields: f" "{\"A\":1,\"b\":\"str\",\"c\":1.0,\"d\":null,\"e\":1,\"f\":1,\"f\":1}") |}] ;; let%expect_test _ = let extra_fields = `Assoc [ "A", `Int 1 ; "b", `String "str" ; "c", `Float 1. ; "d", `Null ; "e", `Int 1 ; "f", `Int 1 ; "g", `Int 1 ] in require_does_raise [%here] (fun () -> t_of_yojson extra_fields); [%expect {| (Of_yojson_error "ppx_yojson_test.ml.Exceptions.Record.t_of_yojson: extra fields: g" "{\"A\":1,\"b\":\"str\",\"c\":1.0,\"d\":null,\"e\":1,\"f\":1,\"g\":1}") |}] ;; end end ppx_yojson_conv-0.17.0/test/ppx_yojson_test.mli000066400000000000000000000000001461647336100217660ustar00rootroot00000000000000