pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=096105e9eeebf599e2178cff874a8161900359a2 ppx_sexp_conv-0.17.0/000077500000000000000000000000001461647336100145055ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/.gitignore000066400000000000000000000000411461647336100164700ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_sexp_conv-0.17.0/.ocamlformat000066400000000000000000000000231461647336100170050ustar00rootroot00000000000000profile=janestreet ppx_sexp_conv-0.17.0/CHANGES.md000066400000000000000000000040661461647336100161050ustar00rootroot00000000000000## 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.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100167350ustar00rootroot00000000000000This 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.17.0/LICENSE.md000066400000000000000000000021461461647336100161140ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_sexp_conv-0.17.0/Makefile000066400000000000000000000004031461647336100161420ustar00rootroot00000000000000INSTALL_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.17.0/README.org000066400000000000000000000425771461647336100161720ustar00rootroot00000000000000#+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=]], you can get the same effect with =open Core=. 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.Sexp_grammar= for details. Use =[@@deriving sexp_grammar]= to derive the grammar for a type. 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 ** Tagging grammars Use =[@sexp_grammar.tag key = value]=, where =(key : string)= and =(value : Sexp.t)=, to annotate a grammar with a tag that can be inspected at runtime. ** Custom grammars Use =[@sexp_grammar.custom grammar]= to override a type's sexp grammar with =grammar=. ** Stub grammars Annotate a type with =[@sexp_grammar.any]= to use a stub grammar that accepts any sexp. Alternately, write =[@sexp_grammar.any desc]= where =(desc : string)= to use =desc= as a human-readable description for the stub grammar. * 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 The attributes =sexp.list= and =sexp.array= indicate that a list or array record field, respectively, can be omitted when it is empty. #+begin_src ocaml type t = { arr : int array [@sexp.array] ; lst : int list [@sexp.list] } [@@deriving sexp] { arr = [||]; lst = [] } => () { arr = [|1;2|]; lst = [3;4] } => ((arr (1 2)) (lst (3 4))) #+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 *** Inline records Constructors with inline records are represented as lists, the first element being the constructor name, the rest being the record fields, represented the same way as in record types, but without being wrapped in an extra layer of parentheses. #+begin_src ocaml type t = A of { x : int } A { x = 8 } => (A (x 8)) #+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. If the type is for a record field, it will likely need parentheses to avoid applying the attribute to the record field itself, /e.g./: #+begin_src ocaml type foo = int * (stuff [@sexp.opaque]) [@@deriving sexp] type bar = { a : int ; b : (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 have been replaced with attributes. Here are the appropriate conversions to update from code using the old types to the new 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.17.0/bench/000077500000000000000000000000001461647336100155645ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/bench/dune000066400000000000000000000001721461647336100164420ustar00rootroot00000000000000(library (name ppx_sexp_conv_bench) (libraries base parsexp) (preprocess (pps ppx_bench ppx_compare ppx_sexp_conv))) ppx_sexp_conv-0.17.0/bench/ppx_sexp_conv_bench.ml000066400000000000000000000142121461647336100221500ustar00rootroot00000000000000open! Base let bench_sexp_of_t ~sexp_of_t t = let t = Sys.opaque_identity t in fun () -> sexp_of_t t ;; let bench_t_of_sexp ~t_of_sexp string = let sexp = Sys.opaque_identity (Parsexp.Single.parse_string_exn string) in fun () -> t_of_sexp sexp ;; let%bench_module "Record" = (module struct type t = { a : int ; b : int option [@omit_nil] ; c : bool [@sexp.bool] ; d : int array [@sexp.array] ; e : int list [@sexp.list] ; f : int option [@sexp.option] ; g : int [@default 0] [@sexp_drop_default ( = )] ; h : int [@default 0] [@sexp_drop_default.compare] ; i : int [@default 0] [@sexp_drop_default.equal] ; j : int [@default 0] [@sexp_drop_default.sexp] ; k : 'a. 'a list } [@@deriving sexp] let%bench_fun "sexp_of_t, full" = bench_sexp_of_t ~sexp_of_t { a = 1 ; b = Some 2 ; c = true ; d = [| 3; 4 |] ; e = [ 5; 6 ] ; f = Some 7 ; g = 8 ; h = 9 ; i = 10 ; j = 11 ; k = [] } ;; let%bench_fun "sexp_of_t, empty" = bench_sexp_of_t ~sexp_of_t { a = 0 ; b = None ; c = false ; d = [||] ; e = [] ; f = None ; g = 0 ; h = 0 ; i = 0 ; j = 0 ; k = [] } ;; let%bench_fun "t_of_sexp, full, in order" = bench_t_of_sexp ~t_of_sexp "((a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h 9) (i 10) (j 11) (k ()))" ;; let%bench_fun "t_of_sexp, full, reverse order" = bench_t_of_sexp ~t_of_sexp "((k ()) (j 11) (i 10) (h 9) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) (a 1))" ;; let%bench_fun "t_of_sexp, empty" = bench_t_of_sexp ~t_of_sexp "((a 0) (k ()))" end) ;; let%bench_module "Variant" = (module struct type t = | Atomic | Tuple of int * string | List of int list [@sexp.list] | Record of { a : int ; b : int option [@omit_nil] ; c : bool [@sexp.bool] ; d : int array [@sexp.array] ; e : int list [@sexp.list] ; f : int option [@sexp.option] ; g : int [@default 0] [@sexp_drop_default ( = )] ; h : int [@default 0] [@sexp_drop_default.compare] ; i : int [@default 0] [@sexp_drop_default.equal] ; j : int [@default 0] [@sexp_drop_default.sexp] ; k : 'a. 'a list } [@@deriving sexp] let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t Atomic let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (Tuple (1, "hello")) let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (List [ 1; 2 ]) let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (List []) let%bench_fun "sexp_of_t, record, full" = bench_sexp_of_t ~sexp_of_t (Record { a = 1 ; b = Some 2 ; c = true ; d = [| 3; 4 |] ; e = [ 5; 6 ] ; f = Some 7 ; g = 8 ; h = 9 ; i = 10 ; j = 11 ; k = [] }) ;; let%bench_fun "sexp_of_t, record, empty" = bench_sexp_of_t ~sexp_of_t (Record { a = 0 ; b = None ; c = false ; d = [||] ; e = [] ; f = None ; g = 0 ; h = 0 ; i = 0 ; j = 0 ; k = [] }) ;; let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic" let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple 1 hello)" let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)" let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)" let%bench_fun "t_of_sexp, record, full, in order" = bench_t_of_sexp ~t_of_sexp "(Record (a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h 9) (i 10) (j 11) \ (k ()))" ;; let%bench_fun "t_of_sexp, record, full, reverse order" = bench_t_of_sexp ~t_of_sexp "(Record (k ()) (j 11) (i 10) (h 9) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) \ (a 1))" ;; let%bench_fun "t_of_sexp, record, empty" = bench_t_of_sexp ~t_of_sexp "(Record (a 0) (k ()))" ;; end) ;; let%bench_module "Tag" = (module struct type t = [ `Atomic | `Tuple of int * string | `List of int list [@sexp.list] ] [@@deriving sexp] let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t `Atomic let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (`Tuple (1, "hello")) let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (`List [ 1; 2 ]) let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (`List []) let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic" let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple (1 hello))" let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)" let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)" end) ;; let%bench_module "Inherit" = (module struct type atomic = [ `Atomic ] [@@deriving sexp] type tuple = [ `Tuple of int * string ] [@@deriving sexp] type listed = [ `List of int list [@sexp.list] ] [@@deriving sexp] type t = [ atomic | tuple | listed ] [@@deriving sexp] let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t `Atomic let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (`Tuple (1, "hello")) let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (`List [ 1; 2 ]) let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (`List []) let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic" let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple (1 hello))" let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)" let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)" end) ;; ppx_sexp_conv-0.17.0/bench/ppx_sexp_conv_bench.mli000066400000000000000000000000611461647336100223160ustar00rootroot00000000000000(*_ This module deliberately exports nothing. *) ppx_sexp_conv-0.17.0/dune000066400000000000000000000000001461647336100153510ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/dune-project000066400000000000000000000000211461647336100170200ustar00rootroot00000000000000(lang dune 3.11) ppx_sexp_conv-0.17.0/expander/000077500000000000000000000000001461647336100163135ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/expander/attrs.ml000066400000000000000000000126401461647336100200050ustar00rootroot00000000000000open! Base open! Ppxlib module To_lift = struct type 'a t = { to_lift : 'a } [@@unboxed] end open To_lift let default = Attribute.declare "sexp.default" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) (fun x -> { to_lift = x }) ;; let drop_default = Attribute.declare "sexp.sexp_drop_default" Attribute.Context.label_declaration Ast_pattern.(pstr (alt_option (pstr_eval __ nil ^:: nil) nil)) (function | None -> None | Some x -> Some { to_lift = 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 -> { to_lift = 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 grammar_custom = Attribute.declare "sexp_grammar.custom" Attribute.Context.core_type Ast_pattern.(single_expr_payload __) (fun x -> x) ;; let grammar_any = Attribute.declare "sexp_grammar.any" Attribute.Context.core_type Ast_pattern.(alt_option (single_expr_payload (estring __)) (pstr nil)) (fun x -> x) ;; let tag_attribute_for_context context = let open Ast_pattern in let key_equals_value = Ast_pattern.( pexp_apply (pexp_ident (lident (string "="))) (no_label __ ^:: no_label __ ^:: nil) |> pack2) in let get_captured_values ast_pattern context expression = Ast_pattern.to_func ast_pattern context expression.pexp_loc expression (fun x -> x) in let rec collect_sequence expression = match expression.pexp_desc with | Pexp_sequence (l, r) -> l :: collect_sequence r | _ -> [ expression ] in let esequence ast_pattern = Ast_pattern.of_func (fun context _loc expression k -> collect_sequence expression |> List.map ~f:(get_captured_values ast_pattern context) |> k) in Attribute.declare "sexp_grammar.tag" context (pstr (pstr_eval (esequence key_equals_value) nil ^:: nil)) (fun x -> x) ;; let tag_type = tag_attribute_for_context Core_type let tag_ld = tag_attribute_for_context Label_declaration let tag_cd = tag_attribute_for_context Constructor_declaration let tag_poly = tag_attribute_for_context Rtag let tags_attribute_for_context context = Attribute.declare "sexp_grammar.tags" context Ast_pattern.(single_expr_payload __) (fun x -> x) ;; let tags_type = tags_attribute_for_context Core_type let tags_ld = tags_attribute_for_context Label_declaration let tags_cd = tags_attribute_for_context Constructor_declaration let tags_poly = tags_attribute_for_context Rtag 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.") ;; ppx_sexp_conv-0.17.0/expander/attrs.mli000066400000000000000000000042031461647336100201520ustar00rootroot00000000000000open! Base open! Ppxlib (** [default], [drop_default], and [drop_if] attributes are annotated with expressions that should be lifted out of the scope of ppx-generated temporary variables. See the [Lifted] module. *) module To_lift : sig type 'a t = { to_lift : 'a } [@@unboxed] end val default : (label_declaration, expression To_lift.t) Attribute.t val drop_default : (label_declaration, expression To_lift.t option) Attribute.t val drop_if : (label_declaration, expression To_lift.t) Attribute.t val drop_default_equal : (label_declaration, unit) Attribute.t val drop_default_compare : (label_declaration, unit) Attribute.t val drop_default_sexp : (label_declaration, unit) Attribute.t val omit_nil : (label_declaration, unit) Attribute.t val option : (label_declaration, unit) Attribute.t val list : (label_declaration, unit) Attribute.t val array : (label_declaration, unit) Attribute.t val bool : (label_declaration, unit) 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 val grammar_any : (core_type, string option) Attribute.t val grammar_custom : (core_type, expression) Attribute.t val tag_type : (core_type, (expression * expression) list) Attribute.t val tag_ld : (label_declaration, (expression * expression) list) Attribute.t val tag_cd : (constructor_declaration, (expression * expression) list) Attribute.t val tag_poly : (row_field, (expression * expression) list) Attribute.t val tags_type : (core_type, expression) Attribute.t val tags_ld : (label_declaration, expression) Attribute.t val tags_cd : (constructor_declaration, expression) Attribute.t val tags_poly : (row_field, expression) Attribute.t ppx_sexp_conv-0.17.0/expander/conversion.ml000066400000000000000000000131161461647336100210340ustar00rootroot00000000000000open! Base open! Ppxlib open Ast_builder.Default open Helpers module Reference = struct type t = { types : type_declaration list ; binds : value_binding list list ; ident : longident_loc ; args : (arg_label * expression) list } let bind t binds = { t with binds = binds :: t.binds } let bind_types t types = { t with types = types @ t.types } let maybe_apply { types; binds; ident; args } ~loc maybe_arg = let ident = pexp_ident ~loc ident in let args = match maybe_arg with | None -> args | Some arg -> args @ [ Nolabel, arg ] in let expr = match args with | [] -> ident | _ -> pexp_apply ~loc ident args in with_types ~loc ~types (with_let ~loc ~binds expr) ;; let apply t ~loc arg = maybe_apply t ~loc (Some arg) let to_expression t ~loc = maybe_apply t ~loc None let to_value_expression t ~loc ~rec_flag ~values_being_defined = let may_refer_directly_to ident = match rec_flag with | Nonrecursive -> true | Recursive -> not (Set.mem values_being_defined (Longident.name ident.txt)) in match t with | { types = []; binds = []; ident; args = [] } when may_refer_directly_to ident -> pexp_ident ~loc ident | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg) ;; end module Lambda = struct type t = { types : type_declaration list ; binds : value_binding list list ; cases : cases } let bind t binds = { t with binds = binds :: t.binds } let bind_types t types = { t with types = types @ t.types } (* generic case: use [function] or [match] *) let maybe_apply_generic ~loc ~types ~binds maybe_arg cases = let expr = match maybe_arg with | None -> pexp_function ~loc cases | Some arg -> pexp_match ~loc arg cases in with_types ~loc ~types (with_let ~loc ~binds expr) ;; (* zero cases: synthesize an "impossible" case, i.e. [| _ -> .] *) let maybe_apply_impossible ~loc ~types ~binds maybe_arg = [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(pexp_unreachable ~loc) ] |> maybe_apply_generic ~loc ~binds ~types maybe_arg ;; (* one case without guard: use [fun] or [let] *) let maybe_apply_simple ~loc ~types ~binds maybe_arg pat body = let expr = match maybe_arg with | None -> pexp_fun ~loc Nolabel None pat body | Some arg -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr:arg ] body in with_types ~loc ~types (with_let ~loc ~binds expr) ;; (* shared special-casing logic for [apply] and [to_expression] *) let maybe_apply t ~loc maybe_arg = match t with | { types; binds; cases = [] } -> maybe_apply_impossible ~loc ~types ~binds maybe_arg | { types; binds; cases = [ { pc_lhs; pc_guard = None; pc_rhs } ] } -> maybe_apply_simple ~loc ~types ~binds maybe_arg pc_lhs pc_rhs | { types; binds; cases } -> maybe_apply_generic ~loc ~types ~binds maybe_arg cases ;; let apply t ~loc arg = maybe_apply t ~loc (Some arg) let to_expression t ~loc = maybe_apply t ~loc None let to_value_expression t ~loc = match t with | { types = []; binds = []; cases = _ } -> (* lambdas without [let] are already values *) let expr = to_expression t ~loc in assert (is_value_expression expr); expr | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg) ;; end type t = | Reference of Reference.t | Lambda of Lambda.t let of_lambda cases = Lambda { types = []; binds = []; cases } let of_reference_exn expr = match expr.pexp_desc with | Pexp_ident ident -> Reference { types = []; binds = []; ident; args = [] } | Pexp_apply ({ pexp_desc = Pexp_ident ident; _ }, args) -> Reference { types = []; binds = []; ident; args } | _ -> Location.raise_errorf ~loc:expr.pexp_loc "ppx_sexp_conv: internal error.\n\ [Conversion.of_reference_exn] expected an identifier possibly applied to arguments.\n\ Instead, got:\n\ %s" (Pprintast.string_of_expression expr) ;; let to_expression t ~loc = match t with | Reference reference -> Reference.to_expression ~loc reference | Lambda lambda -> Lambda.to_expression ~loc lambda ;; let to_value_expression t ~loc ~rec_flag ~values_being_defined = match t with | Reference reference -> Reference.to_value_expression ~loc ~rec_flag ~values_being_defined reference | Lambda lambda -> Lambda.to_value_expression ~loc lambda ;; let apply t ~loc e = match t with | Reference reference -> Reference.apply ~loc reference e | Lambda lambda -> Lambda.apply ~loc lambda e ;; let bind t binds = match t with | Reference reference -> Reference (Reference.bind reference binds) | Lambda lambda -> Lambda (Lambda.bind lambda binds) ;; let bind_types t types = match t with | Reference reference -> Reference (Reference.bind_types reference types) | Lambda lambda -> Lambda (Lambda.bind_types lambda types) ;; module Apply_all = struct type t = { bindings : value_binding list ; arguments : pattern list ; converted : expression list } end let gen_symbols list ~prefix = List.mapi list ~f:(fun i _ -> gen_symbol ~prefix:(prefix ^ Int.to_string i) ()) ;; let apply_all ts ~loc = let arguments_names = gen_symbols ts ~prefix:"arg" in let converted_names = gen_symbols ts ~prefix:"res" in let bindings = List.map3_exn ts arguments_names converted_names ~f:(fun t arg conv -> let expr = apply ~loc t (evar ~loc arg) in value_binding ~loc ~pat:(pvar ~loc conv) ~expr) in ({ bindings ; arguments = List.map arguments_names ~f:(pvar ~loc) ; converted = List.map converted_names ~f:(evar ~loc) } : Apply_all.t) ;; ppx_sexp_conv-0.17.0/expander/conversion.mli000066400000000000000000000032271461647336100212070ustar00rootroot00000000000000open! Base open! Ppxlib (** Sexp conversion function, expressed as either a single expression or as a collection of [match] cases. Expressing as cases rather than wrapping directly in [pexp_function] allows us to simplify some expressions built on this. *) type t (** Construct [t] from a list of pattern/expression cases. *) val of_lambda : cases -> t (** Construct [t] from an identifier, possibly applied to arguments. Raise on any other form of expression. *) val of_reference_exn : expression -> t (** Convert [t] to an expression. *) val to_expression : t -> loc:location -> expression (** Convert [t] to an expression that is a syntactic value, i.e. a constant, identifier, or lambda expression that does no "work", can can be preallocated, and works in the context of a [let rec]. *) val to_value_expression : t -> loc:location -> rec_flag:rec_flag -> values_being_defined:Set.M(String).t -> expression (** Apply [t] to an argument. *) val apply : t -> loc:location -> expression (** argument [t] is applied to *) -> expression (** Wrap [t] in [let]-bindings. *) val bind : t -> value_binding list -> t (** Wrap [t] in [let open .. in] with type declarations. *) val bind_types : t -> type_declaration list -> t module Apply_all : sig type t = { bindings : value_binding list ; arguments : pattern list ; converted : expression list } end (** Applies each [t] to a fresh variable, and binds the results to fresh variables. Returns the corresponding [value_binding]s, patterns for the argument variables, and expressions for the result variables. *) val apply_all : t list -> loc:location -> Apply_all.t ppx_sexp_conv-0.17.0/expander/dune000066400000000000000000000004261461647336100171730ustar00rootroot00000000000000(library (name ppx_sexp_conv_expander) (public_name ppx_sexp_conv.expander) (libraries base compiler-libs.common ppxlib ppxlib_jane ppxlib.metaquot_lifters) (ppx_runtime_libraries ppx_sexp_conv.runtime-lib sexplib0) (preprocess (pps ppxlib.metaquot ppxlib.traverse))) ppx_sexp_conv-0.17.0/expander/expand_of_sexp.ml000066400000000000000000001243111461647336100216510ustar00rootroot00000000000000open! Base open! Ppxlib open Ast_builder.Default open Helpers open Lifted.Monad_infix (* 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: Sexplib0.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_of_sexp = struct module Ptag_error_function = struct type t = | Ptag_no_args | Ptag_takes_args end module Row_or_constructor = struct type t = | Row of row_field | Constructor of constructor_declaration end let with_error_source ~loc ~full_type_name make_body = let lifted = let name = lazy (Fresh_name.create "error_source" ~loc) in make_body ~error_source:(fun () -> Fresh_name.expression (force name)) >>| fun body -> match Lazy.is_val name with | false -> (* no references to [name], no need to define it *) body | true -> (* add a definition for [name] *) [%expr let [%p Fresh_name.pattern (force name)] = [%e estring ~loc full_type_name] in [%e body]] in Lifted.let_bind_user_expressions lifted ~loc ;; (* Utility functions for polymorphic variants *) (* Handle backtracking when variants do not match *) let handle_no_variant_match loc expr = [ [%pat? Sexplib0.Sexp_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 ~fresh_atom 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 (Fresh_name.expression fresh_atom) matches ;; (* Generate code for matching malformed S-expressions *) let mk_variant_other_matches ~error_source ~fresh__sexp loc rev_els call = let coll_structs acc (loc, cnstr) = (pstring ~loc cnstr --> match (call : Ptag_error_function.t) with | Ptag_no_args -> [%expr Sexplib0.Sexp_conv_error.ptag_no_args [%e error_source ()] [%e Fresh_name.expression fresh__sexp]] | Ptag_takes_args -> [%expr Sexplib0.Sexp_conv_error.ptag_takes_args [%e error_source ()] [%e Fresh_name.expression fresh__sexp]]) :: acc in let exc_no_variant_match = [%pat? _] --> [%expr Sexplib0.Sexp_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 "unsupported: polymorphic variant intersection type" | Rtag (_, false, []) -> Location.raise_errorf ~loc "unsupported: polymorphic variant empty type" ;; 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 ~error_source ~typevars ?full_type ?(internal = false) typ : Conversion.t = let loc = typ.ptyp_loc in match Ppxlib_jane.Jane_syntax.Core_type.of_ast typ with | Some (Jtyp_tuple alist, (_ : attributes)) -> Conversion.of_reference_exn (labeled_tuple_of_sexp ~error_source ~typevars ~loc alist) | Some (Jtyp_layout _, _) | None -> (match typ with | _ when Option.is_some (Attribute.get Attrs.opaque typ) -> Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.opaque_of_sexp] | [%type: [%t? _] sexp_opaque] | [%type: _] -> Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.opaque_of_sexp] | [%type: [%t? ty1] sexp_list] -> let arg1 = Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars ty1) in Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.list_of_sexp [%e arg1]] | [%type: [%t? ty1] sexp_array] -> let arg1 = Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars ty1) in Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.array_of_sexp [%e arg1]] | { ptyp_desc = Ptyp_tuple tp; _ } -> Conversion.of_lambda (tuple_of_sexp ~error_source ~typevars (loc, tp)) | { ptyp_desc = Ptyp_var parm; _ } -> (match Map.find typevars parm with | Some fresh -> Conversion.of_reference_exn (Fresh_name.expression fresh) | None -> Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" parm) | { ptyp_desc = Ptyp_constr (id, args); _ } -> let args = List.map args ~f:(fun arg -> Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars arg)) in Conversion.of_reference_exn (type_constr_of_sexp ~loc ~internal id args) | { ptyp_desc = Ptyp_arrow (_, _, _); _ } -> Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.fun_of_sexp] | { ptyp_desc = Ptyp_variant (row_fields, Closed, _); _ } -> variant_of_sexp ~error_source ~typevars ?full_type (loc, row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> poly_of_sexp ~error_source ~typevars parms poly_tp | { ptyp_desc = Ptyp_variant (_, Open, _); _ } | { 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 (unlabeled) tuples *) and tuple_of_sexp ~error_source ~typevars (loc, tps) = let fps = List.map ~f:(type_of_sexp ~error_source ~typevars) tps in let ({ bindings; arguments; converted } : Conversion.Apply_all.t) = Conversion.apply_all ~loc fps in let n = List.length fps in let fresh_sexp = Fresh_name.create "sexp" ~loc in [ [%pat? Sexplib0.Sexp.List [%p plist ~loc arguments]] --> pexp_let ~loc Nonrecursive bindings (pexp_tuple ~loc converted) ; Fresh_name.pattern fresh_sexp --> [%expr Sexplib0.Sexp_conv_error.tuple_of_size_n_expected [%e error_source ()] [%e eint ~loc n] [%e Fresh_name.expression fresh_sexp]] ] (* Conversion of labeled tuples *) and labeled_tuple_of_sexp ~error_source ~typevars ~loc alist = assert (Labeled_tuple.is_valid alist); let fields_expr = List.fold_right alist ~init:[%expr Empty] ~f:(fun (label_option, core_type) rest_expr -> let name_expr = estring ~loc (Labeled_tuple.atom_of_label label_option) in let conv_expr = type_of_sexp ~error_source ~typevars core_type |> Conversion.to_expression ~loc:core_type.ptyp_loc in [%expr Field { name = [%e name_expr]; conv = [%e conv_expr]; rest = [%e rest_expr] }]) in let create_expr = let pats, exprs = List.map alist ~f:(fun (label_option, _) -> let name = Fresh_name.create ~loc "field" in Fresh_name.pattern name, (label_option, Fresh_name.expression name)) |> List.unzip in let pat = List.fold_right pats ~init:(punit ~loc) ~f:(fun pat1 pat2 -> ppat_tuple ~loc [ pat1; pat2 ]) in let expr = Ppxlib_jane.Jane_syntax.Labeled_tuples.expr_of ~loc exprs in [%expr fun [%p pat] -> [%e expr]] in pexp_apply ~loc [%expr Sexplib0.Sexp_conv_labeled_tuple.labeled_tuple_of_sexp] [ Labelled "caller", error_source () ; Labelled "fields", fields_expr ; Labelled "create", create_expr ] (* Generate code for matching included variant types *) and handle_variant_inh ~error_source ~typevars ~fresh_atom ~fresh__sexp full_type ~match_last other_matches inh = let loc = inh.ptyp_loc in let func_expr = type_of_sexp ~error_source ~typevars ~internal:true inh in let app = Conversion.of_reference_exn (Conversion.apply ~loc func_expr (Fresh_name.expression fresh__sexp)) in let match_exc = handle_no_variant_match loc (handle_variant_match_last loc ~match_last ~fresh_atom other_matches) in let new_other_matches = [ [%pat? _] --> pexp_try ~loc [%expr ([%e Conversion.to_expression ~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 ~error_source ~typevars ~fresh_atom ~fresh__sexp 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 ~error_source ~typevars ~fresh_atom ~fresh__sexp full_type ~match_last other_matches inh in let other_matches = mk_variant_other_matches ~error_source ~fresh__sexp 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 ~fresh_atom match_atoms_inhs (* Variant conversions *) (* Match arguments of constructors (variants or sum types) *) and mk_cnstr_args_match ~error_source ~typevars ~loc ~is_variant ~fresh__sexp ~fresh__tag ~fresh_sexp_args 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 : Row_or_constructor.t) 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 = Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars tp) in cnstr [%expr Sexplib0.Sexp_conv.list_map [%e cnv] [%e Fresh_name.expression fresh_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 = Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars tp) in cnstr [%expr Sexplib0.Sexp_conv.list_map [%e cnv] [%e Fresh_name.expression fresh_sexp_args]] | _ -> let bindings, patts, good_arg_match = let fps = List.map ~f:(type_of_sexp ~error_source ~typevars) tps in let ({ bindings; arguments; converted } : Conversion.Apply_all.t) = Conversion.apply_all ~loc fps in let good_arg_match = cnstr (pexp_tuple ~loc converted) in bindings, arguments, good_arg_match in [%expr match [%e Fresh_name.expression fresh_sexp_args] with | [%p plist ~loc patts] -> [%e pexp_let ~loc Nonrecursive bindings good_arg_match] | _ -> [%e if is_variant then [%expr Sexplib0.Sexp_conv_error.ptag_incorrect_n_args [%e error_source ()] [%e Fresh_name.expression fresh__tag] [%e Fresh_name.expression fresh__sexp]] else [%expr Sexplib0.Sexp_conv_error.stag_incorrect_n_args [%e error_source ()] [%e Fresh_name.expression fresh__tag] [%e Fresh_name.expression fresh__sexp]]]] (* Generate code for matching structured variants *) and mk_variant_match_struct ~error_source ~typevars ~fresh_atom ~fresh__sexp ~fresh_sexp_args 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 fresh__tag = Fresh_name.create "_tag" ~loc in let expr = mk_cnstr_args_match ~error_source ~typevars ~loc:tp.ptyp_loc ~is_variant:true ~fresh__sexp ~fresh__tag ~fresh_sexp_args cnstr [ tp ] (Row row) in let new_match = ppat_alias ~loc [%pat? [%p pstring ~loc cnstr]] (Fresh_name.to_string_loc fresh__tag) --> expr in new_match :: other_matches, false | `I inh -> handle_variant_inh ~error_source ~typevars ~fresh_atom ~fresh__sexp full_type ~match_last other_matches inh in let other_matches = mk_variant_other_matches ~error_source ~fresh__sexp 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 ~fresh_atom match_structs_inhs , !has_structs_ref ) (* Generate code for handling atomic and structured variants (i.e. not included variant types) *) and handle_variant_tag ~error_source ~typevars loc full_type row_field_list = let fresh_atom = Fresh_name.create "atom" ~loc in let fresh_sexp = Fresh_name.create "sexp" ~loc in let fresh__sexp = Fresh_name.create "_sexp" ~loc in let fresh_sexp_args = Fresh_name.create "sexp_args" ~loc in 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 ~error_source ~typevars ~fresh_atom ~fresh__sexp ~fresh_sexp_args loc full_type rev_structs_inhs rev_atoms in let maybe_sexp_args_patt = if has_structs then Fresh_name.pattern fresh_sexp_args else [%pat? _] in [ ppat_alias ~loc [%pat? Sexplib0.Sexp.Atom [%p Fresh_name.pattern fresh_atom]] (Fresh_name.to_string_loc fresh__sexp) --> mk_variant_match_atom ~error_source ~typevars ~fresh_atom ~fresh__sexp loc full_type rev_atoms_inhs rev_structs ; ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%p Fresh_name.pattern fresh_atom] :: [%p maybe_sexp_args_patt])] (Fresh_name.to_string_loc fresh__sexp) --> match_struct ; ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _)] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ; ppat_alias ~loc [%pat? Sexplib0.Sexp.List []] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ] (* Generate matching code for variants *) and variant_of_sexp ~error_source ~typevars ?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 = let fresh_sexp = Fresh_name.create ~loc "sexp" in match row_fields with | { prf_desc = Rinherit inh; _ } :: rest -> let rec loop inh row_fields = let call = [%expr ([%e Conversion.to_expression ~loc (type_of_sexp ~error_source ~typevars ~internal:true inh)] [%e Fresh_name.expression fresh_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 ~error_source ~typevars loc full_type row_fields in pexp_match ~loc (Fresh_name.expression fresh_sexp) rftag_matches in pexp_try ~loc call (handle_no_variant_match loc expr) in [ Fresh_name.pattern fresh_sexp --> loop inh rest ] | _ :: _ -> handle_variant_tag ~error_source ~typevars loc full_type row_fields | [] -> Location.raise_errorf ~loc "of_sexp is not supported for empty polymorphic variants (impossible?)" in if is_contained then ( let fresh_sexp = Fresh_name.create "sexp" ~loc in Conversion.of_lambda [ Fresh_name.pattern fresh_sexp --> [%expr try [%e pexp_match ~loc (Fresh_name.expression fresh_sexp) top_match] with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ]) else Conversion.of_lambda top_match and poly_of_sexp ~error_source ~typevars parms tp = let loc = tp.ptyp_loc in let typevars = List.fold parms ~init:typevars ~f:(fun map parm -> Map.set map ~key:parm.txt ~data:(Fresh_name.create ("_of_" ^ parm.txt) ~loc:parm.loc)) in let bindings = let mk_binding parm = let fresh = Map.find_exn typevars parm.txt in let fresh_sexp = Fresh_name.create "sexp" ~loc in value_binding ~loc ~pat:(Fresh_name.pattern fresh) ~expr: [%expr fun [%p Fresh_name.pattern fresh_sexp] -> Sexplib0.Sexp_conv_error.record_poly_field_value [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] in List.map ~f:mk_binding parms in Conversion.bind (type_of_sexp ~error_source ~typevars tp) bindings ;; type record_poly_type = { type_and_field_name : Fresh_name.t ; params : string loc list ; body : core_type } let record_poly_type field = match field.pld_type.ptyp_desc with | Ptyp_poly (params, body) -> let type_and_field_name = Fresh_name.of_string_loc field.pld_name in Some { type_and_field_name; params; body } | _ -> None ;; let record_field_conv field ~poly ~loc ~error_source ~typevars = match poly with | None -> type_of_sexp ~error_source ~typevars field.pld_type |> Conversion.to_expression ~loc | Some { type_and_field_name; params; body } -> let fresh_sexp = Fresh_name.create "sexp" ~loc in let fresh_params = List.map params ~f:(fun { loc; txt } -> Fresh_name.create ~loc ("_" ^ txt)) in let pat = Fresh_name.pattern fresh_sexp in let body = let label = Located.map_lident (Fresh_name.to_string_loc type_and_field_name) in let typevars = List.fold2_exn params fresh_params ~init:typevars ~f:(fun typevars param fresh -> Map.set typevars ~key:param.txt ~data:fresh) in let expr = pexp_let ~loc Nonrecursive (List.map fresh_params ~f:(fun fresh -> let { loc; txt } = Fresh_name.to_string_loc fresh in let expr = [%expr Sexplib0.Sexp_conv_error.record_poly_field_value [%e error_source ()]] in value_binding ~loc ~pat:(pvar ~loc txt) ~expr)) (Conversion.apply (type_of_sexp ~error_source ~typevars body) ~loc (Fresh_name.expression fresh_sexp)) in pexp_record ~loc [ label, expr ] None in eabstract ~loc [ pat ] body ;; let fields_arg_for_record_of_sexp poly_fields ~loc ~error_source ~typevars = List.fold_right poly_fields ~init:(Lifted.return [%expr Empty]) ~f:(fun (poly, field) rest_lifted -> rest_lifted >>= fun rest_expr -> let label_expr = estring ~loc:field.pld_name.loc field.pld_name.txt in match Record_field_attrs.Of_sexp.create ~loc field with | Specific Required -> Lifted.return [%expr Field { name = [%e label_expr] ; kind = Required ; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars] ; rest = [%e rest_expr] }] | Specific (Default lifted) -> lifted >>| fun default -> [%expr Field { name = [%e label_expr] ; kind = Default (fun () -> [%e default]) ; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars] ; rest = [%e rest_expr] }] | Omit_nil -> Lifted.return [%expr Field { name = [%e label_expr] ; kind = Omit_nil ; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars] ; rest = [%e rest_expr] }] | Sexp_bool -> Lifted.return [%expr Field { name = [%e label_expr] ; kind = Sexp_bool ; conv = () ; rest = [%e rest_expr] }] | Sexp_array core_type -> let conv_expr = type_of_sexp ~error_source ~typevars core_type |> Conversion.to_expression ~loc in Lifted.return [%expr Field { name = [%e label_expr] ; kind = Sexp_array ; conv = [%e conv_expr] ; rest = [%e rest_expr] }] | Sexp_list core_type -> let conv_expr = type_of_sexp ~error_source ~typevars core_type |> Conversion.to_expression ~loc in Lifted.return [%expr Field { name = [%e label_expr] ; kind = Sexp_list ; conv = [%e conv_expr] ; rest = [%e rest_expr] }] | Sexp_option core_type -> let conv_expr = type_of_sexp ~error_source ~typevars core_type |> Conversion.to_expression ~loc in Lifted.return [%expr Field { name = [%e label_expr] ; kind = Sexp_option ; conv = [%e conv_expr] ; rest = [%e rest_expr] }]) ;; let index_of_field_arg_for_record_of_sexp fields ~loc = let field_cases = List.mapi fields ~f:(fun i (_, field) -> let lhs = pstring ~loc:field.pld_name.loc field.pld_name.txt in let rhs = eint ~loc i in case ~lhs ~guard:None ~rhs) in let default_case = case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(eint ~loc (-1)) in let cases = List.concat [ field_cases; [ default_case ] ] in pexp_function ~loc cases ;; let create_arg_for_record_of_sexp td fields ~loc ~constructor = let pat = List.fold_right fields ~init:[%pat? ()] ~f:(fun (poly, field) tail -> let head = let pat = pvar ~loc:field.pld_name.loc field.pld_name.txt in match poly with | None -> pat | Some { type_and_field_name; _ } -> (* Extract a polymorphic value from a polymorphic record defined explicitly for this purpose. *) let label = Located.map_lident (Fresh_name.to_string_loc type_and_field_name) in ppat_record ~loc [ label, pat ] Closed in ppat_tuple ~loc [ head; tail ]) in let body = let record_expr = pexp_record ~loc (List.map fields ~f:(fun (_, field) -> let label = Located.map_lident field.pld_name in let expr = evar ~loc:field.pld_name.loc field.pld_name.txt in label, expr)) None in match constructor with | None -> record_expr | Some label -> (* variant constructor with inline record *) pexp_construct ~loc label (Some record_expr) in let core_type = ptyp_constr ~loc (Located.map_lident td.ptype_name) (List.map td.ptype_params ~f:(fun (core_type, _) -> ptyp_any ~loc:core_type.ptyp_loc)) in eabstract ~loc [ pat ] (pexp_constraint ~loc body core_type) ;; let polymorphic_record_types_for_record_of_sexp fields ~loc = (* Define fresh types to contain polymorphic values parsed from sexps. *) List.filter_map fields ~f:(fun (poly, _) -> match poly with | Some { type_and_field_name; params; body } -> let fresh_field = label_declaration ~loc ~name:(Fresh_name.to_string_loc type_and_field_name) ~mutable_:Immutable ~type_:(strip_attributes#core_type (ptyp_poly ~loc params body)) in let type_decl = type_declaration ~loc ~name:(Fresh_name.to_string_loc type_and_field_name) ~params:[] ~cstrs:[] ~kind:(Ptype_record [ fresh_field ]) ~private_:Public ~manifest:None in Some { type_decl with ptype_attributes = (* define unboxed types to avoid allocation *) [ { attr_loc = loc ; attr_name = { loc; txt = "unboxed" } ; attr_payload = PStr [] } ] } | None -> None) ;; let args_for_record_of_sexp td fields ~loc ~error_source ~typevars ~constructor ~allow_extra_fields = let caller_expr = error_source () in let allow_extra_fields_expr = ebool ~loc allow_extra_fields in let fields = List.map fields ~f:(fun field -> record_poly_type field, field) in let index_of_field_expr = index_of_field_arg_for_record_of_sexp fields ~loc in let create_expr = create_arg_for_record_of_sexp td fields ~loc ~constructor in let fields_expr_lifted = fields_arg_for_record_of_sexp fields ~loc ~error_source ~typevars in fields_expr_lifted >>| fun fields_expr -> let types = polymorphic_record_types_for_record_of_sexp fields ~loc in let args = [ Labelled "caller", caller_expr ; Labelled "fields", fields_expr ; Labelled "index_of_field", index_of_field_expr ; Labelled "allow_extra_fields", allow_extra_fields_expr ; Labelled "create", create_expr ] in types, args ;; (* Generate matching code for records *) let record_of_sexp ~error_source ~typevars ~allow_extra_fields td (loc, flds) = args_for_record_of_sexp td flds ~loc ~error_source ~typevars ~constructor:None ~allow_extra_fields >>| fun (types, args) -> let conv = pexp_apply ~loc [%expr Sexplib0.Sexp_conv_record.record_of_sexp] args |> Conversion.of_reference_exn in Conversion.bind_types conv types ;; (* Sum type conversions *) (* Generate matching code for well-formed S-expressions wrt. sum types *) let mk_good_sum_matches ~error_source ~typevars td (_, cds) = List.map cds ~f:(fun cd -> let loc = cd.pcd_loc in match cd with | { pcd_name = constructor; pcd_args = Pcstr_record fields; _ } -> let allow_extra_fields = Option.is_some (Attribute.get Attrs.allow_extra_fields_cd cd) in args_for_record_of_sexp td fields ~loc ~error_source ~typevars ~constructor:(Some (Located.map_lident constructor)) ~allow_extra_fields >>| fun (types, args) -> let string_pat = let loc = constructor.loc in ppat_or ~loc (pstring ~loc (String.uncapitalize constructor.txt)) (pstring ~loc constructor.txt) in let fresh_sexp = Fresh_name.create "sexp" ~loc in let fresh_sexps = Fresh_name.create "sexps" ~loc in ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%p string_pat] :: [%p Fresh_name.pattern fresh_sexps])] (Fresh_name.to_string_loc fresh_sexp) --> (pexp_apply ~loc [%expr Sexplib0.Sexp_conv_record.record_of_sexps] (List.concat [ [ Labelled "context", Fresh_name.expression fresh_sexp ] ; args ; [ Nolabel, Fresh_name.expression fresh_sexps ] ]) |> with_types ~loc ~types) | { 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? Sexplib0.Sexp.Atom ([%p lcstr] | [%p str])] --> pexp_construct ~loc (Located.lident ~loc cnstr.txt) None |> Lifted.return | { 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 let fresh__sexp = Fresh_name.create "_sexp" ~loc in let fresh__tag = Fresh_name.create "_tag" ~loc in let fresh_sexp_args = Fresh_name.create "sexp_args" ~loc in ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%p ppat_alias ~loc [%pat? [%p lcstr] | [%p str]] (Fresh_name.to_string_loc fresh__tag)] :: [%p Fresh_name.pattern fresh_sexp_args])] (Fresh_name.to_string_loc fresh__sexp) --> mk_cnstr_args_match ~error_source ~typevars ~loc ~is_variant:false ~fresh__sexp ~fresh__tag ~fresh_sexp_args cnstr.txt tps (Constructor cd) |> Lifted.return) ;; (* Generate matching code for malformed S-expressions with good tags wrt. sum types *) let mk_bad_sum_matches ~error_source (loc, cds) = let fresh_sexp = Fresh_name.create "sexp" ~loc in 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 ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ([%p lcstr] | [%p str]) :: _)] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.stag_no_args [%e error_source ()] [%e Fresh_name.expression fresh_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 ppat_alias ~loc [%pat? Sexplib0.Sexp.Atom ([%p lcstr] | [%p str])] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.stag_takes_args [%e error_source ()] [%e Fresh_name.expression fresh_sexp]]) ;; (* Generate matching code for sum types *) let sum_of_sexp ~error_source ~typevars td (loc, alts) = let fresh_sexp = Fresh_name.create "sexp" ~loc in [ mk_good_sum_matches ~error_source ~typevars td (loc, alts) |> Lifted.all ; mk_bad_sum_matches ~error_source (loc, alts) |> Lifted.return ; [ ppat_alias ~loc [%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _)] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.nested_list_invalid_sum [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ; ppat_alias ~loc [%pat? Sexplib0.Sexp.List []] (Fresh_name.to_string_loc fresh_sexp) --> [%expr Sexplib0.Sexp_conv_error.empty_list_invalid_sum [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ; Fresh_name.pattern fresh_sexp --> [%expr Sexplib0.Sexp_conv_error.unexpected_stag [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ] |> Lifted.return ] |> Lifted.all >>| List.concat >>| Conversion.of_lambda ;; (* Empty type *) let nil_of_sexp ~error_source loc : Conversion.t = Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv_error.empty_type [%e error_source ()]] ;; (* Generate code from type definitions *) let td_of_sexp ~typevars ~loc:_ ~poly ~path ~rec_flag ~values_being_defined td = 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 ~error_source = let body = match td.ptype_kind with | Ptype_variant alts -> Attrs.fail_if_allow_extra_field_td ~loc td; sum_of_sexp ~error_source ~typevars td (td.ptype_loc, alts) | Ptype_record lbls -> record_of_sexp ~error_source ~typevars ~allow_extra_fields: (Option.is_some (Attribute.get Attrs.allow_extra_fields_td 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 ~error_source td.ptype_loc |> Lifted.return | Some ty -> type_of_sexp ~error_source ~full_type ~typevars ~internal:create_internal_function ty |> Lifted.return) in (* Prevent violation of value restriction, problems with recursive types, and toplevel effects by eta-expanding function definitions *) body >>| Conversion.to_value_expression ~loc ~rec_flag ~values_being_defined 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 = Map.find_exn typevars tp.txt in Fresh_name.pattern name, Fresh_name.expression name) tps) in let full_type_name = Printf.sprintf "%s.%s" path type_name in let internal_fun_body = if create_internal_function then Some (with_error_source ~loc ~full_type_name (fun ~error_source -> body ~error_source >>| fun body -> eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body))) else None in let external_fun_body = let body_below_lambdas ~error_source = let fresh_sexp = Fresh_name.create "sexp" ~loc in if create_internal_function then ( let no_variant_match_mc = [ [%pat? Sexplib0.Sexp_conv_error.No_variant_match] --> [%expr Sexplib0.Sexp_conv_error.no_matching_variant_found [%e error_source ()] [%e Fresh_name.expression fresh_sexp]] ] in let internal_call = let internal_expr = pexp_ident ~loc { loc; txt = Lident internal_name } in eapply ~loc internal_expr (arg_exprs @ [ Fresh_name.expression fresh_sexp ]) in let try_with = pexp_try ~loc internal_call no_variant_match_mc in [%expr fun [%p Fresh_name.pattern fresh_sexp] -> [%e try_with]] |> Lifted.return) else body ~error_source in let body_with_lambdas ~error_source = body_below_lambdas ~error_source >>| fun body -> eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body) in with_error_source ~loc ~full_type_name 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 tds = List.map ~f:name_type_params_in_td tds in let typevars td = List.fold td.ptype_params ~init:(Map.empty (module String)) ~f:(fun map param -> let name = get_type_param_name param in Map.set map ~key:name.txt ~data:(Fresh_name.create ("_of_" ^ name.txt) ~loc:name.loc)) in let singleton = match tds with | [ _ ] -> true | _ -> false in let values_being_defined = List.map tds ~f:(fun td -> td.ptype_name.txt ^ "_of_sexp") |> Set.of_list (module String) in if singleton then ( let rec_flag = really_recursive_respecting_opaque rec_flag tds in match rec_flag with | Recursive -> let bindings = List.concat_map tds ~f:(fun td -> let typevars = typevars td in let internals, externals = td_of_sexp ~typevars ~loc ~poly ~path ~rec_flag ~values_being_defined td in internals @ externals) in pstr_value_list ~loc Recursive bindings | Nonrecursive -> List.concat_map tds ~f:(fun td -> let typevars = typevars td in let internals, externals = td_of_sexp ~typevars ~loc ~poly ~path ~rec_flag ~values_being_defined 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 typevars = typevars td in let internals, externals = td_of_sexp ~typevars ~poly ~loc ~path ~rec_flag ~values_being_defined td in internals @ externals) in pstr_value_list ~loc rec_flag bindings) ;; let core_type_of_sexp ~path core_type = let loc = { core_type.ptyp_loc with loc_ghost = true } in let full_type_name = Printf.sprintf "%s line %i: %s" path loc.loc_start.pos_lnum (string_of_core_type core_type) in with_error_source ~loc ~full_type_name (fun ~error_source -> type_of_sexp ~error_source ~typevars:(Map.empty (module String)) core_type |> Conversion.to_value_expression ~loc ~rec_flag:Nonrecursive ~values_being_defined:(Set.empty (module String)) |> Merlin_helpers.hide_expression |> Lifted.return) ;; end ppx_sexp_conv-0.17.0/expander/expand_of_sexp.mli000066400000000000000000000014201461647336100220150ustar00rootroot00000000000000open! Base open! Ppxlib module Sig_generate_of_sexp : sig (** Given a type, produce the type of its [of_sexp] conversion. *) val type_of_of_sexp : loc:location -> core_type -> core_type (** Derive an [of_sexp] interface for a list of type declarations. *) val mk_sig : poly:bool -> loc:location -> path:string -> rec_flag * type_declaration list -> signature_item list end module Str_generate_of_sexp : sig (** Given a type, produce its [of_sexp] conversion. *) val core_type_of_sexp : path:string -> core_type -> expression (** Derive an [of_sexp] implementation for a list of type declarations. *) val tds_of_sexp : loc:location -> poly:bool -> path:string -> rec_flag * type_declaration list -> structure_item list end ppx_sexp_conv-0.17.0/expander/expand_sexp_of.ml000066400000000000000000000734141461647336100216600ustar00rootroot00000000000000open! Base open! Ppxlib open Ast_builder.Default open Helpers open Lifted.Monad_infix (* 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] -> Sexplib0.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 module Str_generate_sexp_of = struct module Types_being_defined = struct type t = | Nonrec | Rec of Set.M(String).t let to_rec_flag = function | Nonrec -> Nonrecursive | Rec _ -> Recursive ;; let to_values_being_defined = function | Nonrec -> Set.empty (module String) | Rec types -> Set.map (module String) types ~f:(fun s -> "sexp_of_" ^ s) ;; end 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 ~renaming typ : Conversion.t = let loc = { typ.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast typ with | Some (Jtyp_tuple alist, (_ : attributes)) -> Conversion.of_lambda [ sexp_of_labeled_tuple ~renaming ~loc alist ] | Some (Jtyp_layout _, _) | None -> (match typ with | _ when Option.is_some (Attribute.get Attrs.opaque typ) -> Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.sexp_of_opaque] | [%type: _] -> Conversion.of_lambda [ ppat_any ~loc --> [%expr Sexplib0.Sexp.Atom "_"] ] | [%type: [%t? _] sexp_opaque] -> Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.sexp_of_opaque] | { ptyp_desc = Ptyp_tuple tp; _ } -> Conversion.of_lambda [ sexp_of_tuple ~renaming (loc, tp) ] | { ptyp_desc = Ptyp_var parm; _ } -> (match Renaming.binding_kind renaming parm ~loc with | Universally_bound fresh -> Conversion.of_reference_exn (Fresh_name.expression fresh) | Existentially_bound -> sexp_of_type ~renaming [%type: _]) | { ptyp_desc = Ptyp_constr (id, args); _ } -> Conversion.of_reference_exn (sexp_of_type_constr ~loc id (List.map args ~f:(fun tp -> Conversion.to_expression ~loc (sexp_of_type ~renaming tp)))) | { ptyp_desc = Ptyp_arrow (_, _, _); _ } -> Conversion.of_lambda [ ppat_any ~loc --> [%expr Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore] ] | { ptyp_desc = Ptyp_variant (row_fields, Closed, _); _ } -> sexp_of_variant ~renaming (loc, row_fields) | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } -> sexp_of_poly ~renaming parms poly_tp | { ptyp_desc = Ptyp_variant (_, Open, _); _ } | { 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 (unlabeled) tuples *) and sexp_of_tuple ~renaming (loc, tps) = let fps = List.map ~f:(fun tp -> sexp_of_type ~renaming tp) tps in let ({ bindings; arguments; converted } : Conversion.Apply_all.t) = Conversion.apply_all ~loc fps in let in_expr = [%expr Sexplib0.Sexp.List [%e elist ~loc converted]] in let expr = pexp_let ~loc Nonrecursive bindings in_expr in ppat_tuple ~loc arguments --> expr (* Conversion of labeled tuples *) and sexp_of_labeled_tuple ~renaming ~loc alist = assert (Labeled_tuple.is_valid alist); let ({ bindings; arguments; converted } : Conversion.Apply_all.t) = List.map alist ~f:(fun (_, core_type) -> sexp_of_type ~renaming core_type) |> Conversion.apply_all ~loc in let expr = let sexp_exprs = (* Constructor inference allows to to leave off [Sexplib0.Sexp.] here. *) List.map2_exn alist converted ~f:(fun (label_option, _) expr -> [%expr List [ Atom [%e estring ~loc (Labeled_tuple.atom_of_label label_option)] ; [%e expr] ]]) in [%expr Sexplib0.Sexp.List [%e elist ~loc sexp_exprs]] |> pexp_let ~loc Nonrecursive bindings in let pat = ( List.map2_exn alist arguments ~f:(fun (label_option, _) arg -> label_option, arg) , Closed ) |> Ppxlib_jane.Jane_syntax.Labeled_tuples.pat_of ~loc in pat --> expr (* Conversion of variant types *) and sexp_of_variant ~renaming ((loc, row_fields) : Location.t * row_field list) : Conversion.t = let item row = match row.prf_desc with | Rtag ({ txt = cnstr; _ }, true, []) -> ppat_variant ~loc cnstr None --> [%expr Sexplib0.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 = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in let name = Fresh_name.create "l" ~loc in ppat_variant ~loc cnstr (Some (Fresh_name.pattern name)) --> [%expr Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%e estring ~loc cnstr] :: Sexplib0.Sexp_conv.list_map [%e cnv_expr] [%e Fresh_name.expression name])] | _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list") | Rtag ({ txt = cnstr; _ }, _, [ [%type: [%t? tp] sexp_list] ]) -> let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in let name = Fresh_name.create "l" ~loc in ppat_variant ~loc cnstr (Some (Fresh_name.pattern name)) --> [%expr Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%e estring ~loc cnstr] :: Sexplib0.Sexp_conv.list_map [%e cnv_expr] [%e Fresh_name.expression name])] | Rtag ({ txt = cnstr; _ }, false, [ tp ]) -> let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e estring ~loc cnstr]] in let fresh = Fresh_name.create "v" ~loc in let cnstr_arg = Conversion.apply ~loc (sexp_of_type ~renaming tp) (Fresh_name.expression fresh) in let expr = [%expr Sexplib0.Sexp.List [%e elist ~loc [ cnstr_expr; cnstr_arg ]]] in ppat_variant ~loc cnstr (Some (Fresh_name.pattern fresh)) --> expr | Rinherit { ptyp_desc = Ptyp_constr (id, []); _ } -> let name = Fresh_name.create "v" ~loc in ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name) --> sexp_of_type_constr ~loc id [ Fresh_name.expression name ] | Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) -> Location.raise_errorf ~loc "unsupported: polymorphic variant intersection type" | Rinherit ({ ptyp_desc = Ptyp_constr (id, _ :: _); _ } as typ) -> let call = Conversion.to_expression ~loc (sexp_of_type ~renaming typ) in let name = Fresh_name.create "v" ~loc in ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name) --> [%expr [%e call] [%e Fresh_name.expression name]] | Rinherit _ -> Location.raise_errorf ~loc "unsupported: polymorphic variant with invalid (non-identifier) inherited type" | Rtag (_, false, []) -> Location.raise_errorf ~loc "unsupported: polymorphic variant empty type" in Conversion.of_lambda (List.map ~f:item row_fields) (* Polymorphic record fields *) and sexp_of_poly ~renaming parms tp = let loc = tp.ptyp_loc in let renaming = List.fold_left parms ~init:renaming ~f:(Renaming.add_universally_bound ~prefix:"_of_") in let bindings = let mk_binding parm = let name = match Renaming.binding_kind renaming parm.txt ~loc:parm.loc with | Universally_bound name -> name | Existentially_bound -> assert false in value_binding ~loc ~pat:(Fresh_name.pattern name) ~expr:[%expr Sexplib0.Sexp_conv.sexp_of_opaque] in List.map ~f:mk_binding parms in Conversion.bind (sexp_of_type ~renaming tp) bindings ;; (* Conversion of record types *) let mk_rec_patt loc patt name fresh = let p = Loc.make (Longident.Lident name) ~loc, Fresh_name.pattern fresh 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 ~bnds patt expr name tp ?sexp_of is_empty_expr = let loc = tp.ptyp_loc in let fresh = Fresh_name.create name ~loc in let patt = mk_rec_patt loc patt name fresh in let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in let cnv_expr = match sexp_of with | None -> cnv_expr | Some sexp_of -> [%expr [%e sexp_of] [%e cnv_expr]] in let bnd = Fresh_name.create "bnd" ~loc in let arg = Fresh_name.create "arg" ~loc in let expr = [%expr let [%p Fresh_name.pattern bnds] = [%e match is_empty_expr with | Inspect_value is_empty_expr -> [%expr if [%e is_empty_expr loc (Fresh_name.expression fresh)] then [%e Fresh_name.expression bnds] else ( let [%p Fresh_name.pattern arg] = [%e cnv_expr] [%e Fresh_name.expression fresh] in let [%p Fresh_name.pattern bnd] = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ; [%e Fresh_name.expression arg] ] in ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t))] | Inspect_sexp is_empty_expr -> [%expr let [%p Fresh_name.pattern arg] = [%e cnv_expr] [%e Fresh_name.expression fresh] in if [%e is_empty_expr ~cnv_expr loc (Fresh_name.expression arg)] then [%e Fresh_name.expression bnds] else ( let [%p Fresh_name.pattern bnd] = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ; [%e Fresh_name.expression arg] ] in ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t))]] in [%e expr]] in patt, expr ;; let disallow_type_variables_and_recursive_occurrences ~types_being_defined ~loc ~attr_name 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 "[@%s] was used, but the type of the field contains a type variable: '%s.\n\ Comparison is not avaiable for type variables.\n\ Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead." attr_name v | t -> super#core_type_desc t end in iter#core_type in let disallow_recursive_occurrences = match (types_being_defined : Types_being_defined.t) with | Nonrec -> fun _ -> () | Rec 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 "[@%s] was used, but the type of the field contains a type defined \ in the current recursive block: %s.\n\ This is not supported.\n\ Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] \ instead." attr_name 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 ~bnds patt expr name tp ?sexp_of default = let is_empty = let inspect_value equality_f = Inspect_value (fun loc expr -> [%expr [%e equality_f loc] [%e default] [%e expr]]) in match (how : Record_field_attrs.Sexp_of.Drop.t) with | Sexp -> Inspect_sexp (fun ~cnv_expr loc sexp_expr -> [%expr Sexplib0.Sexp_conv.( = ) ([%e cnv_expr] [%e default]) [%e sexp_expr]]) |> Lifted.return | No_arg -> inspect_value (fun loc -> [%expr Sexplib0.Sexp_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"]]) |> Lifted.return | Func lifted -> lifted >>| fun f -> inspect_value (fun _ -> f) | Compare -> inspect_value (fun loc -> disallow_type_variables_and_recursive_occurrences ~types_being_defined ~attr_name:"sexp_drop_default.compare" ~loc tp; [%expr [%compare.equal: [%t tp]]]) |> Lifted.return | Equal -> inspect_value (fun loc -> disallow_type_variables_and_recursive_occurrences ~types_being_defined ~attr_name:"sexp_drop_default.equal" ~loc tp; [%expr [%equal: [%t tp]]]) |> Lifted.return in is_empty >>| sexp_of_record_field ~renaming ~bnds patt expr name tp ?sexp_of ;; let sexp_of_label_declaration_list ~types_being_defined ~renaming loc flds ~wrap_expr = let bnds = Fresh_name.create "bnds" ~loc in 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 lifted ld = lifted >>= fun ((patt : (Longident.t loc * pattern) list), expr) -> let name = ld.pld_name.txt in let loc = ld.pld_name.loc in let fresh = Fresh_name.create name ~loc in match Record_field_attrs.Sexp_of.create ~loc ld with | Sexp_option tp -> let v = Fresh_name.create "v" ~loc in let bnd = Fresh_name.create "bnd" ~loc in let arg = Fresh_name.create "arg" ~loc in let patt = mk_rec_patt loc patt name fresh in let vname = Fresh_name.expression v in let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in let expr = [%expr let [%p Fresh_name.pattern bnds] = match [%e Fresh_name.expression fresh] with | Stdlib.Option.None -> [%e Fresh_name.expression bnds] | Stdlib.Option.Some [%p Fresh_name.pattern v] -> let [%p Fresh_name.pattern arg] = [%e cnv_expr] in let [%p Fresh_name.pattern bnd] = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ; [%e Fresh_name.expression arg] ] in ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t) in [%e expr]] in Lifted.return (patt, expr) | Sexp_bool -> let patt = mk_rec_patt loc patt name fresh in let bnd = Fresh_name.create "bnd" ~loc in let expr = [%expr let [%p Fresh_name.pattern bnds] = if [%e Fresh_name.expression fresh] then ( let [%p Fresh_name.pattern bnd] = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ] in ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t)) else [%e Fresh_name.expression bnds] in [%e expr]] in Lifted.return (patt, expr) | Sexp_list tp -> sexp_of_record_field ~renaming ~bnds patt expr name tp ~sexp_of: (* deliberately using whatever [sexp_of_list] is in scope *) [%expr sexp_of_list] list_empty_expr |> Lifted.return | Sexp_array tp -> sexp_of_record_field ~renaming ~bnds patt expr name tp ~sexp_of: (* deliberately using whatever [sexp_of_array] is in scope *) [%expr sexp_of_array] array_empty_expr |> Lifted.return | Specific (Drop_default how) -> let tp = ld.pld_type in (match Attribute.get Attrs.default ld with | None -> Location.raise_errorf ~loc "no default to drop" | Some { to_lift = default } -> Record_field_attrs.lift_default ~loc ld default >>= sexp_of_default_field ~types_being_defined how ~renaming ~bnds patt expr name tp) | Specific (Drop_if test) -> test >>| fun test -> let tp = ld.pld_type in sexp_of_record_field ~renaming ~bnds patt expr name tp (Inspect_value (fun loc expr -> [%expr [%e test] [%e expr]])) | Omit_nil -> let tp = ld.pld_type in let patt = mk_rec_patt loc patt name fresh in let vname = Fresh_name.expression fresh in let arg = Fresh_name.create "arg" ~loc in let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in let bnds_expr = [%expr match [%e cnv_expr] with | Sexplib0.Sexp.List [] -> [%e Fresh_name.expression bnds] | [%p Fresh_name.pattern arg] -> (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ; [%e Fresh_name.expression arg] ] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t)] in ( patt , [%expr let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in [%e expr]] ) |> Lifted.return | Specific Keep -> let tp = ld.pld_type in let patt = mk_rec_patt loc patt name fresh in let vname = Fresh_name.expression fresh in let arg = Fresh_name.create "arg" ~loc in let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in let bnds_expr = [%expr let [%p Fresh_name.pattern arg] = [%e cnv_expr] in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ; [%e Fresh_name.expression arg] ] :: [%e Fresh_name.expression bnds] : _ Stdlib.List.t)] in ( patt , [%expr let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in [%e expr]] ) |> Lifted.return in let init_expr = wrap_expr (Fresh_name.expression bnds) in List.fold_left ~f:coll ~init:(Lifted.return ([], init_expr)) flds >>| fun (patt, expr) -> ( ppat_record ~loc patt Closed , [%expr let [%p Fresh_name.pattern bnds] = ([] : _ Stdlib.List.t) 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 Sexplib0.Sexp.Atom [%e constr_str]] in sexp_of_label_declaration_list ~types_being_defined ~renaming loc lds ~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List ([%e cnstr_expr] :: [%e expr])]) >>| fun (patt, expr) -> ppat_construct ~loc constr_lid (Some patt) --> expr | Pcstr_tuple pcd_args -> (match pcd_args with | [] -> ppat_construct ~loc constr_lid None --> [%expr Sexplib0.Sexp.Atom [%e constr_str]] |> Lifted.return | args -> (match args with | [ tp ] when Option.is_some (Attribute.get inline_attr row) -> (match tp with | [%type: [%t? tp] list] -> let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in let name = Fresh_name.create "l" ~loc in ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name)) --> [%expr Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%e constr_str] :: Sexplib0.Sexp_conv.list_map [%e cnv_expr] [%e Fresh_name.expression name])] | _ -> Attrs.invalid_attribute ~loc inline_attr "_ list") | [ [%type: [%t? tp] sexp_list] ] -> let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in let name = Fresh_name.create "l" ~loc in ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name)) --> [%expr Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%e constr_str] :: Sexplib0.Sexp_conv.list_map [%e cnv_expr] [%e Fresh_name.expression name])] | _ -> let sexp_of_args = List.map ~f:(sexp_of_type ~renaming) args in let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e constr_str]] in let ({ bindings; arguments; converted } : Conversion.Apply_all.t) = Conversion.apply_all ~loc sexp_of_args in let patt = match arguments with | [ arg ] -> arg | _ -> ppat_tuple ~loc arguments in ppat_construct ~loc constr_lid (Some patt) --> pexp_let ~loc Nonrecursive bindings [%expr Sexplib0.Sexp.List [%e elist ~loc (cnstr_expr :: converted)]]) |> Lifted.return) ;; let sexp_of_sum ~types_being_defined ~renaming tps cds = List.map cds ~f:(fun cd -> let renaming = Renaming.with_constructor_declaration renaming ~type_parameters: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) |> Lifted.all >>| Conversion.of_lambda ;; (* Empty type *) let sexp_of_nil loc = Conversion.of_lambda [ ppat_any ~loc --> [%expr 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 renaming = Renaming.of_type_declaration td ~prefix:"_of_" in let body = let body = match td.ptype_kind with | Ptype_variant cds -> sexp_of_sum ~renaming ~types_being_defined (List.map tps ~f:(fun x -> x.txt)) cds | Ptype_record lds -> sexp_of_label_declaration_list ~renaming loc lds ~types_being_defined ~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List [%e expr]]) >>| fun (patt, expr) -> Conversion.of_lambda [ 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 ~renaming ty) |> Lifted.return in body >>| fun body -> 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 v = Fresh_name.create "v" ~loc in let coercion = [%expr ([%e Fresh_name.expression v] : [%t ty_src] :> [%t ty_dst])] in [%expr fun [%p Fresh_name.pattern v] -> [%e Conversion.apply ~loc body coercion]]) else (* Prevent violation of value restriction, problems with recursive types, and top-level effects by eta-expanding function definitions *) Conversion.to_value_expression ~loc ~rec_flag:(Types_being_defined.to_rec_flag types_being_defined) ~values_being_defined: (Types_being_defined.to_values_being_defined types_being_defined) body in let typ = Sig_generate_sexp_of.mk_type td in let func_name = "sexp_of_" ^ type_name in let body = body >>| fun body -> let patts = List.map tps ~f:(fun id -> match Renaming.binding_kind renaming id.txt ~loc:id.loc with | Universally_bound name -> Fresh_name.pattern name | Existentially_bound -> assert false) in let rec_flag = Types_being_defined.to_rec_flag types_being_defined in eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts body) in let body = Lifted.let_bind_user_expressions ~loc 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_respecting_opaque rec_flag tds in let (types_being_defined : Types_being_defined.t) = match rec_flag with | Nonrecursive -> Nonrec | Recursive -> Rec (Set.of_list (module String) (List.map tds ~f:(fun td -> td.ptype_name.txt))) in let bindings = List.map tds ~f:(sexp_of_td ~types_being_defined) in pstr_value_list ~loc rec_flag bindings ;; let sexp_of_exn ~loc:_ ~path ec = let renaming = Renaming.without_type () 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 branch_sum ec Attrs.list_exception ~types_being_defined:Nonrec renaming ~loc constr_lid (estring ~loc (get_full_cnstr cnstr.txt)) extension_constructor_kind >>| fun converter -> let assert_false = ppat_any ~loc --> [%expr assert false] in [%expr Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor [%e pexp_construct ~loc constr_lid None]] [%e Conversion.to_expression ~loc (Conversion.of_lambda [ 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 let expr = Lifted.let_bind_user_expressions ~loc expr in [ pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:[%pat? ()] ~expr ] ] ;; let sexp_of_core_type core_type = let loc = { core_type.ptyp_loc with loc_ghost = true } in sexp_of_type ~renaming:(Renaming.without_type ()) core_type |> Conversion.to_value_expression ~loc ~rec_flag:Nonrecursive ~values_being_defined:(Set.empty (module String)) |> Merlin_helpers.hide_expression ;; end ppx_sexp_conv-0.17.0/expander/expand_sexp_of.mli000066400000000000000000000020351461647336100220200ustar00rootroot00000000000000open! Base open! Ppxlib module Sig_generate_sexp_of : sig (** Given a type, produce the type of its [sexp_of] conversion. *) val type_of_sexp_of : loc:location -> core_type -> core_type (** Derive a [sexp_of] interface for a list of type declarations. *) val mk_sig : loc:location -> path:string -> rec_flag * type_declaration list -> signature_item list (** Derive a [sexp_of] interface for an exception declaration. *) val mk_sig_exn : loc:location -> path:string -> type_exception -> signature_item list end module Str_generate_sexp_of : sig (** Given a type, produce its [sexp_of] conversion. *) val sexp_of_core_type : core_type -> expression (** Derive a [sexp_of] implementation for a list of type declarations. *) val sexp_of_tds : loc:location -> path:string -> rec_flag * type_declaration list -> structure_item list (** Derive a [sexp_of] implementation for an exception declaration. *) val sexp_of_exn : loc:location -> path:string -> type_exception -> structure_item list end ppx_sexp_conv-0.17.0/expander/fresh_name.ml000066400000000000000000000006421461647336100207560ustar00rootroot00000000000000open! Base open Ppxlib open Ast_builder.Default type t = { loc : location ; unique_name : string } let create string ~loc = { loc; unique_name = gen_symbol ~prefix:string () } let of_string_loc { loc; txt } = create txt ~loc let to_string_loc { loc; unique_name } = { loc; txt = unique_name } let expression { loc; unique_name } = evar unique_name ~loc let pattern { loc; unique_name } = pvar unique_name ~loc ppx_sexp_conv-0.17.0/expander/fresh_name.mli000066400000000000000000000011121461647336100211200ustar00rootroot00000000000000(** Represents freshly generated names at ppx expansion time. *) open! Base open Ppxlib type t (** Creates a new fresh name using the given string as a prefix. *) val create : string -> loc:location -> t (** [of_string_loc { loc; txt }] is equivalent to [create txt ~loc] *) val of_string_loc : string loc -> t (** Extracts the freshly created name and its location. *) val to_string_loc : t -> string loc (** Constructs an expression referring to the fresh name. *) val expression : t -> expression (** Constructs a pattern binding the fresh name. *) val pattern : t -> pattern ppx_sexp_conv-0.17.0/expander/helpers.ml000066400000000000000000000155061461647336100203160ustar00rootroot00000000000000open! Base open! Ppxlib open Ast_builder.Default let ( --> ) lhs rhs = case ~guard:None ~lhs ~rhs (* 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 make_rigid_types tps = List.fold tps ~init:(Map.empty (module String)) ~f:(fun map tp -> Map.update map tp.txt ~f:(function | None -> Fresh_name.of_string_loc tp | Some fresh -> (* Ignore duplicate names, the typechecker will raise after expansion. *) fresh)) ;; let find_rigid_type ~loc ~rigid_types name = match Map.find rigid_types name with | Some tp -> Fresh_name.to_string_loc tp | None -> (* Ignore unbound type names, the typechecker will raise after expansion. *) { txt = name; loc } ;; let make_type_rigid ~rigid_types = 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.map_lident (find_rigid_type ~loc:ty.ptyp_loc ~rigid_types s), []) | desc -> super#core_type_desc desc in { ty with ptyp_desc } end in map#core_type ;; (* Generates the quantified type [ ! 'a .. 'z . (make_mono_type t ('a .. 'z)) ] or [type a .. z. make_mono_type t (a .. z)] when [use_rigid_variables] is true. Annotation are needed for non regular recursive datatypes and gadt when the return type of constructors are constrained. Unfortunately, putting rigid variables everywhere does not work because of certains types with constraints. We thus only use rigid variables for sum types, which includes all GADTs. *) let tvars_of_core_type : core_type -> string list = let tvars = object inherit [string list] Ast_traverse.fold as super method! core_type x acc = match x.ptyp_desc with | Ptyp_var x -> if List.mem acc x ~equal:String.equal then acc else x :: acc | _ -> super#core_type x acc end in fun typ -> List.rev (tvars#core_type typ []) ;; let constrained_function_binding (* placing a suitably polymorphic or rigid type constraint on the pattern or body *) (loc : Location.t) (td : type_declaration) (typ : core_type) ~(tps : string loc list) ~(func_name : string) (body : expression) = let vars = tvars_of_core_type typ in let has_vars = match vars with | [] -> false | _ :: _ -> true in let pat = let pat = pvar ~loc func_name in if not has_vars then pat else ( let vars = List.map ~f:(fun txt -> { txt; loc }) vars in ppat_constraint ~loc pat (ptyp_poly ~loc vars typ)) in let body = let use_rigid_variables = match td.ptype_kind with | Ptype_variant _ -> true | _ -> false in if use_rigid_variables then ( let rigid_types = make_rigid_types tps in List.fold_right tps ~f:(fun tp body -> pexp_newtype ~loc (find_rigid_type ~loc:tp.loc ~rigid_types tp.txt) body) ~init:(pexp_constraint ~loc body (make_type_rigid ~rigid_types typ))) else if has_vars then body else pexp_constraint ~loc body typ in value_binding ~loc ~pat ~expr:body ;; let with_let ~loc ~binds body = List.fold_right binds ~init:body ~f:(fun bind body -> if List.is_empty bind then body else pexp_let ~loc Nonrecursive bind body) ;; let with_types ~loc ~types body = if List.is_empty types then body else pexp_open ~loc (open_infos ~loc ~override:Fresh ~expr: (pmod_structure ~loc (List.map types ~f:(fun type_decl -> pstr_type ~loc Recursive [ type_decl ])))) body ;; let fresh_lambda ~loc apply = let var = gen_symbol ~prefix:"x" () in let pat = pvar ~loc var in let arg = evar ~loc var in let body = apply ~arg in pexp_fun ~loc Nolabel None pat body ;; let rec is_value_expression expr = match expr.pexp_desc with (* Syntactic values. *) | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_fun _ | Pexp_lazy _ -> true (* Type-only wrappers; we check their contents. *) | Pexp_constraint (expr, (_ : core_type)) | Pexp_coerce (expr, (_ : core_type option), (_ : core_type)) | Pexp_newtype ((_ : string loc), expr) -> is_value_expression expr (* Allocating constructors; they are only values if all of their contents are. *) | Pexp_tuple exprs -> List.for_all exprs ~f:is_value_expression | Pexp_construct (_, maybe_expr) -> Option.for_all maybe_expr ~f:is_value_expression | Pexp_variant (_, maybe_expr) -> Option.for_all maybe_expr ~f:is_value_expression | Pexp_record (fields, maybe_expr) -> List.for_all fields ~f:(fun (_, expr) -> is_value_expression expr) && Option.for_all maybe_expr ~f:is_value_expression (* Not values, or not always values. We make a conservative approximation. *) | Pexp_unreachable | Pexp_let _ | Pexp_apply _ | Pexp_match _ | Pexp_try _ | Pexp_field _ | Pexp_setfield _ | Pexp_array _ | Pexp_ifthenelse _ | Pexp_sequence _ | Pexp_while _ | Pexp_for _ | Pexp_send _ | Pexp_new _ | Pexp_setinstvar _ | Pexp_override _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_assert _ | Pexp_poly _ | Pexp_object _ | Pexp_pack _ | Pexp_open _ | Pexp_letop _ | Pexp_extension _ -> false ;; let really_recursive_respecting_opaque 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 () ;; let strip_attributes = object inherit Ast_traverse.map method! attribute attr = Location.raise_errorf ~loc:attr.attr_loc "failed to strip attribute from syntax" method! attributes _ = [] method! signature items = List.filter items ~f:(fun item -> match item.psig_desc with | Psig_attribute _ -> false | _ -> true) method! structure items = List.filter items ~f:(fun item -> match item.pstr_desc with | Pstr_attribute _ -> false | _ -> true) method! class_signature csig = { csig with pcsig_fields = List.filter csig.pcsig_fields ~f:(fun field -> match field.pctf_desc with | Pctf_attribute _ -> false | _ -> true) } method! class_structure cstr = { cstr with pcstr_fields = List.filter cstr.pcstr_fields ~f:(fun field -> match field.pcf_desc with | Pcf_attribute _ -> false | _ -> true) } end ;; ppx_sexp_conv-0.17.0/expander/helpers.mli000066400000000000000000000037141461647336100204650ustar00rootroot00000000000000open! Base open! Ppxlib (** Constructs a branch of a [match] or [function] expression with no guard. *) val ( --> ) : pattern -> expression -> case (** Replace all type variables like ['a] with wildcard ([_]) types. *) val replace_variables_by_underscores : core_type -> core_type (** Create a binding for a derived function, adding a type annotation if required. *) val constrained_function_binding : location (** location to use for the binding *) -> type_declaration (** type declaration used to derive the function *) -> core_type (** type of the function *) -> tps:string loc list (** names of type parameters in the declaration *) -> func_name:string (** name to bind the function to *) -> expression (** expression representing the function *) -> value_binding (** Wraps an expression in layers of non-recursive [let] bindings, with the bindings sorted from outermost to innermost. *) val with_let : loc:location -> binds:value_binding list list -> expression -> expression (** Wraps an expression in [let open] containing type declarations, if non-empty. *) val with_types : loc:location -> types:type_declaration list -> expression -> expression (** Constructs a lambda of a fresh variable. Passes a reference to that variable as [arg] to construct the lambda's body. *) val fresh_lambda : loc:location -> (arg:expression -> expression) -> expression (** Conservative approximation of which expressions are syntactically values, i.e. constants, variables, or lambdas. When [true], these expressions have no effects (other than possibly closure allocation) and can be used in [let rec] definitions. When [false], they may need to be eta-expanded or wrapped in [lazy]. *) val is_value_expression : expression -> bool (** Shadows [Ppxlib.really_recursive] with a version that respects the [[@opaque]] attribute. *) val really_recursive_respecting_opaque : rec_flag -> type_declaration list -> rec_flag val strip_attributes : Ast_traverse.map ppx_sexp_conv-0.17.0/expander/labeled_tuple.ml000066400000000000000000000002621461647336100214460ustar00rootroot00000000000000open! Base let is_valid alist = List.exists alist ~f:(fun (option, _) -> Option.is_some option) let atom_of_label = function | None -> "." | Some string -> "~" ^ string ;; ppx_sexp_conv-0.17.0/expander/labeled_tuple.mli000066400000000000000000000005061461647336100216200ustar00rootroot00000000000000(* Support for labeled tuples, a language feature currently only implemented in Jane Street's experimental branch of the compiler (https://github.com/ocaml-flambda/flambda-backend/). *) open! Base open Ppxlib_jane val is_valid : Jane_syntax.Labeled_tuples.core_type -> bool val atom_of_label : string option -> string ppx_sexp_conv-0.17.0/expander/lifted.ml000066400000000000000000000021271461647336100201160ustar00rootroot00000000000000open! Base open Ppxlib open Ast_builder.Default type 'a t = { value_bindings : value_binding list ; body : 'a } include Monad.Make (struct type nonrec 'a t = 'a t let return body = { value_bindings = []; body } let bind a ~f = let b = f a.body in { value_bindings = a.value_bindings @ b.value_bindings; body = b.body } ;; let map = `Define_using_bind end) let create ~loc ~prefix ~ty rhs = let name = gen_symbol ~prefix () in let lhs = pvar ~loc name in let body = evar ~loc name in let ty, rhs, body = if Helpers.is_value_expression rhs then ty, rhs, body else ( (* Thunkify the value to evaluate when referred to. *) let ty = [%type: Stdlib.Unit.t -> [%t ty]] in let rhs = [%expr fun () -> [%e rhs]] in let body = [%expr [%e body] ()] in ty, rhs, body) in { value_bindings = [ value_binding ~loc ~pat:(ppat_constraint ~loc lhs ty) ~expr:rhs ] ; body } ;; let let_bind_user_expressions { value_bindings; body } ~loc = if List.is_empty value_bindings then body else pexp_let ~loc Nonrecursive value_bindings body ;; ppx_sexp_conv-0.17.0/expander/lifted.mli000066400000000000000000000017741461647336100202760ustar00rootroot00000000000000open! Base open Ppxlib (** Represents an ['a], along with some user expressions that should lifted out of the scope of internal bindings. For example, if a user writes [[@@default x]], they mean [x] in the surface code, not some temporary variable [x] added by ppx machinery. *) type 'a t (** As a monad, combines all client expressions so they can be lifted to the outermost level of generated code. *) include Monad.S with type 'a t := 'a t (** Lifts the given expression and binds it to a fresh variable starting with [prefix]. The expression is evaluated each time it is referred to. The binding is annotated with [ty]. Uses [loc] for generated code. *) val create : loc:location -> prefix:string -> ty:core_type -> expression -> expression t (** Uses [let] to bind all lifted user expressions, with the contained expression as the body. Should be called in whatever scope the user should be able to refer to. *) val let_bind_user_expressions : expression t -> loc:location -> expression ppx_sexp_conv-0.17.0/expander/ppx_sexp_conv_expander.ml000066400000000000000000000027571461647336100234410ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default module Attrs = Attrs module Record_field_attrs = Record_field_attrs open Expand_sexp_of open Expand_of_sexp 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_core_type ty 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 end module Sexp_grammar = Ppx_sexp_conv_grammar 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.core_type_of_sexp 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:"Sexplib0.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.17.0/expander/ppx_sexp_conv_expander.mli000066400000000000000000000033701461647336100236020ustar00rootroot00000000000000open Ppxlib module Attrs = Attrs module Record_field_attrs = Record_field_attrs 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 : ctxt:Expansion_context.Extension.t -> core_type -> core_type val core_type : tags_of_doc_comments:bool -> ctxt:Expansion_context.Extension.t -> core_type -> expression val sig_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> signature val str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> bool (** [true] means capture doc comments as tags *) -> 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.17.0/expander/ppx_sexp_conv_grammar.ml000066400000000000000000000613641461647336100232600ustar00rootroot00000000000000open! Base open! Ppxlib open Ast_builder.Default let copy = object inherit Ast_traverse.map method! location loc = { loc with loc_ghost = true } method! attributes _ = [] end ;; let unsupported ~loc string = Location.raise_errorf ~loc "sexp_grammar: %s are unsupported" string ;; let ewith_tag ~loc ~key ~value grammar = [%expr { key = [%e key]; value = [%e value]; grammar = [%e grammar] }] ;; let eno_tag ~loc grammar = [%expr No_tag [%e grammar]] let etag ~loc with_tag = [%expr Tag [%e with_tag]] let etagged ~loc with_tag = [%expr Tagged [%e with_tag]] let tag_of_doc_comment ~loc comment = ( [%expr Ppx_sexp_conv_lib.Sexp_grammar.doc_comment_tag] , [%expr Atom [%e estring ~loc comment]] ) ;; module Tags = struct type t = { defined_using_tags : expression option ; defined_using_tag : (expression * expression) list } let get x ~tags ~tag = { defined_using_tags = Attribute.get tags x ; defined_using_tag = Attribute.get tag x |> Option.value ~default:[] } ;; end let rec with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags = match tags_expr with | [%expr []] -> grammar | [%expr ([%e? key], [%e? value]) :: [%e? tags_expr]] -> wrap_tag ~loc (ewith_tag ~loc ~key ~value (with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags)) | _ -> wrap_tags grammar ~loc ~tags_expr ;; let with_tags grammar ~wrap_tag ~wrap_tags ~loc ~(tags : Tags.t) ~comments = let tags_from_comments = List.map comments ~f:(tag_of_doc_comment ~loc) in let init = match tags.defined_using_tags with | None -> grammar | Some tags_expr -> with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags in List.fold_right (List.concat [ tags_from_comments; tags.defined_using_tag ]) ~init ~f:(fun (key, value) grammar -> wrap_tag ~loc (ewith_tag ~loc ~key ~value grammar)) ;; let with_tags_as_list grammar ~core_type ~loc ~tags ~comments = let wrap_tags grammar ~loc ~tags_expr = [%expr Sexplib0.Sexp_conv.sexp_grammar_with_tag_list ([%e grammar] : [%t core_type] Sexplib0.Sexp_grammar.with_tag_list) ~tags:[%e tags_expr]] in with_tags (eno_tag ~loc grammar) ~wrap_tag:etag ~wrap_tags ~loc ~tags ~comments ;; let with_tags_as_grammar grammar ~loc ~tags ~comments = let wrap_tags grammar ~loc ~tags_expr = [%expr Sexplib0.Sexp_conv.sexp_grammar_with_tags [%e grammar] ~tags:[%e tags_expr]] in with_tags grammar ~wrap_tag:etagged ~wrap_tags ~loc ~tags ~comments ;; let grammar_name name = name ^ "_sexp_grammar" let tyvar_grammar_name name = grammar_name ("_'" ^ name) let estr { loc; txt } = estring ~loc txt let grammar_type ~loc core_type = [%type: [%t copy#core_type core_type] Sexplib0.Sexp_grammar.t] ;; let abstract_grammar ~ctxt ~loc id = let module_name = ctxt |> Expansion_context.Deriver.code_path |> Code_path.fully_qualified_path in [%expr Any [%e estr { id with txt = String.concat ~sep:"." [ module_name; id.txt ] }]] ;; let arrow_grammar ~loc = [%expr Sexplib0.Sexp_conv.fun_sexp_grammar.untyped] let opaque_grammar ~loc = [%expr Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped] let any_grammar ~loc name = [%expr Any [%e estring ~loc name]] let list_grammar ~loc expr = [%expr List [%e expr]] let many_grammar ~loc expr = [%expr Many [%e expr]] let fields_grammar ~loc expr = [%expr Fields [%e expr]] let tyvar_grammar ~loc expr = [%expr Tyvar [%e expr]] let recursive_grammar ~loc name args = [%expr Recursive ([%e name], [%e args])] let tycon_grammar ~loc tycon_name params defns = [%expr Tycon ([%e tycon_name], [%e params], [%e defns])] ;; let defns_type ~loc = [%type: Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t] let untyped_grammar ~loc expr = match expr with | [%expr { untyped = [%e? untyped] }] -> untyped | _ -> [%expr [%e expr].untyped] ;; let typed_grammar ~loc expr = match expr with | [%expr [%e? typed].untyped] -> typed | _ -> [%expr { untyped = [%e expr] }] ;; let annotated_grammar ~loc expr core_type = pexp_constraint ~loc expr (grammar_type ~loc core_type) ;; let defn_expr ~loc ~tycon ~tyvars ~grammar = [%expr { tycon = [%e tycon]; tyvars = [%e tyvars]; grammar = [%e grammar] }] ;; let union_grammar ~loc exprs = match exprs with | [] -> [%expr Union []] | [ expr ] -> expr | _ -> [%expr Union [%e elist ~loc exprs]] ;; let tuple_grammar ~loc exprs = List.fold_right exprs ~init:[%expr Empty] ~f:(fun expr rest -> [%expr Cons ([%e expr], [%e rest])]) ;; let atom_clause ~loc = [%expr Atom_clause] let list_clause ~loc args = [%expr List_clause { args = [%e args] }] module Variant_clause_type = struct type t = { name : label loc ; comments : string list ; tags : Tags.t ; clause_kind : expression } let to_grammar_expr { name; comments; tags; clause_kind } ~loc = [%expr { name = [%e estr name]; clause_kind = [%e clause_kind] }] |> with_tags_as_list ~loc:name.loc ~comments ~tags ~core_type:[%type: Sexplib0.Sexp_grammar.clause] ;; end let variant_grammars ~loc ~case_sensitivity ~clauses = match List.is_empty clauses with | true -> [] | false -> let clause_exprs = List.map clauses ~f:(Variant_clause_type.to_grammar_expr ~loc) in let grammar = [%expr Variant { case_sensitivity = [%e case_sensitivity] ; clauses = [%e elist ~loc clause_exprs] }] in [ grammar ] ;; (* Wrap [expr] in [fun a b ... ->] for type parameters. *) let td_params_fun td expr = let loc = td.ptype_loc in let params = List.map td.ptype_params ~f:(fun param -> let { loc; txt } = get_type_param_name param in pvar ~loc (tyvar_grammar_name txt)) in eabstract ~loc params expr ;; module Row_field_type = struct type t = | Inherit of core_type | Tag_no_arg of string loc | Tag_with_arg of string loc * core_type let of_row_field ~loc row_field = match row_field with | Rinherit core_type -> Inherit core_type | Rtag (name, possibly_no_arg, possible_type_args) -> (match possibly_no_arg, possible_type_args with | true, [] -> Tag_no_arg name | false, [ core_type ] -> Tag_with_arg (name, core_type) | false, [] -> unsupported ~loc "empty polymorphic variant types" | true, _ :: _ | false, _ :: _ :: _ -> unsupported ~loc "intersection types") ;; end let attr_doc_comments attributes ~tags_of_doc_comments = match tags_of_doc_comments with | false -> [] | true -> let doc_pattern = Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) in List.filter_map attributes ~f:(fun attribute -> match attribute.attr_name.txt with | "ocaml.doc" | "doc" -> Ast_pattern.parse doc_pattern attribute.attr_loc attribute.attr_payload ~on_error:(fun () -> None) (fun doc -> Some doc) | _ -> None) ;; let grammar_of_type_tags core_type grammar ~tags_of_doc_comments = let tags = Tags.get core_type ~tags:Attrs.tags_type ~tag:Attrs.tag_type in let loc = core_type.ptyp_loc in let comments = attr_doc_comments ~tags_of_doc_comments core_type.ptyp_attributes in with_tags_as_grammar grammar ~loc ~tags ~comments ;; let grammar_of_field_tags field grammar ~tags_of_doc_comments = let tags = Tags.get field ~tags:Attrs.tags_ld ~tag:Attrs.tag_ld in let loc = field.pld_loc in let comments = attr_doc_comments ~tags_of_doc_comments field.pld_attributes in with_tags_as_list grammar ~loc ~tags ~comments ~core_type:[%type: Sexplib0.Sexp_grammar.field] ;; let rec grammar_of_type core_type ~rec_flag ~tags_of_doc_comments = let loc = core_type.ptyp_loc in let grammar = let from_attribute = match ( Attribute.get Attrs.grammar_custom core_type , Attribute.get Attrs.grammar_any core_type ) with | Some _, Some _ -> Some [%expr [%ocaml.warning "[@sexp_grammar.custom] and [@sexp_grammar.any] are mutually exclusive"]] | Some expr, None -> Some (untyped_grammar ~loc (annotated_grammar ~loc expr core_type)) | None, Some maybe_name -> Some (any_grammar ~loc (Option.value maybe_name ~default:"ANY")) | None, None -> (* only check [[@sexp.opaque]] if neither other attribute is present, so that it only counts as using the attribute when we actually base the grammar on it *) (match Attribute.get Attrs.opaque core_type with | Some () -> Some (opaque_grammar ~loc) | None -> None) in match from_attribute with | Some expr -> expr | None -> (match Ppxlib_jane.Jane_syntax.Core_type.of_ast core_type with | Some (Jtyp_tuple ltps, _attrs) -> grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments ltps | Some (Jtyp_layout _, _) | None -> (match core_type.ptyp_desc with | Ptyp_any -> any_grammar ~loc "_" | Ptyp_var name -> (match rec_flag with | Recursive -> (* For recursive grammars, [grammar_of_type] for any type variables is called inside a [defn]. The variables should therefore be resolved as [Tyvar] grammars. *) tyvar_grammar ~loc (estring ~loc name) | Nonrecursive -> (* Outside recursive [defn]s, type variables are passed in as function arguments. *) unapplied_type_constr_conv ~loc ~f:tyvar_grammar_name (Located.lident ~loc name) |> untyped_grammar ~loc) | Ptyp_arrow _ -> arrow_grammar ~loc | Ptyp_tuple list -> List.map ~f:(grammar_of_type ~rec_flag ~tags_of_doc_comments) list |> tuple_grammar ~loc |> list_grammar ~loc | Ptyp_constr (id, args) -> List.map args ~f:(fun core_type -> let loc = core_type.ptyp_loc in grammar_of_type ~rec_flag ~tags_of_doc_comments core_type |> typed_grammar ~loc) |> type_constr_conv ~loc ~f:grammar_name id |> untyped_grammar ~loc | Ptyp_object _ -> unsupported ~loc "object types" | Ptyp_class _ -> unsupported ~loc "class types" | Ptyp_alias _ -> unsupported ~loc "type aliases" | Ptyp_variant (rows, closed_flag, (_ : string list option)) -> (match closed_flag with | Open -> unsupported ~loc "open polymorphic variant types" | Closed -> grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows) | Ptyp_poly _ -> unsupported ~loc "explicitly polymorphic types" | Ptyp_package _ -> unsupported ~loc "first-class module types" | Ptyp_extension _ -> unsupported ~loc "unexpanded ppx extensions")) in grammar_of_type_tags core_type grammar ~tags_of_doc_comments and grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments alist = assert (Labeled_tuple.is_valid alist); let fields = List.concat_map alist ~f:(fun (lbl, typ) -> let lbl = Labeled_tuple.atom_of_label lbl in let field = grammar_of_type ~rec_flag ~tags_of_doc_comments typ in let clauses : Variant_clause_type.t list = (* Labeled tuples are encoded as a list of singleton variants, where the constructor name is used for the label. *) [ { name = { txt = lbl; loc } ; comments = [] ; tags = { defined_using_tags = None; defined_using_tag = [] } (* We can use empty comments and tags because it's not possible to attach an attribute to a labeled tuple field. *) ; clause_kind = list_clause ~loc [%expr Cons ([%e field], Empty)] } ] in let case_sensitivity = [%expr Case_sensitive] in variant_grammars ~loc ~case_sensitivity ~clauses) in list_grammar ~loc (tuple_grammar ~loc fields) and grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows = let inherits, clauses = List.partition_map rows ~f:(fun row : (_, Variant_clause_type.t) Either.t -> let tags = Tags.get row ~tags:Attrs.tags_poly ~tag:Attrs.tag_poly in let comments = attr_doc_comments ~tags_of_doc_comments row.prf_attributes in match Attribute.get Attrs.list_poly row with | Some () -> (match Row_field_type.of_row_field ~loc row.prf_desc with | Tag_with_arg (name, [%type: [%t? ty] list]) -> let clause_kind = grammar_of_type ~rec_flag ~tags_of_doc_comments ty |> many_grammar ~loc |> list_clause ~loc in Second { name; comments; tags; clause_kind } | _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list") | None -> (match Row_field_type.of_row_field ~loc row.prf_desc with | Inherit core_type -> First (grammar_of_type ~rec_flag ~tags_of_doc_comments core_type |> with_tags_as_grammar ~loc ~tags ~comments) | Tag_no_arg name -> Second { name; comments; tags; clause_kind = atom_clause ~loc } | Tag_with_arg (name, core_type) -> let clause_kind = [ grammar_of_type ~rec_flag ~tags_of_doc_comments core_type ] |> tuple_grammar ~loc |> list_clause ~loc in Second { name; comments; tags; clause_kind })) in variant_grammars ~loc ~case_sensitivity:[%expr Case_sensitive] ~clauses |> List.append inherits |> union_grammar ~loc ;; let record_expr ~loc ~rec_flag ~tags_of_doc_comments ~extra_attr syntax fields = let fields = List.map fields ~f:(fun field -> let loc = field.pld_loc in let field_kind = Record_field_attrs.Of_sexp.create ~loc field in let required = match field_kind with | Specific Required -> true | Specific (Default _) | Sexp_bool | Sexp_option _ | Sexp_array _ | Sexp_list _ | Omit_nil -> false in let args = match field_kind with | Specific Required | Specific (Default _) | Omit_nil -> [%expr Cons ([%e grammar_of_type ~tags_of_doc_comments ~rec_flag field.pld_type], Empty)] | Sexp_bool -> [%expr Empty] | Sexp_option ty -> [%expr Cons ([%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty], Empty)] | Sexp_list ty | Sexp_array ty -> [%expr Cons (List (Many [%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty]), Empty)] in [%expr { name = [%e estr field.pld_name] ; required = [%e ebool ~loc required] ; args = [%e args] }] |> grammar_of_field_tags field ~tags_of_doc_comments) in let allow_extra_fields = match Attribute.get extra_attr syntax with | Some () -> true | None -> false in [%expr { allow_extra_fields = [%e ebool ~loc allow_extra_fields] ; fields = [%e elist ~loc fields] }] ;; let grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clause_decls = let clauses = List.map clause_decls ~f:(fun clause : Variant_clause_type.t -> let loc = clause.pcd_loc in let tags = Tags.get clause ~tags:Attrs.tags_cd ~tag:Attrs.tag_cd in let comments = attr_doc_comments ~tags_of_doc_comments clause.pcd_attributes in match Attribute.get Attrs.list_variant clause with | Some () -> (match clause.pcd_args with | Pcstr_tuple [ [%type: [%t? ty] list] ] -> let args = many_grammar ~loc (grammar_of_type ty ~rec_flag ~tags_of_doc_comments) in { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args } | _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list") | None -> (match clause.pcd_args with | Pcstr_tuple [] -> { name = clause.pcd_name; comments; tags; clause_kind = atom_clause ~loc } | Pcstr_tuple (_ :: _ as args) -> let args = tuple_grammar ~loc (List.map args ~f:(grammar_of_type ~rec_flag ~tags_of_doc_comments)) in { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args } | Pcstr_record fields -> let args = record_expr ~loc ~rec_flag ~tags_of_doc_comments ~extra_attr:Attrs.allow_extra_fields_cd clause fields |> fields_grammar ~loc in { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args })) in variant_grammars ~loc ~case_sensitivity:[%expr Case_sensitive_except_first_character] ~clauses |> union_grammar ~loc ;; let grammar_of_td ~ctxt ~rec_flag ~tags_of_doc_comments td = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_open -> unsupported ~loc "open types" | Ptype_record fields -> record_expr ~loc ~rec_flag ~tags_of_doc_comments ~extra_attr:Attrs.allow_extra_fields_td td fields |> fields_grammar ~loc |> list_grammar ~loc | Ptype_variant clauses -> grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clauses | Ptype_abstract -> (match td.ptype_manifest with | None -> abstract_grammar ~ctxt ~loc td.ptype_name | Some core_type -> grammar_of_type ~rec_flag ~tags_of_doc_comments core_type) ;; let pattern_of_td td = let { loc; txt } = td.ptype_name in ppat_constraint ~loc (pvar ~loc (grammar_name txt)) (ptyp_poly ~loc (List.map td.ptype_params ~f:get_type_param_name) (combinator_type_of_type_declaration td ~f:grammar_type)) ;; (* Any grammar expression that is purely a constant does no work, and does not need to be wrapped in [Lazy]. *) let rec is_preallocated_constant expr = match expr.pexp_desc with | Pexp_constraint (expr, _) | Pexp_coerce (expr, _, _) | Pexp_open (_, expr) -> is_preallocated_constant expr | Pexp_constant _ -> true | Pexp_tuple args -> List.for_all ~f:is_preallocated_constant args | Pexp_variant (_, maybe_arg) | Pexp_construct (_, maybe_arg) -> Option.for_all ~f:is_preallocated_constant maybe_arg | Pexp_record (fields, maybe_template) -> List.for_all fields ~f:(fun (_, expr) -> is_preallocated_constant expr) && Option.for_all ~f:is_preallocated_constant maybe_template | _ -> false ;; (* Any grammar expression that just refers to a previously defined grammar also does not need to be wrapped in [Lazy]. Accessing the previous grammar is work, but building the closure for a lazy value is at least as much work anyway. *) let rec is_variable_access expr = match expr.pexp_desc with | Pexp_constraint (expr, _) | Pexp_coerce (expr, _, _) | Pexp_open (_, expr) -> is_variable_access expr | Pexp_ident _ -> true | Pexp_field (expr, _) -> is_variable_access expr | _ -> false ;; let grammar_needs_lazy_wrapper expr = not (is_preallocated_constant expr || is_variable_access expr) ;; let lazy_grammar ~loc td expr = if List.is_empty td.ptype_params (* polymorphic types generate functions, so the body does not need a [lazy] wrapper *) && grammar_needs_lazy_wrapper expr then [%expr Lazy (lazy [%e expr])] else expr ;; let force_expr ~loc expr = [%expr Stdlib.Lazy.force [%e expr]] (* Definitions of grammars that do not refer to each other. *) let nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments td_lists = List.concat_map td_lists ~f:(fun tds -> List.map tds ~f:(fun td -> let td = name_type_params_in_td td in let loc = td.ptype_loc in let pat = pattern_of_td td in let expr = grammar_of_td ~ctxt ~rec_flag:Nonrecursive ~tags_of_doc_comments td |> lazy_grammar td ~loc |> typed_grammar ~loc |> td_params_fun td in value_binding ~loc ~pat ~expr) |> pstr_value_list ~loc Nonrecursive) ;; (* Type constructor grammars used to "tie the knot" for (mutally) recursive grammars. *) let recursive_grammar_tycons tds = List.map tds ~f:(fun td -> let td = name_type_params_in_td td in let loc = td.ptype_loc in let pat = pattern_of_td td in let expr = recursive_grammar ~loc (estr td.ptype_name) (List.map td.ptype_params ~f:(fun param -> let { loc; txt } = get_type_param_name param in tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc) |> elist ~loc) |> typed_grammar ~loc |> td_params_fun td in value_binding ~loc ~pat ~expr) ;; (* Recursive grammar definitions, based on the type constructors from above. *) let recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds = List.map tds ~f:(fun td -> let td = name_type_params_in_td td in let loc = td.ptype_loc in let tycon = estr td.ptype_name in let tyvars = List.map td.ptype_params ~f:(fun param -> estr (get_type_param_name param)) |> elist ~loc in let grammar = grammar_of_td ~ctxt ~rec_flag:Recursive ~tags_of_doc_comments td in defn_expr ~loc ~tycon ~tyvars ~grammar) |> elist ~loc ;; (* Grammar expression using [Recursive] and a shared definition of grammar definitions. The shared definitions are wrapped in [lazy] to avoid toplevel side effects. *) let recursive_grammar_expr ~defns_name td = let td = name_type_params_in_td td in let loc = td.ptype_loc in let pat = pattern_of_td td in let expr = let tyvars = List.map td.ptype_params ~f:(fun param -> let { loc; txt } = get_type_param_name param in tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc) |> elist ~loc in tycon_grammar ~loc (estr td.ptype_name) tyvars (evar ~loc defns_name |> force_expr ~loc) |> lazy_grammar td ~loc |> typed_grammar ~loc |> td_params_fun td in value_binding ~loc ~pat ~expr ;; (* Puts together recursive grammar definitions from the parts implemented above. *) let recursive_grammars ~ctxt ~loc ~tags_of_doc_comments tds = match List.is_empty tds with | true -> [] | false -> let defns_name = gen_symbol ~prefix:"grammars" () in let defns_item = let expr = recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds |> pexp_let ~loc Nonrecursive (recursive_grammar_tycons tds) |> pexp_lazy ~loc in let pat = ppat_constraint ~loc (pvar ~loc defns_name) (defns_type ~loc) in pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ] in let grammars_item = List.map tds ~f:(recursive_grammar_expr ~defns_name) |> pstr_value ~loc Nonrecursive in [%str include struct open struct [%%i defns_item] end [%%i grammars_item] end] ;; let partition_recursive_and_nonrecursive ~rec_flag tds = match (rec_flag : rec_flag) with | Nonrecursive -> [], [ tds ] | Recursive -> (* Pulling out non-recursive references repeatedly means we only "tie the knot" for variables that actually need it, and we don't have to manually [ignore] the added bindings in case they are unused. *) let rec loop tds ~acc = let obj = object inherit type_is_recursive Recursive tds method recursion td = {}#go () end in let recursive, nonrecursive = List.partition_tf tds ~f:(fun td -> match obj#recursion td with | Recursive -> true | Nonrecursive -> false) in if List.is_empty recursive || List.is_empty nonrecursive then recursive, nonrecursive :: acc else loop recursive ~acc:(nonrecursive :: acc) in loop tds ~acc:[] ;; let str_type_decl ~ctxt (rec_flag, tds) tags_of_doc_comments = let loc = Expansion_context.Deriver.derived_item_loc ctxt in let recursive, nonrecursive = partition_recursive_and_nonrecursive ~rec_flag tds in [ recursive_grammars ~ctxt ~loc ~tags_of_doc_comments recursive ; nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments nonrecursive ] |> List.concat ;; let sig_type_decl ~ctxt:_ (_rec_flag, tds) = List.map tds ~f:(fun td -> let loc = td.ptype_loc in value_description ~loc ~name:(Loc.map td.ptype_name ~f:grammar_name) ~type_:(combinator_type_of_type_declaration td ~f:grammar_type) ~prim:[] |> psig_value ~loc) ;; let extension_loc ~ctxt = let loc = Expansion_context.Extension.extension_point_loc ctxt in { loc with loc_ghost = true } ;; let core_type ~tags_of_doc_comments ~ctxt core_type = let loc = extension_loc ~ctxt in pexp_constraint ~loc (core_type |> grammar_of_type ~rec_flag:Nonrecursive ~tags_of_doc_comments |> typed_grammar ~loc) (core_type |> grammar_type ~loc) |> Merlin_helpers.hide_expression ;; let type_extension ~ctxt core_type = assert_no_attributes_in#core_type core_type; let loc = extension_loc ~ctxt in core_type |> grammar_type ~loc ;; ppx_sexp_conv-0.17.0/expander/ppx_sexp_conv_grammar.mli000066400000000000000000000007671461647336100234310ustar00rootroot00000000000000open! Base open! Ppxlib val type_extension : ctxt:Expansion_context.Extension.t -> core_type -> core_type val core_type : tags_of_doc_comments:bool -> ctxt:Expansion_context.Extension.t -> core_type -> expression val sig_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> signature val str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> bool (** [true] means capture doc comments as tags *) -> structure ppx_sexp_conv-0.17.0/expander/record_field_attrs.ml000066400000000000000000000072461461647336100225140ustar00rootroot00000000000000open! Base open! Ppxlib open Attrs module Generic = struct type 'specific t = | Omit_nil | Sexp_array of core_type | Sexp_bool | Sexp_list of core_type | Sexp_option of core_type | Specific of 'specific end open Generic let get_attribute attr ld ~f = Option.map (Attribute.get attr ld) ~f:(fun x -> f x, Attribute.name attr) ;; let create ~loc specific_getters ld ~if_no_attribute = let generic_getters = [ get_attribute omit_nil ~f:(fun () -> Omit_nil) ; (fun ld -> match ld.pld_type with | 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 let getters = let wrapped_getters = List.map specific_getters ~f:(fun get ld -> Option.map (get ld) ~f:(fun (specific, string) -> Specific specific, string)) in List.concat [ wrapped_getters; generic_getters ] in match List.filter_map getters ~f:(fun f -> f ld) with | [] -> Specific if_no_attribute | [ (v, _) ] -> v | _ :: _ :: _ as attributes -> Location.raise_errorf ~loc "The following elements are mutually exclusive: %s" (String.concat ~sep:" " (List.map attributes ~f:snd)) ;; let strip_attributes = object inherit Ast_traverse.map method! attributes _ = [] end ;; let lift_default ~loc ld expr = let ty = strip_attributes#core_type ld.pld_type in Lifted.create ~loc ~prefix:"default" ~ty expr ;; let lift_drop_default ~loc ld expr = let ty = strip_attributes#core_type ld.pld_type in Lifted.create ~loc ~prefix:"drop_default" ~ty:[%type: [%t ty] -> [%t ty] -> Stdlib.Bool.t] expr ;; let lift_drop_if ~loc ld expr = let ty = strip_attributes#core_type ld.pld_type in Lifted.create ~loc ~prefix:"drop_if" ~ty:[%type: [%t ty] -> Stdlib.Bool.t] expr ;; module Of_sexp = struct type t = | Default of expression Lifted.t | Required let create ~loc ld = create ~loc [ get_attribute default ~f:(fun { to_lift = default } -> Default (lift_default ~loc ld default)) ] ld ~if_no_attribute:Required ;; end module Sexp_of = struct module Drop = struct type t = | No_arg | Compare | Equal | Sexp | Func of expression Lifted.t end type t = | Drop_default of Drop.t | Drop_if of expression Lifted.t | Keep let create ~loc ld = create ~loc [ get_attribute drop_default ~f:(function | None -> Drop_default No_arg | Some { to_lift = e } -> Drop_default (Func (lift_drop_default ~loc ld 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 { to_lift = x } -> Drop_if (lift_drop_if ~loc ld x)) ] ld ~if_no_attribute:Keep ;; end ppx_sexp_conv-0.17.0/expander/record_field_attrs.mli000066400000000000000000000014731461647336100226610ustar00rootroot00000000000000open! Base open! Ppxlib module Generic : sig type 'specific t = | Omit_nil | Sexp_array of core_type | Sexp_bool | Sexp_list of core_type | Sexp_option of core_type | Specific of 'specific end module Of_sexp : sig type t = | Default of expression Lifted.t | Required val create : loc:Location.t -> label_declaration -> t Generic.t end module Sexp_of : sig module Drop : sig type t = | No_arg | Compare | Equal | Sexp | Func of expression Lifted.t end type t = | Drop_default of Drop.t | Drop_if of expression Lifted.t | Keep val create : loc:Location.t -> label_declaration -> t Generic.t end (** Lift the contents of [Attrs.default]. *) val lift_default : loc:location -> label_declaration -> expression -> expression Lifted.t ppx_sexp_conv-0.17.0/expander/renaming.ml000066400000000000000000000067271461647336100204610ustar00rootroot00000000000000open! Base open! Ppxlib type t = { universal : (Fresh_name.t, string loc) Result.t Map.M(String).t ; existential : bool } module Binding_kind = struct type t = | Universally_bound of Fresh_name.t | Existentially_bound end let add_universally_bound t name ~prefix = { t with universal = Map.set t.universal ~key:name.txt ~data:(Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc)) } ;; let binding_kind t var ~loc = match Map.find t.universal var with | None -> if t.existential then Binding_kind.Existentially_bound else Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" var | Some (Ok fresh) -> Binding_kind.Universally_bound fresh | 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: {v "x" -> Ok "a" "y" -> Ok "b" v} 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 [original] on user error, to let the typer give the error message *) let with_constructor_declaration original cd ~type_parameters:tps = (* Add all type variables of a type to a map. *) let add_typevars = object inherit [t] Ast_traverse.fold as super method! core_type ty t = 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 { t with universal = Map.set t.universal ~key:var ~data:(Error error) } | _ -> super#core_type ty t end in let aux t tp_name tp_in_return_type = match tp_in_return_type.ptyp_desc with | Ptyp_var var -> let data = let loc = tp_in_return_type.ptyp_loc in if Map.mem t.universal var then Error { loc; txt = "ppx_sexp_conv: duplicate variable" } else ( match Map.find original.universal tp_name with | Some result -> result | None -> Error { loc; txt = "ppx_sexp_conv: unbound type parameter" }) in { t with universal = Map.set t.universal ~key:var ~data } | _ -> add_typevars#core_type tp_in_return_type t in match cd.pcd_res with | None -> original | Some ty -> (match ty.ptyp_desc with | Ptyp_constr (_, params) -> if List.length params <> List.length tps then original else Stdlib.ListLabels.fold_left2 tps params ~init:{ existential = true; universal = Map.empty (module String) } ~f:aux | _ -> original) ;; let of_type_declaration decl ~prefix = { existential = false ; universal = List.fold decl.ptype_params ~init:(Map.empty (module String)) ~f:(fun map param -> let name = get_type_param_name param in Map.update map name.txt ~f:(function | None -> Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc) | Some _ -> Error { loc = name.loc; txt = "ppx_sexp_conv: duplicate variable" })) } ;; let without_type () = { existential = false; universal = Map.empty (module String) } ppx_sexp_conv-0.17.0/expander/renaming.mli000066400000000000000000000036441461647336100206250ustar00rootroot00000000000000(* 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). *) open! Base open! Ppxlib type t (** Renaming for contexts outside a type declaration, such as expression extensions. *) val without_type : unit -> t (** Renaming for a type declaration. Adds [prefix] to bindings for type parameters. *) val of_type_declaration : type_declaration -> prefix:string -> t (** Adds a new name with the given [prefix] for a universally bound type variable. *) val add_universally_bound : t -> string loc -> prefix:string -> t module Binding_kind : sig type t = | Universally_bound of Fresh_name.t | Existentially_bound end (** Looks up the binding for a type variable. *) val binding_kind : t -> string -> loc:location -> Binding_kind.t (** Extends the renaming of a type declaration with GADT context for a constructor declaration, if any. *) val with_constructor_declaration : t -> constructor_declaration -> type_parameters:string list -> t ppx_sexp_conv-0.17.0/ppx_sexp_conv.opam000066400000000000000000000015401461647336100202560ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" 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" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "sexplib0" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "[@@deriving] plugin to generate S-expression conversion functions" description: " Part of the Jane Street's PPX rewriters collection. " ppx_sexp_conv-0.17.0/runtime-lib/000077500000000000000000000000001461647336100167345ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/runtime-lib/dune000066400000000000000000000002021461647336100176040ustar00rootroot00000000000000(library (name ppx_sexp_conv_lib) (public_name ppx_sexp_conv.runtime-lib) (libraries sexplib0) (preprocess no_preprocessing)) ppx_sexp_conv-0.17.0/runtime-lib/ppx_sexp_conv_lib.ml000066400000000000000000000004021461647336100230030ustar00rootroot00000000000000module Conv = Sexplib0.Sexp_conv module Conv_error = Sexplib0.Sexp_conv_error module Sexp_grammar = Sexplib0.Sexp_grammar module Sexp = struct include Sexplib0.Sexp let t_sexp_grammar = Conv.sexp_t_sexp_grammar end module Sexpable = Sexplib0.Sexpable ppx_sexp_conv-0.17.0/src/000077500000000000000000000000001461647336100152745ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/src/dune000066400000000000000000000002331461647336100161500ustar00rootroot00000000000000(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.17.0/src/ppx_sexp_conv.ml000066400000000000000000000102611461647336100205210ustar00rootroot00000000000000(* sexp_conv: Preprocessing Module for Automated S-expression Conversions *) open Ppxlib module Attrs = Ppx_sexp_conv_expander.Attrs let register_extension name f = let extension = Extension.declare name Expression Ast_pattern.(ptyp __) f in Driver.register_transformation ("Ppxlib.Deriving." ^ name) ~rules:[ Context_free.Rule.extension extension ] ;; module Sexp_grammar = struct module E = Ppx_sexp_conv_expander.Sexp_grammar let name = "sexp_grammar" let flags = Deriving.Args.(empty +> flag "tags_of_doc_comments") let str_type_decl = Deriving.Generator.V2.make flags E.str_type_decl let sig_type_decl = Deriving.Generator.V2.make_noarg E.sig_type_decl let deriver = Deriving.add name ~sig_type_decl ~str_type_decl (* We default to [tags_of_doc_comments=true] in this case, because doc comments in a [%sexp_grammar] expression have no other purpose. *) let expr_extension = Extension.V3.declare name Expression Ast_pattern.(ptyp __) (E.core_type ~tags_of_doc_comments:true) ;; let type_extension = Extension.V3.declare name Core_type Ast_pattern.(ptyp __) E.type_extension ;; let () = Driver.register_transformation "Ppxlib.Deriving.sexp_grammar" ~rules: [ Context_free.Rule.extension expr_extension ; Context_free.Rule.extension type_extension ] ;; end 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 deriver = Deriving.add name ~str_type_decl ~str_exception ~sig_type_decl ~sig_exception ;; let extension ~loc:_ ~path:_ ctyp = E.core_type ctyp let () = register_extension name 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 deriver = Deriving.add name ~str_type_decl ~sig_type_decl let extension ~loc:_ ~path ctyp = E.core_type ~path ctyp let () = register_extension name 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 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.17.0/src/ppx_sexp_conv.mli000066400000000000000000000002541461647336100206730ustar00rootroot00000000000000open 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.17.0/test/000077500000000000000000000000001461647336100154645ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/test/dune000066400000000000000000000003151461647336100163410ustar00rootroot00000000000000(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.17.0/test/errors.mlt000066400000000000000000000174421461647336100175260ustar00rootroot00000000000000type 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 list [@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 [preprocessor]): [@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 {| Line _, characters _-_: Error: sexp_grammar: object types are unsupported |}] let (_ : _) = [%sexp_grammar: < other : 'k 'v. ('k * 'v) list > ] [%%expect {| Line _, characters _-_: Error: sexp_grammar: object types are unsupported |}] type t = < for_all : 'k 'v. ('k * 'v) list > [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: sexp_grammar: object types are unsupported |}] type t = < other : 'k 'v. ('k * 'v) list > [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: sexp_grammar: object types are unsupported |}] type t = T : 'a -> t [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: Unbound value _'a_sexp_grammar Hint: Did you mean char_sexp_grammar, int_sexp_grammar or ref_sexp_grammar? |}] (* If we can sensibly derive [sexp_grammar], we might as well, because the user might still be able to pair it with a consistent hand-written [t_of_sexp]. *) type _ t = T : int -> string t [@@deriving sexp_grammar] [%%expect {| |}] type _ t = T : int -> string t [@@deriving of_sexp] [%%expect {| Line _, characters _-_: Error: This expression has type string t but an expression was expected of type a__098_ t Type string is not compatible with type a__098_ |}] ppx_sexp_conv-0.17.0/test/examples.mlt000066400000000000000000000023251461647336100200220ustar00rootroot00000000000000module 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: ppx_sexp_conv: unbound type variable 'a |}] let _ = [%of_sexp: 'a] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: unbound type variable 'a |}] let _ = [%sexp (() : 'a)] [%%expect {| Line _, characters _-_: Error: ppx_sexp_conv: unbound type variable 'a |}] type 'a t = | None | Something_else of { value : 'a } [@@deriving sexp] [%%expect {| |}] module Record_with_defaults = struct open Sexplib0.Sexp_conv let a_field = "a_field" let b_field = "b_field" type record_with_defaults = { a : string [@default a_field] ; b : string [@default b_field] } [@@deriving of_sexp] end [%%expect {| |}] module Polymorphic_recursion = struct type 'a t = T of 'a t t [@@deriving sexp_grammar] end [%%expect {| |}] ppx_sexp_conv-0.17.0/test/expansion.ml000066400000000000000000001515401461647336100200300ustar00rootroot00000000000000open! Base open struct type _shadow_constructors = | [] | ( :: ) | None | Some end module Abstract = struct type t [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__002_ = "expansion.ml.Abstract.t" in fun x__003_ -> Sexplib0.Sexp_conv_error.empty_type error_source__002_ x__003_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun _ -> assert false : t -> Sexplib0.Sexp.t) let _ = sexp_of_t [@@@end] end module Tuple = struct type t = int * int * int [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__012_ = "expansion.ml.Tuple.t" in function | Sexplib0.Sexp.List [ arg0__005_; arg1__006_; arg2__007_ ] -> let res0__008_ = int_of_sexp arg0__005_ and res1__009_ = int_of_sexp arg1__006_ and res2__010_ = int_of_sexp arg2__007_ in res0__008_, res1__009_, res2__010_ | sexp__011_ -> Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__012_ 3 sexp__011_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun (arg0__013_, arg1__014_, arg2__015_) -> let res0__016_ = sexp_of_int arg0__013_ and res1__017_ = sexp_of_int arg1__014_ and res2__018_ = sexp_of_int arg2__015_ in Sexplib0.Sexp.List [ res0__016_; res1__017_; res2__018_ ] : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Record = struct type t = { a : int ; b : int ; c : int } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__020_ = "expansion.ml.Record.t" in fun x__021_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__020_ ~fields: (Field { name = "a" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "c" ; kind = Required ; conv = int_of_sexp ; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, ()))) : t -> { a; b; c }) x__021_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__023_; b = b__025_; c = c__027_ } -> let bnds__022_ = ([] : _ Stdlib.List.t) in let bnds__022_ = let arg__028_ = sexp_of_int c__027_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__028_ ] :: bnds__022_ : _ Stdlib.List.t) in let bnds__022_ = let arg__026_ = sexp_of_int b__025_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__026_ ] :: bnds__022_ : _ Stdlib.List.t) in let bnds__022_ = let arg__024_ = sexp_of_int a__023_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__024_ ] :: bnds__022_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__022_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Mutable_record = struct type t = { mutable a : int ; mutable b : int ; mutable c : int } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__030_ = "expansion.ml.Mutable_record.t" in fun x__031_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__030_ ~fields: (Field { name = "a" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "c" ; kind = Required ; conv = int_of_sexp ; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, ()))) : t -> { a; b; c }) x__031_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__033_; b = b__035_; c = c__037_ } -> let bnds__032_ = ([] : _ Stdlib.List.t) in let bnds__032_ = let arg__038_ = sexp_of_int c__037_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__038_ ] :: bnds__032_ : _ Stdlib.List.t) in let bnds__032_ = let arg__036_ = sexp_of_int b__035_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__036_ ] :: bnds__032_ : _ Stdlib.List.t) in let bnds__032_ = let arg__034_ = sexp_of_int a__033_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__034_ ] :: bnds__032_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__032_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Variant = struct type t = | A | B of int * int | C of { a : int ; b : int ; d : int } | D of { mutable a : int ; mutable b : int ; mutable t : int } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__041_ = "expansion.ml.Variant.t" in function | Sexplib0.Sexp.Atom ("a" | "A") -> A | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("b" | "B") as _tag__044_) :: sexp_args__045_) as _sexp__043_ -> (match sexp_args__045_ with | [ arg0__046_; arg1__047_ ] -> let res0__048_ = int_of_sexp arg0__046_ and res1__049_ = int_of_sexp arg1__047_ in B (res0__048_, res1__049_) | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__041_ _tag__044_ _sexp__043_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("c" | "C") :: sexps__051_) as sexp__050_ -> Sexplib0.Sexp_conv_record.record_of_sexps ~context:sexp__050_ ~caller:error_source__041_ ~fields: (Field { name = "a" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "d" ; kind = Required ; conv = int_of_sexp ; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "d" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (d, ()))) : t -> C { a; b; d }) sexps__051_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("d" | "D") :: sexps__053_) as sexp__052_ -> Sexplib0.Sexp_conv_record.record_of_sexps ~context:sexp__052_ ~caller:error_source__041_ ~fields: (Field { name = "a" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Required ; conv = int_of_sexp ; rest = Field { name = "t" ; kind = Required ; conv = int_of_sexp ; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "t" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (t, ()))) : t -> D { a; b; t }) sexps__053_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("a" | "A") :: _) as sexp__042_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__041_ sexp__042_ | Sexplib0.Sexp.Atom ("b" | "B") as sexp__042_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__041_ sexp__042_ | Sexplib0.Sexp.Atom ("c" | "C") as sexp__042_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__041_ sexp__042_ | Sexplib0.Sexp.Atom ("d" | "D") as sexp__042_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__041_ sexp__042_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__040_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__041_ sexp__040_ | Sexplib0.Sexp.List [] as sexp__040_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__041_ sexp__040_ | sexp__040_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__041_ sexp__040_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (function | A -> Sexplib0.Sexp.Atom "A" | B (arg0__054_, arg1__055_) -> let res0__056_ = sexp_of_int arg0__054_ and res1__057_ = sexp_of_int arg1__055_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__056_; res1__057_ ] | C { a = a__059_; b = b__061_; d = d__063_ } -> let bnds__058_ = ([] : _ Stdlib.List.t) in let bnds__058_ = let arg__064_ = sexp_of_int d__063_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__064_ ] :: bnds__058_ : _ Stdlib.List.t) in let bnds__058_ = let arg__062_ = sexp_of_int b__061_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__062_ ] :: bnds__058_ : _ Stdlib.List.t) in let bnds__058_ = let arg__060_ = sexp_of_int a__059_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__060_ ] :: bnds__058_ : _ Stdlib.List.t) in Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "C" :: bnds__058_) | D { a = a__066_; b = b__068_; t = t__070_ } -> let bnds__065_ = ([] : _ Stdlib.List.t) in let bnds__065_ = let arg__071_ = sexp_of_int t__070_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "t"; arg__071_ ] :: bnds__065_ : _ Stdlib.List.t) in let bnds__065_ = let arg__069_ = sexp_of_int b__068_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__069_ ] :: bnds__065_ : _ Stdlib.List.t) in let bnds__065_ = let arg__067_ = sexp_of_int a__066_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__067_ ] :: bnds__065_ : _ Stdlib.List.t) in Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "D" :: bnds__065_) : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Poly_variant = struct type t = [ `A | `B of int ] [@@deriving_inline sexp] let _ = fun (_ : t) -> () let __t_of_sexp__ = (let error_source__077_ = "expansion.ml.Poly_variant.t" in function | Sexplib0.Sexp.Atom atom__073_ as _sexp__075_ -> (match atom__073_ with | "A" -> `A | "B" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__077_ _sexp__075_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__073_ :: sexp_args__076_) as _sexp__075_ -> (match atom__073_ with | "B" as _tag__078_ -> (match sexp_args__076_ with | [ arg0__079_ ] -> let res0__080_ = int_of_sexp arg0__079_ in `B res0__080_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__077_ _tag__078_ _sexp__075_) | "A" -> Sexplib0.Sexp_conv_error.ptag_no_args error_source__077_ _sexp__075_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__074_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__077_ sexp__074_ | Sexplib0.Sexp.List [] as sexp__074_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__077_ sexp__074_ : Sexplib0.Sexp.t -> t) ;; let _ = __t_of_sexp__ let t_of_sexp = (let error_source__082_ = "expansion.ml.Poly_variant.t" in fun sexp__081_ -> try __t_of_sexp__ sexp__081_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__082_ sexp__081_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (function | `A -> Sexplib0.Sexp.Atom "A" | `B v__083_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; sexp_of_int v__083_ ] : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Inline_poly_variant = struct type t = [ Poly_variant.t | `C of int * int ] [@@deriving_inline sexp] let _ = fun (_ : t) -> () let __t_of_sexp__ = (let error_source__095_ = "expansion.ml.Inline_poly_variant.t" in fun sexp__084_ -> try (Poly_variant.__t_of_sexp__ sexp__084_ :> t) with | Sexplib0.Sexp_conv_error.No_variant_match -> (match sexp__084_ with | Sexplib0.Sexp.Atom atom__085_ as _sexp__087_ -> (match atom__085_ with | "C" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__095_ _sexp__087_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__085_ :: sexp_args__088_) as _sexp__087_ -> (match atom__085_ with | "C" as _tag__089_ -> (match sexp_args__088_ with | [ arg0__096_ ] -> let res0__097_ = match arg0__096_ with | Sexplib0.Sexp.List [ arg0__090_; arg1__091_ ] -> let res0__092_ = int_of_sexp arg0__090_ and res1__093_ = int_of_sexp arg1__091_ in res0__092_, res1__093_ | sexp__094_ -> Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__095_ 2 sexp__094_ in `C res0__097_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__095_ _tag__089_ _sexp__087_) | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__086_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__095_ sexp__086_ | Sexplib0.Sexp.List [] as sexp__086_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__095_ sexp__086_) : Sexplib0.Sexp.t -> t) ;; let _ = __t_of_sexp__ let t_of_sexp = (let error_source__099_ = "expansion.ml.Inline_poly_variant.t" in fun sexp__098_ -> try __t_of_sexp__ sexp__098_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__099_ sexp__098_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (function | #Poly_variant.t as v__100_ -> Poly_variant.sexp_of_t v__100_ | `C v__101_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "C" ; (let arg0__102_, arg1__103_ = v__101_ in let res0__104_ = sexp_of_int arg0__102_ and res1__105_ = sexp_of_int arg1__103_ in Sexplib0.Sexp.List [ res0__104_; res1__105_ ]) ] : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Recursive = struct type t = | Banana of t | Orange [@@deriving_inline sexp] let _ = fun (_ : t) -> () let rec t_of_sexp = (let error_source__108_ = "expansion.ml.Recursive.t" in function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("banana" | "Banana") as _tag__111_) :: sexp_args__112_) as _sexp__110_ -> (match sexp_args__112_ with | [ arg0__113_ ] -> let res0__114_ = t_of_sexp arg0__113_ in Banana res0__114_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__108_ _tag__111_ _sexp__110_) | Sexplib0.Sexp.Atom ("orange" | "Orange") -> Orange | Sexplib0.Sexp.Atom ("banana" | "Banana") as sexp__109_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__108_ sexp__109_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("orange" | "Orange") :: _) as sexp__109_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__108_ sexp__109_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__107_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__108_ sexp__107_ | Sexplib0.Sexp.List [] as sexp__107_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__108_ sexp__107_ | sexp__107_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__108_ sexp__107_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let rec sexp_of_t = (function | Banana arg0__115_ -> let res0__116_ = sexp_of_t arg0__115_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Banana"; res0__116_ ] | Orange -> Sexplib0.Sexp.Atom "Orange" : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Nonrecursive = struct open Recursive type nonrec t = t [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (t_of_sexp : Sexplib0.Sexp.t -> t) let _ = t_of_sexp let sexp_of_t = (sexp_of_t : t -> Sexplib0.Sexp.t) let _ = sexp_of_t [@@@end] end module Mutually_recursive = struct type a = | A | B of b | C of { a : a ; b : b ; c : c } and b = { a : a ; b : b } and c = a [@@deriving_inline sexp] let _ = fun (_ : a) -> () let _ = fun (_ : b) -> () let _ = fun (_ : c) -> () let rec a_of_sexp = (let error_source__120_ = "expansion.ml.Mutually_recursive.a" in function | Sexplib0.Sexp.Atom ("a" | "A") -> A | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("b" | "B") as _tag__123_) :: sexp_args__124_) as _sexp__122_ -> (match sexp_args__124_ with | [ arg0__125_ ] -> let res0__126_ = b_of_sexp arg0__125_ in B res0__126_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__120_ _tag__123_ _sexp__122_) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("c" | "C") :: sexps__128_) as sexp__127_ -> Sexplib0.Sexp_conv_record.record_of_sexps ~context:sexp__127_ ~caller:error_source__120_ ~fields: (Field { name = "a" ; kind = Required ; conv = a_of_sexp ; rest = Field { name = "b" ; kind = Required ; conv = b_of_sexp ; rest = Field { name = "c"; kind = Required; conv = c_of_sexp; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, ()))) : a -> C { a; b; c }) sexps__128_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("a" | "A") :: _) as sexp__121_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__120_ sexp__121_ | Sexplib0.Sexp.Atom ("b" | "B") as sexp__121_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__120_ sexp__121_ | Sexplib0.Sexp.Atom ("c" | "C") as sexp__121_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__120_ sexp__121_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__119_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__120_ sexp__119_ | Sexplib0.Sexp.List [] as sexp__119_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__120_ sexp__119_ | sexp__119_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__120_ sexp__119_ : Sexplib0.Sexp.t -> a) and b_of_sexp = (let error_source__130_ = "expansion.ml.Mutually_recursive.b" in fun x__131_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__130_ ~fields: (Field { name = "a" ; kind = Required ; conv = a_of_sexp ; rest = Field { name = "b"; kind = Required; conv = b_of_sexp; rest = Empty } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, ())) : b -> { a; b }) x__131_ : Sexplib0.Sexp.t -> b) and c_of_sexp = (fun x__133_ -> a_of_sexp x__133_ : Sexplib0.Sexp.t -> c) let _ = a_of_sexp and _ = b_of_sexp and _ = c_of_sexp let rec sexp_of_a = (function | A -> Sexplib0.Sexp.Atom "A" | B arg0__134_ -> let res0__135_ = sexp_of_b arg0__134_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__135_ ] | C { a = a__137_; b = b__139_; c = c__141_ } -> let bnds__136_ = ([] : _ Stdlib.List.t) in let bnds__136_ = let arg__142_ = sexp_of_c c__141_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__142_ ] :: bnds__136_ : _ Stdlib.List.t) in let bnds__136_ = let arg__140_ = sexp_of_b b__139_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__140_ ] :: bnds__136_ : _ Stdlib.List.t) in let bnds__136_ = let arg__138_ = sexp_of_a a__137_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__138_ ] :: bnds__136_ : _ Stdlib.List.t) in Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "C" :: bnds__136_) : a -> Sexplib0.Sexp.t) and sexp_of_b = (fun { a = a__144_; b = b__146_ } -> let bnds__143_ = ([] : _ Stdlib.List.t) in let bnds__143_ = let arg__147_ = sexp_of_b b__146_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__147_ ] :: bnds__143_ : _ Stdlib.List.t) in let bnds__143_ = let arg__145_ = sexp_of_a a__144_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__145_ ] :: bnds__143_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__143_ : b -> Sexplib0.Sexp.t) and sexp_of_c = (fun x__148_ -> sexp_of_a x__148_ : c -> Sexplib0.Sexp.t) let _ = sexp_of_a and _ = sexp_of_b and _ = sexp_of_c [@@@end] end module Alias = struct type t = Recursive.t [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (Recursive.t_of_sexp : Sexplib0.Sexp.t -> t) let _ = t_of_sexp let sexp_of_t = (Recursive.sexp_of_t : t -> Sexplib0.Sexp.t) let _ = sexp_of_t [@@@end] end module Re_export = struct type t = Recursive.t = | Banana of t | Orange [@@deriving_inline sexp] let _ = fun (_ : t) -> () let rec t_of_sexp = (let error_source__152_ = "expansion.ml.Re_export.t" in function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("banana" | "Banana") as _tag__155_) :: sexp_args__156_) as _sexp__154_ -> (match sexp_args__156_ with | [ arg0__157_ ] -> let res0__158_ = t_of_sexp arg0__157_ in Banana res0__158_ | _ -> Sexplib0.Sexp_conv_error.stag_incorrect_n_args error_source__152_ _tag__155_ _sexp__154_) | Sexplib0.Sexp.Atom ("orange" | "Orange") -> Orange | Sexplib0.Sexp.Atom ("banana" | "Banana") as sexp__153_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__152_ sexp__153_ | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("orange" | "Orange") :: _) as sexp__153_ -> Sexplib0.Sexp_conv_error.stag_no_args error_source__152_ sexp__153_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__151_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__152_ sexp__151_ | Sexplib0.Sexp.List [] as sexp__151_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__152_ sexp__151_ | sexp__151_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__152_ sexp__151_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let rec sexp_of_t = (function | Banana arg0__159_ -> let res0__160_ = sexp_of_t arg0__159_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Banana"; res0__160_ ] | Orange -> Sexplib0.Sexp.Atom "Orange" : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Unary = struct type 'a t = 'a list option [@@deriving_inline sexp] let _ = fun (_ : 'a t) -> () let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = fun _of_a__161_ x__163_ -> option_of_sexp (list_of_sexp _of_a__161_) x__163_ ;; let _ = t_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__164_ x__165_ -> sexp_of_option (sexp_of_list _of_a__164_) x__165_ ;; let _ = sexp_of_t [@@@end] end module Binary = struct type ('a, 'b) t = ('a, 'b) Either.t [@@deriving_inline sexp] let _ = fun (_ : ('a, 'b) t) -> () let t_of_sexp : 'a 'b. (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = Either.t_of_sexp ;; let _ = t_of_sexp let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = Either.sexp_of_t ;; let _ = sexp_of_t [@@@end] end module First_order = struct type 'a t = 'a -> 'a [@@deriving_inline sexp] let _ = fun (_ : 'a t) -> () let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = fun _of_a__173_ -> Sexplib0.Sexp_conv.fun_of_sexp ;; let _ = t_of_sexp let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = fun _of_a__175_ _ -> Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore ;; let _ = sexp_of_t [@@@end] end module Second_order = struct type ('a, 'b) t = ('a -> 'a) -> ('a -> 'b) -> ('b -> 'b) -> 'a -> 'b [@@deriving_inline sexp] let _ = fun (_ : ('a, 'b) t) -> () let t_of_sexp : 'a 'b. (Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t = fun _of_a__176_ _of_b__177_ -> Sexplib0.Sexp_conv.fun_of_sexp ;; let _ = t_of_sexp let sexp_of_t : 'a 'b. ('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t = fun _of_a__179_ _of_b__180_ _ -> Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore ;; let _ = sexp_of_t [@@@end] end module Named_arguments = struct type t = ?a:int -> b:int -> int -> int [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (Sexplib0.Sexp_conv.fun_of_sexp : Sexplib0.Sexp.t -> t) let _ = t_of_sexp let sexp_of_t = (fun _ -> Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Gadt = struct type _ t = | A : _ option t | B : int -> int t | C : 'a list -> unit t [@@deriving_inline sexp_of] let _ = fun (_ : _ t) -> () let sexp_of_t : 'a__182_. ('a__182_ -> Sexplib0.Sexp.t) -> 'a__182_ t -> Sexplib0.Sexp.t = fun (type a__188_) : ((a__188_ -> Sexplib0.Sexp.t) -> a__188_ t -> Sexplib0.Sexp.t) -> fun _of_a__183_ -> function | A -> Sexplib0.Sexp.Atom "A" | B arg0__184_ -> let res0__185_ = sexp_of_int arg0__184_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__185_ ] | C arg0__186_ -> let res0__187_ = sexp_of_list (fun _ -> Sexplib0.Sexp.Atom "_") arg0__186_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "C"; res0__187_ ] ;; let _ = sexp_of_t [@@@end] end module Recursive_record_containing_variant = struct type t = { a : [ `A of t ] ; b : [ `B ] [@sexp_drop_default Poly.equal] [@default `B] } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let rec t_of_sexp = (let (default__191_ : [ `B ]) = `B in let error_source__190_ = "expansion.ml.Recursive_record_containing_variant.t" in fun x__207_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__190_ ~fields: (Field { name = "a" ; kind = Required ; conv = (fun sexp__206_ -> try match sexp__206_ with | Sexplib0.Sexp.Atom atom__199_ as _sexp__201_ -> (match atom__199_ with | "A" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__190_ _sexp__201_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__199_ :: sexp_args__202_) as _sexp__201_ -> (match atom__199_ with | "A" as _tag__203_ -> (match sexp_args__202_ with | [ arg0__204_ ] -> let res0__205_ = t_of_sexp arg0__204_ in `A res0__205_ | _ -> Sexplib0.Sexp_conv_error.ptag_incorrect_n_args error_source__190_ _tag__203_ _sexp__201_) | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__200_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__190_ sexp__200_ | Sexplib0.Sexp.List [] as sexp__200_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__190_ sexp__200_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__190_ sexp__206_) ; rest = Field { name = "b" ; kind = Default (fun () -> default__191_) ; conv = (fun sexp__197_ -> try match sexp__197_ with | Sexplib0.Sexp.Atom atom__193_ as _sexp__195_ -> (match atom__193_ with | "B" -> `B | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__193_ :: _) as _sexp__195_ -> (match atom__193_ with | "B" -> Sexplib0.Sexp_conv_error.ptag_no_args error_source__190_ _sexp__195_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__194_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__190_ sexp__194_ | Sexplib0.Sexp.List [] as sexp__194_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__190_ sexp__194_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__190_ sexp__197_) ; rest = Empty } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, ())) : t -> { a; b }) x__207_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let rec sexp_of_t = (let (default__214_ : [ `B ]) = `B and (drop_default__213_ : [ `B ] -> [ `B ] -> Stdlib.Bool.t) = Poly.equal in fun { a = a__209_; b = b__215_ } -> let bnds__208_ = ([] : _ Stdlib.List.t) in let bnds__208_ = if drop_default__213_ default__214_ b__215_ then bnds__208_ else ( let arg__217_ = (fun `B -> Sexplib0.Sexp.Atom "B") b__215_ in let bnd__216_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__217_ ] in (bnd__216_ :: bnds__208_ : _ Stdlib.List.t)) in let bnds__208_ = let arg__210_ = let (`A v__211_) = a__209_ in Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "A"; sexp_of_t v__211_ ] in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__210_ ] :: bnds__208_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__208_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Poly_record = struct type t = { a : 'a. 'a list ; b : 'b. 'b option ; c : 'c. 'c } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__219_ = "expansion.ml.Poly_record.t" in fun x__229_ -> let open struct type a__220_ = { a__220_ : 'a. 'a list } [@@unboxed] type b__221_ = { b__221_ : 'b. 'b option } [@@unboxed] type c__222_ = { c__222_ : 'c. 'c } [@@unboxed] end in Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__219_ ~fields: (Field { name = "a" ; kind = Required ; conv = (fun sexp__227_ -> { a__220_ = (let _a__228_ = Sexplib0.Sexp_conv_error.record_poly_field_value error_source__219_ in list_of_sexp _a__228_ sexp__227_) }) ; rest = Field { name = "b" ; kind = Required ; conv = (fun sexp__225_ -> { b__221_ = (let _b__226_ = Sexplib0.Sexp_conv_error.record_poly_field_value error_source__219_ in option_of_sexp _b__226_ sexp__225_) }) ; rest = Field { name = "c" ; kind = Required ; conv = (fun sexp__223_ -> { c__222_ = (let _c__224_ = Sexplib0.Sexp_conv_error.record_poly_field_value error_source__219_ in _c__224_ sexp__223_) }) ; rest = Empty } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | _ -> -1) ~allow_extra_fields:false ~create:(fun ({ a__220_ = a }, ({ b__221_ = b }, ({ c__222_ = c }, ()))) : t -> { a; b; c }) x__229_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__231_; b = b__234_; c = c__237_ } -> let bnds__230_ = ([] : _ Stdlib.List.t) in let bnds__230_ = let arg__238_ = let _of_c__239_ = Sexplib0.Sexp_conv.sexp_of_opaque in _of_c__239_ c__237_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__238_ ] :: bnds__230_ : _ Stdlib.List.t) in let bnds__230_ = let arg__235_ = let _of_b__236_ = Sexplib0.Sexp_conv.sexp_of_opaque in sexp_of_option _of_b__236_ b__234_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__235_ ] :: bnds__230_ : _ Stdlib.List.t) in let bnds__230_ = let arg__232_ = let _of_a__233_ = Sexplib0.Sexp_conv.sexp_of_opaque in sexp_of_list _of_a__233_ a__231_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__232_ ] :: bnds__230_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__230_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Record_with_defaults = struct type t = { a : int [@default 0] ; b : int [@default 0] [@sexp_drop_default.compare] ; c : int [@default 0] [@sexp_drop_default.equal] ; d : int [@default 0] [@sexp_drop_default.sexp] ; e : int [@default 0] [@sexp_drop_default ( = )] ; f : int [@sexp_drop_if ( = ) 0] } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let (default__242_ : int) = 0 and (default__243_ : int) = 0 and (default__244_ : int) = 0 and (default__245_ : int) = 0 and (default__246_ : int) = 0 in let error_source__241_ = "expansion.ml.Record_with_defaults.t" in fun x__247_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__241_ ~fields: (Field { name = "a" ; kind = Default (fun () -> default__246_) ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Default (fun () -> default__245_) ; conv = int_of_sexp ; rest = Field { name = "c" ; kind = Default (fun () -> default__244_) ; conv = int_of_sexp ; rest = Field { name = "d" ; kind = Default (fun () -> default__243_) ; conv = int_of_sexp ; rest = Field { name = "e" ; kind = Default (fun () -> default__242_) ; conv = int_of_sexp ; rest = Field { name = "f" ; kind = Required ; conv = int_of_sexp ; rest = Empty } } } } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | "d" -> 3 | "e" -> 4 | "f" -> 5 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, (d, (e, (f, ())))))) : t -> { a; b; c; d; e; f }) x__247_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (let (default__252_ : int) = 0 and (default__257_ : int) = 0 and (default__262_ : int) = 0 and (default__268_ : int) = 0 and (drop_default__267_ : int -> int -> Stdlib.Bool.t) = ( = ) and (drop_if__273_ : Stdlib.Unit.t -> int -> Stdlib.Bool.t) = fun () -> ( = ) 0 in fun { a = a__249_; b = b__253_; c = c__258_; d = d__263_; e = e__269_; f = f__274_ } -> let bnds__248_ = ([] : _ Stdlib.List.t) in let bnds__248_ = if (drop_if__273_ ()) f__274_ then bnds__248_ else ( let arg__276_ = sexp_of_int f__274_ in let bnd__275_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "f"; arg__276_ ] in (bnd__275_ :: bnds__248_ : _ Stdlib.List.t)) in let bnds__248_ = if drop_default__267_ default__268_ e__269_ then bnds__248_ else ( let arg__271_ = sexp_of_int e__269_ in let bnd__270_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "e"; arg__271_ ] in (bnd__270_ :: bnds__248_ : _ Stdlib.List.t)) in let bnds__248_ = let arg__265_ = sexp_of_int d__263_ in if Sexplib0.Sexp_conv.( = ) (sexp_of_int default__262_) arg__265_ then bnds__248_ else ( let bnd__264_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__265_ ] in (bnd__264_ :: bnds__248_ : _ Stdlib.List.t)) in let bnds__248_ = if [%equal: int] default__257_ c__258_ then bnds__248_ else ( let arg__260_ = sexp_of_int c__258_ in let bnd__259_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__260_ ] in (bnd__259_ :: bnds__248_ : _ Stdlib.List.t)) in let bnds__248_ = if [%compare.equal: int] default__252_ b__253_ then bnds__248_ else ( let arg__255_ = sexp_of_int b__253_ in let bnd__254_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__255_ ] in (bnd__254_ :: bnds__248_ : _ Stdlib.List.t)) in let bnds__248_ = let arg__250_ = sexp_of_int a__249_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__250_ ] :: bnds__248_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__248_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Record_with_special_types = struct type t = { a : int option [@sexp.option] ; b : int list [@sexp.list] ; c : int array [@sexp.array] ; d : bool [@sexp.bool] } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__284_ = "expansion.ml.Record_with_special_types.t" in fun x__285_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__284_ ~fields: (Field { name = "a" ; kind = Sexp_option ; conv = int_of_sexp ; rest = Field { name = "b" ; kind = Sexp_list ; conv = int_of_sexp ; rest = Field { name = "c" ; kind = Sexp_array ; conv = int_of_sexp ; rest = Field { name = "d"; kind = Sexp_bool; conv = (); rest = Empty } } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | "d" -> 3 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, (d, ())))) : t -> { a; b; c; d }) x__285_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__287_; b = b__292_; c = c__296_; d = d__299_ } -> let bnds__286_ = ([] : _ Stdlib.List.t) in let bnds__286_ = if d__299_ then ( let bnd__300_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d" ] in (bnd__300_ :: bnds__286_ : _ Stdlib.List.t)) else bnds__286_ in let bnds__286_ = if match c__296_ with | [||] -> true | _ -> false then bnds__286_ else ( let arg__298_ = (sexp_of_array sexp_of_int) c__296_ in let bnd__297_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__298_ ] in (bnd__297_ :: bnds__286_ : _ Stdlib.List.t)) in let bnds__286_ = if match b__292_ with | [] -> true | _ -> false then bnds__286_ else ( let arg__294_ = (sexp_of_list sexp_of_int) b__292_ in let bnd__293_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__294_ ] in (bnd__293_ :: bnds__286_ : _ Stdlib.List.t)) in let bnds__286_ = match a__287_ with | Stdlib.Option.None -> bnds__286_ | Stdlib.Option.Some v__288_ -> let arg__290_ = sexp_of_int v__288_ in let bnd__289_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__290_ ] in (bnd__289_ :: bnds__286_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__286_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Record_with_omit_nil = struct type t = { a : int option [@sexp.omit_nil] ; b : int list [@sexp.omit_nil] ; c : unit [@sexp.omit_nil] ; d : int [@sexp.omit_nil] } [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__302_ = "expansion.ml.Record_with_omit_nil.t" in fun x__303_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__302_ ~fields: (Field { name = "a" ; kind = Omit_nil ; conv = option_of_sexp int_of_sexp ; rest = Field { name = "b" ; kind = Omit_nil ; conv = list_of_sexp int_of_sexp ; rest = Field { name = "c" ; kind = Omit_nil ; conv = unit_of_sexp ; rest = Field { name = "d" ; kind = Omit_nil ; conv = int_of_sexp ; rest = Empty } } } }) ~index_of_field:(function | "a" -> 0 | "b" -> 1 | "c" -> 2 | "d" -> 3 | _ -> -1) ~allow_extra_fields:false ~create:(fun (a, (b, (c, (d, ())))) : t -> { a; b; c; d }) x__303_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__305_; b = b__307_; c = c__309_; d = d__311_ } -> let bnds__304_ = ([] : _ Stdlib.List.t) in let bnds__304_ = match sexp_of_int d__311_ with | Sexplib0.Sexp.List [] -> bnds__304_ | arg__312_ -> (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__312_ ] :: bnds__304_ : _ Stdlib.List.t) in let bnds__304_ = match sexp_of_unit c__309_ with | Sexplib0.Sexp.List [] -> bnds__304_ | arg__310_ -> (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__310_ ] :: bnds__304_ : _ Stdlib.List.t) in let bnds__304_ = match sexp_of_list sexp_of_int b__307_ with | Sexplib0.Sexp.List [] -> bnds__304_ | arg__308_ -> (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__308_ ] :: bnds__304_ : _ Stdlib.List.t) in let bnds__304_ = match sexp_of_option sexp_of_int a__305_ with | Sexplib0.Sexp.List [] -> bnds__304_ | arg__306_ -> (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__306_ ] :: bnds__304_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__304_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Variant_with_sexp_list = struct type t = A of int list [@sexp.list] [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__315_ = "expansion.ml.Variant_with_sexp_list.t" in function | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom (("a" | "A") as _tag__318_) :: sexp_args__319_) as _sexp__317_ -> A (Sexplib0.Sexp_conv.list_map int_of_sexp sexp_args__319_) | Sexplib0.Sexp.Atom ("a" | "A") as sexp__316_ -> Sexplib0.Sexp_conv_error.stag_takes_args error_source__315_ sexp__316_ | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__314_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__315_ sexp__314_ | Sexplib0.Sexp.List [] as sexp__314_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__315_ sexp__314_ | sexp__314_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__315_ sexp__314_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun (A l__320_) -> Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "A" :: Sexplib0.Sexp_conv.list_map sexp_of_int l__320_) : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Poly_variant_with_sexp_list = struct type t = [ `A of int list [@sexp.list] ] [@@deriving_inline sexp] let _ = fun (_ : t) -> () let __t_of_sexp__ = (let error_source__327_ = "expansion.ml.Poly_variant_with_sexp_list.t" in function | Sexplib0.Sexp.Atom atom__322_ as _sexp__324_ -> (match atom__322_ with | "A" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__327_ _sexp__324_ | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__322_ :: sexp_args__325_) as _sexp__324_ -> (match atom__322_ with | "A" as _tag__326_ -> `A (Sexplib0.Sexp_conv.list_map int_of_sexp sexp_args__325_) | _ -> Sexplib0.Sexp_conv_error.no_variant_match ()) | Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__323_ -> Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__327_ sexp__323_ | Sexplib0.Sexp.List [] as sexp__323_ -> Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__327_ sexp__323_ : Sexplib0.Sexp.t -> t) ;; let _ = __t_of_sexp__ let t_of_sexp = (let error_source__329_ = "expansion.ml.Poly_variant_with_sexp_list.t" in fun sexp__328_ -> try __t_of_sexp__ sexp__328_ with | Sexplib0.Sexp_conv_error.No_variant_match -> Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__329_ sexp__328_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun (`A l__330_) -> Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "A" :: Sexplib0.Sexp_conv.list_map sexp_of_int l__330_) : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Record_allowing_extra_fields = struct type t = { a : int } [@@allow_extra_fields] [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (let error_source__332_ = "expansion.ml.Record_allowing_extra_fields.t" in fun x__333_ -> Sexplib0.Sexp_conv_record.record_of_sexp ~caller:error_source__332_ ~fields:(Field { name = "a"; kind = Required; conv = int_of_sexp; rest = Empty }) ~index_of_field:(function | "a" -> 0 | _ -> -1) ~allow_extra_fields:true ~create:(fun (a, ()) : t -> { a }) x__333_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun { a = a__335_ } -> let bnds__334_ = ([] : _ Stdlib.List.t) in let bnds__334_ = let arg__336_ = sexp_of_int a__335_ in (Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__336_ ] :: bnds__334_ : _ Stdlib.List.t) in Sexplib0.Sexp.List bnds__334_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end module Opaque = struct type t = (int[@sexp.opaque]) list [@@deriving_inline sexp] let _ = fun (_ : t) -> () let t_of_sexp = (fun x__338_ -> list_of_sexp Sexplib0.Sexp_conv.opaque_of_sexp x__338_ : Sexplib0.Sexp.t -> t) ;; let _ = t_of_sexp let sexp_of_t = (fun x__339_ -> sexp_of_list Sexplib0.Sexp_conv.sexp_of_opaque x__339_ : t -> Sexplib0.Sexp.t) ;; let _ = sexp_of_t [@@@end] end ppx_sexp_conv-0.17.0/test/expansion.mli000066400000000000000000000164341461647336100202030ustar00rootroot00000000000000open! Base module Abstract : sig type t [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Tuple : sig type t = int * int * int [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Record : sig type t = { a : int ; b : int ; c : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Mutable_record : sig type t = { mutable a : int ; mutable b : int ; mutable c : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Variant : sig type t = | A | B of int * int | C of { a : int ; b : int ; d : int } | D of { mutable a : int ; mutable b : int ; mutable t : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_variant : sig type t = [ `A | `B of int ] [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] val sexp_of_t : t -> Sexplib0.Sexp.t val t_of_sexp : Sexplib0.Sexp.t -> t val __t_of_sexp__ : Sexplib0.Sexp.t -> t end [@@ocaml.doc "@inline"] [@@@end] end module Inline_poly_variant : sig type t = [ Poly_variant.t | `C of int * int ] [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] val sexp_of_t : t -> Sexplib0.Sexp.t val t_of_sexp : Sexplib0.Sexp.t -> t val __t_of_sexp__ : Sexplib0.Sexp.t -> t end [@@ocaml.doc "@inline"] [@@@end] end module Recursive : sig type t = | Banana of t | Orange [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Nonrecursive : sig open Recursive type nonrec t = t [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Mutually_recursive : sig type a = | A | B of b | C of { a : a ; b : b ; c : c } and b = { a : a ; b : b } and c = a [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] val sexp_of_a : a -> Sexplib0.Sexp.t val sexp_of_b : b -> Sexplib0.Sexp.t val sexp_of_c : c -> Sexplib0.Sexp.t val a_of_sexp : Sexplib0.Sexp.t -> a val b_of_sexp : Sexplib0.Sexp.t -> b val c_of_sexp : Sexplib0.Sexp.t -> c end [@@ocaml.doc "@inline"] [@@@end] end module Alias : sig type t = Recursive.t [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Re_export : sig type t = Recursive.t = | Banana of t | Orange [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Unary : sig type 'a t = 'a list option [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S1 with type 'a t := 'a t end [@@ocaml.doc "@inline"] [@@@end] end module Binary : sig type ('a, 'b) t = ('a, 'b) Either.t [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t end [@@ocaml.doc "@inline"] [@@@end] end module First_order : sig type 'a t = 'a -> 'a [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S1 with type 'a t := 'a t end [@@ocaml.doc "@inline"] [@@@end] end module Second_order : sig type ('a, 'b) t = ('a -> 'a) -> ('a -> 'b) -> ('b -> 'b) -> 'a -> 'b [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S2 with type ('a, 'b) t := ('a, 'b) t end [@@ocaml.doc "@inline"] [@@@end] end module Named_arguments : sig type t = ?a:int -> b:int -> int -> int [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Gadt : sig type _ t = | A : _ option t | B : int -> int t | C : 'a list -> unit t [@@deriving_inline sexp_of] include sig [@@@ocaml.warning "-32"] val sexp_of_t : ('a__001_ -> Sexplib0.Sexp.t) -> 'a__001_ t -> Sexplib0.Sexp.t end [@@ocaml.doc "@inline"] [@@@end] end module Recursive_record_containing_variant : sig type t = { a : [ `A of t ] ; b : [ `B ] } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_record : sig type t = { a : 'a. 'a list ; b : 'b. 'b option ; c : 'c. 'c } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Record_with_defaults : sig type t = { a : int ; b : int ; c : int ; d : int ; e : int ; f : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Record_with_special_types : sig type t = { a : int option ; b : int list ; c : int array ; d : bool } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Record_with_omit_nil : sig type t = { a : int option ; b : int list ; c : unit ; d : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Variant_with_sexp_list : sig type t = A of int list [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Poly_variant_with_sexp_list : sig type t = [ `A of int list ] [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] val sexp_of_t : t -> Sexplib0.Sexp.t val t_of_sexp : Sexplib0.Sexp.t -> t val __t_of_sexp__ : Sexplib0.Sexp.t -> t end [@@ocaml.doc "@inline"] [@@@end] end module Record_allowing_extra_fields : sig type t = { a : int } [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module Opaque : sig type t = int list [@@deriving_inline sexp] include sig [@@@ocaml.warning "-32"] include Sexplib0.Sexpable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end ppx_sexp_conv-0.17.0/test/lib/000077500000000000000000000000001461647336100162325ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/test/lib/conv_test.ml000066400000000000000000000037451461647336100206010ustar00rootroot00000000000000open Ppx_sexp_conv_lib open Conv let%test_module "Exceptions" = (module 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.Arg0" let%test_unit _ = check_sexp (Arg1 1) "(conv_test.ml.Arg1 1)" let%test_unit _ = check_sexp (Arg2 (2, 3)) "(conv_test.ml.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.E 1)"; check_sexp e_string "(conv_test.ml.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.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.17.0/test/lib/conv_test.mli000066400000000000000000000000551461647336100207410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/lib/dune000066400000000000000000000002141461647336100171050ustar00rootroot00000000000000(library (name ppx_sexp_conv_lib_test) (libraries ppx_sexp_conv_lib) (preprocess (pps ppxlib ppx_sexp_conv ppx_here ppx_inline_test))) ppx_sexp_conv-0.17.0/test/nonrec_test.ml000066400000000000000000000041571461647336100203500ustar00rootroot00000000000000open 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.17.0/test/ppx_sexp_test.ml000066400000000000000000000613371461647336100207350ustar00rootroot00000000000000open Ppx_sexp_conv_lib open Conv (* Module names below are used in error messages being tested. *) [@@@warning "-unused-module"] 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] 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 : natural_option Sexplib0.Sexp_grammar.t = { untyped = Union [ List Empty; Integer ] } ;; 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 ( Printf.printf "%S vs %S\n%!" (Sexp.to_string sexp) str; assert false) ;; (* 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 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 (type k1 k2) (module K1 : Of_sexpable with type t = k1) (module K2 : Of_sexpable with type t = k2) = [%sexp_grammar: (K1.t * K2.t) 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 ppx_sexp_conv-0.17.0/test/ppx_sexp_test.mli000066400000000000000000000000001461647336100210620ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/test/sexp_grammar/000077500000000000000000000000001461647336100201515ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/test/sexp_grammar/dune000066400000000000000000000007511461647336100210320ustar00rootroot00000000000000(library (name ppx_sexp_conv_test_sexp_grammar) (libraries base expect_test_helpers_core.expect_test_helpers_base sexp_grammar) (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.17.0/test/sexp_grammar/test_allow_extra_fields.ml000066400000000000000000000066321461647336100254200ustar00rootroot00000000000000open! Base module _ = struct type t = { a : int } [@@sexp.allow_extra_fields] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = true ; fields = [ No_tag { name = "a" ; required = true ; args = Cons (int_sexp_grammar.untyped, Empty) } ] }))) } ;; let _ = t_sexp_grammar [@@@end] end module _ = struct type t = { a : int } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "a" ; required = true ; args = Cons (int_sexp_grammar.untyped, Empty) } ] }))) } ;; let _ = t_sexp_grammar [@@@end] end module _ = 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 : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Allow_extra_fields" ; clause_kind = List_clause { args = Fields { allow_extra_fields = true ; fields = [ No_tag { name = "foo" ; required = true ; args = Cons (int_sexp_grammar.untyped, Empty) } ] } } } ; No_tag { name = "Forbid_extra_fields" ; clause_kind = List_clause { args = Fields { allow_extra_fields = false ; fields = [ No_tag { name = "bar" ; required = true ; args = Cons (int_sexp_grammar.untyped, Empty) } ] } } } ] })) } ;; let _ = t_sexp_grammar [@@@end] let _ = Allow_extra_fields { foo = 1 } let _ = Forbid_extra_fields { bar = 1 } end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_allow_extra_fields.mli000066400000000000000000000000551461647336100255620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_attributes.ml000066400000000000000000000054651461647336100237420ustar00rootroot00000000000000open! Base module type S = sig type t [@@deriving sexp_grammar] end let show_grammar (module M : S) = Expect_test_helpers_base.print_s ([%sexp_of: _ Sexp_grammar.t] [%sexp_grammar: M.t]) ;; module Grammarless = struct type t = [ `A | `B of string ] end let the_grammar = [%sexp_grammar: [ `A | `B of string ]] let%expect_test "[@sexp_grammar.custom] in [@@deriving]" = show_grammar (module struct type t = (Grammarless.t[@sexp_grammar.custom the_grammar]) * int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Cons ( (the_grammar : Grammarless.t Sexplib0.Sexp_grammar.t).untyped , Cons (int_sexp_grammar.untyped, Empty) )))) } ;; let _ = t_sexp_grammar [@@@end] end); [%expect {| (List ( Cons (Variant ( (case_sensitivity Case_sensitive) (clauses ( (No_tag ( (name A) (clause_kind Atom_clause))) (No_tag ( (name B) (clause_kind (List_clause (args (Cons String Empty)))))))))) (Cons Integer Empty))) |}] ;; let%expect_test "[@sexp_grammar.custom] in [%sexp_grammar]" = show_grammar (module struct type t = Grammarless.t * int let t_sexp_grammar = [%sexp_grammar: (Grammarless.t[@sexp_grammar.custom the_grammar]) * int] ;; end); [%expect {| (List ( Cons (Variant ( (case_sensitivity Case_sensitive) (clauses ( (No_tag ( (name A) (clause_kind Atom_clause))) (No_tag ( (name B) (clause_kind (List_clause (args (Cons String Empty)))))))))) (Cons Integer Empty))) |}] ;; let%expect_test "[@sexp_grammar.any] in [@@deriving]" = show_grammar (module struct type t = (Grammarless.t[@sexp_grammar.any "GRAMMARLESS"]) * (Grammarless.t[@sexp_grammar.any]) [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = List (Cons (Any "GRAMMARLESS", Cons (Any "ANY", Empty))) } ;; let _ = t_sexp_grammar [@@@end] end); [%expect {| (List (Cons (Any GRAMMARLESS) (Cons (Any ANY) Empty))) |}] ;; let%expect_test "[@sexp_grammar.any] in [%sexp_grammar]" = show_grammar (module struct type t = Grammarless.t * Grammarless.t let t_sexp_grammar = [%sexp_grammar: (Grammarless.t[@sexp_grammar.any "GRAMMARLESS"]) * (Grammarless.t[@sexp_grammar.any])] ;; end); [%expect {| (List (Cons (Any GRAMMARLESS) (Cons (Any ANY) Empty))) |}] ;; ppx_sexp_conv-0.17.0/test/sexp_grammar/test_attributes.mli000066400000000000000000000000551461647336100241010ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_base_map.ml000066400000000000000000000012751461647336100233160ustar00rootroot00000000000000open! Base module type S = sig type t [@@deriving sexp_grammar] end 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 (type a) (module Key : S with type t = a) v_sexp_grammar = t_sexp_grammar Key.t_sexp_grammar v_sexp_grammar ;; end type t = string Pair.M(Key).t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Pair.m__t_sexp_grammar (module Key) string_sexp_grammar).untyped) } ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_base_map.mli000066400000000000000000000000551461647336100234620ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_coverage_for_deriving.ml000066400000000000000000000421171461647336100260770ustar00rootroot00000000000000open Ppx_sexp_conv_lib.Conv [@@@warning "-37"] (* allow unused constructors *) type abstract_a [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : abstract_a) -> () let (abstract_a_sexp_grammar : abstract_a Sexplib0.Sexp_grammar.t) = { untyped = Any "Test_coverage_for_deriving.abstract_a" } ;; let _ = abstract_a_sexp_grammar [@@@end] type abstract_b [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : abstract_b) -> () let (abstract_b_sexp_grammar : abstract_b Sexplib0.Sexp_grammar.t) = { untyped = Any "Test_coverage_for_deriving.abstract_b" } ;; let _ = abstract_b_sexp_grammar [@@@end] type integer = int [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : integer) -> () let (integer_sexp_grammar : integer Sexplib0.Sexp_grammar.t) = int_sexp_grammar let _ = integer_sexp_grammar [@@@end] type tuple = int * string [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : tuple) -> () let (tuple_sexp_grammar : tuple Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Cons (int_sexp_grammar.untyped, Cons (string_sexp_grammar.untyped, Empty))))) } ;; let _ = tuple_sexp_grammar [@@@end] type pos = { x : float ; y : float } [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : pos) -> () let (pos_sexp_grammar : pos Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "x" ; required = true ; args = Cons (float_sexp_grammar.untyped, Empty) } ; No_tag { name = "y" ; required = true ; args = Cons (float_sexp_grammar.untyped, Empty) } ] }))) } ;; let _ = pos_sexp_grammar [@@@end] type 'a unary = 'a list [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a unary) -> () let unary_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a unary Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar ;; let _ = unary_sexp_grammar [@@@end] type enum = | One | Two | Three [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : enum) -> () let (enum_sexp_grammar : enum Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "One"; clause_kind = Atom_clause } ; No_tag { name = "Two"; clause_kind = Atom_clause } ; No_tag { name = "Three"; clause_kind = Atom_clause } ] } } ;; let _ = enum_sexp_grammar [@@@end] type ('a, 'b) which = | This of 'a | That of 'b [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : ('a, 'b) which) -> () let which_sexp_grammar : 'a 'b. 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) which Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "This" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ; No_tag { name = "That" ; clause_kind = List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) } } ] } } ;; let _ = which_sexp_grammar [@@@end] type 'a optional = | No | Yes of 'a [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a optional) -> () let optional_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a optional Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "No"; clause_kind = Atom_clause } ; No_tag { name = "Yes" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ] } } ;; let _ = optional_sexp_grammar [@@@end] type empty = | [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : empty) -> () let (empty_sexp_grammar : empty Sexplib0.Sexp_grammar.t) = { untyped = Union [] } let _ = empty_sexp_grammar [@@@end] type _ phantom = int [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : _ phantom) -> () let phantom_sexp_grammar : 'a__086_. 'a__086_ Sexplib0.Sexp_grammar.t -> 'a__086_ phantom Sexplib0.Sexp_grammar.t = fun _'a__086__sexp_grammar -> int_sexp_grammar ;; let _ = phantom_sexp_grammar [@@@end] type color = [ `Red | `Blue ] [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : color) -> () let (color_sexp_grammar : color Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "Red"; clause_kind = Atom_clause } ; No_tag { name = "Blue"; clause_kind = Atom_clause } ] } } ;; let _ = color_sexp_grammar [@@@end] type adjective = [ color | `Fast | `Slow | `Count of int ] [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : adjective) -> () let (adjective_sexp_grammar : adjective Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Union [ color_sexp_grammar.untyped ; Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "Fast"; clause_kind = Atom_clause } ; No_tag { name = "Slow"; clause_kind = Atom_clause } ; No_tag { name = "Count" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ] } ])) } ;; let _ = adjective_sexp_grammar [@@@end] type 'a tree = { data : 'a ; children : 'a tree list } [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a tree) -> () include struct open struct let (grammars__118_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let tree_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Recursive ("tree", [ _'a_sexp_grammar.untyped ]) } in [ { tycon = "tree" ; tyvars = [ "a" ] ; grammar = List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "data" ; required = true ; args = Cons (Tyvar "a", Empty) } ; No_tag { name = "children" ; required = true ; args = Cons ( (list_sexp_grammar (tree_sexp_grammar { untyped = Tyvar "a" })) .untyped , Empty ) } ] }) } ]) ;; let _ = grammars__118_ end let tree_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tycon ("tree", [ _'a_sexp_grammar.untyped ], Stdlib.Lazy.force grammars__118_) } ;; let _ = tree_sexp_grammar end [@@@end] type alpha = int and beta = { alpha : alpha ; betas : beta list } and gamma = beta list [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : alpha) -> () let _ = fun (_ : beta) -> () let _ = fun (_ : gamma) -> () include struct open struct let (grammars__131_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let (alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t) = { untyped = Recursive ("alpha", []) } and (beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t) = { untyped = Recursive ("beta", []) } in [ { tycon = "alpha"; tyvars = []; grammar = int_sexp_grammar.untyped } ; { tycon = "beta" ; tyvars = [] ; grammar = List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "alpha" ; required = true ; args = Cons (alpha_sexp_grammar.untyped, Empty) } ; No_tag { name = "betas" ; required = true ; args = Cons ((list_sexp_grammar beta_sexp_grammar).untyped, Empty) } ] }) } ]) ;; let _ = grammars__131_ end let (alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Tycon ("alpha", [], Stdlib.Lazy.force grammars__131_))) } and (beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Tycon ("beta", [], Stdlib.Lazy.force grammars__131_))) } ;; let _ = alpha_sexp_grammar and _ = beta_sexp_grammar end let (gamma_sexp_grammar : gamma Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (list_sexp_grammar beta_sexp_grammar).untyped) } ;; let _ = gamma_sexp_grammar [@@@end] type record_attributes = { a : int [@default 0] ; b : bool [@sexp.bool] ; c : float option [@sexp.option] ; d : string list [@sexp.list] ; e : bytes array [@sexp.array] ; f : Ppx_sexp_conv_lib.Sexp.t [@sexp.omit_nil] } [@@sexp.allow_extra_fields] [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : record_attributes) -> () let (record_attributes_sexp_grammar : record_attributes Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = true ; fields = [ No_tag { name = "a" ; required = false ; args = Cons (int_sexp_grammar.untyped, Empty) } ; No_tag { name = "b"; required = false; args = Empty } ; No_tag { name = "c" ; required = false ; args = Cons (float_sexp_grammar.untyped, Empty) } ; No_tag { name = "d" ; required = false ; args = Cons (List (Many string_sexp_grammar.untyped), Empty) } ; No_tag { name = "e" ; required = false ; args = Cons (List (Many bytes_sexp_grammar.untyped), Empty) } ; No_tag { name = "f" ; required = false ; args = Cons (Ppx_sexp_conv_lib.Sexp.t_sexp_grammar.untyped, Empty) } ] }))) } ;; let _ = record_attributes_sexp_grammar [@@@end] type variant_attributes = | A | B of int list [@sexp.list] | C of { a : int [@default 0] ; b : bool [@sexp.bool] ; c : float option [@sexp.option] ; d : string list [@sexp.list] ; e : bytes array [@sexp.array] ; f : Ppx_sexp_conv_lib.Sexp.t [@sexp.omit_nil] } [@sexp.allow_extra_fields] [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : variant_attributes) -> () let (variant_attributes_sexp_grammar : variant_attributes Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "A"; clause_kind = Atom_clause } ; No_tag { name = "B" ; clause_kind = List_clause { args = Many int_sexp_grammar.untyped } } ; No_tag { name = "C" ; clause_kind = List_clause { args = Fields { allow_extra_fields = true ; fields = [ No_tag { name = "a" ; required = false ; args = Cons (int_sexp_grammar.untyped, Empty) } ; No_tag { name = "b"; required = false; args = Empty } ; No_tag { name = "c" ; required = false ; args = Cons (float_sexp_grammar.untyped, Empty) } ; No_tag { name = "d" ; required = false ; args = Cons ( List (Many string_sexp_grammar.untyped) , Empty ) } ; No_tag { name = "e" ; required = false ; args = Cons ( List (Many bytes_sexp_grammar.untyped) , Empty ) } ; No_tag { name = "f" ; required = false ; args = Cons ( Ppx_sexp_conv_lib.Sexp.t_sexp_grammar .untyped , Empty ) } ] } } } ] })) } ;; let _ = variant_attributes_sexp_grammar [@@@end] type polymorphic_variant_attributes = [ `A | `B of int list [@sexp.list] ] [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : polymorphic_variant_attributes) -> () let (polymorphic_variant_attributes_sexp_grammar : polymorphic_variant_attributes Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "A"; clause_kind = Atom_clause } ; No_tag { name = "B" ; clause_kind = List_clause { args = Many int_sexp_grammar.untyped } } ] })) } ;; let _ = polymorphic_variant_attributes_sexp_grammar [@@@end] type opaque = { x : (string[@sexp.opaque]) ; y : int -> int } [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : opaque) -> () let (opaque_sexp_grammar : opaque Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "x" ; required = true ; args = Cons (Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped, Empty) } ; No_tag { name = "y" ; required = true ; args = Cons (Sexplib0.Sexp_conv.fun_sexp_grammar.untyped, Empty) } ] }))) } ;; let _ = opaque_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_coverage_for_deriving.mli000066400000000000000000000122111461647336100262400ustar00rootroot00000000000000(** This file covers a lot of cases for [@@deriving], for both interface and implementation. They are also exported for validation. *) type abstract_a [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val abstract_a_sexp_grammar : abstract_a Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type abstract_b [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val abstract_b_sexp_grammar : abstract_b Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type integer = int [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val integer_sexp_grammar : integer Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type tuple = int * string [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val tuple_sexp_grammar : tuple Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type pos = { x : float ; y : float } [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val pos_sexp_grammar : pos Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type 'a unary = 'a list [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val unary_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a unary Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type enum = | One | Two | Three [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val enum_sexp_grammar : enum Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type ('a, 'b) which = | This of 'a | That of 'b [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val which_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) which Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type 'a optional = | No | Yes of 'a [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val optional_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a optional Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type empty = | [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val empty_sexp_grammar : empty Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type _ phantom = int [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val phantom_sexp_grammar : 'a__003_ Sexplib0.Sexp_grammar.t -> 'a__003_ phantom Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type color = [ `Red | `Blue ] [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val color_sexp_grammar : color Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type adjective = [ color | `Fast | `Slow | `Count of int ] [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val adjective_sexp_grammar : adjective Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type 'a tree = { data : 'a ; children : 'a tree list } [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val tree_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type alpha = int and beta = { alpha : alpha ; betas : beta list } and gamma = beta list [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t val beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t val gamma_sexp_grammar : gamma Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type record_attributes = { a : int ; b : bool ; c : float option ; d : string list ; e : bytes array ; f : Ppx_sexp_conv_lib.Sexp.t } [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val record_attributes_sexp_grammar : record_attributes Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type variant_attributes = | A | B of int list | C of { a : int ; b : bool ; c : float option ; d : string list ; e : bytes array ; f : Ppx_sexp_conv_lib.Sexp.t } [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val variant_attributes_sexp_grammar : variant_attributes Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type polymorphic_variant_attributes = [ `A | `B of int list ] [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val polymorphic_variant_attributes_sexp_grammar : polymorphic_variant_attributes Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] type opaque = { x : string ; y : int -> int } [@@deriving sexp] [@@deriving_inline sexp_grammar] include sig [@@@ocaml.warning "-32"] val opaque_sexp_grammar : opaque Sexplib0.Sexp_grammar.t end [@@ocaml.doc "@inline"] [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_extension.ml000066400000000000000000000011451461647336100235570ustar00rootroot00000000000000open! 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 _ (M : S) : sig val t_sexp_grammar : int Map.M(String).t Sexplib0.Sexp_grammar.t [@@warning "-32"] end = M (* The grammar is illegible, so just make sure it builds. *) let (_ : _ Sexplib0.Sexp_grammar.t) = [%sexp_grammar: int Map.M(String).t] (* This used to give a compilation error. *) let (_ : _ Sexplib0.Sexp_grammar.t) = [%sexp_grammar: _ list] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_extension.mli000066400000000000000000000000551461647336100237270ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_functors.ml000066400000000000000000000110311461647336100234010ustar00rootroot00000000000000open! Base module Maybe = struct type 'a t = 'a option [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> option_sexp_grammar _'a_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) -> () include struct open struct let (grammars__001_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Recursive ("t", [ _'a_sexp_grammar.untyped ]) } and u_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Recursive ("u", [ _'a_sexp_grammar.untyped ]) } in [ { tycon = "t" ; tyvars = [ "a" ] ; grammar = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons ( (u_sexp_grammar (T.t_sexp_grammar { untyped = Tyvar "a" })) .untyped , Empty ) } } ] } } ; { tycon = "u" ; tyvars = [ "a" ] ; grammar = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "U" ; clause_kind = List_clause { args = Cons ( (Maybe.t_sexp_grammar (t_sexp_grammar (T.t_sexp_grammar { untyped = Tyvar "a" }))) .untyped , Empty ) } } ] } } ]) ;; let _ = grammars__001_ end let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tycon ("t", [ _'a_sexp_grammar.untyped ], Stdlib.Lazy.force grammars__001_) } and u_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tycon ("u", [ _'a_sexp_grammar.untyped ], Stdlib.Lazy.force grammars__001_) } ;; let _ = t_sexp_grammar and _ = u_sexp_grammar end [@@@end] type 'a v = V of 'a t [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a v) -> () let v_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a v Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "V" ; clause_kind = List_clause { args = Cons ((t_sexp_grammar _'a_sexp_grammar).untyped, Empty) } } ] } } ;; 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 : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Cons ( (T2.t_sexp_grammar int_sexp_grammar).untyped , Cons ((T1.t_sexp_grammar int_sexp_grammar).untyped, Empty) )))) } ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_functors.mli000066400000000000000000000000551461647336100235560ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_gadt.ml000066400000000000000000000036201461647336100224620ustar00rootroot00000000000000open! Base type t = T : ('a[@sexp.opaque]) -> t [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped, Empty) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] type nullary = Nullary : nullary [@@deriving sexp] [@@deriving_inline sexp_grammar] let _ = fun (_ : nullary) -> () let (nullary_sexp_grammar : nullary Sexplib0.Sexp_grammar.t) = { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Nullary"; clause_kind = Atom_clause } ] } } ;; let _ = nullary_sexp_grammar [@@@end] (* We can't derive [of_sexp], but we can derive a sensible grammar for this type. *) type _ grammar_only = Grammar_only : int -> string grammar_only [@@warning "-37"] [@@deriving_inline sexp_grammar] let _ = fun (_ : _ grammar_only) -> () let grammar_only_sexp_grammar : 'a__016_. 'a__016_ Sexplib0.Sexp_grammar.t -> 'a__016_ grammar_only Sexplib0.Sexp_grammar.t = fun _'a__016__sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Grammar_only" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ] } } ;; let _ = grammar_only_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_gadt.mli000066400000000000000000000000551461647336100226320ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_nonrec.ml000066400000000000000000000006061461647336100230300ustar00rootroot00000000000000open! Base open struct type t = int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar let _ = t_sexp_grammar [@@@end] end type nonrec t = t [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = t_sexp_grammar let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_nonrec.mli000066400000000000000000000000551461647336100231770ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_opaque.ml000066400000000000000000000004521461647336100230350ustar00rootroot00000000000000open! Base type t = (int[@sexp.opaque]) list [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (list_sexp_grammar Sexplib0.Sexp_conv.opaque_sexp_grammar).untyped) } ;; let _ = t_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_opaque.mli000066400000000000000000000000551461647336100232050ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_polymorphic_variants.ml000066400000000000000000000077521461647336100260310ustar00rootroot00000000000000open Base [@@@warning "-37"] module _ = struct type 'a t = [ `A | `B ] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "A"; clause_kind = Atom_clause } ; No_tag { name = "B"; clause_kind = Atom_clause } ] } } ;; let _ = t_sexp_grammar [@@@end] end module _ = 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 : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "A" ; clause_kind = List_clause { args = Cons ( List (Cons ( int_sexp_grammar.untyped , Cons (int_sexp_grammar.untyped, Empty) )) , Empty ) } } ; No_tag { name = "B" ; clause_kind = List_clause { args = Cons (string_sexp_grammar.untyped, Empty) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] open Expect_test_helpers_base 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 _ = struct module With_sexp = struct type t = [ `Int of int | `List of int list | `Sexp_dot_list of int list [@sexp.list] ] [@@deriving sexp] end type t = [ `Int of int | `List of int list | `Sexp_dot_list of int list [@sexp.list] ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "Int" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ; No_tag { name = "List" ; clause_kind = List_clause { args = Cons ((list_sexp_grammar int_sexp_grammar).untyped, Empty) } } ; No_tag { name = "Sexp_dot_list" ; clause_kind = List_clause { args = Many int_sexp_grammar.untyped } } ] })) } ;; let _ = t_sexp_grammar [@@@end] let (T : (With_sexp.t, t) Type_equal.t) = T open Expect_test_helpers_base 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))); [%expect {| (Int 1) (List ()) (Sexp_dot_list) (List (1)) (Sexp_dot_list 1) (List (1 2)) (Sexp_dot_list 1 2) |}] ;; end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_polymorphic_variants.mli000066400000000000000000000000551461647336100261670ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_polymorphic_variants.mlt000066400000000000000000000040751461647336100262100ustar00rootroot00000000000000(* 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. *) open Base type t = [ `A of int & string ] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: unsupported: polymorphic variant intersection type |}] type t = [ `A of int & string ] [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: sexp_grammar: intersection types are unsupported |}] type t = [> `A ] [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: Type unsupported for ppx [of_sexp] conversion |}] type t = [> `A ] [@@deriving sexp_grammar] [%%expect {| Line _, characters _-_: Error: sexp_grammar: open polymorphic variant types are unsupported |}] 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: A type variable is unbound in this type declaration. In type [< `A ] as 'a the variable 'a is unbound |}] 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: sexp_grammar: type aliases are unsupported |}] type a = A : [> ] -> a [@@deriving sexp] [%%expect {| Line _, characters _-_: Error: Type unsupported for ppx [of_sexp] conversion |}] type a = A : [> ] -> a [@@deriving sexp_of] [%%expect {| Line _, characters _-_: Error: Type unsupported for ppx [sexp_of] conversion |}] type a = [ `A ] [@@deriving sexp];; #verbose true let f = [%sexp_of: [< a ]] [%%expect {| val f : [< a ] -> Sexp.t = |}] let f = [%of_sexp: [> a ]] [%%expect {| Line _, characters _-_: Error: Type unsupported for ppx [of_sexp] conversion |}] let f = [%of_sexp: [ | a ]] [%%expect {| val f : Sexp.t -> a = |}] ;; #verbose false ppx_sexp_conv-0.17.0/test/sexp_grammar/test_polymorphism.ml000066400000000000000000000014431461647336100243060ustar00rootroot00000000000000open! 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 : 'a 'b__001_ 'b. 'a Sexplib0.Sexp_grammar.t -> 'b__001_ Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b__001_, 'b) t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b__001__sexp_grammar _'b_sexp_grammar -> { untyped = List (Cons (_'a_sexp_grammar.untyped, Cons (_'b_sexp_grammar.untyped, Empty))) } ;; let _ = t_sexp_grammar let (u_sexp_grammar : u Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (t_sexp_grammar string_sexp_grammar int_sexp_grammar float_sexp_grammar).untyped) } ;; let _ = u_sexp_grammar [@@@end] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_polymorphism.mli000066400000000000000000000000551461647336100244550ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_recursive_groups.ml000066400000000000000000000062271461647336100251570ustar00rootroot00000000000000open Base [@@@warning "-37"] module _ = struct type t = T of int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] end module _ = 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) -> () include struct open struct let (grammars__001_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Recursive ("t", []) } and (u_sexp_grammar : u Sexplib0.Sexp_grammar.t) = { untyped = Recursive ("u", []) } in [ { tycon = "t" ; tyvars = [] ; grammar = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "T_int" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ; No_tag { name = "T_u" ; clause_kind = List_clause { args = Cons (u_sexp_grammar.untyped, Empty) } } ] } } ; { tycon = "u" ; tyvars = [] ; grammar = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "U_int" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ; No_tag { name = "U_t" ; clause_kind = List_clause { args = Cons (t_sexp_grammar.untyped, Empty) } } ] } } ]) ;; let _ = grammars__001_ end let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Tycon ("t", [], Stdlib.Lazy.force grammars__001_))) } and (u_sexp_grammar : u Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Tycon ("u", [], Stdlib.Lazy.force grammars__001_))) } ;; let _ = t_sexp_grammar and _ = u_sexp_grammar end [@@@end] end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_recursive_groups.mli000066400000000000000000000000551461647336100253210ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_regular_variants.ml000066400000000000000000000076031461647336100251200ustar00rootroot00000000000000open Base [@@@warning "-37"] module _ = struct type 'a t = | A | B [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "A"; clause_kind = Atom_clause } ; No_tag { name = "B"; clause_kind = Atom_clause } ] } } ;; let _ = t_sexp_grammar [@@@end] end module _ = 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 : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "A" ; clause_kind = List_clause { args = Cons ( int_sexp_grammar.untyped , Cons (int_sexp_grammar.untyped, Empty) ) } } ; No_tag { name = "B" ; clause_kind = List_clause { args = Cons (string_sexp_grammar.untyped, Empty) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] open Expect_test_helpers_base 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 _ = struct module With_sexp = struct type t = | Int of int | List of int list | Sexp_dot_list of int list [@sexp.list] [@@deriving sexp] end type t = With_sexp.t = | Int of int | List of int list | Sexp_dot_list of int list [@sexp.list] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "Int" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ; No_tag { name = "List" ; clause_kind = List_clause { args = Cons ((list_sexp_grammar int_sexp_grammar).untyped, Empty) } } ; No_tag { name = "Sexp_dot_list" ; clause_kind = List_clause { args = Many int_sexp_grammar.untyped } } ] })) } ;; let _ = t_sexp_grammar [@@@end] let (T : (With_sexp.t, t) Type_equal.t) = T open Expect_test_helpers_base 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))); [%expect {| (Int 1) (List ()) (Sexp_dot_list) (List (1)) (Sexp_dot_list 1) (List (1 2)) (Sexp_dot_list 1 2) |}] ;; end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_regular_variants.mli000066400000000000000000000000551461647336100252630ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_tag_type_names.ml000066400000000000000000000107651461647336100245520ustar00rootroot00000000000000open! Base module _ = struct (* Nonrecursive constant *) type t = [ `T of int ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] end module _ = struct (* Recursive constant *) type t = [ `T of t ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () include struct open struct let (grammars__001_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Recursive ("t", []) } in [ { tycon = "t" ; tyvars = [] ; grammar = Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (t_sexp_grammar.untyped, Empty) } } ] } } ]) ;; let _ = grammars__001_ end let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Tycon ("t", [], Stdlib.Lazy.force grammars__001_))) } ;; let _ = t_sexp_grammar end [@@@end] end module _ = struct (* Nonrecursive parameterized *) type 'a t = [ `T of 'a ] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ] } } ;; let _ = t_sexp_grammar [@@@end] end module _ = struct (* Recursive parameterized *) type 'a t = [ `T of 'a t ] [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () include struct open struct let (grammars__002_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t) = lazy (let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Recursive ("t", [ _'a_sexp_grammar.untyped ]) } in [ { tycon = "t" ; tyvars = [ "a" ] ; grammar = Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons ( (t_sexp_grammar { untyped = Tyvar "a" }).untyped , Empty ) } } ] } } ]) ;; let _ = grammars__002_ end let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Tycon ("t", [ _'a_sexp_grammar.untyped ], Stdlib.Lazy.force grammars__002_) } ;; let _ = t_sexp_grammar end [@@@end] end module _ = struct (* Aliasing of non-parameterized type *) type t = int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar let _ = t_sexp_grammar [@@@end] end module _ = struct (* Aliasing of parameterized type *) type 'a t = 'a list [@@deriving_inline sexp_grammar] let _ = fun (_ : 'a t) -> () let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_tag_type_names.mli000066400000000000000000000000551461647336100247120ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_tags.ml000066400000000000000000000325301461647336100225030ustar00rootroot00000000000000open Base module _ = struct module type S = sig type t [@@deriving sexp_grammar] end let show_grammar (module M : S) = Expect_test_helpers_base.print_s ([%sexp_of: _ Sexp_grammar.t] [%sexp_grammar: M.t]) ;; let%expect_test "basic" = show_grammar (module struct type nonrec t = (unit[@tag "key" = Atom "value"]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key key) (value value) (grammar (List Empty)))) |}] ;; let%expect_test "tag ordering" = show_grammar (module struct type nonrec t = (unit [@tag "key1" = Atom "value1"; "key2" = Atom "value2"]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key key1) (value value1) (grammar ( Tagged ( (key key2) (value value2) (grammar (List Empty))))))) |}] ;; let%expect_test "tag idents/expressions" = show_grammar (module struct let k = "key" let v = Sexp.Atom "value" let kf () = k let vf () = v type nonrec t = (unit [@tag k = v; kf () = vf ()]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key key) (value value) (grammar ( Tagged ( (key key) (value value) (grammar (List Empty))))))) |}] ;; let%expect_test "tag nesting" = show_grammar (module struct type nonrec t' = (unit[@sexp_grammar.tag "inner" = Atom "inner value"]) [@@deriving sexp_grammar] type nonrec t = (t'[@sexp_grammar.tag "outer" = Atom "outer value"]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key outer) (value "outer value") (grammar ( Tagged ( (key inner) (value "inner value") (grammar (List Empty))))))) |}] ;; let%expect_test "@tags attribute" = (* literal constant *) show_grammar (module struct type t = (unit[@tags [ "y", Atom "Y"; "z", Atom "Z" ]]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key y) (value Y) (grammar ( Tagged ( (key z) (value Z) (grammar (List Empty))))))) |}]; (* non-constant expression *) show_grammar (module struct type t = (unit [@tags List.concat [ [ "x", Sexp.Atom "X" ]; [ "y", Atom "Y"; "z", Atom "Z" ] ]]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key x) (value X) (grammar ( Tagged ( (key y) (value Y) (grammar ( Tagged ( (key z) (value Z) (grammar (List Empty)))))))))) |}]; (* cons onto non-constant expression *) show_grammar (module struct type t = (unit [@tags ("w", Sexp.Atom "W") :: List.concat [ [ "x", Sexp.Atom "X" ]; [ "y", Atom "Y"; "z", Atom "Z" ] ]]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key w) (value W) (grammar ( Tagged ( (key x) (value X) (grammar ( Tagged ( (key y) (value Y) (grammar ( Tagged ( (key z) (value Z) (grammar (List Empty))))))))))))) |}]; (* empty *) show_grammar (module struct type t = (unit[@tags List.concat []]) [@@deriving sexp_grammar] end); [%expect {| (List Empty) |}]; (* with [@tag] *) show_grammar (module struct type t = (unit[@tag "a" = Atom "A"] [@tags [ "b", Atom "B" ]]) [@@deriving sexp_grammar] end); [%expect {| (Tagged ( (key a) (value A) (grammar ( Tagged ( (key b) (value B) (grammar (List Empty))))))) |}] ;; let%expect_test "doc comments - variant clauses" = show_grammar (module struct [@@@ocaml.warning "-37"] (** IGNORED *) type t = | Clause0 of (unit[@tag "k0" = Atom "v0"]) (** first clause *) | Clause1 [@tag "k1" = Atom "v1"] (** second clause *) [@@deriving sexp_grammar ~tags_of_doc_comments] (** IGNORED *) end); [%expect {| (Variant ( (case_sensitivity Case_sensitive_except_first_character) (clauses ( (Tag ( (key sexp_grammar.doc_comment) (value " first clause ") (grammar ( No_tag ( (name Clause0) (clause_kind ( List_clause ( args ( Cons (Tagged ( (key k0) (value v0) (grammar (List Empty)))) Empty))))))))) (Tag ( (key sexp_grammar.doc_comment) (value " second clause ") (grammar ( Tag ( (key k1) (value v1) (grammar ( No_tag ( (name Clause1) (clause_kind Atom_clause))))))))))))) |}] ;; let%expect_test "doc comments - poly variant clauses" = show_grammar (module struct [@@@ocaml.warning "-37"] (** IGNORED *) type t = ([ `Clause0 of (unit[@tag "k0" = Atom "v0"]) (** first clause *) | `Clause1 [@tag "k1" = Atom "v1"] (** second clause *) ] [@tag "kouter" = Atom "vouter"]) [@@deriving sexp_grammar ~tags_of_doc_comments] (** IGNORED *) end); [%expect {| (Tagged ( (key kouter) (value vouter) (grammar ( Variant ( (case_sensitivity Case_sensitive) (clauses ( (Tag ( (key sexp_grammar.doc_comment) (value " first clause ") (grammar ( No_tag ( (name Clause0) (clause_kind ( List_clause ( args ( Cons (Tagged ( (key k0) (value v0) (grammar (List Empty)))) Empty))))))))) (Tag ( (key sexp_grammar.doc_comment) (value " second clause ") (grammar ( Tag ( (key k1) (value v1) (grammar ( No_tag ( (name Clause1) (clause_kind Atom_clause)))))))))))))))) |}] ;; let%expect_test "doc comments - record fields" = show_grammar (module struct (** IGNORED *) type t = { field0 : (unit[@tag "k0" = Atom "v0"]) (** first field *) ; field1 : unit [@tag "k1" = Atom "v1"] (** second field *) } [@@deriving sexp_grammar ~tags_of_doc_comments] (** IGNORED *) end); [%expect {| (List ( Fields ( (allow_extra_fields false) (fields ( (Tag ( (key sexp_grammar.doc_comment) (value " first field ") (grammar ( No_tag ( (name field0) (required true) (args ( Cons (Tagged ( (key k0) (value v0) (grammar (List Empty)))) Empty))))))) (Tag ( (key sexp_grammar.doc_comment) (value " second field ") (grammar ( Tag ( (key k1) (value v1) (grammar ( No_tag ( (name field1) (required true) (args (Cons (List Empty) Empty))))))))))))))) |}] ;; let%expect_test "deriving sexp_grammar without tags_of_doc_comments" = show_grammar (module struct type t = { field : unit (** IGNORED *) } [@@deriving sexp_grammar] end); [%expect {| (List ( Fields ( (allow_extra_fields false) (fields (( No_tag ( (name field) (required true) (args (Cons (List Empty) Empty))))))))) |}] ;; let%expect_test "doc comments on subexpressions" = show_grammar (module struct [@@@ocaml.warning "-37"] type t = Foo of { bar : int (** inner *) } (** outer *) [@@deriving sexp_grammar ~tags_of_doc_comments] end); [%expect {| (Variant ( (case_sensitivity Case_sensitive_except_first_character) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " outer ") (grammar ( No_tag ( (name Foo) (clause_kind ( List_clause ( args ( Fields ( (allow_extra_fields false) (fields (( Tag ( (key sexp_grammar.doc_comment) (value " inner ") (grammar ( No_tag ( (name bar) (required true) (args (Cons Integer Empty))))))))))))))))))))))) |}]; show_grammar (module struct [@@@ocaml.warning "-37"] type t = [ `A of [ `B (** inner *) ] (** outer *) ] [@@deriving sexp_grammar ~tags_of_doc_comments] end); [%expect {| (Variant ( (case_sensitivity Case_sensitive) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " outer ") (grammar ( No_tag ( (name A) (clause_kind ( List_clause ( args ( Cons (Variant ( (case_sensitivity Case_sensitive) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " inner ") (grammar ( No_tag ( (name B) (clause_kind Atom_clause)))))))))) Empty))))))))))))) |}]; show_grammar (module struct [@@@ocaml.warning "-37"] type t = { a : [ `B of int (** inner *) ] (** outer *) } [@@deriving sexp_grammar ~tags_of_doc_comments] end); [%expect {| (List ( Fields ( (allow_extra_fields false) (fields (( Tag ( (key sexp_grammar.doc_comment) (value " outer ") (grammar ( No_tag ( (name a) (required true) (args ( Cons (Variant ( (case_sensitivity Case_sensitive) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " inner ") (grammar ( No_tag ( (name B) (clause_kind (List_clause (args (Cons Integer Empty))))))))))))) Empty)))))))))))) |}]; show_grammar (module struct [@@@ocaml.warning "-37"] type t = [ `A of [ `B (** inner *) ] option (** outer *) ] [@@deriving sexp_grammar ~tags_of_doc_comments] end); [%expect {| (Variant ( (case_sensitivity Case_sensitive) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " outer ") (grammar ( No_tag ( (name A) (clause_kind ( List_clause ( args ( Cons (Option ( Variant ( (case_sensitivity Case_sensitive) (clauses (( Tag ( (key sexp_grammar.doc_comment) (value " inner ") (grammar ( No_tag ( (name B) (clause_kind Atom_clause))))))))))) Empty))))))))))))) |}] ;; end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_tags.mli000066400000000000000000000000571461647336100226530ustar00rootroot00000000000000(* This interface intentionally left empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_tags.mlt000066400000000000000000000023511461647336100226650ustar00rootroot00000000000000open Ppx_sexp_conv_lib open Conv;; #verbose true module No_keys = struct type t = (unit[@sexp_grammar.tag]) [@@deriving sexp_grammar] end [%%expect {| Line _, characters _-_: Error: :: expected |}] module Key_literal_is_not_string = struct type t = (unit[@sexp_grammar.tag 1 = [%sexp ""]]) [@@deriving sexp_grammar] end [%%expect {| Line _, characters _-_: Error: This expression has type int but an expression was expected of type string |}] module Key_ident_is_not_string = struct let k = 1 type t = (unit[@sexp_grammar.tag k = [%sexp ""]]) [@@deriving sexp_grammar] end [%%expect {| Line _, characters _-_: Error: This expression has type int but an expression was expected of type string |}] module Value_literal_is_not_sexp = struct type t = (unit[@sexp_grammar.tag "key" = 1]) [@@deriving sexp_grammar] end [%%expect {| Line _, characters _-_: Error: This expression has type int but an expression was expected of type Sexp.t |}] module Value_ident_is_not_sexp = struct let v = 1 type t = (unit[@sexp_grammar.tag "key" = v]) [@@deriving sexp_grammar] end [%%expect {| Line _, characters _-_: Error: This expression has type int but an expression was expected of type Sexp.t |}] ppx_sexp_conv-0.17.0/test/sexp_grammar/test_test.ml000066400000000000000000000041011461647336100225150ustar00rootroot00000000000000open! Base module _ = struct type t = int [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar let _ = t_sexp_grammar [@@@deriving.end] end module _ = 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 : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "T" ; clause_kind = List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) } } ] } } ;; let _ = t_sexp_grammar let u_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar -> { untyped = Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "U" ; clause_kind = List_clause { args = Cons ( (option_sexp_grammar (t_sexp_grammar _'a_sexp_grammar)) .untyped , Empty ) } } ] } } ;; let _ = u_sexp_grammar [@@@deriving.end] (* Avoid unused constructor warnings. *) let _ = T () let _ = U None end module _ = struct type ('a, 'b) t = 'a -> 'b [@@deriving_inline sexp_grammar] let _ = fun (_ : ('a, 'b) t) -> () let t_sexp_grammar : 'a 'b. 'a Sexplib0.Sexp_grammar.t -> 'b Sexplib0.Sexp_grammar.t -> ('a, 'b) t Sexplib0.Sexp_grammar.t = fun _'a_sexp_grammar _'b_sexp_grammar -> Sexplib0.Sexp_conv.fun_sexp_grammar ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_test.mli000066400000000000000000000000551461647336100226720ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_sexp_conv-0.17.0/test/sexp_grammar/test_variants_more.ml000066400000000000000000000060461461647336100244210ustar00rootroot00000000000000open Base [@@@warning "-37"] module _ = struct type t = A of [ `A of int ] [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (Variant { case_sensitivity = Case_sensitive_except_first_character ; clauses = [ No_tag { name = "A" ; clause_kind = List_clause { args = Cons ( Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "A" ; clause_kind = List_clause { args = Cons ( int_sexp_grammar.untyped , Empty ) } } ] } , Empty ) } } ] })) } ;; let _ = t_sexp_grammar [@@@end] end module _ = struct type t = { a : [ `A of int ] } [@@deriving_inline sexp_grammar] let _ = fun (_ : t) -> () let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = { untyped = Lazy (lazy (List (Fields { allow_extra_fields = false ; fields = [ No_tag { name = "a" ; required = true ; args = Cons ( Variant { case_sensitivity = Case_sensitive ; clauses = [ No_tag { name = "A" ; clause_kind = List_clause { args = Cons (int_sexp_grammar.untyped, Empty) } } ] } , Empty ) } ] }))) } ;; let _ = t_sexp_grammar [@@@end] end ppx_sexp_conv-0.17.0/test/sexp_grammar/test_variants_more.mli000066400000000000000000000000001461647336100245520ustar00rootroot00000000000000ppx_sexp_conv-0.17.0/test/test.sexp000066400000000000000000000006561461647336100173530ustar00rootroot00000000000000(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")