pax_global_header00006660000000000000000000000064140134765600014520gustar00rootroot0000000000000052 comment=3609848f056a15be1af6ad9bc3bd63f993869e36 ppx_sexp_conv-0.14.3/000077500000000000000000000000001401347656000145005ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/.gitignore000066400000000000000000000000411401347656000164630ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_sexp_conv-0.14.3/CHANGES.md000066400000000000000000000042121401347656000160710ustar00rootroot00000000000000## v0.14.2 - Upgrade to ppxlib 0.18.0 ## v0.14.1 - Depend on ppxlib >= v0.15.0. ## v0.11 - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and ppx\_metaquot. ## v0.10 - Added new `[@@deriving sexp]` record-field attribute, `[@sexp.omit_nil]`, for a field that is omitted if its sexp representation is `()`. - Improved `[%sexp_of: 'a]` and `[%of_sexp: 'a]` to not expose variable names intended for internal use. ## v0.9 ## 113.43.00 - Fix generator for polymorphic types where var names clashes with type name: `type 't t = ...` ## 113.33.00 - Clean up the documentation for sexplib, modernizing it to include `ppx_sexp_conv`, and breaking up the documentation between sexplib and `ppx_sexp_conv`. Also changed the formatting to use org-mode, so it will render properly on github. Markdown doesn't render well by default, unless you use quite different conventions about linebeaks. ## 113.24.00 - Trying to improve the tests in ppx\_sexp\_conv because they are a mess. At least all tests are automatic now. And more things are tested like the sexpification of exceptions. - Update to follow `Type_conv` and `Ppx_core` evolution. - Make ppx\_sexp\_conv correctly handle aliases to polymorphic variants: type t = ` `A ` `@@deriving sexp` type u = t `@@deriving sexp` type v = ` u | `B ` `@@deriving sexp` Before, `v_of_sexp` would never manage to read `B. This problem is now fixed if you use `sexp_poly` on `u` instead of `sexp`, and if you don't, you get an "unbound value __u_of_sexp__". People should use `sexp_poly` when they have a polymorphic variant type that is not syntactically a polymorphic variant, but in practice it's simpler to replace `sexp` by `sexp_poly` when faced with the error above. The need for `sexp_poly` should happen only in one new case: an implementation says `type u = t `@@deriving sexp`` but the interface says `type u = ``A` `@@deriving sexp``. (the old case where it was already needed is when you have an interface that says `type u = t `@@deriving sexp`` and in some other implementation you try to say `type t = ` That_module.t | `A ` `@@deriving sexp``). ppx_sexp_conv-0.14.3/CONTRIBUTING.md000066400000000000000000000044101401347656000167300ustar00rootroot00000000000000This 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_sexp_conv-0.14.3/LICENSE.md000066400000000000000000000021351401347656000161050ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2020 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_sexp_conv-0.14.3/Makefile000066400000000000000000000004031401347656000161350ustar00rootroot00000000000000INSTALL_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_sexp_conv-0.14.3/README.org000066400000000000000000000405141401347656000161520ustar00rootroot00000000000000#+TITLE: ppx\_sexp\_conv * [@@deriving sexp] =ppx_sexp_conv= is a PPX syntax extension that generates code for converting OCaml types to and from s-expressions, as defined in the [[https://github.com/janestreet/sexplib][=sexplib=]] library. S-expressions are defined by the following type: #+begin_src ocaml type sexp = Atom of string | List of sexp list #+end_src and are rendered as parenthesized lists of strings, /e.g./ =(This (is an) (s expression))=. =ppx_sexp_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 sexp] #+end_src to get two values defined automatically, =sexp_of_int_pair= and =int_pair_of_sexp=. If we only want one direction, we can write one of the following. #+begin_src ocaml type int_pair = (int * int) [@@deriving sexp_of] type int_pair = (int * int) [@@deriving of_sexp] #+end_src These sexp-converters depend on having a set of converters for basic values (/e.g./, =int_of_sexp=) already in scope. This can be done by writing: #+begin_src ocaml open Sexplib.Std #+end_src If you're using [[https://github.com/janestreet/core][=Core=]] or [[https://github.com/janestreet/core_kernel][=Core_kernel=]], you can get the same effect with =open Core= or =open Core_kernel=. It's also possible to construct converters based on type expressions, /i.e./: #+begin_src ocaml [%sexp_of: (int * string) list] [1,"one"; 2,"two"] |> Sexp.to_string;; => "((1 one) (2 two))" [%sexp_of: (int * string) list] [1,"one"; 2,"two"] |> [%of_sexp: (int * string) list];; => [1,"one"; 2,"two"] #+end_src For =%sexp_of=, we can also omit the conversion of some types by putting underscores for that type name. #+begin_src ocaml [%sexp_of: (int * _) list] [1,"one"; 2,"two"] |> Sexp.to_string;; => "((1 _)(2 _))" #+end_src * [@@deriving sexp_grammar] If =ppx_sexp_conv= can derive =of_sexp=, it can also generate a description of the sexps that the resulting =t_of_sexp= would accept. This is the sexp grammar. See =Sexplib0.Raw_grammar= for details. It is possible to construct sexp grammars directly from type expressions, e.g., #+BEGIN_SRC ocaml [%sexp_grammar: (int, bool array) Either.t Base.Map.M(String).t] #+END_SRC The syntax for grammars of polymorphic types is nonstandard: #+BEGIN_SRC ocaml [%sexp_grammar: < for_all : 'a 'b . ('a, 'b) Either.t > ] #+END_SRC We represent polymorphic types as object types because we cannot deserialize objects from sexps, and object method types are one of the few places we can use OCaml's syntax for explicit type variables. ** Conversion rules In the following, we'll review the serialization rules for different OCaml types. *** Basic types Basic types are represented as atoms. For numbers like =int=, =int32=, =int64=, =float=, the string in the atom is what is accepted the standard ocaml functions =int_of_string=, =Int32.of_string=, etc. For the types =char= or =string=, the string in the atom is respectively a one character string or the string itself. *** Lists and arrays OCaml-lists and arrays are represented as s-expression 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 like a 0-tuple. /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 a zero-element list, and =Some= is treated as a singleton list, as shown below. #+begin_src ocaml None => () Some value => (value) #+end_src We also support reading options following the ordinary rules for variants /i.e./: #+begin_src ocaml None => None Some value => (Some value) #+end_src The rules for variants are described below. *** Records Records are represented as lists of lists, where each inner 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 =sexp.option= indicates that a record field should be optional. /e.g./: #+begin_src ocaml type t = { x : int option; y : int option [@sexp.option]; } [@@deriving sexp] #+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 ())) #+end_src Note that, when present, an optional value is represented as the bare value, rather than explicitly as an option. The attribute =sexp.bool= indicates that a boolean record field is shown as either present or absent, but not as containing a value. #+begin_src ocaml type t = { enabled : bool [@sexp.bool] } [@@deriving sexp] { enabled = true } => ((enabled)) { enabled = false } => () #+end_src **** 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] [@sexp_drop_default (=)]; c : int [@default 3] [@sexp_drop_if fun x -> x = 3]; d : int Queue.t [@sexp.omit_nil] } [@@deriving sexp] #+end_src The =@default= annotation lets one specify a default value to be selected if the field is not specified, when converting from an s-expression. The =@sexp_drop_default= annotation implies that the field will be dropped when generating the s-expression if the value being serialized is equal to the default according to the specified equality function. =@sexp_drop_if= is like =@sexp_drop_default=, except that it lets you specify the condition under which the field is dropped. Finally, =@sexp.omit_nil= means to treat a missing field as if it has value =List []= when reading, and drop the field if it has value =List []= when writing. ***** Specifying equality for [@sexp_drop_default] The equality used by [@sexp_drop_default] is customizable. There are several ways to specify the equality function: #+begin_src ocaml type t = { a : u [@default u0] [@sexp_drop_default (=)]; (* explicit user-provided function *) b : u [@default u0] [@sexp_drop_default.compare]; (* uses [%compare.equal: u] *) c : u [@default u0] [@sexp_drop_default.equal]; (* uses [%equal: u] *) d : u [@default u0] [@sexp_drop_default.sexp]; (* compares sexp representations *) e : u [@default u0] [@sexp_drop_default]; (* deprecated. uses polymorphic equality. *) } [@@deriving sexp] #+end_src **** Allowing extra fields The =@sexp.allow_extra_fields= annotation lets one specify that the sexp-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 sexp converters that may be called during conversion of a sexp to the record. #+begin_src ocaml type t = { a: int } [@@deriving sexp] ((a 0)(b b)) => exception type t = { a: int } [@@deriving sexp] [@@sexp.allow_extra_fields] ((a 0)(b b)) => {a = 0} type t = A of { a : int } [@sexp.allow_extra_fields] [@@deriving sexp] (A (a 0)(b b)) => A {a = 0} #+end_src *** Variants Constant constructors in variants are represented as strings. Constructors with arguments are represented as lists, the first element being the constructor name, the rest being its arguments. Constructors may also be started in lowercase in S-expressions, but will always be converted to uppercase when converting from OCaml values. For example: #+begin_src ocaml type t = A | B of int * float * t [@@deriving sexp] 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. Variants support the attribute =sexp.list= when a clause has a single list as its argument. #+begin_src ocaml type t = | A of int list | B of int list [@sexp.list] A [1; 2; 3] => (A (1 2 3)) B [1; 2; 3] => (B 1 2 3) #+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 S-expression converter, for example as in: #+begin_src ocaml type ab = [ `A | `B ] [@@deriving sexp] type cd = [ `C | `D ] [@@deriving sexp] type abcd = [ ab | cd ] [@@deriving sexp] #+end_src However, because `ppx_sexp_conv` needs to generate additional code to support inclusions of polymorphic variants, `ppx_sexp_conv` needs to know when processing a type definition whether it might be included in a polymorphic variant. `ppx_sexp_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 sexp_poly]` (resp `of_sexp_poly`) instead of `[@@deriving sexp]` (resp `of_sexp`): #+begin_src ocaml type ab = [ `A | `B ] [@@deriving sexp] type alias_of_ab = ab [@@deriving sexp_poly] type abcd = [ ab | `C | `D ] [@@deriving sexp] #+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 sexp] type foo = int t [@@deriving sexp] #+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 sexp_of_t sexp_of_a v #+end_src where =sexp_of_a=, which may also be named differently in this particular case, is a function that converts values of type ='a= to an S-expression. 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 S-expression 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 =sexp.opaque= to the type, /e.g./: #+begin_src ocaml type foo = int * (stuff [@sexp.opaque]) [@@deriving sexp] #+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 an S-expression back to the original value. Here is an example conversion: #+begin_src ocaml (42, some_stuff) => (42 ) #+end_src *** Exceptions S-expression converters for exceptions can be automatically registered. #+begin_src ocaml module M = struct exception Foo of int [@@deriving sexp] end #+end_src Such exceptions will be translated in a similar way as sum types, but their constructor will be prefixed with the fully qualified module path (here: =M.Foo=) so as to be able to discriminate between them without problems. The user can then easily convert an exception matching the above one to an S-expression using =sexp_of_exn=. User-defined conversion functions can be registered, too, by calling =add_exn_converter=. This should make it very convenient for users to catch arbitrary exceptions escaping their program and pretty-printing them, including all arguments, as S-expressions. The library already contains mappings for all known exceptions that can escape functions in the OCaml standard library. *** 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 42) (bar 3)) #+end_src Reading in the above S-expression 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_sexp_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 sexp] #+end_src will generate: #+begin_src ocaml include Sexpable.S1 with type 'a t := 'a t #+end_src instead of: #+begin_src ocaml val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.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_sexp_conv= will simply generate a list of value bindings. *** Weird looking type errors In some cases, a type can meet all the conditions listed above, in which case the rewriting will apply, but lead to a type error. This happens when the type [t] is an alias to a type which does have constraints on the parameters, for instance: #+begin_src ocaml type 'a s constraint 'a = [> `read ] val sexp_of_s : ... val s_of_sexp : ... type 'a t = 'a s [@@deriving_inline sexp] include Sexpable.S1 with type 'a t := 'a t [@@@end] #+end_src will give an error looking like: #+begin_src Error: In this `with' constraint, the new definition of t does not match its original definition in the constrained signature: Type declarations do not match: type 'a t = 'a t constraint 'a = [> `read ] is not included in type 'a t File "sexpable.mli", line 8, characters 21-58: Expected declaration Their constraints differ. #+end_src To workaround that error, simply copy the constraint on the type which has the =[@@deriving]= annotation. This will force generating a list of value bindings. ** Deprecated syntax Originally, ~ppx_sexp_conv~ used special types instead of attributes. Those types are now deprecated. Here are the appropriate conversions to update from code using now-deprecated types to the newer attributes. *** Opaque types Convert uses of ~sexp_opaque~ to uses of ~[@sexp.opaque]~. The ~[@sexp.opaque]~ attribute usually needs explicit parentheses to clarify what type it annotate. Before: #+begin_src ocaml type t = int sexp_opaque list [@@deriving sexp] #+end_src After: #+begin_src ocaml type t = (int [@sexp.opaque]) list [@@deriving sexp] #+end_src *** Record fields Convert uses of ~sexp_option~, ~sexp_list~, ~sexp_array~, and ~sexp_bool~ to uses of ~[@sexp.option]~, ~[@sexp.list]~, ~[@sexp.array]~, and ~[@sexp.bool]~ as appropriate. The attribute only specifies the modification, not the type, so you will need to use the regular types ~option~, ~list~, ~array~, and/or ~bool~ as well. Unlike ~[@sexp.opaque]~, these attributes do not need extra parentheses. Before: #+begin_src ocaml type t = { a : int sexp_option ; b : int sexp_list ; c : int sexp_array ; d : sexp_bool } [@@deriving sexp] #+end_src After: #+begin_src ocaml type t = { a : int option [@sexp.option] ; b : int list [@sexp.list] ; c : int array [@sexp.array] ; d : bool [@sexp.bool] } [@@deriving sexp] #+end_src *** Variant constructors Convert uses of ~sexp_list~ in variants and polymorphic variants to uses of ~[@sexp.list]~. You need to add the regular type ~list~ as well. Unlike ~[@sexp.opaque]~, this attribute does not need extra parentheses. Before: #+begin_src ocaml type t = A of int sexp_list [@@deriving sexp] type u = [`B of int sexp_list] [@@deriving sexp] #+end_src After: #+begin_src ocaml type t = A of int list [@sexp.list] [@@deriving sexp] type u = [`B of int list [@sexp.list]] [@@deriving sexp] #+end_src ppx_sexp_conv-0.14.3/dune000066400000000000000000000000001401347656000153440ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/dune-project000066400000000000000000000000201401347656000170120ustar00rootroot00000000000000(lang dune 1.10)ppx_sexp_conv-0.14.3/expander/000077500000000000000000000000001401347656000163065ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/expander/attrs.ml000066400000000000000000000145011401347656000177760ustar00rootroot00000000000000open! Base open! Ppxlib let default = Attribute.declare "sexp.default" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) let drop_default = Attribute.declare "sexp.sexp_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 "sexp.@sexp_drop_default.equal" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let drop_default_compare = Attribute.declare "sexp.@sexp_drop_default.compare" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let drop_default_sexp = Attribute.declare "sexp.@sexp_drop_default.sexp" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let drop_if = Attribute.declare "sexp.sexp_drop_if" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> x) let opaque = Attribute.declare "sexp.opaque" Attribute.Context.core_type Ast_pattern.(pstr nil) () let omit_nil = Attribute.declare "sexp.omit_nil" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let option = Attribute.declare "sexp.option" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let list = Attribute.declare "sexp.list" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let array = Attribute.declare "sexp.array" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let bool = Attribute.declare "sexp.bool" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () let list_variant = Attribute.declare "sexp.list" Attribute.Context.constructor_declaration Ast_pattern.(pstr nil) () let list_exception = Attribute.declare "sexp.list" Attribute.Context.type_exception Ast_pattern.(pstr nil) () let list_poly = Attribute.declare "sexp.list" Attribute.Context.rtag Ast_pattern.(pstr nil) () let allow_extra_fields_td = Attribute.declare "sexp.allow_extra_fields" Attribute.Context.type_declaration Ast_pattern.(pstr nil) () let allow_extra_fields_cd = Attribute.declare "sexp.allow_extra_fields" Attribute.Context.constructor_declaration Ast_pattern.(pstr nil) () let invalid_attribute ~loc attr description = Location.raise_errorf ~loc "ppx_sexp_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_sexp_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_sexp_conv: [@@@@allow_extra_fields] only works on records. \ For inline records, do: type t = A of { a : int } [@@allow_extra_fields] | B \ [@@@@deriving sexp]" | _ -> Location.raise_errorf ~loc "ppx_sexp_conv: [@@@@allow_extra_fields] is only allowed on \ records." module Record_field_handler = struct type common = [ `omit_nil | `sexp_array of core_type | `sexp_bool | `sexp_list of core_type | `sexp_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 = [ get_attribute omit_nil ~f:(fun () -> `omit_nil) ; (fun ld -> match ld.pld_type with | [%type: sexp_bool ] -> Some (`sexp_bool, "sexp_bool") | [%type: [%t? ty] sexp_option ] -> Some (`sexp_option ty, "sexp_option") | [%type: [%t? ty] sexp_list ] -> Some (`sexp_list ty, "sexp_list") | [%type: [%t? ty] sexp_array ] -> Some (`sexp_array ty, "sexp_array") | ty when Option.is_some (Attribute.get bool ld) -> (match ty with | [%type: bool] -> Some (`sexp_bool, "[@sexp.bool]") | _ -> invalid_attribute ~loc bool "bool") | ty when Option.is_some (Attribute.get option ld) -> (match ty with | [%type: [%t? ty] option] -> Some (`sexp_option ty, "[@sexp.option]") | _ -> invalid_attribute ~loc option "_ option") | ty when Option.is_some (Attribute.get list ld) -> (match ty with | [%type: [%t? ty] list] -> Some (`sexp_list ty, "[@sexp.list]") | _ -> invalid_attribute ~loc list "_ list") | ty when Option.is_some (Attribute.get array ld) -> (match ty with | [%type: [%t? ty] array] -> Some (`sexp_array ty, "[@sexp.array]") | _ -> invalid_attribute ~loc array "_ array") | _ -> 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_sexp = struct type t = [ common | `default of expression ] let create ~loc ld = create ~loc [ get_attribute default ~f:(fun default -> `default default) ] ld end module Sexp_of = struct type t = [ common | `drop_default of [ `no_arg | `compare | `equal | `sexp | `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_sexp ~f:(fun () -> `drop_default `sexp) ; get_attribute drop_if ~f:(fun x -> `drop_if x) ] ld |> Option.value ~default:`keep end end ppx_sexp_conv-0.14.3/expander/attrs.mli000066400000000000000000000026071401347656000201530ustar00rootroot00000000000000open! Base open! Ppxlib val default : (label_declaration, expression) 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 list_variant : (constructor_declaration, unit) Attribute.t val list_exception : (type_exception, unit) Attribute.t val list_poly : (row_field, 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 = [ `omit_nil | `sexp_array of core_type | `sexp_bool | `sexp_list of core_type | `sexp_option of core_type ] module Of_sexp : sig type t = [ common | `default of expression ] val create : loc:Location.t -> label_declaration -> t option end module Sexp_of : sig type t = [ common | `drop_default of [ `no_arg | `compare | `equal | `sexp | `func of expression ] | `drop_if of expression | `keep ] val create : loc:Location.t -> label_declaration -> t end end ppx_sexp_conv-0.14.3/expander/dune000066400000000000000000000003441401347656000171650ustar00rootroot00000000000000(library (name ppx_sexp_conv_expander) (public_name ppx_sexp_conv.expander) (libraries base ppxlib ppxlib.metaquot_lifters) (ppx_runtime_libraries ppx_sexp_conv.runtime-lib) (preprocess (pps ppxlib.metaquot ppxlib.traverse)))ppx_sexp_conv-0.14.3/expander/ppx_sexp_conv_expander.ml000066400000000000000000002072341401347656000234310ustar00rootroot00000000000000open 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 }] -> begin 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 end | _ -> 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 sexp_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 sexp_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_sexp_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_sexp_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 (Caml.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 = fun (* 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? _] sexp_opaque ] -> () | _ -> super#core_type ctype end)#go () ;; (* Generates the signature for type conversion to S-expressions *) module Sig_generate_sexp_of = struct let type_of_sexp_of ~loc t = let loc = { loc with loc_ghost = true } in [%type: [%t t] -> Ppx_sexp_conv_lib.Sexp.t] let mk_type td = combinator_type_of_type_declaration td ~f:type_of_sexp_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 ((^) "sexp_of_") td.ptype_name) ~type_:(mk_type td) ~prim:[])) let mk_sig_exn ~loc:_ ~path:_ _te = [] end (* Generates the signature for type conversion from S-expressions *) module Sig_generate_of_sexp = struct let type_of_of_sexp ~loc t = let loc = { loc with loc_ghost = true } in [%type: Ppx_sexp_conv_lib.Sexp.t -> [%t t]] let mk_type td = combinator_type_of_type_declaration td ~f:type_of_of_sexp let sig_of_td with_poly td = let of_sexp_type = mk_type td in let loc = td.ptype_loc in let of_sexp_item = psig_value ~loc (value_description ~loc ~name:(Located.map (fun s -> s ^ "_of_sexp") td.ptype_name) ~type_:of_sexp_type ~prim:[]) in match with_poly, is_polymorphic_variant td ~sig_:true with | true, `Surely_not -> Location.raise_errorf ~loc "Sig_generate_of_sexp.sig_of_td: sexp_poly annotation \ but type is surely not a polymorphic variant" | false, (`Surely_not | `Maybe) -> [of_sexp_item] | (true | false), `Definitely | true, `Maybe -> [ of_sexp_item ; psig_value ~loc (value_description ~loc ~name:(Located.map (fun s -> "__" ^ s ^ "_of_sexp__") td.ptype_name) ~type_:of_sexp_type ~prim:[]) ] let mk_sig ~poly ~loc:_ ~path:_ (_rf, tds) = List.concat_map tds ~f:(sig_of_td poly) end module Str_generate_sexp_of = struct (* Handling of record defaults *) let sexp_of_type_constr ~loc id args = type_constr_conv ~loc id ~f:(fun s -> "sexp_of_" ^ s) args (* Conversion of types *) let rec sexp_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_sexp_conv_lib.Conv.sexp_of_opaque ] | [%type: _ ] -> Fun [%expr fun _ -> Ppx_sexp_conv_lib.Sexp.Atom "_" ] | [%type: [%t? _] sexp_opaque ] -> Fun [%expr Ppx_sexp_conv_lib.Conv.sexp_of_opaque ] | { ptyp_desc = Ptyp_tuple tp; _ } -> Match [sexp_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 [%%sexp_of: ]. \ Please use locally abstract types instead." | `ok renaming -> begin match Renaming.binding_kind renaming parm with | Universally_bound parm -> Fun (evar ~loc ("_of_" ^ parm)) | Existentially_bound -> sexp_of_type ~typevar_handling [%type: _ ] end) | { ptyp_desc = Ptyp_constr (id, args); _ } -> Fun (sexp_of_type_constr ~loc id (List.map args ~f:(fun tp -> Fun_or_match.expr ~loc (sexp_of_type ~typevar_handling tp)))) | { ptyp_desc = Ptyp_arrow (_,_,_); _ } -> Fun [%expr fun _f -> Ppx_sexp_conv_lib.Conv.(sexp_of_fun ignore) ] | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> sexp_of_variant ~typevar_handling (loc,row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> sexp_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 [sexp_of] conversion" (* Conversion of tuples *) and sexp_of_tuple ~typevar_handling (loc,tps) = let fps = List.map ~f:(fun tp -> sexp_of_type ~typevar_handling tp) tps in let bindings, pvars, evars = Fun_or_match.map_tmp_vars ~loc fps in let in_expr = [%expr Ppx_sexp_conv_lib.Sexp.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 sexp_of_variant ~typevar_handling ((loc,row_fields):(Location.t * row_field list)) : Fun_or_match.t = let item = fun row -> match row.prf_desc with | Rtag ({ txt = cnstr; _},true,[]) -> ppat_variant ~loc cnstr None --> [%expr Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc cnstr]] | Rtag ({ txt = cnstr; _ },_,[ tp ]) when Option.is_some (Attribute.get Attrs.list_poly row) -> (match tp with | [%type: [%t? tp] list] -> let cnv_expr = Fun_or_match.expr ~loc (sexp_of_type ~typevar_handling tp) in ppat_variant ~loc cnstr (Some [%pat? l]) --> [%expr Ppx_sexp_conv_lib.Sexp.List ( Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc cnstr] :: Ppx_sexp_conv_lib.Conv.list_map [%e cnv_expr] l ) ] | _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list") | Rtag ({ txt = cnstr; _ },_,[ [%type: [%t? tp] sexp_list] ]) -> let cnv_expr = Fun_or_match.expr ~loc (sexp_of_type ~typevar_handling tp) in ppat_variant ~loc cnstr (Some [%pat? l]) --> [%expr Ppx_sexp_conv_lib.Sexp.List ( Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc cnstr] :: Ppx_sexp_conv_lib.Conv.list_map [%e cnv_expr] l ) ] | Rtag ({ txt = cnstr; _ },false,[tp]) -> let cnstr_expr = [%expr Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc cnstr] ] in let var, patt = evar ~loc "v0", pvar ~loc "v0" in let cnstr_arg = Fun_or_match.unroll ~loc var (sexp_of_type ~typevar_handling tp) in let expr = [%expr Ppx_sexp_conv_lib.Sexp.List [%e elist ~loc [cnstr_expr; cnstr_arg]]] in ppat_variant ~loc cnstr (Some patt) --> expr | Rinherit { ptyp_desc = Ptyp_constr (id, []); _ } -> ppat_alias ~loc (ppat_type ~loc id) (Loc.make "v" ~loc) --> sexp_of_type_constr ~loc id [[%expr v]] | Rtag (_,true,[_]) | Rtag (_,_,_::_::_) -> Location.raise_errorf ~loc "unsupported: sexp_of_variant/Rtag/&" | Rinherit ({ ptyp_desc = Ptyp_constr (id, _::_); _ } as typ) -> let call = Fun_or_match.expr ~loc (sexp_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: sexp_of_variant/Rinherit/non-id" (* impossible?*) | Rtag (_,false,[]) -> assert false in Match (List.map ~f:item row_fields) (* Polymorphic record fields *) and sexp_of_poly ~typevar_handling parms tp = let loc = tp.ptyp_loc in match typevar_handling with | `disallowed_in_type_expr -> (* Should be impossible because [sexp_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_sexp_conv_lib.Conv.sexp_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 sexp_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_sexp of (cnv_expr:expression -> location -> expression -> expression) let sexp_of_record_field ~renaming patt expr name tp ?sexp_of is_empty_expr = let loc = tp.ptyp_loc in let patt = mk_rec_patt loc patt name in let cnv_expr = match sexp_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 sexp_of with | None -> cnv_expr | Some sexp_of -> [%expr [%e sexp_of] [%e cnv_expr] ] in let expr = let v_name = [%expr [%e "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 = Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]; arg] in bnd :: bnds] | Inspect_sexp 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 = Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]; 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 "[@sexp_drop_default.%s] was used, but the type of the field contains a \ type variable: '%s.\n\ Comparison is not avaiable for type variables.\nConsider using \ [@sexp_drop_if _] or [@sexp_drop_default.sexp] 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 "[@sexp_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.\nConsider using \ [@sexp_drop_if _] or [@sexp_drop_default.sexp] 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 sexp_of_default_field ~types_being_defined how ~renaming patt expr name tp ?sexp_of default = let is_empty = match how with | `sexp -> Inspect_sexp (fun ~cnv_expr loc sexp_expr -> [%expr Ppx_sexp_conv_lib.Conv.(=) ([%e cnv_expr] [%e default]) [%e sexp_expr]]) | `no_arg | `func _ | `compare | `equal as how -> let equality_f loc = match how with | `no_arg -> [%expr (Ppx_sexp_conv_lib.Conv.(=) [@ocaml.ppwarning "[@sexp_drop_default] is deprecated: please use one of:\ \n- [@sexp_drop_default f] and give an explicit equality function \ ([f = Poly.(=)] corresponds to the old behavior)\ \n- [@sexp_drop_default.compare] if the type supports [%compare]\ \n- [@sexp_drop_default.equal] if the type supports [%equal]\ \n- [@sexp_drop_default.sexp] if you want to compare the sexp 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 sexp_of_record_field ~renaming patt expr name tp ?sexp_of is_empty let sexp_of_label_declaration_list ~types_being_defined ~renaming loc flds ~wrap_expr = let list_empty_expr = Inspect_value (fun loc lst -> [%expr match [%e lst] with | [] -> true | _ -> false ]) in let array_empty_expr = Inspect_value (fun loc arr -> [%expr match [%e arr] with | [||] -> true | _ -> false ]) in let coll ((patt : (Longident.t loc * pattern) list), expr) ld = let name = ld.pld_name.txt in let loc = ld.pld_name.loc in match Attrs.Record_field_handler.Sexp_of.create ~loc ld with | `sexp_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 (sexp_of_type ~typevar_handling:(`ok renaming) tp) in let expr = [%expr let bnds = match [%e evar ~loc ("v_" ^ name)] with | Ppx_sexp_conv_lib.Option.None -> bnds | Ppx_sexp_conv_lib.Option.Some v -> let arg = [%e cnv_expr] in let bnd = Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]; arg] in bnd :: bnds in [%e expr] ] in patt, expr | `sexp_bool -> let patt = mk_rec_patt loc patt name in let expr = [%expr let bnds = if [%e evar ~loc ("v_" ^ name)] then let bnd = Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]] in bnd :: bnds else bnds in [%e expr] ] in patt, expr | `sexp_list tp -> sexp_of_record_field ~renaming patt expr name tp ~sexp_of:[%expr sexp_of_list ] list_empty_expr | `sexp_array tp -> sexp_of_record_field ~renaming patt expr name tp ~sexp_of:[%expr sexp_of_array ] array_empty_expr | `drop_default how -> let tp = ld.pld_type in begin match Attribute.get Attrs.default ld with | None -> Location.raise_errorf ~loc "no default to drop" | Some default -> sexp_of_default_field ~types_being_defined how ~renaming patt expr name tp default end | `drop_if test -> let tp = ld.pld_type in sexp_of_record_field ~renaming patt expr name tp (Inspect_value (fun loc expr -> [%expr [%e test] [%e expr]])) | `omit_nil | `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 (sexp_of_type ~typevar_handling:(`ok renaming) tp) in let bnds = match test with | `keep -> [%expr let arg = [%e cnv_expr] in Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]; arg] :: bnds ] | `omit_nil -> [%expr match [%e cnv_expr] with | Ppx_sexp_conv_lib.Sexp.List [] -> bnds | arg -> Ppx_sexp_conv_lib.Sexp.List [Ppx_sexp_conv_lib.Sexp.Atom [%e estring ~loc name]; 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 = [] in [%e expr]] (* Conversion of sum types *) let branch_sum row inline_attr ~types_being_defined renaming ~loc constr_lid constr_str args = match args with | Pcstr_record lds -> let cnstr_expr = [%expr Ppx_sexp_conv_lib.Sexp.Atom [%e constr_str] ] in let patt, expr = (* Uncomment to wrap record *) (* sexp_of_label_declaration_list loc lds * ~wrap_expr:(fun expr -> * [%expr Ppx_sexp_conv_lib.Sexp.List [ [%e cnstr_expr]; * Ppx_sexp_conv_lib.Sexp.List [%e expr] * ] * ]) *) sexp_of_label_declaration_list ~types_being_defined ~renaming loc lds ~wrap_expr:(fun expr -> [%expr Ppx_sexp_conv_lib.Sexp.List ([%e cnstr_expr] :: [%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 Ppx_sexp_conv_lib.Sexp.Atom [%e constr_str]] | args -> match args with | [ tp ] when Option.is_some (Attribute.get inline_attr row) -> (match tp with | [%type: [%t? tp] list ] -> let cnv_expr = Fun_or_match.expr ~loc (sexp_of_type ~typevar_handling:(`ok renaming) tp) in ppat_construct ~loc constr_lid (Some [%pat? l]) --> [%expr Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom [%e constr_str] :: Ppx_sexp_conv_lib.Conv.list_map [%e cnv_expr] l)] | _ -> Attrs.invalid_attribute ~loc inline_attr "_ list") | [ [%type: [%t? tp] sexp_list ] ] -> let cnv_expr = Fun_or_match.expr ~loc (sexp_of_type ~typevar_handling:(`ok renaming) tp) in ppat_construct ~loc constr_lid (Some [%pat? l]) --> [%expr Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom [%e constr_str] :: Ppx_sexp_conv_lib.Conv.list_map [%e cnv_expr] l)] | _ -> let sexp_of_args = List.map ~f:(sexp_of_type ~typevar_handling:(`ok renaming)) args in let cnstr_expr = [%expr Ppx_sexp_conv_lib.Sexp.Atom [%e constr_str] ] in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc sexp_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 Ppx_sexp_conv_lib.Sexp.List [%e elist ~loc (cnstr_expr :: vars)]] let sexp_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_str = estring ~loc:cd.pcd_name.loc cd.pcd_name.txt in branch_sum cd Attrs.list_variant ~types_being_defined renaming ~loc:cd.pcd_loc constr_lid constr_str cd.pcd_args ) ) (* Empty type *) let sexp_of_nil loc = Fun_or_match.Fun [%expr fun _v -> assert false ] (* Generate code from type definitions *) let sexp_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 -> sexp_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 = sexp_of_label_declaration_list ~renaming loc lds ~types_being_defined ~wrap_expr:(fun expr -> [%expr Ppx_sexp_conv_lib.Sexp.List [%e expr]]) in Match [patt --> expr] | Ptype_open -> Location.raise_errorf ~loc "ppx_sexp_conv: open types not supported" | Ptype_abstract -> match td.ptype_manifest with | None -> sexp_of_nil loc | Some ty -> sexp_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 "sexp_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_sexp_of.mk_type td in let func_name = "sexp_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 sexp_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:(sexp_of_td ~types_being_defined) in pstr_value_list ~loc rec_flag bindings let sexp_of_exn ~types_being_defined ~loc:_ ~path ec = let renaming = Renaming.identity in let get_full_cnstr str = path ^ "." ^ str in let loc = ec.ptyexn_loc in let expr = match ec.ptyexn_constructor with | {pext_name = cnstr; pext_kind = Pext_decl (extension_constructor_kind, None); _;} -> let constr_lid = Located.map lident cnstr in let converter = branch_sum ec Attrs.list_exception ~types_being_defined renaming ~loc constr_lid (estring ~loc (get_full_cnstr cnstr.txt)) extension_constructor_kind in let assert_false = ppat_any ~loc --> [%expr assert false] in [%expr Ppx_sexp_conv_lib.Conv.Exn_converter.add [%extension_constructor [%e pexp_construct ~loc constr_lid None]] [%e Fun_or_match.expr ~loc (Match [converter; assert_false])] ] | { pext_kind = Pext_decl (_, Some _); _} -> Location.raise_errorf ~loc "sexp_of_exn/:" | { pext_kind = Pext_rebind _; _} -> Location.raise_errorf ~loc "sexp_of_exn/rebind" in [ pstr_value ~loc Nonrecursive [value_binding ~loc ~pat:[%pat? ()] ~expr] ] end module Str_generate_of_sexp = struct (* Utility functions for polymorphic variants *) (* Handle backtracking when variants do not match *) let handle_no_variant_match loc expr = [[%pat? Ppx_sexp_conv_lib.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 S-expressions *) let mk_variant_other_matches loc rev_els call = let coll_structs acc (loc, cnstr) = pstring ~loc cnstr --> (match call with | `ptag_no_args -> [%expr Ppx_sexp_conv_lib.Conv_error.ptag_no_args _tp_loc _sexp] | `ptag_takes_args -> [%expr Ppx_sexp_conv_lib.Conv_error.ptag_takes_args _tp_loc _sexp]) :: acc in let exc_no_variant_match = [%pat? _] --> [%expr Ppx_sexp_conv_lib.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 = match row_field.prf_desc with | Rtag ({ txt = cnstr; _ },true,[]) -> let tpl = loc, cnstr in ( tpl :: atoms, structs, `A tpl :: ainhs, sinhs ) | Rtag ({ txt = cnstr; _ },false,[tp]) -> let loc = tp.ptyp_loc in ( atoms, (loc, cnstr) :: structs, ainhs, `S (loc, cnstr, 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_sexp ?(internal=false) id args = type_constr_conv id args ~f:(fun s -> let s = s ^ "_of_sexp" in if internal then "__" ^ s ^ "__" else s ) (* Conversion of types *) let rec type_of_sexp ~typevar_handling ?full_type ?(internal=false) typ : Fun_or_match.t = let loc = typ.ptyp_loc in match typ with | _ when Option.is_some (Attribute.get Attrs.opaque typ) -> Fun [%expr Ppx_sexp_conv_lib.Conv.opaque_of_sexp ] | [%type: [%t? _] sexp_opaque ] | [%type: _ ] -> Fun [%expr Ppx_sexp_conv_lib.Conv.opaque_of_sexp ] (*| [%type: sexp_option ] -> (* will never match surely! *) Fun [%expr fun a_of_sexp v -> Ppx_sexp_conv_lib.Option.Some (a_of_sexp v) ]*) | [%type: [%t? ty1] sexp_list ] -> let arg1 = Fun_or_match.expr ~loc (type_of_sexp ~typevar_handling ty1) in Fun [%expr (fun a_of_sexp v -> Ppx_sexp_conv_lib.Conv.list_of_sexp a_of_sexp v) [%e arg1]] | [%type: [%t? ty1] sexp_array ] -> let arg1 = Fun_or_match.expr ~loc (type_of_sexp ~typevar_handling ty1) in Fun [%expr (fun a_of_sexp v -> Ppx_sexp_conv_lib.Conv.array_of_sexp a_of_sexp v) [%e arg1] ] | { ptyp_desc = Ptyp_tuple tp; _ } -> Match (tuple_of_sexp ~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_sexp: ]. \ 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_sexp ~typevar_handling arg)) in Fun (type_constr_of_sexp ~loc ~internal id args) | { ptyp_desc = Ptyp_arrow (_,_,_); _ } -> Fun [%expr Ppx_sexp_conv_lib.Conv.fun_of_sexp ] | { ptyp_desc = Ptyp_variant (row_fields, _, _); _ } -> variant_of_sexp ~typevar_handling ?full_type (loc,row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> poly_of_sexp ~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_sexp] conversion" (* Conversion of tuples *) and tuple_of_sexp ~typevar_handling (loc,tps) = let fps = List.map ~f:(type_of_sexp ~typevar_handling) tps in let bindings, patts, vars = Fun_or_match.map_tmp_vars ~loc fps in let n = List.length fps in [ [%pat? Ppx_sexp_conv_lib.Sexp.List [%p plist ~loc patts]] --> pexp_let ~loc Nonrecursive bindings (pexp_tuple ~loc vars) ; [%pat? sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.tuple_of_size_n_expected _tp_loc [%e eint ~loc n] sexp] ] (* 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_sexp ~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] _sexp] 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, cnstr) -> let new_match = pstring ~loc cnstr --> pexp_variant ~loc cnstr 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_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 cnstr tps row = let cnstr vars_expr = if is_variant then pexp_variant ~loc cnstr (Some vars_expr) else pexp_construct ~loc (Located.lident ~loc cnstr) (Some vars_expr) in match tps with | [ tp ] when Option.is_some (match row with | `Row r -> Attribute.get Attrs.list_poly r | `Constructor c -> Attribute.get Attrs.list_variant c) -> (match tp with | [%type: [%t? tp] list] -> let cnv = Fun_or_match.expr ~loc (type_of_sexp ~typevar_handling tp) in cnstr [%expr Ppx_sexp_conv_lib.Conv.list_map ([%e cnv]) sexp_args ] | _ -> (match row with | `Row _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list" | `Constructor _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list")) | [ [%type: [%t? tp] sexp_list ] ] -> let cnv = Fun_or_match.expr ~loc (type_of_sexp ~typevar_handling tp) in cnstr [%expr Ppx_sexp_conv_lib.Conv.list_map ([%e cnv]) sexp_args ] | _ -> let bindings,patts,good_arg_match = let fps = List.map ~f:(type_of_sexp ~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 sexp_args with | [%p plist ~loc patts] -> [%e pexp_let ~loc Nonrecursive bindings good_arg_match] | _ -> [%e if is_variant then [%expr Ppx_sexp_conv_lib.Conv_error.ptag_incorrect_n_args _tp_loc _tag _sexp] else [%expr Ppx_sexp_conv_lib.Conv_error.stag_incorrect_n_args _tp_loc _tag _sexp]] ] (* 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, cnstr, tp, row) -> has_structs_ref := true; let expr = mk_cnstr_args_match ~typevar_handling ~loc:tp.ptyp_loc ~is_variant:true cnstr [tp] (`Row row) in let new_match = [%pat? ([%p pstring ~loc cnstr] 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_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_sexp_args_patt = if has_structs then [%pat? sexp_args ] else [%pat? _ ] in [ [%pat? Ppx_sexp_conv_lib.Sexp.Atom atom as _sexp] --> mk_variant_match_atom ~typevar_handling loc full_type rev_atoms_inhs rev_structs ; [%pat? Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom atom :: [%p maybe_sexp_args_patt]) as _sexp] --> match_struct ; [%pat? Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_poly_var _tp_loc sexp] ; [%pat? Ppx_sexp_conv_lib.Sexp.List [] as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_poly_var _tp_loc sexp] ] (* Generate matching code for variants *) and variant_of_sexp ~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_sexp ~typevar_handling ~internal:true inh)] sexp :> [%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 sexp] rftag_matches in pexp_try ~loc call (handle_no_variant_match loc expr) in [ [%pat? sexp] --> loop inh rest ] | _ :: _ -> handle_variant_tag ~typevar_handling loc full_type row_fields | [] -> assert false (* impossible *) in if is_contained then Fun [%expr fun sexp -> try [%e pexp_match ~loc [%expr sexp] top_match] with Ppx_sexp_conv_lib.Conv_error.No_variant_match -> Ppx_sexp_conv_lib.Conv_error.no_matching_variant_found _tp_loc sexp ] else Match top_match and poly_of_sexp ~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 sexp -> Ppx_sexp_conv_lib.Conv_error.record_poly_field_value _tp_loc sexp] in List.map ~f:mk_binding parms in match type_of_sexp ~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 cases = function | [] -> inits,cases | ld :: more_flds -> let loc = ld.pld_name.loc in let nm = ld.pld_name.txt in match Attrs.Record_field_handler.Of_sexp.create ~loc ld, ld.pld_type with | Some `sexp_bool, _ -> let inits = [%expr false] :: inits in let cases = (pstring ~loc nm --> [%expr if ! [%e evar ~loc (nm ^ "_field")] then duplicates := ( field_name :: !duplicates ) else (match _field_sexps with | [] -> [%e evar ~loc (nm ^ "_field")] := true | _ :: _ -> Ppx_sexp_conv_lib.Conv_error.record_sexp_bool_with_payload _tp_loc sexp) ] ) :: cases in loop inits cases more_flds | Some (`sexp_option tp), _ | (None | Some (`default _ | `omit_nil | `sexp_array _ | `sexp_list _)), tp -> let inits = [%expr Ppx_sexp_conv_lib.Option.None] :: inits in let unrolled = Fun_or_match.unroll ~loc [%expr _field_sexp ] (type_of_sexp ~typevar_handling tp) in let cases = (pstring ~loc nm --> [%expr match ! [%e evar ~loc (nm ^ "_field")] with | Ppx_sexp_conv_lib.Option.None -> let _field_sexp = _field_sexp () in let fvalue = [%e unrolled] in [%e evar ~loc (nm ^ "_field")] := Ppx_sexp_conv_lib.Option.Some fvalue | Ppx_sexp_conv_lib.Option.Some _ -> duplicates := (field_name :: ! duplicates) ] ) :: cases in loop inits cases more_flds in let handle_extra = [ [%pat? _] --> if allow_extra_fields then [%expr ()] else [%expr if !Ppx_sexp_conv_lib.Conv.record_check_extra_fields then extra := (field_name :: !extra) else ()] ] in loop [] handle_extra (List.rev flds) (* Generate code for handling the result of matching record fields *) let mk_handle_record_match_result ~typevar_handling 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 ! [%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_sexp.create ~loc ld with | Some (`default _ | `sexp_bool | `sexp_option _ | `sexp_list _ | `sexp_array _ | `omit_nil) -> mk_default loc | None -> has_nonopt_fields := true; ( [%expr (Ppx_sexp_conv_lib.Conv.(=) [%e fld] Ppx_sexp_conv_lib.Option.None, [%e estring ~loc nm]) ] :: bi_lst, [%pat? Ppx_sexp_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 cnvt_value ld = let nm = ld.pld_name.txt in match Attrs.Record_field_handler.Of_sexp.create ~loc ld with | Some (`sexp_list _) -> [%expr match [%e evar ~loc (nm ^ "_value")] with | Ppx_sexp_conv_lib.Option.None -> [] | Ppx_sexp_conv_lib.Option.Some v -> v ] | Some (`sexp_array _) -> [%expr match [%e evar ~loc (nm ^ "_value")] with | Ppx_sexp_conv_lib.Option.None -> [||] | Ppx_sexp_conv_lib.Option.Some v -> v ] | Some (`default default) -> [%expr match [%e evar ~loc (nm ^ "_value")] with | Ppx_sexp_conv_lib.Option.None -> [%e default] | Ppx_sexp_conv_lib.Option.Some v -> v ] | Some (`sexp_bool | `sexp_option _) | None -> evar ~loc (nm ^ "_value") | Some `omit_nil -> [%expr match [%e evar ~loc (nm ^ "_value")] with | Ppx_sexp_conv_lib.Option.Some v -> v | Ppx_sexp_conv_lib.Option.None -> (* We change the exception so it contains a sub-sexp of the initial sexp, otherwise sexplib won't find the source location for the error. *) try [%e Fun_or_match.unroll ~loc [%expr Ppx_sexp_conv_lib.Sexp.List [] ] (type_of_sexp ~typevar_handling ld.pld_type) ] with Ppx_sexp_conv_lib.Conv_error.Of_sexp_error (e, _sexp) -> raise (Ppx_sexp_conv_lib.Conv_error.Of_sexp_error (e, sexp)) ] in let match_good_expr = if has_poly then match List.map ~f:cnvt_value flds with | [match_good_expr] -> match_good_expr | match_good_exprs -> pexp_tuple ~loc match_good_exprs else let cnvt ld = Located.lident ~loc ld.pld_name.txt, cnvt_value ld 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_sexp_conv_lib.Conv_error.record_undefined_elements _tp_loc sexp [%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_fields = 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? Ppx_sexp_conv_lib.Sexp.List ((Ppx_sexp_conv_lib.Sexp.Atom field_name) :: (([] | [ _ ]) as _field_sexps)) :: tail] --> [%expr let _field_sexp () = ((match _field_sexps with | [ x ] -> x | [] -> Ppx_sexp_conv_lib.Conv_error.record_only_pairs_expected _tp_loc sexp | _ -> assert false)) in [%e pexp_match ~loc [%expr field_name] mc_fields]; iter tail] ; [%pat? ((Ppx_sexp_conv_lib.Sexp.Atom _ | Ppx_sexp_conv_lib.Sexp.List _) as sexp) :: _] --> [%expr Ppx_sexp_conv_lib.Conv_error.record_only_pairs_expected _tp_loc sexp] ; [%pat? []] --> [%expr ()] ] ] in iter field_sexps; match !duplicates with | _ :: _ -> Ppx_sexp_conv_lib.Conv_error.record_duplicate_fields _tp_loc (!duplicates) sexp | [] -> match !extra with | _ :: _ -> Ppx_sexp_conv_lib.Conv_error.record_extra_fields _tp_loc (!extra) sexp | [] -> [%e mk_handle_record_match_result ~typevar_handling 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_sexp ~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_sexp ~typevar_handling ~allow_extra_fields (loc,flds) : Fun_or_match.t = Match [ [%pat? Ppx_sexp_conv_lib.Sexp.List field_sexps as sexp] --> (label_declaration_list_of_sexp ~typevar_handling ~allow_extra_fields loc flds ~wrap_expr:(fun x -> x)) ; [%pat? Ppx_sexp_conv_lib.Sexp.Atom _ as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.record_list_instead_atom _tp_loc sexp] ] (* Sum type conversions *) (* Generate matching code for well-formed S-expressions wrt. sum types *) let mk_good_sum_matches ~typevar_handling (loc,cds) = List.map cds ~f:(fun cd -> match cd with | { pcd_name = cnstr; pcd_args = Pcstr_record fields; _} -> let lcstr = pstring ~loc (String.uncapitalize cnstr.txt) in let str = pstring ~loc cnstr.txt in let expr = label_declaration_list_of_sexp ~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.txt) (Some e)) in [%pat? (* Uncomment to wrap record *) (* (Ppx_sexp_conv_lib.Sexp.List * [ Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str] as _tag) * ; Ppx_sexp_conv_lib.Sexp.List field_sexps * ] as sexp) *) Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str] as _tag) :: field_sexps) as sexp ] --> expr | { pcd_name = cnstr; pcd_args = Pcstr_tuple []; _} -> Attrs.fail_if_allow_extra_field_cd ~loc cd; let lcstr = pstring ~loc (String.uncapitalize cnstr.txt) in let str = pstring ~loc cnstr.txt in [%pat? Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str])] --> pexp_construct ~loc (Located.lident ~loc cnstr.txt) None | { pcd_name = cnstr; pcd_args = Pcstr_tuple (_::_ as tps); _} -> Attrs.fail_if_allow_extra_field_cd ~loc cd; let lcstr = pstring ~loc (String.uncapitalize cnstr.txt) in let str = pstring ~loc cnstr.txt in [%pat? (Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str] as _tag) :: sexp_args) as _sexp) ] --> mk_cnstr_args_match ~typevar_handling ~loc ~is_variant:false cnstr.txt tps (`Constructor cd) ) (* Generate matching code for malformed S-expressions with good tags wrt. sum types *) let mk_bad_sum_matches (loc,cds) = List.map cds ~f:(function | { pcd_name = cnstr; pcd_args = Pcstr_tuple []; _} -> let lcstr = pstring ~loc (String.uncapitalize cnstr.txt) in let str = pstring ~loc cnstr.txt in [%pat? Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str]) :: _) as sexp ] --> [%expr Ppx_sexp_conv_lib.Conv_error.stag_no_args _tp_loc sexp] | { pcd_name = cnstr; pcd_args = (Pcstr_tuple (_ :: _) | Pcstr_record _); _} -> let lcstr = pstring ~loc (String.uncapitalize cnstr.txt) in let str = pstring ~loc cnstr.txt in [%pat? Ppx_sexp_conv_lib.Sexp.Atom ([%p lcstr] | [%p str]) as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.stag_takes_args _tp_loc sexp] ) (* Generate matching code for sum types *) let sum_of_sexp ~typevar_handling (loc,alts) : Fun_or_match.t = Match (List.concat [ mk_good_sum_matches ~typevar_handling (loc,alts); mk_bad_sum_matches (loc,alts); [ [%pat? Ppx_sexp_conv_lib.Sexp.List (Ppx_sexp_conv_lib.Sexp.List _ :: _) as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.nested_list_invalid_sum _tp_loc sexp] ; [%pat? Ppx_sexp_conv_lib.Sexp.List [] as sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.empty_list_invalid_sum _tp_loc sexp] ; [%pat? sexp] --> [%expr Ppx_sexp_conv_lib.Conv_error.unexpected_stag _tp_loc sexp] ] ]) (* Empty type *) let nil_of_sexp loc : Fun_or_match.t = Fun [%expr fun sexp -> Ppx_sexp_conv_lib.Conv_error.empty_type _tp_loc sexp ] (* Generate code from type definitions *) let td_of_sexp ~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_sexp 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 "sexp_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_sexp ~typevar_handling (td.ptype_loc, alts) | Ptype_record lbls -> record_of_sexp ~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_sexp_conv: open types not supported" | Ptype_abstract -> Attrs.fail_if_allow_extra_field_td ~loc td; match td.ptype_manifest with | None -> nil_of_sexp td.ptype_loc | Some ty -> type_of_sexp ~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_sexp" in let internal_name = "__" ^ type_name ^ "_of_sexp__" 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_sexp_conv_lib.Conv_error.No_variant_match] --> [%expr Ppx_sexp_conv_lib.Conv_error.no_matching_variant_found _tp_loc sexp] ] in let internal_call = let internal_expr = evar ~loc internal_name in eapply ~loc internal_expr (arg_exprs @ [ [%expr sexp] ]) in let try_with = pexp_try ~loc internal_call no_variant_match_mc in false, bind_tp_loc_in [%expr fun sexp -> [%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 typ = Sig_generate_of_sexp.mk_type td in let mk_binding func_name body = 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_sexp ~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_sexp ~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_sexp ~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_sexp ~typevar_handling ~poly ~loc ~path ~rec_flag td in internals @ externals) in pstr_value_list ~loc rec_flag bindings let type_of_sexp ~typevar_handling ~path ctyp = let loc = { ctyp.ptyp_loc with loc_ghost = true } in let fp = type_of_sexp ~typevar_handling ctyp in let body = Merlin_helpers.hide_expression ( match fp with | Fun fun_expr -> [%expr [%e fun_expr] sexp ] | Match matchings -> pexp_match ~loc [%expr sexp] 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 sexp -> let _tp_loc = [%e estring ~loc full_type_name] in [%e body] ] ;; end (* Generates the signature for generation of sexp grammar *) module Sig_generate_sexp_grammar = struct let type_of_sexp_grammar ~loc _ = [%type: Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t] 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 (fun n -> n ^ "_sexp_grammar") td.ptype_name) ~type_:(type_of_sexp_grammar ~loc td) ~prim:[])) end module Sexp_of = struct let type_extension ty = Sig_generate_sexp_of.type_of_sexp_of ~loc:{ ty.ptyp_loc with loc_ghost = true } ty let core_type ty = Str_generate_sexp_of.sexp_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_sexp_of.mk_sig let sig_exception = Sig_generate_sexp_of.mk_sig_exn let str_type_decl = Str_generate_sexp_of.sexp_of_tds let str_exception = Str_generate_sexp_of.sexp_of_exn ~types_being_defined:`Nonrecursive end module Sexp_grammar = struct let type_extension ty = Sig_generate_sexp_grammar.type_of_sexp_grammar ty ~loc:ty.ptyp_loc ;; let core_type ~loc ~path ty = Merlin_helpers.hide_expression (Str_generate_sexp_grammar.sexp_grammar ~loc ~path ty) let sig_type_decl = Sig_generate_sexp_grammar.mk_sig let str_type_decl = Str_generate_sexp_grammar.grammar_of_tds end module Of_sexp = struct let type_extension ty = Sig_generate_of_sexp.type_of_of_sexp ~loc:ty.ptyp_loc ty let core_type = Str_generate_of_sexp.type_of_sexp ~typevar_handling:`disallowed_in_type_expr let sig_type_decl ~poly ~loc ~path tds = Sig_generate_of_sexp.mk_sig ~poly ~loc ~path tds let str_type_decl ~loc ~poly ~path tds = Str_generate_of_sexp.tds_of_sexp ~loc ~poly ~path tds end module Sig_sexp = struct let mk_sig ~loc ~path decls = List.concat [ Sig_generate_sexp_of.mk_sig ~loc ~path decls ; Sig_generate_of_sexp.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_sexp_conv_lib.Sexpable.S" ~handle_polymorphic_variant:false tds with | Some include_infos -> [psig_include ~loc include_infos] | None -> mk_sig ~loc ~path decls end ppx_sexp_conv-0.14.3/expander/ppx_sexp_conv_expander.mli000066400000000000000000000034471401347656000236020ustar00rootroot00000000000000open 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 Sexp_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 sig_exception : loc:Location.t -> path:string -> type_exception -> signature val str_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure val str_exception : loc:Location.t -> path:string -> type_exception -> structure end module Of_sexp : 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 (** the type is annotated with sexp_poly instead of sexp *) -> path:string (** the module path within the file *) -> rec_flag * type_declaration list -> structure end module Sexp_grammar : sig val type_extension : core_type -> core_type val core_type : loc:Location.t -> path:string -> 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 Sig_sexp : sig val sig_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> signature end ppx_sexp_conv-0.14.3/expander/sexp_grammar_lifter.ml000066400000000000000000000044301401347656000226730ustar00rootroot00000000000000open! Base open! Ppxlib open! Ast_builder.Default module Atom = struct type t = Sexp.Private.Raw_grammar.Atom.t = | String | Bool | Char | Float | Int | This of { ignore_capitalization : bool ; string : string } [@@deriving traverse_lift] let lifter ~loc = object inherit [expression] lift inherit Ppxlib_metaquot_lifters.expression_lifters loc end ;; end type atom = Atom.t type var_name = Sexp.Private.Raw_grammar.var_name type type_name = Sexp.Private.Raw_grammar.type_name let lift_string ~loc s = pexp_constant ~loc (Pconst_string (s, loc, None)) let lift_var_name = lift_string let lift_type_name = lift_string type 't type_ = 't Sexp.Private.Raw_grammar.type_ = | Any | Apply of 't type_ * 't type_ list | Atom of atom | Explicit_bind of var_name list * 't type_ | Explicit_var of int | Grammar of 't | Implicit_var of int | List of 't sequence_type | Option of 't type_ | Record of 't record_type | Recursive of type_name | Union of 't type_ list | Variant of 't variant_type and 't sequence_type = 't component list and 't component = 't Sexp.Private.Raw_grammar.component = | One of 't type_ | Optional of 't type_ | Many of 't type_ | Fields of 't record_type and 't variant_type = 't Sexp.Private.Raw_grammar.variant_type = { ignore_capitalization : bool ; alts : (label * 't sequence_type) list } and 't record_type = 't Sexp.Private.Raw_grammar.record_type = { allow_extra_fields : bool ; fields : (label * 't field) list } and 't field = 't Sexp.Private.Raw_grammar.field = { optional : bool ; args : 't sequence_type } (* [traverse_lift] generates references to a type named [t] even if it doesn't exist. So make sure it exists. *) and t = unit [@@deriving traverse_lift, traverse_map] let lifter ~loc = let atom_lifter = Atom.lifter ~loc in object inherit [expression] lift inherit Ppxlib_metaquot_lifters.expression_lifters loc method atom atom = atom_lifter#t atom method label = lift_string ~loc method var_name = lift_var_name ~loc method type_name = lift_type_name ~loc end ;; ppx_sexp_conv-0.14.3/expander/str_generate_sexp_grammar.ml000066400000000000000000000617641401347656000241050ustar00rootroot00000000000000open! Base open! Ppxlib open! Ast_builder.Default open! Sexp.Private.Raw_grammar module Var_name = String module Type_name = String module Longident = struct include Longident include (val Comparator.make ~compare ~sexp_of_t) end let debug_s message values = Caml.prerr_endline (Sexp.to_string_hum (Sexp.message message values)) ;; let _ = debug_s (* [grammar] and [generic_group] form the generic part of grammar: it's the information we can compute statically from the AST *) type grammar = | Inline of grammar Sexp.Private.Raw_grammar.type_ loc (* E.g.,[Ref_same_group "t"] vs [Ref_other_group (Ldot (Lident "t", "Foo"))]. *) | Ref_same_group of Type_name.t loc | Ref_other_group of Longident.t loc type generic_group = { implicit_vars : var_name list ; ggid : generic_group_id ; types : (type_name * grammar type_) list } (* [group] has extra information collected from scope at runtime, necessary to interpret [implicit_vars] in [generic_group] *) type group = { apply_implicit : grammar list } let id_mapper = object inherit Sexp_grammar_lifter.map method var_name x = x method unit () = () method type_name x = x method list f l = List.map l ~f method label x = x method int x = x method bool x = x method atom x = x end ;; let erase_locs : grammar Sexp.Private.Raw_grammar.type_ -> grammar Sexp.Private.Raw_grammar.type_ = id_mapper#type_ (function | Inline x -> Inline { x with loc = Location.none } | Ref_same_group x -> Ref_same_group { x with loc = Location.none } | Ref_other_group x -> Ref_other_group { x with loc = Location.none }) ;; let make_generic_group ~implicit_vars ~types = let ggid = let types = List.map types ~f:(fun (x, g) -> x, erase_locs g) in Caml.Digest.string (Caml.Marshal.to_string types []) in { implicit_vars; types; ggid } ;; type t = { grammars : grammar Map.M(Type_name).t ; generic_group : generic_group ; group : group ; loc : Location.t ; module_path : string } let impossible ~loc s = Location.raise_errorf ~loc "ppx_sexp_conv: sexp_grammar: Impossible! %s" s ;; let not_supported ~loc s = Location.raise_errorf ~loc "ppx_sexp_conv: sexp_grammar doesn't support %s" s ;; module Env : sig type t val sexp_of_t : t -> Sexp.t val create : rec_flag -> type_declaration list -> t val is_in_this_recursive_group : t -> Type_name.t -> bool (** [add_implicit_variable ~loc t id] registers [id] as an implicit variable (a type introduced by functor application) and returns the correct [Implicit_var _] to refer to [id]. *) val add_implicit_variable : loc:Location.t -> t -> Longident.t -> 'a type_ (** [type_for_var ~loc t type_name var] returns the right grammar (typically [Explicit_var _]) for [var_name] in [type_name] in this recursive group. *) val type_for_var : loc:Location.t -> t -> Type_name.t -> Var_name.t -> 'a type_ (** Register some type variables as being universally quantified. *) val within_polymorphic_record_field : t -> Var_name.t loc list -> t (** [with_explicit_bind ~loc t type_name type_] wraps [type_] in [Explicit_bind] if [t] indicates that [type_name] has type variables that might otherwise be free in [type_]. *) val with_explicit_bind : loc:Location.t -> t -> Type_name.t -> 'a type_ -> 'a type_ (** For the [implicit_vars] field of a [generic_group] value. *) val implicit_vars : t -> Type_name.t list (** For the [apply_implicit] field of a [group] value *) val apply_implicit : t -> grammar list end = struct module Explicit_type_variables = struct type t = Var_name.t option array let sexp_of_t : t -> Sexp.t = Array.sexp_of_t (Option.sexp_of_t Var_name.sexp_of_t) let create td = List.map td.ptype_params ~f:(fun (ctype, _variance) -> match ctype.ptyp_desc with | Ptyp_any -> None | Ptyp_var s -> Some s | _ -> Location.raise_errorf ~loc:ctype.ptyp_loc "not a type parameter") |> Array.of_list ;; let find t name = Array.find_mapi t ~f:(fun i var_name -> match Option.equal String.equal var_name (Some name) with | true -> Some i | false -> None) ;; let explicit_bind t type_ = match t with | [||] -> type_ | _ -> let variables = Array.map t ~f:(Option.value ~default:"_") |> Array.to_list in Explicit_bind (variables, type_) ;; end (* The kitchen-sink type for information used as we generate the grammars. *) type init = { (* Explicit type variables of type declarations in this recursive group. *) explicit : Explicit_type_variables.t Map.M(Type_name).t ; (* Implicit type variables in this mutually recursive group, filled in as we traverse the type declarations. *) mutable implicit : int loc Map.M(Longident).t ; rec_flag : rec_flag } type t = | Init of init | Within_polymorphic_record_field of { (* [first_class_polymorphism] represents universally-quantified variables introduced by polymorphic record fields. (We actually do support polymorphic record fields!) Values of these types can't occur in serializable values so we're substituting them with the unsatisfiable grammar [Union []]. *) first_class_polymorphism : Set.M(Var_name).t ; t : t } let sexp_of_init { explicit; implicit; rec_flag } : Sexp.t = List [ Atom "T" ; List [ List [ Atom "explicit" ; Map.sexp_of_m__t (module Type_name) Explicit_type_variables.sexp_of_t explicit ] ; List [ Atom "implicit" ; Map.sexp_of_m__t (module struct type t = Longident.t let sexp_of_t t = sexp_of_string (Longident.name t) end) (fun { loc = _; txt = int } -> sexp_of_int int) implicit ] ; List [ Atom "rec_flag"; Ast_traverse.sexp_of#rec_flag rec_flag ] ] ] ;; let rec sexp_of_t t : Sexp.t = match t with | Init init -> sexp_of_init init | Within_polymorphic_record_field { first_class_polymorphism; t } -> List [ Atom "Within_polymorphic_record_field" ; List [ List [ Atom "first_class_polymorphism" ; Set.sexp_of_m__t (module Type_name) first_class_polymorphism ] ; List [ Atom "t"; sexp_of_t t ] ] ] ;; let _ = sexp_of_t let create rec_flag tds : t = Init { explicit = List.map tds ~f:(fun td -> td.ptype_name.txt, Explicit_type_variables.create td) |> Map.of_alist_exn (module Type_name) ; implicit = Map.empty (module Longident) ; rec_flag } ;; let rec get_init t = match t with | Init init -> init | Within_polymorphic_record_field { first_class_polymorphism = _; t } -> get_init t ;; let add_implicit_variable ~loc t lident = let init = get_init t in match Map.find init.implicit lident with | Some i -> Implicit_var i.txt | None -> let i = Map.length init.implicit in init.implicit <- Map.add_exn init.implicit ~key:lident ~data:{ loc; txt = i }; Implicit_var i ;; let sort_by_index m ~f = Map.to_alist m |> List.sort ~compare:(fun (_, i) (_, j) -> compare (f i) (f j)) ;; let implicit_vars t = let init = get_init t in List.map (sort_by_index init.implicit ~f:(fun x -> x.txt)) ~f:(fun (lid, _) -> Longident.name lid) ;; let apply_implicit t = let init = get_init t in List.map (sort_by_index init.implicit ~f:(fun x -> x.txt)) ~f:(fun (lident, { loc; txt = _ }) -> Ref_other_group { loc; txt = lident }) ;; let is_in_this_recursive_group t type_name = let init = get_init t in match init.rec_flag with | Nonrecursive -> false | Recursive -> Map.mem init.explicit type_name ;; let variables_of_type ~loc init type_name = match Map.find init.explicit type_name with | None -> impossible ~loc ("unknown type name: " ^ type_name) | Some variables -> variables ;; let rec type_for_var ~loc t type_name var_name = match t with | Within_polymorphic_record_field { first_class_polymorphism; t } -> (match Set.mem first_class_polymorphism var_name with | true -> Union [] | false -> type_for_var ~loc t type_name var_name) | Init init -> (match Explicit_type_variables.find (variables_of_type ~loc init type_name) var_name with | None -> Location.raise_errorf "unbound type parameter '%s" var_name | Some i -> Explicit_var i) ;; let within_polymorphic_record_field t type_names = Within_polymorphic_record_field { first_class_polymorphism = List.map type_names ~f:(fun { loc = _; txt } -> txt) |> Set.of_list (module Type_name) ; t } ;; let with_explicit_bind ~loc t type_name type_ = let init = get_init t in Explicit_type_variables.explicit_bind (variables_of_type ~loc init type_name) type_ ;; end let _ = Env.sexp_of_t module Row_field = struct type t = | Inherit of core_type | Tag_nullary of label (** [Tag_sexp_list (label, ctype)] means one of these forms: - [`Label of ctype sexp_list] - [`Label of ctype list [@sexp.list]]. *) | Tag_sexp_list of label * core_type | Tag_tuple of label * core_type let core_type_within_sexp_list args sexp_list_attribute attribute_of = match args with | [ [%type: [%t? type_] sexp_list] ] -> Some type_ | [ [%type: [%t? type_]] ] when Option.is_some (Attribute.get sexp_list_attribute attribute_of) -> (match type_ with | [%type: [%t? type_] list] -> Some type_ | _ -> Attrs.invalid_attribute ~loc:type_.ptyp_loc sexp_list_attribute "_ list") | _ -> None ;; let create row_field = match row_field.prf_desc with | Rinherit ctype -> Inherit ctype | Rtag ({ loc; txt = label }, nullary, possible_arg_types) -> (match nullary, possible_arg_types with | true , [] -> Tag_nullary label | false, ([ ctype ] as args) -> (match core_type_within_sexp_list args Attrs.list_poly row_field with | Some ctype -> Tag_sexp_list (label, ctype) | None -> Tag_tuple (label, ctype)) | false, [] -> impossible ~loc "polymorphic variant constructor neither nullary nor not" | true, _ :: _ | false, _ :: _ :: _ -> not_supported ~loc "polymorphic variants with intersection types ([`A of _ & _])") ;; end module Opaque = struct type t = | Not_opaque of core_type | Opaque let create ctype : t = match Attribute.get Attrs.opaque ctype with | Some () -> Opaque | None -> (match ctype.ptyp_desc with | Ptyp_constr ({ loc = _; txt = Lident "sexp_opaque" }, _) -> Opaque | _ -> Not_opaque ctype) ;; end let sexp_grammar_suffix = "_sexp_grammar" (* Given [(u, v) A.B.F(M)(N).t], [type_of_type_constructor] returns {[ fun [u_grammar; v_grammar] -> Apply ( Grammar A.B.f__t_sexp_grammar , [ M.t_sexp_grammar; N.t_sexp_grammar; u_grammar; v_grammar ]) ]}, which is the usual scheme implemented by [Ast_builder.*.type_constr_conv] but defunctionalized because polymorphic sexp_grammars are constructors not functions. *) let type_of_type_constructor ~loc env lident args = let apply_if_args tycon = function | [] -> tycon | args -> Apply (tycon, args) in match lident with | Lident type_name when Env.is_in_this_recursive_group env type_name -> apply_if_args (Recursive type_name) args | Lident _ | Ldot ((Lident _ | Ldot _), _) -> apply_if_args (Env.add_implicit_variable ~loc env lident) args | Lapply _ -> impossible ~loc ("Expected type name, got " ^ Longident.name lident) | Ldot ((Lapply _ as module_path), n) -> let suffix_n functor_ = String.uncapitalize functor_ ^ "__" ^ n in let rec gather_lapply functor_args : Longident.t -> Longident.t * _ = function | Lapply (rest, arg) -> gather_lapply (arg :: functor_args) rest | Lident functor_ -> Lident (suffix_n functor_), functor_args | Ldot (functor_path, functor_) -> Ldot (functor_path, suffix_n functor_), functor_args in let ident, functor_args = gather_lapply [] module_path in let tycon = Env.add_implicit_variable ~loc env ident in let functor_args = List.map functor_args ~f:(fun functor_arg -> Env.add_implicit_variable ~loc env (Ldot (functor_arg, "t"))) in Apply (tycon, functor_args @ args) ;; (* We use a fully qualified module path here because it does not make sense for the user to shadow these grammars with other values. *) let unsupported_builtin ~loc type_name = let ( +.+ ) a b = Ldot (a, b) in Grammar (Ref_other_group { loc ; txt = Lident "Ppx_sexp_conv_lib" +.+ "Sexp" +.+ "Private" +.+ "Raw_grammar" +.+ type_name }) ;; let type_of_core_type env0 type_name ctype = let rec type_of_core_type env ctype = match Opaque.create ctype with | Opaque -> unsupported_builtin ~loc:ctype.ptyp_loc "opaque" | Not_opaque { ptyp_desc; ptyp_loc = loc; ptyp_attributes = _; ptyp_loc_stack = _ } -> (match ptyp_desc with | Ptyp_any -> (* For consistency with [%of_sexp: _] which treats [_] as unsatisfiable. *) Union [] | Ptyp_var s -> Env.type_for_var ~loc env type_name s | Ptyp_arrow (_, _, _) -> unsupported_builtin ~loc "fun" | Ptyp_tuple core_types -> List (List.map core_types ~f:(fun core_type -> One (type_of_core_type env core_type))) | Ptyp_constr (ident, args) -> type_of_type_constructor ~loc env ident.txt (List.map args ~f:(type_of_core_type env)) | Ptyp_object (_, _) -> not_supported ~loc "objects" | Ptyp_class (_, _) -> not_supported ~loc "classes" | Ptyp_alias (_, _) -> not_supported ~loc "aliases" | Ptyp_variant (row_fields, Closed, None) -> type_of_row_fields env row_fields | Ptyp_variant (_, Open, _) | Ptyp_variant (_, _, Some _) -> not_supported ~loc "polymorphic variants with < or >" | Ptyp_poly (first_class_variables, core_type) -> let env = Env.within_polymorphic_record_field env first_class_variables in type_of_core_type env core_type | Ptyp_package _ -> not_supported ~loc "packed modules" | Ptyp_extension _ -> not_supported ~loc "extension nodes") and type_of_row_fields env row_fields = let alts, inherits = List.partition_map row_fields ~f:(fun row_field -> match Row_field.create row_field with | Inherit ctype -> Second ((type_of_core_type env) ctype) | Tag_nullary label -> First (label, []) | Tag_sexp_list (label, ctype) -> First (label, [ Many (type_of_core_type env ctype) ]) | Tag_tuple (label, ctype) -> First (label, [ One (type_of_core_type env ctype) ])) in let types = match alts with | [] -> None | _ :: _ -> Some (Variant { ignore_capitalization = false; alts }) in match Option.to_list types @ inherits with | [] -> unsupported_builtin ~loc:ctype.ptyp_loc "empty" | [ type_ ] -> type_ | _ :: _ as types -> Union types in (type_of_core_type env0) ctype ;; let record_type_of_label_declarations env type_name lds ~allow_extra_fields = { allow_extra_fields ; fields = List.map lds ~f:(fun ld -> let { pld_name; pld_mutable = _; pld_type; pld_loc; pld_attributes = _ } = ld in let field = match Attrs.Record_field_handler.Of_sexp.create ~loc:pld_loc ld with | None -> { optional = false ; args = [ One (type_of_core_type env type_name pld_type) ] } | Some (`default _ | `omit_nil) -> { optional = true ; args = [ One (type_of_core_type env type_name pld_type) ] } | Some `sexp_bool -> { optional = true; args = [] } | Some (`sexp_array core_type | `sexp_list core_type) -> { optional = true ; args = [ One (List [ Many (type_of_core_type env type_name core_type) ]) ] } | Some (`sexp_option core_type) -> { optional = true ; args = [ One (type_of_core_type env type_name core_type) ] } in pld_name.txt, field) } ;; module Constructor_declaration = struct type t = | Record of { allow_extra_fields : bool ; fields : label_declaration list ; label : label } | Tuple_regular of label * core_type list (** [Tuple_sexp_list (label, ctype)] means one of these forms: - [Label of ctype sexp_list] - [Label of ctype list [@sexp.list]]. *) | Tuple_sexp_list of label * core_type let create ({ pcd_name; pcd_args; pcd_res; pcd_loc; _ } as cd) = match pcd_res with | Some _ -> not_supported ~loc:pcd_loc "GADTs" | None -> let label = pcd_name.txt in (match pcd_args with | Pcstr_record fields -> Record { allow_extra_fields = Option.is_some (Attribute.get Attrs.allow_extra_fields_cd cd) ; fields ; label } | Pcstr_tuple args -> (match Row_field.core_type_within_sexp_list args Attrs.list_variant cd with | Some ctype -> Tuple_sexp_list (label, ctype ) | None -> Tuple_regular (label, args))) ;; end let variant env type_name constructor_declarations = let alts = List.map constructor_declarations ~f:(fun constructor_declaration -> match Constructor_declaration.create constructor_declaration with | Record { allow_extra_fields; fields; label } -> let fields = record_type_of_label_declarations env type_name fields ~allow_extra_fields in label, [ Fields fields ] | Tuple_regular (label, ctypes) -> let f ctype = One (type_of_core_type env type_name ctype) in label, List.map ctypes ~f | Tuple_sexp_list (label, ctype ) -> label, [ Many (type_of_core_type env type_name ctype) ]) in Variant { ignore_capitalization = true; alts } ;; let type_of_type_declaration env td = let loc = td.ptype_loc in let type_name = td.ptype_name.txt in let type_ = match td.ptype_kind with | Ptype_variant alts -> variant env type_name alts | Ptype_record lds -> Record (record_type_of_label_declarations env type_name lds ~allow_extra_fields: (Attribute.get Attrs.allow_extra_fields_td td |> Option.is_some)) | Ptype_open -> not_supported ~loc "open types" | Ptype_abstract -> (match td.ptype_manifest with | None -> unsupported_builtin ~loc "empty" | Some core_type -> type_of_core_type env type_name core_type) in Env.with_explicit_bind ~loc env td.ptype_name.txt type_ ;; let create ~loc ~path rec_flag tds : t = let env = Env.create rec_flag tds in let grammars = List.map tds ~f:(fun { ptype_name; _ } -> ptype_name.txt, Ref_same_group ptype_name) |> Map.of_alist_exn (module Type_name) in let types = List.map tds ~f:(fun td -> td.ptype_name.txt, type_of_type_declaration env td) in let generic_group = make_generic_group ~implicit_vars:(Env.implicit_vars env) ~types in let group = { apply_implicit = Env.apply_implicit env } in { grammars; generic_group; group; loc; module_path = path } ;; let collect_type_variables_of_polymorphic_grammar core_type = match core_type with | [%type: < for_all : [%t? { ptyp_desc = Ptyp_poly (variables, core_type); _ }] > ] -> let var_names = List.map variables ~f:(fun { txt; loc = _ } -> txt) in var_names, core_type | { ptyp_desc = Ptyp_object _; _ } -> not_supported ~loc:core_type.ptyp_loc "objects, except the syntax [%sexp_grammar: < for_all : 'a 'b . ... >] to generate \ grammars of polymorphic types" | _ -> [], core_type ;; let singleton ~loc ~path core_type : t = let name = { loc; txt = "dummy_type_name_from_sexp_grammar" } in let params, core_type = let type_variables, core_type = collect_type_variables_of_polymorphic_grammar core_type in ( List.map type_variables ~f:(fun var_name -> ptyp_var ~loc var_name, (NoVariance, NoInjectivity)) , core_type ) in let td = type_declaration ~loc ~name ~params ~cstrs:[] ~kind:Ptype_abstract ~private_:Public ~manifest:(Some core_type) in let env = Env.create Recursive [ td ] in let types = [ name.txt, type_of_type_declaration env td ] in { grammars = Map.singleton (module Type_name) name.txt (Ref_same_group name) ; generic_group = make_generic_group ~implicit_vars:(Env.implicit_vars env) ~types ; group = { apply_implicit = Env.apply_implicit env } ; loc ; module_path = path } ;; module Pattern = struct let the_generic_group ~loc = [%pat? _the_generic_group] let the_group ~loc = [%pat? _the_group] end module Expression = struct let the_generic_group ~loc = [%expr _the_generic_group] let the_group ~loc = [%expr _the_group] let list ~loc xs ~f = elist ~loc (List.map xs ~f:(f ~loc)) let tuple2 a b ~loc (a_, b_) = [%expr [%e a ~loc a_], [%e b ~loc b_]] let map_lident_last lident ~f = match lident with | Lident x -> Lident (f x) | Ldot (lident, x) -> Ldot (lident, f x) | Lapply _ -> invalid_arg "Lapply" ;; let of_grammar ~loc = let type_lifter = Sexp_grammar_lifter.lifter ~loc in let rec of_grammar = function | Inline { loc; txt = type_ } -> [%expr Inline [%e type_lifter#type_ of_grammar type_]] | Ref_same_group { loc; txt = type_name } -> [%expr Ref ([%e type_lifter#type_name type_name], [%e the_group ~loc])] | Ref_other_group { loc; txt = lid } -> pexp_ident ~loc { loc ; txt = map_lident_last lid ~f:(fun type_name -> type_name ^ sexp_grammar_suffix) } in of_grammar ;; let of_type ~loc = (Sexp_grammar_lifter.lifter ~loc)#type_ (of_grammar ~loc) let of_generic_group ~loc { implicit_vars; ggid; types } = [%expr { implicit_vars = [%e list ~loc implicit_vars ~f:Sexp_grammar_lifter.lift_var_name] ; ggid = [%e estring ~loc ggid] ; types = [%e list ~loc types ~f:(tuple2 Sexp_grammar_lifter.lift_type_name of_type)] }] ;; let of_group ~loc { apply_implicit } ~module_path = [%expr { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [%e list ~loc apply_implicit ~f:of_grammar] ; generic_group = [%e the_generic_group ~loc] ; origin = [%e estring ~loc module_path] }] ;; end let sexp_grammar_name ~loc type_name = { loc; txt = Lident (type_name ^ sexp_grammar_suffix) } ;; let to_pat_and_expr { grammars; generic_group; group; loc; module_path } = let bindings = Map.to_alist grammars |> List.map ~f:(fun (type_name, grammar) -> let pat = [%pat? ([%p ppat_var ~loc { loc; txt = type_name ^ sexp_grammar_suffix }] : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t)] in let expr = Expression.of_grammar ~loc grammar in pat, expr) in let pat = ppat_tuple (List.map bindings ~f:fst) ~loc in let generic_group = Expression.of_generic_group ~loc generic_group in let group = Expression.of_group ~loc group ~module_path in let grammars = pexp_let Nonrecursive (List.map bindings ~f:(fun (pat, expr) -> value_binding ~loc ~pat ~expr)) (pexp_tuple ~loc (Map.to_alist grammars |> List.map ~f:(fun (type_name, _) -> pexp_ident ~loc (sexp_grammar_name ~loc type_name)))) ~loc in let expr = [%expr let ([%p Pattern.the_generic_group ~loc] : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = [%e generic_group] in let ([%p Pattern.the_group ~loc] : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = [%e group] in [%e grammars]] in pat, expr ;; let grammar_of_tds ~loc ~path (rec_flag, tds) = let pat, expr = create ~loc ~path rec_flag tds |> to_pat_and_expr in [%str let [%p pat] = [%e expr]] ;; let sexp_grammar ~loc ~path core_type = singleton ~loc ~path core_type |> to_pat_and_expr |> snd ;; ppx_sexp_conv-0.14.3/expander/str_generate_sexp_grammar.mli000066400000000000000000000003351401347656000242410ustar00rootroot00000000000000open! Base open! Ppxlib val grammar_of_tds : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure_item list val sexp_grammar : loc:Location.t -> path:string -> core_type -> expression ppx_sexp_conv-0.14.3/ppx_sexp_conv.opam000066400000000000000000000014311401347656000202500ustar00rootroot00000000000000opam-version: "2.0" version: "v0.14.0" maintainer: "opensource@janestreet.com" authors: ["Jane Street Group, LLC "] homepage: "https://github.com/janestreet/ppx_sexp_conv" bug-reports: "https://github.com/janestreet/ppx_sexp_conv/issues" dev-repo: "git+https://github.com/janestreet/ppx_sexp_conv.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_sexp_conv/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.04.2"} "base" {>= "v0.14" & < "v0.15"} "sexplib0" {>= "v0.14" & < "v0.15"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.22.0"} ] synopsis: "[@@deriving] plugin to generate S-expression conversion functions" description: " Part of the Jane Street's PPX rewriters collection. " ppx_sexp_conv-0.14.3/runtime-lib/000077500000000000000000000000001401347656000167275ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/runtime-lib/dune000066400000000000000000000001761401347656000176110ustar00rootroot00000000000000(library (name ppx_sexp_conv_lib) (public_name ppx_sexp_conv.runtime-lib) (libraries sexplib0) (preprocess no_preprocessing))ppx_sexp_conv-0.14.3/runtime-lib/ppx_sexp_conv_lib.ml000066400000000000000000000004601401347656000230020ustar00rootroot00000000000000module Conv = Sexplib0.Sexp_conv module Conv_error = Sexplib0.Sexp_conv_error module Lazy_group_id = Sexplib0.Private.Lazy_group_id module Sexp = Sexplib0.Sexp module Sexpable = Sexplib0.Sexpable module Option = struct type 'a t = 'a option = | None | Some of 'a end ppx_sexp_conv-0.14.3/src/000077500000000000000000000000001401347656000152675ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/src/dune000066400000000000000000000002261401347656000161450ustar00rootroot00000000000000(library (name ppx_sexp_conv) (public_name ppx_sexp_conv) (kind ppx_deriver) (libraries ppxlib ppx_sexp_conv_expander) (preprocess no_preprocessing))ppx_sexp_conv-0.14.3/src/ppx_sexp_conv.ml000066400000000000000000000071731401347656000205240ustar00rootroot00000000000000(* sexp_conv: Preprocessing Module for Automated S-expression Conversions *) open Ppxlib module Attrs = Ppx_sexp_conv_expander.Attrs module Sexp_of = struct module E = Ppx_sexp_conv_expander.Sexp_of let name = "sexp_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 str_exception = Deriving.Generator.make_noarg E.str_exception ;; let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl ;; let sig_exception = Deriving.Generator.make_noarg E.sig_exception ;; let extension ~loc:_ ~path:_ ctyp = E.core_type ctyp let deriver = Deriving.add name ~str_type_decl ~str_exception ~sig_type_decl ~sig_exception ~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_sexp = struct module E = Ppx_sexp_conv_expander.Of_sexp let name = "of_sexp" 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_sexp_poly = struct module E = Ppx_sexp_conv_expander.Of_sexp 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_sexp_poly" ~sig_type_decl ~str_type_decl ;; end module Sexp_grammar = struct module E = Ppx_sexp_conv_expander.Sexp_grammar let name = "sexp_grammar" let str_type_decl = Deriving.Generator.make_noarg E.str_type_decl ;; let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl ;; let extension = E.core_type let deriver = Deriving.add name ~sig_type_decl ~str_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 let sexp_of = Sexp_of.deriver let of_sexp = Of_sexp.deriver let of_sexp_poly = Of_sexp_poly.deriver let sexp_grammar = Sexp_grammar.deriver module Sexp_in_sig = struct module E = Ppx_sexp_conv_expander.Sig_sexp let sig_type_decl = Deriving.Generator.make_noarg E.sig_type_decl ;; let deriver = Deriving.add "ppx_sexp_conv: let this be a string that wouldn't parse if put in the source" ~sig_type_decl end let sexp = Deriving.add_alias "sexp" [sexp_of; of_sexp] ~sig_type_decl:[Sexp_in_sig.deriver] ~str_exception:[sexp_of] ~sig_exception:[sexp_of] let sexp_poly = Deriving.add_alias "sexp_poly" [sexp_of; of_sexp_poly] ppx_sexp_conv-0.14.3/src/ppx_sexp_conv.mli000066400000000000000000000003011401347656000206570ustar00rootroot00000000000000open Ppxlib val of_sexp : Deriving.t val sexp_of : Deriving.t val sexp : Deriving.t val of_sexp_poly : Deriving.t val sexp_poly : Deriving.t val sexp_grammar : Deriving.t ppx_sexp_conv-0.14.3/test/000077500000000000000000000000001401347656000154575ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/test/dune000066400000000000000000000003121401347656000163310ustar00rootroot00000000000000(library (name ppx_sexp_conv_test) (libraries base expect_test_helpers_core sexplib) (flags :standard -w -30) (preprocess (pps ppxlib ppx_sexp_conv ppx_compare ppx_here ppx_inline_test ppx_expect)))ppx_sexp_conv-0.14.3/test/errors.mlt000066400000000000000000000157711401347656000175240ustar00rootroot00000000000000type t = { a : int [@sexp_drop_default] [@sexp.omit_nil] } [@@deriving sexp_of] [%%expect{| Line _, characters _-_: Error: The following elements are mutually exclusive: sexp.sexp_drop_default sexp.omit_nil |}] type t = { a : int sexp_list [@sexp.omit_nil] } [@@deriving sexp_of] [%%expect{| Line _, characters _-_: Error: The following elements are mutually exclusive: sexp.omit_nil sexp_list |}] type t = { a : int [@default 0] [@sexp.omit_nil] } [@@deriving of_sexp] [%%expect{| Line _, characters _-_: Error: The following elements are mutually exclusive: sexp.default sexp.omit_nil |}] type t = int [@@deriving sexp][@@sexp.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: [@@allow_extra_fields] is only allowed on records. |}] type 'a t = 'a option = None | Some of 'a [@@deriving sexp][@@sexp.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: [@@allow_extra_fields] is only allowed on records. |}] type 'a t = Some of {a : int} [@@deriving sexp] [@@sexp.allow_extra_fields] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: [@@allow_extra_fields] only works on records. For inline records, do: type t = A of { a : int } [@allow_extra_fields] | B [@@deriving sexp] |}] type 'a t = | Some of {a : int} | None [@sexp.allow_extra_fields] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: [@allow_extra_fields] is only allowed on inline records. |}] type t = | Non | Som of { next : t; [@default Non] [@sexp_drop_default.equal] } [@@deriving sexp] [%%expect{| Line _, characters _-_: Error: [@sexp_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 [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead. |}] type nonrec 'a t = { foo : 'a option; [@default None] [@sexp_drop_default.equal] } [@@deriving sexp] [%%expect{| Line _, characters _-_: Error: [@sexp_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 [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead. |}] open Base type t = { a : int [@default 8] [@sexp_drop_default] } [@@deriving sexp_of] [%%expect{| Line _, characters _-_: Error (warning 22): [@sexp_drop_default] is deprecated: please use one of: - [@sexp_drop_default f] and give an explicit equality function ([f = Poly.(=)] corresponds to the old behavior) - [@sexp_drop_default.compare] if the type supports [%compare] - [@sexp_drop_default.equal] if the type supports [%equal] - [@sexp_drop_default.sexp] if you want to compare the sexp representations |}] type t = { x : unit [@sexp.opaque] } [@@deriving sexp_of] type t = { x : unit [@sexp.opaque] } [@@deriving of_sexp] type t = { x : unit [@sexp.opaque] } [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: Attribute `sexp.opaque' was not used. Hint: `sexp.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 `sexp.opaque' was not used. Hint: `sexp.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 `sexp.opaque' was not used. Hint: `sexp.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 [@sexp.option] } [@@deriving sexp_of] type t = { x : unit [@sexp.option] } [@@deriving of_sexp] type t = { x : unit [@sexp.option] } [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option]. |}] type t = { x : unit [@sexp.list] } [@@deriving sexp_of] type t = { x : unit [@sexp.list] } [@@deriving of_sexp] type t = { x : unit [@sexp.list] } [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. |}] type t = { x : unit [@sexp.array] } [@@deriving sexp_of] type t = { x : unit [@sexp.array] } [@@deriving of_sexp] type t = { x : unit [@sexp.array] } [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array]. |}] type t = { x : unit [@sexp.bool] } [@@deriving sexp_of] type t = { x : unit [@sexp.bool] } [@@deriving of_sexp] type t = { x : unit [@sexp.bool] } [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool]. |}] type t = A of unit [@sexp.list] [@@deriving sexp_of] type t = A of unit [@sexp.list] [@@deriving of_sexp] type t = A of unit [@sexp.list] [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. |}] type t = [`A of unit [@sexp.list]] [@@deriving sexp_of] type t = [`A of unit [@sexp.list]] [@@deriving of_sexp] type t = [ `A of unit [@sexp.list]] [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. Line _, characters _-_: Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list]. |}] let (_ : _) = [%sexp_grammar: 'k -> 'v -> ('k * 'v) list] [%%expect{| |}] let (_ : _) = [%sexp_grammar: < for_all : 'k 'v . ('k * 'v) list > ] [%%expect{| |}] let (_ : _) = [%sexp_grammar: < other : 'k 'v . ('k * 'v) list > ] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support objects, except the syntax [%sexp_grammar: < for_all : 'a 'b . ... >] to generate grammars of polymorphic types |}] type t = < for_all : 'k 'v . ('k * 'v) list > [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support objects |}] type t = < other : 'k 'v . ('k * 'v) list > [@@deriving sexp_grammar] [%%expect{| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support objects |}] ppx_sexp_conv-0.14.3/test/examples.mlt000066400000000000000000000017151401347656000200170ustar00rootroot00000000000000 module Position_for_polymorphic_variant_errors = struct type t1 = [ `A ] [@@deriving of_sexp] type t2 = [ `B ] [@@deriving of_sexp] type t3 = A of [ t1 | t2 ] [@@deriving of_sexp] let (_ : t3) = t3_of_sexp (List [Atom "A"; Atom "C"]) end [%%expect{| Exception: (Of_sexp_error "examples.mlt.Position_for_polymorphic_variant_errors.t3_of_sexp: no matching variant found" (invalid_sexp C)) |}] let _ = [%sexp_of: 'a] [%%expect{| Line _, characters _-_: Error: Type variables not allowed in [%sexp_of: ]. Please use locally abstract types instead. |}] let _ = [%of_sexp: 'a] [%%expect{| Line _, characters _-_: Error: Type variables not allowed in [%of_sexp: ]. Please use locally abstract types instead. |}] let _ = [%sexp (() : 'a)] [%%expect{| Line _, characters _-_: Error: Type variables not allowed in [%sexp_of: ]. Please use locally abstract types instead. |}] type 'a t = | None | Something_else of { value : 'a } [@@deriving sexp] [%%expect{||}] ppx_sexp_conv-0.14.3/test/expect/000077500000000000000000000000001401347656000167475ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/test/expect/dune000066400000000000000000000007111401347656000176240ustar00rootroot00000000000000(library (name ppx_sexp_conv_test_expect) (libraries base expect_test_helpers_core sexp_grammar_validation) (preprocess (pps ppx_sexp_conv ppx_expect ppx_here))) (rule (targets regular_vs_polymorphic_variants.diff) (deps test_regular_variants.ml test_polymorphic_variants.ml) (mode promote) (action (bash "%{bin:patdiff-for-review} %{bin:patdiff} %{deps} > %{targets} || true"))) (alias (name DEFAULT) (deps regular_vs_polymorphic_variants.diff))ppx_sexp_conv-0.14.3/test/expect/regular_vs_polymorphic_variants.diff000066400000000000000000000104701401347656000263100ustar00rootroot00000000000000------ test_regular_variants.ml ++++++ test_polymorphic_variants.ml @|============================================================ -| | A -| | B +| [ `A +| | `B +| ] @|============================================================ -| ; ggid = "\239\242\007o\016\222\178\133\218\153\146w\129\255\167\208" +| ; ggid = "\133a\241\019; \198\184U\181\220#\191\190\200\b" @|============================================================ -| , Variant { ignore_capitalization = true; alts = [ "A", []; "B", [] ] } ) -| ) +| , Variant { ignore_capitalization = false; alts = [ "A", []; "B", [] ] } +| ) ) @|============================================================ -| ; origin = "test_regular_variants.ml.Nullary" +| ; origin = "test_polymorphic_variants.ml.Nullary" @|============================================================ -| | A of int * int -| | B of string +| [ `A of int * int +| | `B of string +| ] @|============================================================ -| type t = With_sexp.t = -| | A of int * int -| | B of string +| type t = +| [ `A of int * int +| | `B of string +| ] @|============================================================ -| ; ggid = "B\127\229(\029\022\255\"\167ab\178F\134\201\234" +| ; ggid = "\196t P\169\167\173C\251\132\141N\003n \132" @|============================================================ -| { ignore_capitalization = true +| { ignore_capitalization = false @|============================================================ -| [ "A", [ One (Implicit_var 0); One (Implicit_var 0) ] +| [ "A", [ One (List [ One (Implicit_var 0); One (Implicit_var 0) ]) ] @|============================================================ -| ; origin = "test_regular_variants.ml.With_arguments" +| ; origin = "test_polymorphic_variants.ml.With_arguments" @|============================================================ -| print_s (With_sexp.sexp_of_t (A (1, 2))); -| print_s (With_sexp.sexp_of_t (B "foo")); +| print_s (With_sexp.sexp_of_t (`A (1, 2))); +| print_s (With_sexp.sexp_of_t (`B "foo")); @|============================================================ -| (A 1 2) +| (A (1 2)) @|============================================================ -| | Int of int -| | List of int list -| | Sexp_dot_list of int list [@sexp.list] -| | Sexp_list of int sexp_list [@warning "-3"] +| [ `Int of int +| | `List of int list +| | `Sexp_dot_list of int list [@sexp.list] +| | `Sexp_list of int sexp_list [@warning "-3"] +| ] @|============================================================ -| type t = With_sexp.t = -| | Int of int -| | List of int list -| | Sexp_dot_list of int list [@sexp.list] -| | Sexp_list of int sexp_list [@warning "-3"] +| type t = +| [ `Int of int +| | `List of int list +| | `Sexp_dot_list of int list [@sexp.list] +| | `Sexp_list of int sexp_list [@warning "-3"] +| ] @|============================================================ -| ; ggid = "\219\014J\247\148Iq\193\248\rk\216J\012\200\152" +| ; ggid = "\221\2240I,\229H~\212(;\201\127\159rK" @|============================================================ -| { ignore_capitalization = true +| { ignore_capitalization = false @|============================================================ -| ; origin = "test_regular_variants.ml.Sexp_list" +| ; origin = "test_polymorphic_variants.ml.Sexp_list" @|============================================================ -| print_s (With_sexp.sexp_of_t (Int 1)); +| print_s (With_sexp.sexp_of_t (`Int 1)); @|============================================================ -| print_s (With_sexp.sexp_of_t (List l )); -| print_s (With_sexp.sexp_of_t (Sexp_dot_list l )); -| print_s (With_sexp.sexp_of_t (Sexp_list l))); +| print_s (With_sexp.sexp_of_t (`List l )); +| print_s (With_sexp.sexp_of_t (`Sexp_dot_list l )); +| print_s (With_sexp.sexp_of_t (`Sexp_list l))); ppx_sexp_conv-0.14.3/test/expect/test_allow_extra_fields.ml000066400000000000000000000105601401347656000242110ustar00rootroot00000000000000open! Base module Allow_extra_fields = struct type t = { a : int } [@@sexp.allow_extra_fields] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\024\018\219\231,\176\148\206Y\195\132\0042H\\U" ; types = [ ( "t" , Record { allow_extra_fields = true ; fields = [ "a", { optional = false; args = [ One (Implicit_var 0) ] } ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_allow_extra_fields.ml.Allow_extra_fields" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Forbid_extra_fields = struct type t = { a : int } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\142\248\194uE\0077q\014\151\186\131R\n\213$" ; types = [ ( "t" , Record { allow_extra_fields = false ; fields = [ "a", { optional = false; args = [ One (Implicit_var 0) ] } ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_allow_extra_fields.ml.Forbid_extra_fields" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Variant_type = struct type t = | Allow_extra_fields of { foo : int } [@sexp.allow_extra_fields] | Forbid_extra_fields of { bar : int } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "d\241\139\1990f06\b\n\217\001J:\030B" ; types = [ ( "t" , Variant { ignore_capitalization = true ; alts = [ ( "Allow_extra_fields" , [ Fields { allow_extra_fields = true ; fields = [ ( "foo" , { optional = false; args = [ One (Implicit_var 0) ] } ) ] } ] ) ; ( "Forbid_extra_fields" , [ Fields { allow_extra_fields = false ; fields = [ ( "bar" , { optional = false; args = [ One (Implicit_var 0) ] } ) ] } ] ) ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_allow_extra_fields.ml.Variant_type" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] let _ = Allow_extra_fields { foo = 1 } let _ = Forbid_extra_fields { bar = 1 } end ppx_sexp_conv-0.14.3/test/expect/test_allow_extra_fields.mli000066400000000000000000000000551401347656000243600ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_base_map.ml000066400000000000000000000023451401347656000221130ustar00rootroot00000000000000open! Base module Key = struct type t = int [@@deriving sexp_grammar] end module Pair = struct type ('a, 'b) t = 'a * 'b [@@deriving sexp_grammar] module M (A : T) = struct type 'b t = A.t * 'b end let m__t_sexp_grammar = [%sexp_grammar: < for_all : 'a 'b. ('a, 'b) t > ] end type t = string Pair.M(Key).t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "string"; "Pair.m__t"; "Key.t" ] ; ggid = "^DF\173\243\197\131\141\253\181\029-\19450\231" ; types = [ "t", Apply (Implicit_var 1, [ Implicit_var 2; Implicit_var 0 ]) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ string_sexp_grammar; Pair.m__t_sexp_grammar; Key.t_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_base_map.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.14.3/test/expect/test_base_map.mli000066400000000000000000000000551401347656000222600ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_extension.ml000066400000000000000000000011261401347656000223540ustar00rootroot00000000000000open! Base (* Not sure how much people will want to use this, considering that the input is more complicated and specific than the output, but they have it. *) module type S = sig val t_sexp_grammar : [%sexp_grammar: int Map.M(String).t] end module F (M : S) : sig val t_sexp_grammar : Sexp.Private.Raw_grammar.t [@@warning "-32"] end = M (* The grammar is illegible, so just make sure it builds. *) let (_ : Sexp.Private.Raw_grammar.t) = [%sexp_grammar: int Map.M(String).t] (* This used to give a compilation error. *) let (_ : Sexp.Private.Raw_grammar.t) = [%sexp_grammar: _ list] ppx_sexp_conv-0.14.3/test/expect/test_extension.mli000066400000000000000000000000551401347656000225250ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_first_class_polymorphism.ml000066400000000000000000000047021401347656000255010ustar00rootroot00000000000000open Base module Variable_never_used = struct type t = { foo : 'a. int } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\024\152\133\012~\187\175\166\b\177\175\029\184\128m\128" ; types = [ ( "t" , Record { allow_extra_fields = false ; fields = [ "foo", { optional = false; args = [ One (Implicit_var 0) ] } ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_first_class_polymorphism.ml.Variable_never_used" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Variable_used = struct type t = { foo : 'a. 'a option } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "option" ] ; ggid = "\140\253\217\243\196\191\188CD'Q\192\007\000yu" ; types = [ ( "t" , Record { allow_extra_fields = false ; fields = [ ( "foo" , { optional = false ; args = [ One (Apply (Implicit_var 0, [ Union [] ])) ] } ) ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ option_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_first_class_polymorphism.ml.Variable_used" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.14.3/test/expect/test_first_class_polymorphism.mli000066400000000000000000000000551401347656000256470ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_functors.ml000066400000000000000000000132271401347656000222100ustar00rootroot00000000000000open! Base module Maybe = struct type 'a t = 'a option [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "option" ] ; ggid = "j\132);\135qH\158\135\222H\001\007\004\158\218" ; types = [ "t", Explicit_bind ([ "a" ], Apply (Implicit_var 0, [ Explicit_var 0 ])) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ option_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_functors.ml.Maybe" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Make (T : sig type 'a t [@@deriving sexp_grammar] end) = struct [@@@warning "-37"] type 'a t = T of 'a T.t u and 'a u = U of 'a T.t t Maybe.t [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let _ = fun (_ : 'a u) -> () let ( (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) , (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) ) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "T.t"; "Maybe.t" ] ; ggid = "\245\184\243\180\181_5t\027u6u\233p#\158" ; types = [ ( "t" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ ( "T" , [ One (Apply ( Recursive "u" , [ Apply (Implicit_var 0, [ Explicit_var 0 ]) ] )) ] ) ] } ) ) ; ( "u" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ ( "U" , [ One (Apply ( Implicit_var 1 , [ Apply ( Recursive "t" , [ Apply (Implicit_var 0, [ Explicit_var 0 ]) ] ) ] )) ] ) ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ T.t_sexp_grammar; Maybe.t_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_functors.ml.Make" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) and (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("u", _the_group) in t_sexp_grammar, u_sexp_grammar ;; let _ = t_sexp_grammar and _ = u_sexp_grammar [@@@end] type 'a v = V of 'a t [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a v) -> () let (v_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "t" ] ; ggid = "W\019\225!\031\181\213k\190\002\145\212\228\251\207#" ; types = [ ( "v" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ "V", [ One (Apply (Implicit_var 0, [ Explicit_var 0 ])) ] ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ t_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_functors.ml.Make" } in let (v_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("v", _the_group) in v_sexp_grammar ;; let _ = v_sexp_grammar [@@@end] end module T1 = Make (Maybe) module T2 = Make (T1) type t = int T2.t * int T1.t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "T2.t"; "T1.t" ] ; ggid = "\023\203\177!5(\\B1\167\214\007S\000\134B" ; types = [ ( "t" , List [ One (Apply (Implicit_var 1, [ Implicit_var 0 ])) ; One (Apply (Implicit_var 2, [ Implicit_var 0 ])) ] ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; T2.t_sexp_grammar; T1.t_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_functors.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.14.3/test/expect/test_functors.mli000066400000000000000000000000551401347656000223540ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_nonrec.ml000066400000000000000000000033011401347656000216210ustar00rootroot00000000000000open! Base open struct type t = int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" ; types = [ "t", Implicit_var 0 ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_nonrec.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end type nonrec t = t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "t" ] ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" ; types = [ "t", Implicit_var 0 ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ t_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_nonrec.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.14.3/test/expect/test_nonrec.mli000066400000000000000000000000551401347656000217750ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_opaque.ml000066400000000000000000000017721401347656000216410ustar00rootroot00000000000000open! Base type t = (int[@sexp.opaque]) list [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "list" ] ; ggid = "2*\207\018\214\219\006M]8\234\246i\151\192\200" ; types = [ ( "t" , Apply ( Implicit_var 0 , [ Grammar Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.opaque_sexp_grammar ] ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ list_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_opaque.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.14.3/test/expect/test_opaque.mli000066400000000000000000000000551401347656000220030ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_origin.ml000066400000000000000000000034311401347656000216300ustar00rootroot00000000000000open! Base open! Expect_test_helpers_base let test = function | Sexp.Private.Raw_grammar.Ref (_, group) -> print_endline group.origin | Inline _ -> print_cr [%here] (Atom "Unexpected [Inline]") ;; type t = unit [@@deriving sexp_grammar] let extension_node = [%sexp_grammar: int] let%expect_test "toplevel" = test t_sexp_grammar; [%expect {| test_origin.ml |}]; test extension_node; [%expect {| test_origin.ml |}] ;; module Foo = struct type t = unit [@@deriving sexp_grammar] let extension_node = [%sexp_grammar: unit] end let%expect_test "[Foo]" = test Foo.t_sexp_grammar; [%expect {| test_origin.ml.Foo |}]; test Foo.extension_node; [%expect {| test_origin.ml.Foo |}] ;; module F (M : sig type t [@@deriving sexp_grammar] end) = struct type t = M.t [@@deriving sexp_grammar] let extension_node = [%sexp_grammar: M.t] end module F_foo = F (Foo) (* Because the origin is generated at the type definition, it points to the functor definition rather than the functor application. *) let%expect_test "[F_foo]" = test F_foo.t_sexp_grammar; [%expect {| test_origin.ml.F |}]; test F_foo.extension_node; [%expect {| test_origin.ml.F |}] ;; let m__t_sexp_grammar, m__extension_node = let module M = struct type t = unit [@@deriving sexp_grammar] let extension_node = [%sexp_grammar: unit] end in M.t_sexp_grammar, M.extension_node ;; (* ppx_deriving omits modules defined in expressions from the [path]. Maybe there's not a good way to bring the module name out of that scope. E.g., how to disambiguate multiple evaluations of that expression? *) let%expect_test "modules in expressions" = test m__t_sexp_grammar; [%expect {| test_origin.ml |}]; test m__extension_node; [%expect {| test_origin.ml |}] ;; ppx_sexp_conv-0.14.3/test/expect/test_origin.mli000066400000000000000000000000551401347656000220000ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_percent_sexp_grammar.ml000066400000000000000000000113501401347656000245450ustar00rootroot00000000000000open! Base (* Printing the raw grammar should be a last resort when there is no better way to test the ppx (e.g., [@@deriving_inline _]). The output is illegible and fragile. *) let test raw_grammar = Sexp_grammar_validation.Raw_grammar.sexp_of_t raw_grammar |> Stdio.print_s ;; let%expect_test "polymorphic" = test [%sexp_grammar: < for_all : 'k 'v. ('k * 'v) list > ]; [%expect {| ((generic_groups ((6a84293b8771489e87de480107049eda ((implicit_vars (list)) (types ((t (Explicit_bind (a) (Apply (Implicit_var 0) ((Explicit_var 0))))))))) (90163c5a0ec60eaf19da04c7fc7e1f3d ((implicit_vars (List.t)) (types ((list (Explicit_bind (a) (Apply (Implicit_var 0) ((Explicit_var 0))))))))) (c235a370b5135a2c190baecfd2bd77e7 ((implicit_vars (list)) (types ((dummy_type_name_from_sexp_grammar (Explicit_bind (k v) (Apply (Implicit_var 0) ((List ((One (Explicit_var 0)) (One (Explicit_var 1)))))))))))))) (groups ((0 ((generic_group 6a84293b8771489e87de480107049eda) (origin list.ml.T) (apply_implicit ((Inline (Explicit_bind ('a) (List ((Many (Explicit_var 0)))))))))) (1 ((generic_group 90163c5a0ec60eaf19da04c7fc7e1f3d) (origin base.ml.Export) (apply_implicit ((Ref t 0))))) (2 ((generic_group c235a370b5135a2c190baecfd2bd77e7) (origin test_percent_sexp_grammar.ml) (apply_implicit ((Ref list 1))))))) (start (Ref dummy_type_name_from_sexp_grammar 2))) |}] ;; let%expect_test "primitive" = test [%sexp_grammar: int]; [%expect {| ((generic_groups ((926517f9eb65458b638457c38981eb19 ((implicit_vars (int)) (types ((t (Implicit_var 0)))))) (9f9fc55ea55deca5e5a55238a9e14814 ((implicit_vars (Int.t)) (types ((int (Implicit_var 0)))))) (fbc7a39b4d9d260c4fa39e5250052c77 ((implicit_vars (int)) (types ((dummy_type_name_from_sexp_grammar (Implicit_var 0)))))))) (groups ((3 ((generic_group 926517f9eb65458b638457c38981eb19) (origin int.ml.T) (apply_implicit ((Inline (Atom Int)))))) (4 ((generic_group 9f9fc55ea55deca5e5a55238a9e14814) (origin base.ml.Export) (apply_implicit ((Ref t 3))))) (5 ((generic_group fbc7a39b4d9d260c4fa39e5250052c77) (origin test_percent_sexp_grammar.ml) (apply_implicit ((Ref int 4))))))) (start (Ref dummy_type_name_from_sexp_grammar 5))) |}] ;; let%expect_test "application of polymorphic type constructor" = test [%sexp_grammar: int list]; [%expect {| ((generic_groups ((6a84293b8771489e87de480107049eda ((implicit_vars (list)) (types ((t (Explicit_bind (a) (Apply (Implicit_var 0) ((Explicit_var 0))))))))) (90163c5a0ec60eaf19da04c7fc7e1f3d ((implicit_vars (List.t)) (types ((list (Explicit_bind (a) (Apply (Implicit_var 0) ((Explicit_var 0))))))))) (926517f9eb65458b638457c38981eb19 ((implicit_vars (int)) (types ((t (Implicit_var 0)))))) (9f9fc55ea55deca5e5a55238a9e14814 ((implicit_vars (Int.t)) (types ((int (Implicit_var 0)))))) (b796e27d2ccfcadf2fd17396632c6ef8 ((implicit_vars (int list)) (types ((dummy_type_name_from_sexp_grammar (Apply (Implicit_var 1) ((Implicit_var 0)))))))))) (groups ((0 ((generic_group 6a84293b8771489e87de480107049eda) (origin list.ml.T) (apply_implicit ((Inline (Explicit_bind ('a) (List ((Many (Explicit_var 0)))))))))) (1 ((generic_group 90163c5a0ec60eaf19da04c7fc7e1f3d) (origin base.ml.Export) (apply_implicit ((Ref t 0))))) (3 ((generic_group 926517f9eb65458b638457c38981eb19) (origin int.ml.T) (apply_implicit ((Inline (Atom Int)))))) (4 ((generic_group 9f9fc55ea55deca5e5a55238a9e14814) (origin base.ml.Export) (apply_implicit ((Ref t 3))))) (6 ((generic_group b796e27d2ccfcadf2fd17396632c6ef8) (origin test_percent_sexp_grammar.ml) (apply_implicit ((Ref int 4) (Ref list 1))))))) (start (Ref dummy_type_name_from_sexp_grammar 6))) |}] ;; let%expect_test "arrow type / original polymorphic type syntax" = test [%sexp_grammar: 'k -> 'v -> ('k * 'v) list]; [%expect {| ((generic_groups ((ddc522722eb44f32c55594e2d02c83b6 ((implicit_vars ()) (types ((dummy_type_name_from_sexp_grammar (Grammar (Inline (Union ())))))))))) (groups ((7 ((generic_group ddc522722eb44f32c55594e2d02c83b6) (origin test_percent_sexp_grammar.ml) (apply_implicit ()))))) (start (Ref dummy_type_name_from_sexp_grammar 7))) |}] ;; ppx_sexp_conv-0.14.3/test/expect/test_percent_sexp_grammar.mli000066400000000000000000000000551401347656000247160ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_polymorphic_record_fields.ml000066400000000000000000000135161401347656000255770ustar00rootroot00000000000000open! Base [@@@warning "-37"] module Records_we_can_handle = struct type ('a, 'b) t = { not_first_class_tick_a : 'a ; b : 'a. 'b ; int : 'a. int ; either : 'a. 'a option ; polymorphic_variant : 'a. [ `A of 'a | `B of 'b | `Int of int ] } [@@deriving_inline sexp_grammar] let _ = fun (_ : ('a, 'b) t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "option" ] ; ggid = "\018M5`u:\186\223\136?/\182\187\135R\029" ; types = [ ( "t" , Explicit_bind ( [ "a"; "b" ] , Record { allow_extra_fields = false ; fields = [ ( "not_first_class_tick_a" , { optional = false; args = [ One (Explicit_var 0) ] } ) ; "b" , { optional = false; args = [ One (Explicit_var 1) ] } ; "int", { optional = false; args = [ One (Implicit_var 0) ] } ; ( "either" , { optional = false ; args = [ One (Apply (Implicit_var 1, [ Union [] ])) ] } ) ; ( "polymorphic_variant" , { optional = false ; args = [ One (Variant { ignore_capitalization = false ; alts = [ "A" , [ One (Union []) ] ; "B" , [ One (Explicit_var 1) ] ; "Int", [ One (Implicit_var 0) ] ] }) ] } ) ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; option_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_polymorphic_record_fields.ml.Records_we_can_handle" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Impossible_record = struct type t = { a : 'a. 'a } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [] ; ggid = "&\224\178\151\b>\2179\022\203\130~i\190G\245" ; types = [ ( "t" , Record { allow_extra_fields = false ; fields = [ "a", { optional = false; args = [ One (Union []) ] } ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [] ; generic_group = _the_generic_group ; origin = "test_polymorphic_record_fields.ml.Impossible_record" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Inline_record = struct type 'a t = | Non_poly of { a : 'a } | Poly of { a : 'a. 'a } [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [] ; ggid = "\217\0037(\136\214}@\029 \130x\242\146\137\179" ; types = [ ( "t" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ ( "Non_poly" , [ Fields { allow_extra_fields = false ; fields = [ ( "a" , { optional = false ; args = [ One (Explicit_var 0) ] } ) ] } ] ) ; ( "Poly" , [ Fields { allow_extra_fields = false ; fields = [ "a", { optional = false; args = [ One (Union []) ] } ] } ] ) ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [] ; generic_group = _the_generic_group ; origin = "test_polymorphic_record_fields.ml.Inline_record" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.14.3/test/expect/test_polymorphic_record_fields.mli000066400000000000000000000000551401347656000257420ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_polymorphic_variants.ml000066400000000000000000000120471401347656000246200ustar00rootroot00000000000000open Base [@@@warning "-37"] module Nullary = struct type 'a t = [ `A | `B ] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [] ; ggid = "\133a\241\019; \198\184U\181\220#\191\190\200\b" ; types = [ ( "t" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = false; alts = [ "A", []; "B", [] ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [] ; generic_group = _the_generic_group ; origin = "test_polymorphic_variants.ml.Nullary" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module With_arguments = struct module With_sexp = struct type t = [ `A of int * int | `B of string ] [@@deriving sexp_of] end type t = [ `A of int * int | `B of string ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "string" ] ; ggid = "\196t P\169\167\173C\251\132\141N\003n \132" ; types = [ ( "t" , Variant { ignore_capitalization = false ; alts = [ "A", [ One (List [ One (Implicit_var 0); One (Implicit_var 0) ]) ] ; "B", [ One (Implicit_var 1) ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; string_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_polymorphic_variants.ml.With_arguments" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] open Expect_test_helpers_core let%expect_test _ = print_s (With_sexp.sexp_of_t (`A (1, 2))); print_s (With_sexp.sexp_of_t (`B "foo")); [%expect {| (A (1 2)) (B foo) |}] ;; end module Sexp_list = struct module With_sexp = struct type t = [ `Int of int | `List of int list | `Sexp_dot_list of int list [@sexp.list] | `Sexp_list of int sexp_list [@warning "-3"] ] [@@deriving sexp] end type t = [ `Int of int | `List of int list | `Sexp_dot_list of int list [@sexp.list] | `Sexp_list of int sexp_list [@warning "-3"] ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "list" ] ; ggid = "\221\2240I,\229H~\212(;\201\127\159rK" ; types = [ ( "t" , Variant { ignore_capitalization = false ; alts = [ "Int" , [ One (Implicit_var 0) ] ; "List" , [ One (Apply (Implicit_var 1, [ Implicit_var 0 ])) ] ; "Sexp_dot_list", [ Many (Implicit_var 0) ] ; "Sexp_list" , [ Many (Implicit_var 0) ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; list_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_polymorphic_variants.ml.Sexp_list" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] let (T : (With_sexp.t, t) Type_equal.t) = T open Expect_test_helpers_core let%expect_test _ = print_s (With_sexp.sexp_of_t (`Int 1)); List.iter [ []; [ 1 ]; [ 1; 2 ] ] ~f:(fun l -> print_s (With_sexp.sexp_of_t (`List l )); print_s (With_sexp.sexp_of_t (`Sexp_dot_list l )); print_s (With_sexp.sexp_of_t (`Sexp_list l))); [%expect {| (Int 1) (List ()) (Sexp_dot_list) (Sexp_list) (List (1)) (Sexp_dot_list 1) (Sexp_list 1) (List (1 2)) (Sexp_dot_list 1 2) (Sexp_list 1 2) |}] ;; end ppx_sexp_conv-0.14.3/test/expect/test_polymorphic_variants.mli000066400000000000000000000000551401347656000247650ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_polymorphic_variants.mlt000066400000000000000000000027651401347656000250120ustar00rootroot00000000000000(* This toplevel test exercises some polymorphic variants that sexp_grammar rejects. We show that in each case, the compiler or sexp would have given an error anyway. *) type t = [ `A of int & string ] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: split_row_field/& |}] type t = [ `A of int & string ] [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support polymorphic variants with intersection types ([`A of _ & _]) |}] type t = [> `A ] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: A type variable is unbound in this type declaration. In type [> `A ] as 'a the variable 'a is unbound |}] type t = [> `A ] [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support polymorphic variants with < or > |}] type t = [< `A ] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: A type variable is unbound in this type declaration. In type [< `A ] as 'a the variable 'a is unbound |}] type t = [< `A ] [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support polymorphic variants with < or > |}] type 'a t = [< `A ] as 'a [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: Type unsupported for ppx [of_sexp] conversion |}] type 'a t = [< `A ] as 'a [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: sexp_grammar doesn't support aliases |}] ppx_sexp_conv-0.14.3/test/expect/test_polymorphism.ml000066400000000000000000000026071401347656000231070ustar00rootroot00000000000000open! Base type ('a, _, 'b) t = 'a * 'b and u = (string, int, float) t [@@deriving_inline sexp_grammar] let _ = fun (_ : ('a, _, 'b) t) -> () let _ = fun (_ : u ) -> () let ( (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) , (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) ) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "string"; "int"; "float" ] ; ggid = "\188\229A\199\004o'\003\160n\138\189k\130y]" ; types = [ ( "t" , Explicit_bind ([ "a"; "_"; "b" ], List [ One (Explicit_var 0); One (Explicit_var 2) ]) ) ; "u", Apply (Recursive "t", [ Implicit_var 0; Implicit_var 1; Implicit_var 2 ]) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ string_sexp_grammar; int_sexp_grammar; float_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_polymorphism.ml" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) and (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("u", _the_group) in t_sexp_grammar, u_sexp_grammar ;; let _ = t_sexp_grammar and _ = u_sexp_grammar [@@@end] ppx_sexp_conv-0.14.3/test/expect/test_polymorphism.mli000066400000000000000000000000551401347656000232530ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_recursive_groups.ml000066400000000000000000000053561401347656000237570ustar00rootroot00000000000000open Base [@@@warning "-37"] module One_type = struct type t = T of int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\243A~\012\241*Zj\026)S&\127Q\231x" ; types = [ ( "t" , Variant { ignore_capitalization = true; alts = [ "T", [ One (Implicit_var 0) ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_recursive_groups.ml.One_type" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Two_types = struct type t = | T_int of int | T_u of u and u = | U_int of int | U_t of t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let _ = fun (_ : u) -> () let ( (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) , (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) ) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\241o\231&\242\021\147\249\029+\000\245\187\240\158H" ; types = [ ( "t" , Variant { ignore_capitalization = true ; alts = [ "T_int", [ One (Implicit_var 0) ]; "T_u", [ One (Recursive "u") ] ] } ) ; ( "u" , Variant { ignore_capitalization = true ; alts = [ "U_int", [ One (Implicit_var 0) ]; "U_t", [ One (Recursive "t") ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_recursive_groups.ml.Two_types" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) and (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("u", _the_group) in t_sexp_grammar, u_sexp_grammar ;; let _ = t_sexp_grammar and _ = u_sexp_grammar [@@@end] end ppx_sexp_conv-0.14.3/test/expect/test_recursive_groups.mli000066400000000000000000000000551401347656000241170ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_regular_variants.ml000066400000000000000000000120021401347656000237030ustar00rootroot00000000000000open Base [@@@warning "-37"] module Nullary = struct type 'a t = | A | B [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [] ; ggid = "\239\242\007o\016\222\178\133\218\153\146w\129\255\167\208" ; types = [ ( "t" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true; alts = [ "A", []; "B", [] ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [] ; generic_group = _the_generic_group ; origin = "test_regular_variants.ml.Nullary" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module With_arguments = struct module With_sexp = struct type t = | A of int * int | B of string [@@deriving sexp_of] end type t = With_sexp.t = | A of int * int | B of string [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "string" ] ; ggid = "B\127\229(\029\022\255\"\167ab\178F\134\201\234" ; types = [ ( "t" , Variant { ignore_capitalization = true ; alts = [ "A", [ One (Implicit_var 0); One (Implicit_var 0) ] ; "B", [ One (Implicit_var 1) ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; string_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_regular_variants.ml.With_arguments" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] open Expect_test_helpers_core let%expect_test _ = print_s (With_sexp.sexp_of_t (A (1, 2))); print_s (With_sexp.sexp_of_t (B "foo")); [%expect {| (A 1 2) (B foo) |}] ;; end module Sexp_list = struct module With_sexp = struct type t = | Int of int | List of int list | Sexp_dot_list of int list [@sexp.list] | Sexp_list of int sexp_list [@warning "-3"] [@@deriving sexp] end type t = With_sexp.t = | Int of int | List of int list | Sexp_dot_list of int list [@sexp.list] | Sexp_list of int sexp_list [@warning "-3"] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int"; "list" ] ; ggid = "\219\014J\247\148Iq\193\248\rk\216J\012\200\152" ; types = [ ( "t" , Variant { ignore_capitalization = true ; alts = [ "Int" , [ One (Implicit_var 0) ] ; "List" , [ One (Apply (Implicit_var 1, [ Implicit_var 0 ])) ] ; "Sexp_dot_list", [ Many (Implicit_var 0) ] ; "Sexp_list" , [ Many (Implicit_var 0) ] ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar; list_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_regular_variants.ml.Sexp_list" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] let (T : (With_sexp.t, t) Type_equal.t) = T open Expect_test_helpers_core let%expect_test _ = print_s (With_sexp.sexp_of_t (Int 1)); List.iter [ []; [ 1 ]; [ 1; 2 ] ] ~f:(fun l -> print_s (With_sexp.sexp_of_t (List l )); print_s (With_sexp.sexp_of_t (Sexp_dot_list l )); print_s (With_sexp.sexp_of_t (Sexp_list l))); [%expect {| (Int 1) (List ()) (Sexp_dot_list) (Sexp_list) (List (1)) (Sexp_dot_list 1) (Sexp_list 1) (List (1 2)) (Sexp_dot_list 1 2) (Sexp_list 1 2) |}] ;; end ppx_sexp_conv-0.14.3/test/expect/test_regular_variants.mli000066400000000000000000000000551401347656000240610ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_test.ml000066400000000000000000000077441401347656000213330ustar00rootroot00000000000000open! Base module Simple_grammar = struct type t = int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\146e\023\249\235eE\139c\132W\195\137\129\235\025" ; types = [ "t", Implicit_var 0 ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_test.ml.Simple_grammar" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@deriving.end] end module Recursive_group = struct type 'a t = T of 'a and 'a u = U of 'a t option [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let _ = fun (_ : 'a u) -> () let ( (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) , (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) ) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "option" ] ; ggid = "3\188_G\181s\242\209x\249#\138\249\222\158}" ; types = [ ( "t" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ "T", [ One (Explicit_var 0) ] ] } ) ) ; ( "u" , Explicit_bind ( [ "a" ] , Variant { ignore_capitalization = true ; alts = [ ( "U" , [ One (Apply ( Implicit_var 0 , [ Apply (Recursive "t", [ Explicit_var 0 ]) ] )) ] ) ] } ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ option_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_test.ml.Recursive_group" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) and (u_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("u", _the_group) in t_sexp_grammar, u_sexp_grammar ;; let _ = t_sexp_grammar and _ = u_sexp_grammar [@@@deriving.end] (* Avoid unused constructor warnings. *) let _ = T () let _ = U None end module Functions = struct type ('a, 'b) t = 'a -> 'b [@@deriving_inline sexp_grammar] let _ = fun (_ : ('a, 'b) t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [] ; ggid = "\181\1700\154U\254\250:\nZ\023T\139\004+\014" ; types = [ ( "t" , Explicit_bind ( [ "a"; "b" ] , Grammar Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.fun_sexp_grammar ) ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [] ; generic_group = _the_generic_group ; origin = "test_test.ml.Functions" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.14.3/test/expect/test_test.mli000066400000000000000000000000551401347656000214700ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.14.3/test/expect/test_variants_more.ml000066400000000000000000000056571401347656000232260ustar00rootroot00000000000000open Base [@@@warning "-37"] module Nested_inside_variant = struct type t = A of [ `A of int ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "Z\241\230\155\202\128I6<#U\238\187\226\131," ; types = [ ( "t" , Variant { ignore_capitalization = true ; alts = [ ( "A" , [ One (Variant { ignore_capitalization = false ; alts = [ "A", [ One (Implicit_var 0) ] ] }) ] ) ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_variants_more.ml.Nested_inside_variant" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end module Nested_inside_record = struct type t = { a : [ `A of int ] } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = let (_the_generic_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.generic_group) = { implicit_vars = [ "int" ] ; ggid = "\001\215\152\002\244\149\139\179d\bwc\181\223W\187" ; types = [ ( "t" , Record { allow_extra_fields = false ; fields = [ ( "a" , { optional = false ; args = [ One (Variant { ignore_capitalization = false ; alts = [ "A", [ One (Implicit_var 0) ] ] }) ] } ) ] } ) ] } in let (_the_group : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.group) = { gid = Ppx_sexp_conv_lib.Lazy_group_id.create () ; apply_implicit = [ int_sexp_grammar ] ; generic_group = _the_generic_group ; origin = "test_variants_more.ml.Nested_inside_record" } in let (t_sexp_grammar : Ppx_sexp_conv_lib.Sexp.Private.Raw_grammar.t) = Ref ("t", _the_group) in t_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.14.3/test/expect/test_variants_more.mli000066400000000000000000000000011401347656000233510ustar00rootroot00000000000000 ppx_sexp_conv-0.14.3/test/lib/000077500000000000000000000000001401347656000162255ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/test/lib/conv_test.ml000066400000000000000000000035641401347656000205730ustar00rootroot00000000000000open Ppx_sexp_conv_lib open Conv module Exceptions = struct let check_sexp exn string = match sexp_of_exn_opt exn with | None -> raise exn | Some sexp -> let sexp_as_string = Ppx_sexp_conv_lib.Sexp.to_string sexp in if sexp_as_string <> string then failwith sexp_as_string (* first global exceptions, checking different arities since they don't have the same representation *) exception Arg0 [@@deriving sexp] exception Arg1 of int [@@deriving sexp] exception Arg2 of int * int [@@deriving sexp] let%test_unit _ = check_sexp Arg0 "conv_test.ml.Exceptions.Arg0" let%test_unit _ = check_sexp (Arg1 1) "(conv_test.ml.Exceptions.Arg1 1)" let%test_unit _ = check_sexp (Arg2 (2, 3)) "(conv_test.ml.Exceptions.Arg2 2 3)" (* now local exceptions *) let exn (type a) a sexp_of_a = let module M = struct exception E of a [@@deriving sexp] end in M.E a let%test_unit "incompatible exceptions with the same name" = let e_int = exn 1 sexp_of_int in let e_string = exn "a" sexp_of_string in check_sexp e_int "(conv_test.ml.Exceptions.E 1)"; check_sexp e_string "(conv_test.ml.Exceptions.E a)" let%test_unit "sexp converters are finalized properly for local exceptions" = Gc.compact (); Gc.compact (); let size_before = Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size () in let e = exn 2.5 sexp_of_float in let size_after_local_exn = Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size () in let e_finalized = ref false in Gc.finalise (fun _ -> e_finalized := true) e; check_sexp e "(conv_test.ml.Exceptions.E 2.5)"; Gc.compact (); Gc.compact (); assert !e_finalized; let size_after_gc = Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size () in assert (size_before + 1 = size_after_local_exn); assert (size_before = size_after_gc) end ppx_sexp_conv-0.14.3/test/lib/dune000066400000000000000000000001751401347656000171060ustar00rootroot00000000000000(library (name sexplib_test) (libraries ppx_sexp_conv_lib) (preprocess (pps ppxlib ppx_sexp_conv ppx_here ppx_inline_test)))ppx_sexp_conv-0.14.3/test/nonrec_test.ml000066400000000000000000000041421401347656000203350ustar00rootroot00000000000000open Ppx_sexp_conv_lib.Conv type t = float [@@deriving sexp] module M : sig type t = float list [@@deriving sexp] end = struct type nonrec t = t list [@@deriving sexp] end type 'a u = 'a [@@deriving sexp] module M2 : sig type 'a u = 'a list [@@deriving sexp] end = struct type nonrec 'a u = 'a u list [@@deriving sexp] end type 'a v = 'a w and 'a w = A of 'a v [@@deriving sexp] type 'a v_ = 'a v [@@deriving sexp] type 'a w_ = 'a w [@@deriving sexp] module M3 : sig type 'a v = 'a w_ [@@deriving sexp] type 'a w = 'a v_ [@@deriving sexp] end = struct type nonrec 'a v = 'a w and 'a w = 'a v [@@deriving sexp] end type t0 = A of t0 [@@deriving sexp] module B : sig type nonrec t0 = t0 [@@deriving sexp] end = struct type nonrec t0 = t0 = A of t0 [@@deriving sexp] end type t1 = A of t2 and t2 = B of t1 [@@deriving sexp] module C : sig type nonrec t1 = t1 [@@deriving sexp] type nonrec t2 = t2 [@@deriving sexp] end = struct type nonrec t1 = t1 = A of t2 and t2 = t2 = B of t1 [@@deriving sexp] end type 'a v1 = A of 'a v2 and 'a v2 = B of 'a v1 [@@deriving sexp] module D : sig type nonrec 'a v1 = 'a v1 [@@deriving sexp] type nonrec 'a v2 = 'a v2 [@@deriving sexp] end = struct type nonrec 'a v1 = 'a v1 = A of 'a v2 and 'a v2 = 'a v2 = B of 'a v1 [@@deriving sexp] 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_sexp_conv-0.14.3/test/ppx_sexp_test.ml000066400000000000000000000631261401347656000207260ustar00rootroot00000000000000open Ppx_sexp_conv_lib open Conv open! Sexp.Private.Raw_grammar.Builtin module Sum_and_polymorphic_variants = struct type poly = [ `No_arg | `One_arg of int | `One_tuple of (int * string) | `Two_args of int * string ] [@@deriving sexp, sexp_grammar] let%test_unit _ = List.iter (fun (value, sexp) -> assert (sexp_of_poly value = sexp); assert (poly_of_sexp sexp = value); ) [ `No_arg, Sexp.Atom "No_arg"; `One_arg 1, Sexp.(List [Atom "One_arg"; Atom "1"]); `One_tuple (1, "a"), Sexp.(List [Atom "One_tuple"; List [Atom "1"; Atom "a"]]); `Two_args (1, "a"), Sexp.(List [Atom "Two_args"; List [Atom "1"; Atom "a"]]); ] type nominal = | No_arg | One_arg of int | One_tuple of (int * string) | Two_args of int * string [@@deriving sexp, sexp_grammar] let%test_unit _ = List.iter (fun (value, sexp) -> assert (sexp_of_nominal value = sexp); assert (nominal_of_sexp sexp = value); ) [ No_arg, Sexp.Atom "No_arg"; One_arg 1, Sexp.(List [Atom "One_arg"; Atom "1"]); One_tuple (1, "a"), Sexp.(List [Atom "One_tuple"; List [Atom "1"; Atom "a"]]); Two_args (1, "a"), Sexp.(List [Atom "Two_args"; Atom "1"; Atom "a"]); ] end module Records = struct type t = { a : int ; b : (float * string) list option } [@@deriving sexp, sexp_grammar] let%test_unit _ = let t = { a = 2; b = Some [(1., "a"); (2.3, "b")] } in let sexp = Sexplib.Sexp.of_string "((a 2)(b (((1 a)(2.3 b)))))" in assert (t_of_sexp sexp = t); assert (sexp_of_t t = sexp); ;; let%expect_test _ = let sexp = Sexplib.Sexp.of_string "((a)(b ()))" in Expect_test_helpers_core.show_raise (fun () -> t_of_sexp sexp); [%expect {| (raised ( Of_sexp_error "ppx_sexp_test.ml.Records.t_of_sexp: record conversion: only pairs expected, their first element must be an atom" (invalid_sexp ((a) (b ()))))) |}] let%expect_test _ = let sexp = Sexplib.Sexp.of_string "((a 1)(a))" in Expect_test_helpers_core.show_raise (fun () -> t_of_sexp sexp); [%expect {| (raised ( Of_sexp_error "ppx_sexp_test.ml.Records.t_of_sexp: duplicate fields: a" (invalid_sexp ((a 1) (a))))) |}] let%expect_test _ = let sexp = Sexplib.Sexp.of_string "((a 3 4))" in Expect_test_helpers_core.show_raise (fun () -> t_of_sexp sexp); [%expect {| (raised ( Of_sexp_error "ppx_sexp_test.ml.Records.t_of_sexp: record conversion: only pairs expected, their first element must be an atom" (invalid_sexp (a 3 4)))) |}] let%expect_test _ = let sexp = Sexplib.Sexp.of_string "((c 3))" in Expect_test_helpers_core.show_raise (fun () -> t_of_sexp sexp); [%expect {| (raised ( Of_sexp_error "ppx_sexp_test.ml.Records.t_of_sexp: extra fields: c" (invalid_sexp ((c 3))))) |}] end module Inline_records = struct type t = | A of { a : int ; b : (float * string) list option } | B of int [@@deriving sexp, sexp_grammar] let%test_unit _ = let t = A { a = 2; b = Some [(1., "a"); (2.3, "b")] } in let sexp = Sexplib.Sexp.of_string "(A (a 2)(b (((1 a)(2.3 b)))))" in assert (t_of_sexp sexp = t); assert (sexp_of_t t = sexp); ;; end module User_specified_conversion = struct type my_float = float let sexp_of_my_float n = Sexp.Atom (Printf.sprintf "%.4f" n) let my_float_of_sexp = float_of_sexp let%test_unit _ = let my_float : my_float = 1.2 in let sexp = Sexp.Atom "1.2000" in assert (my_float_of_sexp sexp = my_float); assert (sexp_of_my_float my_float = sexp); ;; end module Exceptions : sig (* no sexp_grammars for exceptions, as they can't be parsed *) exception E0 [@@deriving sexp] exception E1 of string [@@deriving sexp] exception E2 of string * int [@@deriving sexp] exception E_tuple of (string * int) [@@deriving sexp] exception E_record of {a:string; b:int} [@@deriving sexp] end = struct exception E0 [@@deriving sexp] exception E1 of string [@@deriving sexp] exception E2 of string * int [@@deriving sexp] exception E_tuple of (string * int) [@@deriving sexp] exception E_record of {a:string; b:int} [@@deriving sexp] let%test_unit _ = let cases = [ E0, "ppx_sexp_test.ml.Exceptions.E0" ; E1 "a", "(ppx_sexp_test.ml.Exceptions.E1 a)" ; E2 ("b", 2), "(ppx_sexp_test.ml.Exceptions.E2 b 2)" ; E_tuple ("c", 3), "(ppx_sexp_test.ml.Exceptions.E_tuple(c 3))" ; E_record {a="c"; b= 3}, "(ppx_sexp_test.ml.Exceptions.E_record(a c)(b 3))" ] in List.iter (fun (exn, sexp_as_str) -> let sexp = Sexplib.Sexp.of_string sexp_as_str in assert ([%sexp_of: exn] exn = sexp); ) cases ;; end module Abstract_types_are_allowed_in_structures : sig type t [@@deriving sexp, sexp_grammar] end = struct type t [@@deriving sexp, sexp_grammar] end module Manifest_types = struct type a = { t : int } type b = a = { t : int } [@@deriving sexp, sexp_grammar] end module Uses_of_exn = struct type t = int * exn [@@deriving sexp_of] end module Function_types : sig type t1 = int -> unit [@@deriving sexp, sexp_grammar] type t2 = label:int -> ?optional:int -> unit -> unit [@@deriving sexp, sexp_grammar] end = struct type t1 = int -> unit [@@deriving sexp, sexp_grammar] type t2 = label:int -> ?optional:int -> unit -> unit [@@deriving sexp, sexp_grammar] end module No_unused_rec = struct type r = { r : int } [@@deriving sexp, sexp_grammar] 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 sexp, sexp_grammar] type 'b sub2 = [ `C4 | `C5 of 'b ] [@@deriving sexp, sexp_grammar] type ('a, 'b) t = [ sub1 | `C3 of [ `Nested of 'a ] | 'b sub2 | `C6 ] option [@@deriving sexp, sexp_grammar] let%test_unit _ = let cases : ((string * string, float) t * _) list = [ None, "()" ; Some `C1, "(C1)" ; Some `C2, "(C2)" ; Some (`C3 (`Nested ("a", "b"))), "((C3 (Nested (a b))))" ; Some `C4, "(C4)" ; Some (`C5 1.5), "((C5 1.5))" ; Some `C6, "(C6)" ] in List.iter (fun (t, sexp_as_str) -> let sexp = Sexplib.Sexp.of_string sexp_as_str in assert ([%of_sexp: (string * string, float) t] sexp = t); assert ([%sexp_of: (string * string, float) t] t = sexp); ) cases ;; type sub1_alias = sub1 [@@deriving sexp_poly, sexp_grammar] type u = [ `A | sub1_alias | `D ] [@@deriving sexp, sexp_grammar] let%test_unit _ = let cases : (u * _) list = [ `A, "A" ; `C1, "C1" ; `C2, "C2" ; `D, "D" ] in List.iter (fun (u, sexp_as_str) -> let sexp = Sexplib.Sexp.of_string sexp_as_str in assert ([%of_sexp: u] sexp = u); assert ([%sexp_of: u] u = sexp); ) cases ;; end module Polymorphic_record_field = struct type 'x t = { poly : 'a 'b. 'a list ; maybe_x : 'x option } [@@deriving sexp, sexp_grammar] let%test_unit _ = let t x = { poly = []; maybe_x = Some x } in let sexp = Sexplib.Sexp.of_string "((poly ())(maybe_x (1)))" in assert (t_of_sexp int_of_sexp sexp = t 1); assert (sexp_of_t sexp_of_int (t 1) = sexp); ;; end module No_unused_value_warnings : sig end = struct module No_warning : sig type t = [ `A ] [@@deriving sexp, sexp_grammar] end = struct type t = [ `A ] [@@deriving sexp, sexp_grammar] end module Empty = struct end module No_warning2(X : sig type t [@@deriving sexp, sexp_grammar] end) = struct end (* this one can't be handled (what if Empty was a functor, huh?) *) (* module No_warning3(X : sig type t with sexp end) = Empty *) module type S = sig type t = [ `A ] [@@deriving sexp, sexp_grammar] end module No_warning4 : S = struct type t = [ `A ] [@@deriving sexp, sexp_grammar] end module No_warning5 : S = ((struct type t = [ `A ] [@@deriving sexp, sexp_grammar] end : S) : S) module Nested_functors (M1 : sig type t [@@deriving sexp, sexp_grammar] end) (M2 : sig type t [@@deriving sexp, sexp_grammar] end) = struct end let () = let module M : sig type t [@@deriving sexp, sexp_grammar] end = struct type t [@@deriving sexp, sexp_grammar] end in () module Include = struct include (struct type t = int [@@deriving sexp, sexp_grammar] end : sig type t [@@deriving sexp, sexp_grammar] end with type t := int) end end module Default = struct type t = { a : int [@default 2]; } [@@deriving sexp, sexp_grammar] let%test _ = Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 } let%test _ = Sexp.(List [List [Atom "a"; Atom "2"]]) = sexp_of_t { a = 2 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 } let%test _ = t_of_sexp (Sexp.(List [])) = { a = 2 } end module Type_alias = struct (* checking that the [as 'a] is supported and ignored in signatures, that it still exports the sexp_of_t__ when needed *) module B : sig type a = [ `A ] type t = ([`A] as 'a) constraint 'a = a [@@deriving sexp, sexp_grammar] end = struct type a = [ `A ] [@@deriving sexp, sexp_grammar] type t = [ `A ] [@@deriving sexp, sexp_grammar] end let%test _ = Sexp.to_string (B.sexp_of_t `A) = "A" let%test _ = `A = B.t_of_sexp (Sexplib.Sexp.of_string "A") module B2 = struct type t = [ B.t | `B ] [@@deriving sexp, sexp_grammar] end module C : sig type t = (int as 'a) [@@deriving sexp, sexp_grammar] end = struct type t = int [@@deriving sexp, sexp_grammar] end module D : sig type t = 'a constraint 'a = int [@@deriving sexp, sexp_grammar] end = struct type t = int [@@deriving sexp, sexp_grammar] 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 sexp, sexp_grammar] type 'a u = [ t | `b of 'a ] * int [@@deriving sexp, sexp_grammar] end module Drop_default = struct open! Base open Expect_test_helpers_core type t = { a : int; } [@@deriving equal] let test ?cr t_of_sexp sexp_of_t = let (=) = Sexp.(=) in require ?cr [%here] (Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 }); require ?cr [%here] (Sexp.(List []) = sexp_of_t { a = 2 }); let (=) = equal in require ?cr [%here] (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 }); require ?cr [%here] (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 }); require ?cr [%here] (t_of_sexp (Sexp.(List [])) = { a = 2 }) type my_int = int [@@deriving sexp, sexp_grammar] module Poly = struct type nonrec t = t = { a : my_int; [@default 2] [@sexp_drop_default Poly.(=)] } [@@deriving sexp, sexp_grammar] let%test_unit _ = test t_of_sexp sexp_of_t end module Equal = struct let equal_my_int = equal_int type nonrec t = t = { a : my_int; [@default 2] [@sexp_drop_default.equal] } [@@deriving sexp, sexp_grammar] let%test_unit _ = test t_of_sexp sexp_of_t end module Compare = struct let compare_my_int = compare_int type nonrec t = t = { a : my_int; [@default 2] [@sexp_drop_default.compare] } [@@deriving sexp, sexp_grammar] let%test_unit _ = test t_of_sexp sexp_of_t end module Sexp = struct type nonrec t = t = { a : my_int; [@default 2] [@sexp_drop_default.sexp] } [@@deriving sexp, sexp_grammar] let%test_unit _ = test t_of_sexp sexp_of_t end end module Drop_if = struct type t = { a : int [@default 2] [@sexp_drop_if fun x -> x mod 2 = 0] } [@@deriving sexp, sexp_grammar] let%test _ = Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 } let%test _ = Sexp.(List []) = sexp_of_t { a = 2 } let%test _ = Sexp.(List [List [Atom "a"; Atom "3"]]) = sexp_of_t { a = 3 } let%test _ = Sexp.(List []) = sexp_of_t { a = 4 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "3"]])) = { a = 3 } let%test _ = t_of_sexp (Sexp.(List [List [Atom "a"; Atom "4"]])) = { a = 4 } let%test _ = t_of_sexp (Sexp.(List [])) = { a = 2 } type u = { a : int [@sexp_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) -> x = y ] } [@@deriving sexp, sexp_grammar] end module Omit_nil = struct type natural_option = int let sexp_of_natural_option i = if i >= 0 then sexp_of_int i else sexp_of_unit () let natural_option_of_sexp = function | Sexp.List [] -> -1 | sexp -> int_of_sexp sexp ;; let natural_option_sexp_grammar : Sexp.Private.Raw_grammar.t = Inline (Union [ List []; Atom Int ]) let check sexp_of_t t_of_sexp str t = let sexp = Sexplib.Sexp.of_string str in assert (sexp = sexp_of_t t); assert (t_of_sexp sexp = t); ;; type t = { a : natural_option [@sexp.omit_nil] } [@@deriving sexp, sexp_grammar] let%test_unit _ = check sexp_of_t t_of_sexp "()" { a = -1 } let%test_unit _ = check sexp_of_t t_of_sexp "((a 1))" { a = 1 } type t2 = | A of { a : int list [@sexp.omit_nil] } [@@deriving sexp, sexp_grammar] let%test_unit _ = check sexp_of_t2 t2_of_sexp "(A)" (A { a = [] }) let%test_unit _ = check sexp_of_t2 t2_of_sexp "(A (a (1)))" (A { a = [ 1 ] }) end module No_unused_rec_warning = struct type r = { field : r -> unit } [@@deriving sexp_of] end module True_and_false = struct type t = | True | False [@@deriving sexp, sexp_grammar] let%test _ = Sexp.to_string (sexp_of_t True) = "True" let%test _ = Sexp.to_string (sexp_of_t False) = "False" let%test _ = True = t_of_sexp (Sexplib.Sexp.of_string "True") let%test _ = False = t_of_sexp (Sexplib.Sexp.of_string "False") let%test _ = True = t_of_sexp (Sexplib.Sexp.of_string "true") let%test _ = False = t_of_sexp (Sexplib.Sexp.of_string "false") type u = | True of int | False of int [@@deriving sexp, sexp_grammar] let%test _ = Sexp.to_string (sexp_of_u (True 1)) = "(True 1)" let%test _ = Sexp.to_string (sexp_of_u (False 2)) = "(False 2)" let%test _ = True 1 = u_of_sexp (Sexplib.Sexp.of_string "(True 1)") let%test _ = False 2 = u_of_sexp (Sexplib.Sexp.of_string "(False 2)") let%test _ = True 1 = u_of_sexp (Sexplib.Sexp.of_string "(true 1)") let%test _ = False 2 = u_of_sexp (Sexplib.Sexp.of_string "(false 2)") exception True [@@deriving sexp] let%test _ = "ppx_sexp_test.ml.True_and_false.True" = Sexp.to_string (sexp_of_exn True) exception False of int [@@deriving sexp] let%test _ = "(ppx_sexp_test.ml.True_and_false.False 1)" = Sexp.to_string (sexp_of_exn (False 1)) type v = [ `True | `False of int ] [@@deriving sexp, sexp_grammar] let%test _ = Sexp.to_string (sexp_of_v `True) = "True" let%test _ = Sexp.to_string (sexp_of_v (`False 2)) = "(False 2)" end module Gadt = struct let is_eq sexp str = let sexp2 = Sexplib.Sexp.of_string str in if sexp <> sexp2 then begin Printf.printf "%S vs %S\n%!" (Sexp.to_string sexp) str; assert false end (* plain type without argument *) type 'a s = Packed : 'a s [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: int s] Packed) "Packed" (* two kind of existential variables *) type 'a t = Packed : 'a * _ * 'b sexp_opaque -> 'a t [@warning "-3"] [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: int t] (Packed (2, "asd", 1.))) "(Packed 2 _ )" (* plain type with argument *) type 'a u = A : 'a -> 'a u [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: int u] (A 2)) "(A 2)" (* recursive *) type v = A : v option -> v [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: v] (A (Some (A None)))) "(A((A())))" (* implicit existential variable *) type w = A : 'a * int * ('a -> string) -> w [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: w] (A (1., 2, string_of_float))) "(A _ 2 )" (* tricky variable naming *) type 'a x = A : 'a -> 'b x [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: int x] (A 1.)) "(A _)" (* interaction with inline record *) type _ x2 = A : { x : 'c } -> 'c x2 [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: int x2] (A { x = 1 })) "(A (x 1))" (* unused but colliding variables *) type (_, _) y = A : ('a, 'a) y [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: (int, int) y] A) "A" (* making sure we're not reversing parameters *) type (_, _) z = A : ('a * 'b) -> ('a, 'b) z [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: (int, string) z] (A (1, "a"))) "(A (1 a))" (* interaction with universal quantifiers *) type _ z2 = A : { x : 'c. 'c option } -> 'c z2 [@@deriving sexp_of] let%test_unit _ = is_eq ([%sexp_of: unit z2] (A { x = None })) "(A (x ()))" end module Anonymous_variable = struct type _ t = int [@@deriving sexp, sexp_grammar] let%test _ = Sexp.to_string ([%sexp_of: _ t] 2) = "2" let%test _ = [%of_sexp: _ t] (Sexplib.Sexp.of_string "2") = 2 (* making sure we don't generate signatures like (_ -> Sexp.t) -> _ t -> Sexp.t which are too general *) module M : sig type _ t [@@deriving sexp, sexp_grammar] end = struct type 'a t = 'a [@@deriving sexp, sexp_grammar] end end module Record_field_disambiguation = struct type a = { fl: float; b : b } and b = { fl: int } [@@deriving sexp, sexp_grammar] end module Private = struct type t = private int [@@deriving sexp_of] type ('a, 'b) u = private t [@@deriving sexp_of] type ('a, 'b, 'c) v = private ('a, 'b) u [@@deriving sexp_of] end module Nonregular_types = struct type 'a nonregular = | Leaf of 'a | Branch of ('a * 'a) nonregular [@@deriving sexp, sexp_grammar] type 'a variant = [ `A of 'a ] [@@deriving sexp, sexp_grammar] type ('a, 'b) nonregular_with_variant = | Branch of ([ | 'a list variant ], 'b) nonregular_with_variant [@@deriving sexp, sexp_grammar] end module Opaque = struct type t = (int [@sexp.opaque]) list [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "( )" let t = [1; 2] let%test _ = sexp_of_t t = sexp let%test _ = match t_of_sexp sexp with | _ -> false | exception _ -> true type u = [`A of int] [@sexp.opaque] [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "" let u = `A 1 let%test _ = sexp_of_u u = sexp let%test _ = match u_of_sexp sexp with | _ -> false | exception _ -> true end module Optional = struct type t = { optional : int option [@sexp.option] } [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "()" let t = { optional = None } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp let sexp = Sexplib.Sexp.of_string "((optional 5))" let t = { optional = Some 5 } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp end module Nonempty = struct type t = { list : int list [@sexp.list] ; array : int array [@sexp.array] } [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "()" let t = { list = []; array = [||] } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp let sexp = Sexplib.Sexp.of_string "((list (1 2 3)) (array (3 2 1)))" let t = { list = [1;2;3]; array = [|3;2;1|] } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp end module Boolean = struct type t = { no_arg : bool [@sexp.bool] } [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "()" let t = { no_arg = false } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp let sexp = Sexplib.Sexp.of_string "((no_arg))" let t = { no_arg = true } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp type t_allow_extra_fields = { no_arg : bool [@sexp.bool] } [@@deriving sexp, sexp_grammar][@@sexp.allow_extra_fields] let%expect_test _ = Expect_test_helpers_core.require_does_raise ~cr:CR_soon [%here] (fun () -> let r = t_allow_extra_fields_of_sexp (Sexplib.Sexp.of_string "((no_arg true))") in print_endline (Bool.to_string r.no_arg) ); [%expect {| (Of_sexp_error "ppx_sexp_test.ml.Boolean.t_allow_extra_fields_of_sexp: record conversion: a [sexp.bool] field was given a payload." (invalid_sexp ((no_arg true)))) |}] end module Inline = struct type t = A of int list [@sexp.list] [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "(A 1 2 3)" let t = A [1; 2; 3] let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp type u = [ `A of int list [@sexp.list] ] [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "(A 1 2 3)" let u = `A [1; 2; 3] let%test _ = u_of_sexp sexp = u let%test _ = sexp_of_u u = sexp end module Magic_types = struct type t = { sexp_array : int sexp_array [@warning "-3"] ; sexp_list : int sexp_list [@warning "-3"] ; sexp_option : int sexp_option [@warning "-3"] ; sexp_bool : sexp_bool [@warning "-3"] } [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "()" let t = { sexp_array = [||] ; sexp_list = [] ; sexp_option = None ; sexp_bool = false } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp let sexp = Sexplib.Sexp.of_string "((sexp_array (1 2))\ (sexp_list (3 4))\ (sexp_option 5)\ (sexp_bool))" let t = { sexp_array = [|1; 2|] ; sexp_list = [3; 4] ; sexp_option = Some 5 ; sexp_bool = true } let%test _ = t_of_sexp sexp = t let%test _ = sexp_of_t t = sexp type u = | A of int sexp_list [@warning "-3"] [@@deriving sexp, sexp_grammar] type v = [ `A of int sexp_list ] [@warning "-3"] [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "(A 1 2 3)" let u = A [1; 2; 3] let v = `A [1; 2; 3] let%test _ = u_of_sexp sexp = u let%test _ = sexp_of_u u = sexp let%test _ = v_of_sexp sexp = v let%test _ = sexp_of_v v = sexp end module Variance = struct type (+'a, -'b, 'c, +_, -_, _) t [@@deriving sexp, sexp_grammar] 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 sexp, sexp_grammar] type 'hey rigid_hey = Hey of 'hey [@@deriving sexp, sexp_grammar] type ('foo,'rigid_foo) foo = Foo of 'foo [@@deriving sexp, sexp_grammar] type 'rigid_bar rigid_rigid_bar = Bar [@@deriving sexp, sexp_grammar] 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_sexpable = sig type t [@@deriving of_sexp, sexp_grammar] end let s__t_of_sexp (type k1 k2 ) (module K1 : Of_sexpable with type t = k1) (module K2 : Of_sexpable with type t = k2) (_ : Sexp.t) : (k1, k2) t = assert false (* You would actually have to write this manually for functors. *) let s__t_sexp_grammar = [%sexp_grammar: < for_all : 'k1 'k2 . ('k1 * 'k2) list > ] end module Int = struct type t = int [@@deriving of_sexp, sexp_grammar] end module String = struct type t = string [@@deriving of_sexp, sexp_grammar] end module M : sig type t = Bidirectional_map.S(String)(Int).t [@@deriving of_sexp, sexp_grammar] end = struct type t = Bidirectional_map.S(String)(Int).t [@@deriving of_sexp, sexp_grammar] end end module Type_extensions = struct let _ = ([%sexp_of: int] : [%sexp_of: int]) let _ = ([%of_sexp: int] : [%of_sexp: int]) end module Allow_extra_fields = struct let should_raise f x = try ignore (f x); false with _ -> true module M1 = struct type t1 = { a : int } [@@deriving sexp] type t2 = t1 = { a : int } [@@deriving sexp, sexp_grammar][@@sexp.allow_extra_fields] let sexp = Sexplib.Sexp.of_string "((a 1))" let sexp_extra = Sexplib.Sexp.of_string "((a 1)(b 2))" let%test _ = t2_of_sexp sexp = t2_of_sexp sexp_extra let%test _ = t1_of_sexp sexp = t2_of_sexp sexp let%test _ = should_raise t1_of_sexp sexp_extra let%expect_test _ = Expect_test_helpers_core.require_does_raise ~cr:CR_soon [%here] (fun () -> t2_of_sexp (Sexplib.Sexp.of_string "((a 1)(a))")); [%expect {| (Of_sexp_error "ppx_sexp_test.ml.Allow_extra_fields.M1.t2_of_sexp: duplicate fields: a" (invalid_sexp ((a 1) (a)))) |}] end module M2 = struct type t1 = | A of { a : int list } [@@deriving sexp] type t2 = t1 = | A of { a : int list } [@sexp.allow_extra_fields] [@@deriving sexp, sexp_grammar] let sexp = Sexplib.Sexp.of_string "(A (a (0)))" let sexp_extra = Sexplib.Sexp.of_string "(A (a (0))(b 2))" let%test _ = t2_of_sexp sexp = t2_of_sexp sexp_extra let%test _ = t1_of_sexp sexp = t2_of_sexp sexp let%test _ = should_raise t1_of_sexp sexp_extra end end module Default_values_and_polymorphism = struct type t = { a : int list [@sexp.list] ; b : 'b . 'b -> int } [@@deriving of_sexp] end let (_ : Sexplib.Sexp.Raw_grammar.t) = [%sexp_grammar: < for_all : 'k 'v . ('k * 'v) list > ] ppx_sexp_conv-0.14.3/test/ppx_sexp_test.mli000066400000000000000000000000001401347656000210550ustar00rootroot00000000000000ppx_sexp_conv-0.14.3/test/test.sexp000066400000000000000000000006561401347656000173460ustar00rootroot00000000000000(this is a list) (this is another list and (this is a nested list)) ( "\ This is a multi-line \ string with embedded newlines." "This string contains decimal \255, hex \xff codes, \ and other \\ \n escapes." A# # ## #x| ) ; Line comment #; ( S-expression comment ) #| #| Nested |# block comment "|#" |# #| "" |# #| ""|# #|"" |# #|""|# #| "asdf" "asdf" |# (something #| ; |# () "something else")