My working unpac space for OCaml projects in development
Merge opam/patches/ppx_sexp_conv
+14588
+1
vendor/opam/ppx_sexp_conv/.ocamlformat
+1
vendor/opam/ppx_sexp_conv/.ocamlformat
···
1
+
profile=janestreet
+54
vendor/opam/ppx_sexp_conv/CHANGES.md
+54
vendor/opam/ppx_sexp_conv/CHANGES.md
···
1
+
## v0.11
2
+
3
+
- Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and
4
+
ppx\_metaquot.
5
+
6
+
## v0.10
7
+
8
+
- Added new `[@@deriving sexp]` record-field attribute, `[@sexp.omit_nil]`, for
9
+
a field that is omitted if its sexp representation is `()`.
10
+
11
+
- Improved `[%sexp_of: 'a]` and `[%of_sexp: 'a]` to not expose variable names
12
+
intended for internal use.
13
+
14
+
## v0.9
15
+
16
+
## 113.43.00
17
+
18
+
- Fix generator for polymorphic types where var names clashes with type name: `type 't t = ...`
19
+
20
+
## 113.33.00
21
+
22
+
- Clean up the documentation for sexplib, modernizing it to include
23
+
`ppx_sexp_conv`, and breaking up the documentation between sexplib and
24
+
`ppx_sexp_conv`. Also changed the formatting to use org-mode, so it
25
+
will render properly on github. Markdown doesn't render well by
26
+
default, unless you use quite different conventions about linebeaks.
27
+
28
+
## 113.24.00
29
+
30
+
- Trying to improve the tests in ppx\_sexp\_conv because they are a mess.
31
+
At least all tests are automatic now. And more things are tested like
32
+
the sexpification of exceptions.
33
+
34
+
- Update to follow `Type_conv` and `Ppx_core` evolution.
35
+
36
+
- Make ppx\_sexp\_conv correctly handle aliases to polymorphic variants:
37
+
38
+
type t = ` `A ` `@@deriving sexp`
39
+
type u = t `@@deriving sexp`
40
+
type v = ` u | `B ` `@@deriving sexp`
41
+
42
+
Before, `v_of_sexp` would never manage to read `B. This problem is
43
+
now fixed if you use `sexp_poly` on `u` instead of `sexp`, and if you
44
+
don't, you get an "unbound value __u_of_sexp__". People should use
45
+
`sexp_poly` when they have a polymorphic variant type that is not
46
+
syntactically a polymorphic variant, but in practice it's simpler to
47
+
replace `sexp` by `sexp_poly` when faced with the error above.
48
+
49
+
The need for `sexp_poly` should happen only in one new case: an
50
+
implementation says `type u = t `@@deriving sexp`` but the interface
51
+
says `type u = ``A` `@@deriving sexp``. (the old case where it was
52
+
already needed is when you have an interface that says `type u = t
53
+
`@@deriving sexp`` and in some other implementation you try to say
54
+
`type t = ` That_module.t | `A ` `@@deriving sexp``).
+67
vendor/opam/ppx_sexp_conv/CONTRIBUTING.md
+67
vendor/opam/ppx_sexp_conv/CONTRIBUTING.md
···
1
+
This repository contains open source software that is developed and
2
+
maintained by [Jane Street][js].
3
+
4
+
Contributions to this project are welcome and should be submitted via
5
+
GitHub pull requests.
6
+
7
+
Signing contributions
8
+
---------------------
9
+
10
+
We require that you sign your contributions. Your signature certifies
11
+
that you wrote the patch or otherwise have the right to pass it on as
12
+
an open-source patch. The rules are pretty simple: if you can certify
13
+
the below (from [developercertificate.org][dco]):
14
+
15
+
```
16
+
Developer Certificate of Origin
17
+
Version 1.1
18
+
19
+
Copyright (C) 2004, 2006 The Linux Foundation and its contributors.
20
+
1 Letterman Drive
21
+
Suite D4700
22
+
San Francisco, CA, 94129
23
+
24
+
Everyone is permitted to copy and distribute verbatim copies of this
25
+
license document, but changing it is not allowed.
26
+
27
+
28
+
Developer's Certificate of Origin 1.1
29
+
30
+
By making a contribution to this project, I certify that:
31
+
32
+
(a) The contribution was created in whole or in part by me and I
33
+
have the right to submit it under the open source license
34
+
indicated in the file; or
35
+
36
+
(b) The contribution is based upon previous work that, to the best
37
+
of my knowledge, is covered under an appropriate open source
38
+
license and I have the right under that license to submit that
39
+
work with modifications, whether created in whole or in part
40
+
by me, under the same open source license (unless I am
41
+
permitted to submit under a different license), as indicated
42
+
in the file; or
43
+
44
+
(c) The contribution was provided directly to me by some other
45
+
person who certified (a), (b) or (c) and I have not modified
46
+
it.
47
+
48
+
(d) I understand and agree that this project and the contribution
49
+
are public and that a record of the contribution (including all
50
+
personal information I submit with it, including my sign-off) is
51
+
maintained indefinitely and may be redistributed consistent with
52
+
this project or the open source license(s) involved.
53
+
```
54
+
55
+
Then you just add a line to every git commit message:
56
+
57
+
```
58
+
Signed-off-by: Joe Smith <joe.smith@email.com>
59
+
```
60
+
61
+
Use your real name (sorry, no pseudonyms or anonymous contributions.)
62
+
63
+
If you set your `user.name` and `user.email` git configs, you can sign
64
+
your commit automatically with git commit -s.
65
+
66
+
[dco]: http://developercertificate.org/
67
+
[js]: https://opensource.janestreet.com/
+21
vendor/opam/ppx_sexp_conv/LICENSE.md
+21
vendor/opam/ppx_sexp_conv/LICENSE.md
···
1
+
The MIT License
2
+
3
+
Copyright (c) 2015--2025 Jane Street Group, LLC <opensource-contacts@janestreet.com>
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy
6
+
of this software and associated documentation files (the "Software"), to deal
7
+
in the Software without restriction, including without limitation the rights
8
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9
+
copies of the Software, and to permit persons to whom the Software is
10
+
furnished to do so, subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21
+
SOFTWARE.
+17
vendor/opam/ppx_sexp_conv/Makefile
+17
vendor/opam/ppx_sexp_conv/Makefile
···
1
+
INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
2
+
3
+
default:
4
+
dune build
5
+
6
+
install:
7
+
dune install $(INSTALL_ARGS)
8
+
9
+
uninstall:
10
+
dune uninstall $(INSTALL_ARGS)
11
+
12
+
reinstall: uninstall install
13
+
14
+
clean:
15
+
dune clean
16
+
17
+
.PHONY: default install uninstall reinstall clean
+621
vendor/opam/ppx_sexp_conv/README.org
+621
vendor/opam/ppx_sexp_conv/README.org
···
1
+
#+TITLE: ppx_sexp_conv
2
+
3
+
* [@@deriving sexp]
4
+
5
+
=ppx_sexp_conv= is a PPX syntax extension that generates code for
6
+
converting OCaml types to and from s-expressions, as defined in the
7
+
[[https://github.com/janestreet/sexplib][=sexplib=]] library. S-expressions are defined by the following type:
8
+
9
+
#+begin_src ocaml
10
+
type sexp = Atom of string | List of sexp list
11
+
#+end_src
12
+
13
+
and are rendered as parenthesized lists of strings, /e.g./ =(This (is
14
+
an) (s expression))=.
15
+
16
+
=ppx_sexp_conv= fits into the [[https://github.com/whitequark/ppx_deriving][=ppx_deriving=]] framework, so you can
17
+
invoke it the same way you invoke any other deriving plug-in. Thus,
18
+
we can write
19
+
20
+
#+begin_src ocaml
21
+
type int_pair = (int * int) [@@deriving sexp]
22
+
#+end_src
23
+
24
+
to get two values defined automatically, =sexp_of_int_pair= and
25
+
=int_pair_of_sexp=. If we only want one direction, we can write one
26
+
of the following.
27
+
28
+
#+begin_src ocaml
29
+
type int_pair = (int * int) [@@deriving sexp_of]
30
+
type int_pair = (int * int) [@@deriving of_sexp]
31
+
#+end_src
32
+
33
+
These sexp-converters depend on having a set of converters for basic
34
+
values (/e.g./, =int_of_sexp=) already in scope. This can be done by
35
+
writing:
36
+
37
+
#+begin_src ocaml
38
+
open Sexplib.Std
39
+
#+end_src
40
+
41
+
If you're using [[https://github.com/janestreet/core][=Core=]], you can get the same effect with =open Core=.
42
+
43
+
It's also possible to construct converters based on type expressions,
44
+
/i.e./:
45
+
46
+
#+begin_src ocaml
47
+
[%sexp_of: (int * string) list] [1,"one"; 2,"two"]
48
+
|> Sexp.to_string;;
49
+
=> "((1 one) (2 two))"
50
+
51
+
[%sexp_of: (int * string) list] [1,"one"; 2,"two"]
52
+
|> [%of_sexp: (int * string) list];;
53
+
=> [1,"one"; 2,"two"]
54
+
#+end_src
55
+
56
+
For =%sexp_of=, we can also omit the conversion of some types by
57
+
putting underscores for that type name.
58
+
59
+
#+begin_src ocaml
60
+
[%sexp_of: (int * _) list] [1,"one"; 2,"two"]
61
+
|> Sexp.to_string;;
62
+
=> "((1 _)(2 _))"
63
+
#+end_src
64
+
65
+
Converters for the implicit unboxed version of a record can be derived with the =~unboxed=
66
+
flag. For example,
67
+
68
+
#+begin_src ocaml
69
+
type t = { x : int } [@@deriving sexp ~unboxed]
70
+
#+end_src
71
+
72
+
will give us =sexp_of_t= and =t_of_sexp=, as expected, along with
73
+
=t_u_of_sexp : sexp -> t#= and =sexp_of_t_u : t# -> sexp=.
74
+
75
+
* [@@deriving sexp_grammar]
76
+
77
+
If =ppx_sexp_conv= can derive =of_sexp=, it can also generate a description of
78
+
the sexps that the resulting =t_of_sexp= would accept. This is the sexp grammar.
79
+
See =Sexplib0.Sexp_grammar= for details. Use =[@@deriving sexp_grammar]= to derive
80
+
the grammar for a type.
81
+
82
+
It is possible to construct sexp grammars directly from type expressions, e.g.,
83
+
84
+
#+BEGIN_SRC ocaml
85
+
[%sexp_grammar: (int, bool array) Either.t Base.Map.M(String).t]
86
+
#+END_SRC
87
+
88
+
** Tagging grammars
89
+
90
+
Use =[@sexp_grammar.tag key = value]=, where =(key : string)= and =(value :
91
+
Sexp.t)=, to annotate a grammar with a tag that can be inspected at runtime.
92
+
93
+
** Custom grammars
94
+
95
+
Use =[@sexp_grammar.custom grammar]= to override a type's sexp grammar with
96
+
=grammar=.
97
+
98
+
** Stub grammars
99
+
100
+
Annotate a type with =[@sexp_grammar.any]= to use a stub grammar that accepts
101
+
any sexp. Alternately, write =[@sexp_grammar.any desc]= where =(desc : string)=
102
+
to use =desc= as a human-readable description for the stub grammar.
103
+
104
+
* Conversion rules
105
+
106
+
In the following, we'll review the serialization rules for different
107
+
OCaml types.
108
+
109
+
** Basic types
110
+
111
+
Basic types are represented as atoms. For numbers like =int=,
112
+
=int32=, =int64=, =float=, the string in the atom is what is accepted
113
+
the standard ocaml functions =int_of_string=, =Int32.of_string=, etc.
114
+
For the types =char= or =string=, the string in the atom is
115
+
respectively a one character string or the string itself.
116
+
117
+
** Lists and arrays
118
+
119
+
OCaml-lists and arrays are represented as s-expression lists.
120
+
121
+
** Tuples and unit
122
+
123
+
OCaml tuples are treated as lists of values in the same order as in
124
+
the tuple. The type =unit= is treated like a 0-tuple. /e.g./:
125
+
126
+
#+begin_src ocaml
127
+
(3.14, "foo", "bar bla", 27) => (3.14 foo "bar bla" 27)
128
+
#+end_src
129
+
130
+
** Options
131
+
132
+
With options, =None= is treated as a zero-element list, and =Some= is
133
+
treated as a singleton list, as shown below.
134
+
135
+
#+begin_src ocaml
136
+
None => ()
137
+
Some value => (value)
138
+
#+end_src
139
+
140
+
We also support reading options following the ordinary rules for
141
+
variants /i.e./:
142
+
143
+
#+begin_src ocaml
144
+
None => None
145
+
Some value => (Some value)
146
+
#+end_src
147
+
148
+
The rules for variants are described below.
149
+
150
+
** Records
151
+
152
+
Records are represented as lists of lists, where each inner list is a
153
+
key-value pair. Each pair consists of the name of the record field
154
+
(first element), and its value (second element). /e.g./:
155
+
156
+
#+begin_src ocaml
157
+
{ foo = (3,4);
158
+
bar = "some string"; }
159
+
=> ((foo (3 4)) (bar "some string"))
160
+
#+end_src
161
+
162
+
Type specifications of records allow the use of several attributes. The
163
+
attribute =sexp.option= indicates that an =option= record field should be optional, while
164
+
the attribute =sexp.or_null= indicates that an =or_null= record field should be optional.
165
+
/e.g./:
166
+
167
+
#+begin_src ocaml
168
+
type t =
169
+
{ x : int option;
170
+
y : int option [@sexp.option];
171
+
z : int or_null [@sexp.or_null];
172
+
} [@@deriving sexp]
173
+
#+end_src
174
+
175
+
The following examples show how this works.
176
+
177
+
#+begin_src ocaml
178
+
{ x = Some 1; y = Some 2; } => ((x (1)) (y 2))
179
+
{ x = None ; y = None; } => ((x ()))
180
+
#+end_src
181
+
182
+
Note that, when present, an optional value is represented as the bare
183
+
value, rather than explicitly as an option.
184
+
185
+
The attribute =sexp.bool= indicates that a boolean record field is shown
186
+
as either present or absent, but not as containing a value.
187
+
188
+
#+begin_src ocaml
189
+
type t = { enabled : bool [@sexp.bool] } [@@deriving sexp]
190
+
191
+
{ enabled = true } => ((enabled))
192
+
{ enabled = false } => ()
193
+
#+end_src
194
+
195
+
The attributes =sexp.list= and =sexp.array= indicate that a list or array record
196
+
field, respectively, can be omitted when it is empty.
197
+
198
+
#+begin_src ocaml
199
+
type t =
200
+
{ arr : int array [@sexp.array]
201
+
; lst : int list [@sexp.list]
202
+
}
203
+
[@@deriving sexp]
204
+
205
+
{ arr = [||]; lst = [] } => ()
206
+
{ arr = [|1;2|]; lst = [3;4] } => ((arr (1 2)) (lst (3 4)))
207
+
#+end_src
208
+
209
+
*** Defaults
210
+
211
+
More complex default values can be specified explicitly using several
212
+
constructs, /e.g./:
213
+
214
+
#+begin_src ocaml
215
+
type t =
216
+
{ a : int [@default 42];
217
+
b : int [@default 3] [@sexp_drop_default (=)];
218
+
c : int [@default 3] [@sexp_drop_if fun x -> x = 3];
219
+
d : int Queue.t [@sexp.omit_nil]
220
+
} [@@deriving sexp]
221
+
#+end_src
222
+
223
+
The =@default= annotation lets one specify a default value to be
224
+
selected if the field is not specified, when converting from an
225
+
s-expression. The =@sexp_drop_default= annotation implies that the
226
+
field will be dropped when generating the s-expression if the value
227
+
being serialized is equal to the default according to the specified equality
228
+
function. =@sexp_drop_if= is like =@sexp_drop_default=, except that
229
+
it lets you specify the condition under which the field is dropped.
230
+
Finally, =@sexp.omit_nil= means to treat a missing field as if it
231
+
has value =List []= when reading, and drop the field if it has value
232
+
=List []= when writing.
233
+
234
+
**** Specifying equality for [@sexp_drop_default]
235
+
236
+
The equality used by [@sexp_drop_default] is customizable. There
237
+
are several ways to specify the equality function:
238
+
239
+
#+begin_src ocaml
240
+
type t =
241
+
{ a : u [@default u0] [@sexp_drop_default (=)]; (* explicit user-provided function *)
242
+
b : u [@default u0] [@sexp_drop_default.compare]; (* uses [%compare.equal: u] *)
243
+
c : u [@default u0] [@sexp_drop_default.equal]; (* uses [%equal: u] *)
244
+
d : u [@default u0] [@sexp_drop_default.sexp]; (* compares sexp representations *)
245
+
e : u [@default u0] [@sexp_drop_default]; (* deprecated. uses polymorphic equality. *)
246
+
} [@@deriving sexp]
247
+
#+end_src
248
+
249
+
*** Allowing extra fields
250
+
251
+
The =@sexp.allow_extra_fields= annotation lets one specify that the
252
+
sexp-converters should silently ignore extra fields, instead of
253
+
raising. This applies only to the record to which the annotation is
254
+
attached, and not to deeper sexp converters that may be called during
255
+
conversion of a sexp to the record.
256
+
257
+
#+begin_src ocaml
258
+
type t = { a: int } [@@deriving sexp]
259
+
((a 0)(b b)) => exception
260
+
261
+
type t = { a: int } [@@deriving sexp] [@@sexp.allow_extra_fields]
262
+
((a 0)(b b)) => {a = 0}
263
+
264
+
type t = A of { a : int } [@sexp.allow_extra_fields] [@@deriving sexp]
265
+
(A (a 0)(b b)) => A {a = 0}
266
+
#+end_src
267
+
268
+
** Variants
269
+
270
+
Constant constructors in variants are represented as
271
+
strings. Constructors with arguments are represented as lists, the
272
+
first element being the constructor name, the rest being its
273
+
arguments. Constructors may also be started in lowercase in
274
+
S-expressions, but will always be converted to uppercase when
275
+
converting from OCaml values.
276
+
277
+
For example:
278
+
279
+
#+begin_src ocaml
280
+
type t = A | B of int * float * t [@@deriving sexp]
281
+
B (42, 3.14, B (-1, 2.72, A)) => (B 42 3.14 (B -1 2.72 A))
282
+
#+end_src
283
+
284
+
The above example also demonstrates recursion in data structures.
285
+
286
+
Variants support the attribute =sexp.list= when a clause has a single
287
+
list as its argument.
288
+
289
+
#+begin_src ocaml
290
+
type t =
291
+
| A of int list
292
+
| B of int list [@sexp.list]
293
+
294
+
A [1; 2; 3] => (A (1 2 3))
295
+
B [1; 2; 3] => (B 1 2 3)
296
+
#+end_src
297
+
298
+
*** Inline records
299
+
300
+
Constructors with inline records are represented as lists, the first element
301
+
being the constructor name, the rest being the record fields, represented the
302
+
same way as in record types, but without being wrapped in an extra layer of
303
+
parentheses.
304
+
305
+
#+begin_src ocaml
306
+
type t = A of { x : int }
307
+
308
+
A { x = 8 } => (A (x 8))
309
+
#+end_src
310
+
311
+
** Polymorphic variants
312
+
313
+
Polymorphic variants behave almost the same as ordinary variants. The
314
+
notable difference is that polymorphic variant constructors must
315
+
always start with an either lower- or uppercase character, matching
316
+
the way it was specified in the type definition. This is because
317
+
OCaml distinguishes between upper and lowercase variant
318
+
constructors. Note that type specifications containing unions of
319
+
variant types are also supported by the S-expression converter, for
320
+
example as in:
321
+
322
+
#+begin_src ocaml
323
+
type ab = [ `A | `B ] [@@deriving sexp]
324
+
type cd = [ `C | `D ] [@@deriving sexp]
325
+
type abcd = [ ab | cd ] [@@deriving sexp]
326
+
#+end_src
327
+
328
+
However, because `ppx_sexp_conv` needs to generate additional code to
329
+
support inclusions of polymorphic variants, `ppx_sexp_conv` needs to
330
+
know when processing a type definition whether it might be included in
331
+
a polymorphic variant. `ppx_sexp_conv` will only generate the extra
332
+
code automatically in the common case where the type definition is
333
+
syntactically a polymorphic variant like in the example
334
+
above. Otherwise, you will need to indicate it by using `[@@deriving
335
+
sexp_poly]` (resp `of_sexp_poly`) instead of `[@@deriving sexp]` (resp
336
+
`of_sexp`):
337
+
338
+
#+begin_src ocaml
339
+
type ab = [ `A | `B ] [@@deriving sexp]
340
+
type alias_of_ab = ab [@@deriving sexp_poly]
341
+
type abcd = [ ab | `C | `D ] [@@deriving sexp]
342
+
#+end_src
343
+
344
+
** Polymorphic values
345
+
346
+
There is nothing special about polymorphic values as long as there are
347
+
conversion functions for the type parameters. /e.g./:
348
+
349
+
#+begin_src ocaml
350
+
type 'a t = A | B of 'a [@@deriving sexp]
351
+
type foo = int t [@@deriving sexp]
352
+
#+end_src
353
+
354
+
In the above case the conversion functions will behave as if =foo= had
355
+
been defined as a monomorphic version of =t= with ='a= replaced by
356
+
=int= on the right hand side.
357
+
358
+
If a data structure is indeed polymorphic and you want to convert it,
359
+
you will have to supply the conversion functions for the type
360
+
parameters at runtime. If you wanted to convert a value of type ='a
361
+
t= as in the above example, you would have to write something like
362
+
this:
363
+
364
+
#+begin_src ocaml
365
+
sexp_of_t sexp_of_a v
366
+
#+end_src
367
+
368
+
where =sexp_of_a=, which may also be named differently in this
369
+
particular case, is a function that converts values of type ='a= to an
370
+
S-expression. Types with more than one parameter require passing
371
+
conversion functions for those parameters in the order of their
372
+
appearance on the left hand side of the type definition.
373
+
374
+
** Opaque values
375
+
376
+
Opaque values are ones for which we do not want to perform
377
+
conversions. This may be, because we do not have S-expression
378
+
converters for them, or because we do not want to apply them in a
379
+
particular type context. /e.g./ to hide large, unimportant parts of
380
+
configurations. To prevent the preprocessor from generating calls to
381
+
converters, simply apply the attribute =sexp.opaque= to the type. If the type
382
+
is for a record field, it will likely need parentheses to avoid applying the
383
+
attribute to the record field itself, /e.g./:
384
+
385
+
#+begin_src ocaml
386
+
type foo = int * (stuff [@sexp.opaque]) [@@deriving sexp]
387
+
388
+
type bar =
389
+
{ a : int
390
+
; b : (stuff [@sexp.opaque])
391
+
}
392
+
[@@deriving sexp]
393
+
#+end_src
394
+
395
+
Thus, there is no need to specify converters for type =stuff=, and if
396
+
there are any, they will not be used in this particular context.
397
+
Needless to say, it is not possible to convert such an S-expression
398
+
back to the original value. Here is an example conversion:
399
+
400
+
#+begin_src ocaml
401
+
(42, some_stuff) => (42 <opaque>)
402
+
#+end_src
403
+
404
+
** Phantom parameters
405
+
406
+
Phantom type parameters are ones which are marked to not actually appear on the
407
+
right-hand side of the type definition, and are thus excluded from the derived
408
+
=sexp_of= and =of_sexp= combinators. To prevent the preprocessor from including
409
+
type parameters when deriving or calling combinators, add the attribute
410
+
=sexp.phantom= to the type parameter itself. Here is an example:
411
+
412
+
#+begin_src ocaml
413
+
type ('a[@sexp.phantom], 'b) index = 'b
414
+
[@@deriving sexp]
415
+
416
+
type 'a[@sexp.phantom] int_index = ('a[@sexp.phantom], int) index
417
+
[@@deriving sexp]
418
+
#+end_src
419
+
420
+
The derived functions will have the following types. Note that none of them take
421
+
a combinator for the phantom parameter as an argument.
422
+
423
+
#+begin_src ocaml
424
+
val sexp_of_index : ('b -> Sexp.t) -> ('a, 'b) index -> Sexp.t
425
+
val index_of_sexp : (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) index
426
+
427
+
val sexp_of_int_index : 'a int_index -> Sexp.t
428
+
val int_index_of_sexp : Sexp.t -> 'a int_index
429
+
#+end_src
430
+
431
+
** Exceptions
432
+
433
+
S-expression converters for exceptions can be automatically
434
+
registered.
435
+
436
+
#+begin_src ocaml
437
+
module M = struct
438
+
exception Foo of int [@@deriving sexp]
439
+
end
440
+
#+end_src
441
+
442
+
Such exceptions will be translated in a similar way as sum types, but
443
+
their constructor will be prefixed with the fully qualified module
444
+
path (here: =M.Foo=) so as to be able to discriminate between them
445
+
without problems.
446
+
447
+
The user can then easily convert an exception matching the above one
448
+
to an S-expression using =sexp_of_exn=. User-defined conversion
449
+
functions can be registered, too, by calling =add_exn_converter=.
450
+
This should make it very convenient for users to catch arbitrary
451
+
exceptions escaping their program and pretty-printing them, including
452
+
all arguments, as S-expressions. The library already contains
453
+
mappings for all known exceptions that can escape functions in the
454
+
OCaml standard library.
455
+
456
+
** Hash tables
457
+
458
+
The Stdlib's Hash tables, which are abstract values in OCaml, are
459
+
represented as association lists, /i.e./ lists of key-value pairs,
460
+
/e.g./:
461
+
462
+
#+begin_src scheme
463
+
((foo 42) (bar 3))
464
+
#+end_src
465
+
466
+
Reading in the above S-expression as hash table mapping strings to
467
+
integers (=(string, int) Hashtbl.t=) will map =foo= to =42= and =bar=
468
+
to =3=.
469
+
470
+
Note that the order of elements in the list may matter, because the
471
+
OCaml-implementation of hash tables keeps duplicates. Bindings will
472
+
be inserted into the hash table in the order of appearance. Therefore,
473
+
the last binding of a key will be the "visible" one, the others are
474
+
"hidden". See the OCaml documentation on hash tables for details.
475
+
476
+
* A note about signatures
477
+
478
+
In signatures, =ppx_sexp_conv= tries to generate an include of a named
479
+
interface, instead of a list of value bindings.
480
+
That is:
481
+
482
+
#+begin_src ocaml
483
+
type 'a t [@@deriving sexp]
484
+
#+end_src
485
+
486
+
will generate:
487
+
488
+
#+begin_src ocaml
489
+
include Sexpable.S1 with type 'a t := 'a t
490
+
#+end_src
491
+
492
+
instead of:
493
+
494
+
#+begin_src ocaml
495
+
val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t
496
+
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
497
+
#+end_src
498
+
499
+
There are however a number of limitations:
500
+
- the type has to be named t
501
+
- the type can only have up to 3 parameters
502
+
- there shouldn't be any constraint on the type parameters
503
+
504
+
If these aren't met, then =ppx_sexp_conv= will simply generate a list of value
505
+
bindings.
506
+
507
+
** Weird looking type errors
508
+
509
+
In some cases, a type can meet all the conditions listed above, in which case the
510
+
rewriting will apply, but lead to a type error. This happens when the type [t]
511
+
is an alias to a type which does have constraints on the parameters, for
512
+
instance:
513
+
514
+
#+begin_src ocaml
515
+
type 'a s constraint 'a = [> `read ]
516
+
val sexp_of_s : ...
517
+
val s_of_sexp : ...
518
+
type 'a t = 'a s [@@deriving_inline sexp]
519
+
include Sexpable.S1 with type 'a t := 'a t
520
+
[@@@end]
521
+
#+end_src
522
+
523
+
will give an error looking like:
524
+
525
+
#+begin_src
526
+
Error: In this `with' constraint, the new definition of t
527
+
does not match its original definition in the constrained signature:
528
+
Type declarations do not match:
529
+
type 'a t = 'a t constraint 'a = [> `read ]
530
+
is not included in
531
+
type 'a t
532
+
File "sexpable.mli", line 8, characters 21-58: Expected declaration
533
+
Their constraints differ.
534
+
#+end_src
535
+
536
+
To workaround that error, simply copy the constraint on the type which has the
537
+
=[@@deriving]= annotation. This will force generating a list of value bindings.
538
+
539
+
* Deprecated syntax
540
+
541
+
Originally, ~ppx_sexp_conv~ used special types instead of attributes. Those
542
+
types have been replaced with attributes. Here are the appropriate conversions
543
+
to update from code using the old types to the new attributes.
544
+
545
+
546
+
** Opaque types
547
+
548
+
Convert uses of ~sexp_opaque~ to uses of ~[@sexp.opaque]~. The ~[@sexp.opaque]~
549
+
attribute usually needs explicit parentheses to clarify what type it annotate.
550
+
551
+
Before:
552
+
553
+
#+begin_src ocaml
554
+
type t = int sexp_opaque list
555
+
[@@deriving sexp]
556
+
#+end_src
557
+
558
+
After:
559
+
560
+
#+begin_src ocaml
561
+
type t = (int [@sexp.opaque]) list
562
+
[@@deriving sexp]
563
+
#+end_src
564
+
565
+
** Record fields
566
+
567
+
Convert uses of ~sexp_option~, ~sexp_list~, ~sexp_array~, and ~sexp_bool~ to
568
+
uses of ~[@sexp.option]~, ~[@sexp.list]~, ~[@sexp.array]~, and ~[@sexp.bool]~ as
569
+
appropriate. The attribute only specifies the modification, not the type, so you
570
+
will need to use the regular types ~option~, ~list~, ~array~, and/or ~bool~ as
571
+
well. Unlike ~[@sexp.opaque]~, these attributes do not need extra parentheses.
572
+
573
+
Before:
574
+
575
+
#+begin_src ocaml
576
+
type t =
577
+
{ a : int sexp_option
578
+
; b : int sexp_list
579
+
; c : int sexp_array
580
+
; d : sexp_bool
581
+
}
582
+
[@@deriving sexp]
583
+
#+end_src
584
+
585
+
After:
586
+
587
+
#+begin_src ocaml
588
+
type t =
589
+
{ a : int option [@sexp.option]
590
+
; b : int list [@sexp.list]
591
+
; c : int array [@sexp.array]
592
+
; d : bool [@sexp.bool]
593
+
}
594
+
[@@deriving sexp]
595
+
#+end_src
596
+
597
+
** Variant constructors
598
+
599
+
Convert uses of ~sexp_list~ in variants and polymorphic variants to uses of
600
+
~[@sexp.list]~. You need to add the regular type ~list~ as well. Unlike
601
+
~[@sexp.opaque]~, this attribute does not need extra parentheses.
602
+
603
+
Before:
604
+
605
+
#+begin_src ocaml
606
+
type t = A of int sexp_list
607
+
[@@deriving sexp]
608
+
609
+
type u = [`B of int sexp_list]
610
+
[@@deriving sexp]
611
+
#+end_src
612
+
613
+
After:
614
+
615
+
#+begin_src ocaml
616
+
type t = A of int list [@sexp.list]
617
+
[@@deriving sexp]
618
+
619
+
type u = [`B of int list [@sexp.list]]
620
+
[@@deriving sexp]
621
+
#+end_src
+5
vendor/opam/ppx_sexp_conv/bench/dune
+5
vendor/opam/ppx_sexp_conv/bench/dune
+209
vendor/opam/ppx_sexp_conv/bench/ppx_sexp_conv_bench.ml
+209
vendor/opam/ppx_sexp_conv/bench/ppx_sexp_conv_bench.ml
···
1
+
open! Base
2
+
3
+
let bench_sexp_of_t ~sexp_of_t t =
4
+
let t = Sys.opaque_identity t in
5
+
fun () -> sexp_of_t t
6
+
;;
7
+
8
+
let bench_t_of_sexp ~t_of_sexp string =
9
+
let sexp = Sys.opaque_identity (Parsexp.Single.parse_string_exn string) in
10
+
fun () -> t_of_sexp sexp
11
+
;;
12
+
13
+
module%bench Record = struct
14
+
type t =
15
+
{ a : int
16
+
; b : int option [@omit_nil]
17
+
; c : bool [@sexp.bool]
18
+
; d : int array [@sexp.array]
19
+
; e : int list [@sexp.list]
20
+
; f : int option [@sexp.option]
21
+
; g : int [@default 0] [@sexp_drop_default ( = )]
22
+
; h : int [@default 0] [@sexp_drop_default.compare]
23
+
; i : int [@default 0] [@sexp_drop_default.equal]
24
+
; j : int [@default 0] [@sexp_drop_default.sexp]
25
+
; k : 'a. 'a list
26
+
; l : int or_null [@sexp.or_null]
27
+
}
28
+
[@@deriving sexp]
29
+
30
+
let%bench_fun "sexp_of_t, full" =
31
+
bench_sexp_of_t
32
+
~sexp_of_t
33
+
{ a = 1
34
+
; b = Some 2
35
+
; c = true
36
+
; d = [| 3; 4 |]
37
+
; e = [ 5; 6 ]
38
+
; f = Some 7
39
+
; g = 8
40
+
; h = 9
41
+
; i = 10
42
+
; j = 11
43
+
; k = []
44
+
; l = This 12
45
+
}
46
+
;;
47
+
48
+
let%bench_fun "sexp_of_t, empty" =
49
+
bench_sexp_of_t
50
+
~sexp_of_t
51
+
{ a = 0
52
+
; b = None
53
+
; c = false
54
+
; d = [||]
55
+
; e = []
56
+
; f = None
57
+
; g = 0
58
+
; h = 0
59
+
; i = 0
60
+
; j = 0
61
+
; k = []
62
+
; l = Null
63
+
}
64
+
;;
65
+
66
+
let%bench_fun "t_of_sexp, full, in order" =
67
+
bench_t_of_sexp
68
+
~t_of_sexp
69
+
"((a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h 9) (i 10) (j 11) (k ()) (l \
70
+
12))"
71
+
;;
72
+
73
+
let%bench_fun "t_of_sexp, full, reverse order" =
74
+
bench_t_of_sexp
75
+
~t_of_sexp
76
+
"((l 12) (k ()) (j 11) (i 10) (h 9) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) (a \
77
+
1))"
78
+
;;
79
+
80
+
let%bench_fun "t_of_sexp, empty" = bench_t_of_sexp ~t_of_sexp "((a 0) (k ()))"
81
+
end
82
+
83
+
module%bench Variant = struct
84
+
type t =
85
+
| Atomic
86
+
| Tuple of int * string
87
+
| List of int list [@sexp.list]
88
+
| Record of
89
+
{ a : int
90
+
; b : int option [@omit_nil]
91
+
; c : bool [@sexp.bool]
92
+
; d : int array [@sexp.array]
93
+
; e : int list [@sexp.list]
94
+
; f : int option [@sexp.option]
95
+
; g : int [@default 0] [@sexp_drop_default ( = )]
96
+
; h : int [@default 0] [@sexp_drop_default.compare]
97
+
; i : int [@default 0] [@sexp_drop_default.equal]
98
+
; j : int [@default 0] [@sexp_drop_default.sexp]
99
+
; k : 'a. 'a list
100
+
; l : int or_null [@sexp.or_null]
101
+
}
102
+
[@@deriving sexp]
103
+
104
+
let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t Atomic
105
+
let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (Tuple (1, "hello"))
106
+
let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (List [ 1; 2 ])
107
+
let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (List [])
108
+
109
+
let%bench_fun "sexp_of_t, record, full" =
110
+
bench_sexp_of_t
111
+
~sexp_of_t
112
+
(Record
113
+
{ a = 1
114
+
; b = Some 2
115
+
; c = true
116
+
; d = [| 3; 4 |]
117
+
; e = [ 5; 6 ]
118
+
; f = Some 7
119
+
; g = 8
120
+
; h = 9
121
+
; i = 10
122
+
; j = 11
123
+
; k = []
124
+
; l = This 12
125
+
})
126
+
;;
127
+
128
+
let%bench_fun "sexp_of_t, record, empty" =
129
+
bench_sexp_of_t
130
+
~sexp_of_t
131
+
(Record
132
+
{ a = 0
133
+
; b = None
134
+
; c = false
135
+
; d = [||]
136
+
; e = []
137
+
; f = None
138
+
; g = 0
139
+
; h = 0
140
+
; i = 0
141
+
; j = 0
142
+
; k = []
143
+
; l = Null
144
+
})
145
+
;;
146
+
147
+
let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic"
148
+
let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple 1 hello)"
149
+
let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)"
150
+
let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)"
151
+
152
+
let%bench_fun "t_of_sexp, record, full, in order" =
153
+
bench_t_of_sexp
154
+
~t_of_sexp
155
+
"(Record (a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h 9) (i 10) (j 11) (k \
156
+
()) (l 12))"
157
+
;;
158
+
159
+
let%bench_fun "t_of_sexp, record, full, reverse order" =
160
+
bench_t_of_sexp
161
+
~t_of_sexp
162
+
"(Record (l 12) (k ()) (j 11) (i 10) (h 9) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b \
163
+
(2)) (a 1))"
164
+
;;
165
+
166
+
let%bench_fun "t_of_sexp, record, empty" =
167
+
bench_t_of_sexp ~t_of_sexp "(Record (a 0) (k ()))"
168
+
;;
169
+
end
170
+
171
+
module%bench Tag = struct
172
+
type t =
173
+
[ `Atomic
174
+
| `Tuple of int * string
175
+
| `List of int list [@sexp.list]
176
+
]
177
+
[@@deriving sexp]
178
+
179
+
let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t `Atomic
180
+
let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (`Tuple (1, "hello"))
181
+
let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (`List [ 1; 2 ])
182
+
let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (`List [])
183
+
let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic"
184
+
let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple (1 hello))"
185
+
let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)"
186
+
let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)"
187
+
end
188
+
189
+
module%bench Inherit = struct
190
+
type atomic = [ `Atomic ] [@@deriving sexp]
191
+
type tuple = [ `Tuple of int * string ] [@@deriving sexp]
192
+
type listed = [ `List of int list [@sexp.list] ] [@@deriving sexp]
193
+
194
+
type t =
195
+
[ atomic
196
+
| tuple
197
+
| listed
198
+
]
199
+
[@@deriving sexp]
200
+
201
+
let%bench_fun "sexp_of_t, atomic" = bench_sexp_of_t ~sexp_of_t `Atomic
202
+
let%bench_fun "sexp_of_t, tuple" = bench_sexp_of_t ~sexp_of_t (`Tuple (1, "hello"))
203
+
let%bench_fun "sexp_of_t, list, full" = bench_sexp_of_t ~sexp_of_t (`List [ 1; 2 ])
204
+
let%bench_fun "sexp_of_t, list, empty" = bench_sexp_of_t ~sexp_of_t (`List [])
205
+
let%bench_fun "t_of_sexp, atomic" = bench_t_of_sexp ~t_of_sexp "Atomic"
206
+
let%bench_fun "t_of_sexp, tuple" = bench_t_of_sexp ~t_of_sexp "(Tuple (1 hello))"
207
+
let%bench_fun "t_of_sexp, list, full" = bench_t_of_sexp ~t_of_sexp "(List 1 2)"
208
+
let%bench_fun "t_of_sexp, list, empty" = bench_t_of_sexp ~t_of_sexp "(List)"
209
+
end
+1
vendor/opam/ppx_sexp_conv/bench/ppx_sexp_conv_bench.mli
+1
vendor/opam/ppx_sexp_conv/bench/ppx_sexp_conv_bench.mli
···
1
+
(*_ This module deliberately exports nothing. *)
vendor/opam/ppx_sexp_conv/dune
vendor/opam/ppx_sexp_conv/dune
This is a binary file and will not be displayed.
+1
vendor/opam/ppx_sexp_conv/dune-project
+1
vendor/opam/ppx_sexp_conv/dune-project
···
1
+
(lang dune 3.17)
+251
vendor/opam/ppx_sexp_conv/expander/attrs.ml
+251
vendor/opam/ppx_sexp_conv/expander/attrs.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
module To_lift = struct
5
+
type 'a t = { to_lift : 'a } [@@unboxed]
6
+
end
7
+
8
+
open To_lift
9
+
10
+
let default =
11
+
Attribute.declare
12
+
"sexp.default"
13
+
Attribute.Context.label_declaration
14
+
Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
15
+
(fun x -> { to_lift = x })
16
+
;;
17
+
18
+
let drop_default =
19
+
Attribute.declare_with_attr_loc
20
+
"sexp.sexp_drop_default"
21
+
Attribute.Context.label_declaration
22
+
Ast_pattern.(pstr (many (pstr_eval __ nil)))
23
+
(fun ~attr_loc -> function
24
+
| [ x ] -> { to_lift = x }
25
+
| _ ->
26
+
Location.raise_errorf
27
+
~loc:attr_loc
28
+
"Unsupported [@sexp_drop_default] payload; please use one of:\n\
29
+
- [@sexp_drop_default f] and give an explicit equality function [f]\n\
30
+
- [@sexp_drop_default.compare] if the type supports [%%compare]\n\
31
+
- [@sexp_drop_default.equal] if the type supports [%%equal]\n\
32
+
- [@sexp_drop_default.sexp] if you want to compare the sexp representations\n")
33
+
;;
34
+
35
+
let drop_default_equal =
36
+
Attribute.declare
37
+
"sexp.@sexp_drop_default.equal"
38
+
Attribute.Context.label_declaration
39
+
Ast_pattern.(pstr nil)
40
+
()
41
+
;;
42
+
43
+
let drop_default_compare =
44
+
Attribute.declare
45
+
"sexp.@sexp_drop_default.compare"
46
+
Attribute.Context.label_declaration
47
+
Ast_pattern.(pstr nil)
48
+
()
49
+
;;
50
+
51
+
let drop_default_sexp =
52
+
Attribute.declare
53
+
"sexp.@sexp_drop_default.sexp"
54
+
Attribute.Context.label_declaration
55
+
Ast_pattern.(pstr nil)
56
+
()
57
+
;;
58
+
59
+
let drop_if =
60
+
Attribute.declare
61
+
"sexp.sexp_drop_if"
62
+
Attribute.Context.label_declaration
63
+
Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
64
+
(fun x -> { to_lift = x })
65
+
;;
66
+
67
+
let opaque =
68
+
Attribute.declare "sexp.opaque" Attribute.Context.core_type Ast_pattern.(pstr nil) ()
69
+
;;
70
+
71
+
let omit_nil =
72
+
Attribute.declare
73
+
"sexp.omit_nil"
74
+
Attribute.Context.label_declaration
75
+
Ast_pattern.(pstr nil)
76
+
()
77
+
;;
78
+
79
+
let option =
80
+
Attribute.declare
81
+
"sexp.option"
82
+
Attribute.Context.label_declaration
83
+
Ast_pattern.(pstr nil)
84
+
()
85
+
;;
86
+
87
+
let or_null =
88
+
Attribute.declare
89
+
"sexp.or_null"
90
+
Attribute.Context.label_declaration
91
+
Ast_pattern.(pstr nil)
92
+
()
93
+
;;
94
+
95
+
let list =
96
+
Attribute.declare
97
+
"sexp.list"
98
+
Attribute.Context.label_declaration
99
+
Ast_pattern.(pstr nil)
100
+
()
101
+
;;
102
+
103
+
let array =
104
+
Attribute.declare
105
+
"sexp.array"
106
+
Attribute.Context.label_declaration
107
+
Ast_pattern.(pstr nil)
108
+
()
109
+
;;
110
+
111
+
let bool =
112
+
Attribute.declare
113
+
"sexp.bool"
114
+
Attribute.Context.label_declaration
115
+
Ast_pattern.(pstr nil)
116
+
()
117
+
;;
118
+
119
+
let list_variant =
120
+
Attribute.declare
121
+
"sexp.list"
122
+
Attribute.Context.constructor_declaration
123
+
Ast_pattern.(pstr nil)
124
+
()
125
+
;;
126
+
127
+
let list_exception =
128
+
Attribute.declare "sexp.list" Attribute.Context.type_exception Ast_pattern.(pstr nil) ()
129
+
;;
130
+
131
+
let list_poly =
132
+
Attribute.declare "sexp.list" Attribute.Context.rtag Ast_pattern.(pstr nil) ()
133
+
;;
134
+
135
+
let allow_extra_fields_td =
136
+
Attribute.declare
137
+
"sexp.allow_extra_fields"
138
+
Attribute.Context.type_declaration
139
+
Ast_pattern.(pstr nil)
140
+
()
141
+
;;
142
+
143
+
let allow_extra_fields_cd =
144
+
Attribute.declare
145
+
"sexp.allow_extra_fields"
146
+
Attribute.Context.constructor_declaration
147
+
Ast_pattern.(pstr nil)
148
+
()
149
+
;;
150
+
151
+
let grammar_custom =
152
+
Attribute.declare
153
+
"sexp_grammar.custom"
154
+
Attribute.Context.core_type
155
+
Ast_pattern.(single_expr_payload __)
156
+
(fun x -> x)
157
+
;;
158
+
159
+
let grammar_any =
160
+
Attribute.declare
161
+
"sexp_grammar.any"
162
+
Attribute.Context.core_type
163
+
Ast_pattern.(alt_option (single_expr_payload (estring __)) (pstr nil))
164
+
(fun x -> x)
165
+
;;
166
+
167
+
let tag_attribute_for_context context =
168
+
let open Ast_pattern in
169
+
let key_equals_value =
170
+
Ast_pattern.(
171
+
pexp_apply (pexp_ident (lident (string "="))) (no_label __ ^:: no_label __ ^:: nil)
172
+
|> pack2)
173
+
in
174
+
let get_captured_values ast_pattern context expression =
175
+
Ast_pattern.to_func ast_pattern context expression.pexp_loc expression (fun x -> x)
176
+
in
177
+
let rec collect_sequence expression =
178
+
match expression.pexp_desc with
179
+
| Pexp_sequence (l, r) -> l :: collect_sequence r
180
+
| _ -> [ expression ]
181
+
in
182
+
let esequence ast_pattern =
183
+
Ast_pattern.of_func (fun context _loc expression k ->
184
+
collect_sequence expression
185
+
|> List.map ~f:(get_captured_values ast_pattern context)
186
+
|> k)
187
+
in
188
+
Attribute.declare
189
+
"sexp_grammar.tag"
190
+
context
191
+
(pstr (pstr_eval (esequence key_equals_value) nil ^:: nil))
192
+
(fun x -> x)
193
+
;;
194
+
195
+
let tag_type = tag_attribute_for_context Core_type
196
+
let tag_ld = tag_attribute_for_context Label_declaration
197
+
let tag_cd = tag_attribute_for_context Constructor_declaration
198
+
let tag_poly = tag_attribute_for_context Rtag
199
+
200
+
let tags_attribute_for_context context =
201
+
Attribute.declare
202
+
"sexp_grammar.tags"
203
+
context
204
+
Ast_pattern.(single_expr_payload __)
205
+
(fun x -> x)
206
+
;;
207
+
208
+
let tags_type = tags_attribute_for_context Core_type
209
+
let tags_ld = tags_attribute_for_context Label_declaration
210
+
let tags_cd = tags_attribute_for_context Constructor_declaration
211
+
let tags_poly = tags_attribute_for_context Rtag
212
+
213
+
let phantom =
214
+
Attribute.declare "sexp.phantom" Attribute.Context.core_type Ast_pattern.(pstr nil) ()
215
+
;;
216
+
217
+
let invalid_attribute ~loc attr description =
218
+
Location.raise_errorf
219
+
~loc
220
+
"ppx_sexp_conv: [@%s] is only allowed on type [%s]."
221
+
(Attribute.name attr)
222
+
description
223
+
;;
224
+
225
+
let fail_if_allow_extra_field_cd ~loc x =
226
+
if Option.is_some (Attribute.get allow_extra_fields_cd x)
227
+
then
228
+
Location.raise_errorf
229
+
~loc
230
+
"ppx_sexp_conv: [@@allow_extra_fields] is only allowed on inline records."
231
+
;;
232
+
233
+
let fail_if_allow_extra_field_td ~loc x =
234
+
if Option.is_some (Attribute.get allow_extra_fields_td x)
235
+
then (
236
+
match x.ptype_kind with
237
+
| Ptype_variant cds
238
+
when List.exists cds ~f:(fun cd ->
239
+
match cd.pcd_args with
240
+
| Pcstr_record _ -> true
241
+
| _ -> false) ->
242
+
Location.raise_errorf
243
+
~loc
244
+
"ppx_sexp_conv: [@@@@allow_extra_fields] only works on records. For inline \
245
+
records, do: type t = A of { a : int } [@@allow_extra_fields] | B [@@@@deriving \
246
+
sexp]"
247
+
| _ ->
248
+
Location.raise_errorf
249
+
~loc
250
+
"ppx_sexp_conv: [@@@@allow_extra_fields] is only allowed on records.")
251
+
;;
+42
vendor/opam/ppx_sexp_conv/expander/attrs.mli
+42
vendor/opam/ppx_sexp_conv/expander/attrs.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
(** [default], [drop_default], and [drop_if] attributes are annotated with expressions
5
+
that should be lifted out of the scope of ppx-generated temporary variables. See the
6
+
[Lifted] module. *)
7
+
module To_lift : sig
8
+
type 'a t = { to_lift : 'a } [@@unboxed]
9
+
end
10
+
11
+
val default : (label_declaration, expression To_lift.t) Attribute.t
12
+
val drop_default : (label_declaration, expression To_lift.t) Attribute.t
13
+
val drop_if : (label_declaration, expression To_lift.t) Attribute.t
14
+
val drop_default_equal : (label_declaration, unit) Attribute.t
15
+
val drop_default_compare : (label_declaration, unit) Attribute.t
16
+
val drop_default_sexp : (label_declaration, unit) Attribute.t
17
+
val omit_nil : (label_declaration, unit) Attribute.t
18
+
val option : (label_declaration, unit) Attribute.t
19
+
val or_null : (label_declaration, unit) Attribute.t
20
+
val list : (label_declaration, unit) Attribute.t
21
+
val array : (label_declaration, unit) Attribute.t
22
+
val bool : (label_declaration, unit) Attribute.t
23
+
val opaque : (core_type, unit) Attribute.t
24
+
val phantom : (core_type, unit) Attribute.t
25
+
val list_variant : (constructor_declaration, unit) Attribute.t
26
+
val list_exception : (type_exception, unit) Attribute.t
27
+
val list_poly : (row_field, unit) Attribute.t
28
+
val allow_extra_fields_td : (type_declaration, unit) Attribute.t
29
+
val allow_extra_fields_cd : (constructor_declaration, unit) Attribute.t
30
+
val invalid_attribute : loc:Location.t -> (_, _) Attribute.t -> string -> 'a
31
+
val fail_if_allow_extra_field_cd : loc:Location.t -> constructor_declaration -> unit
32
+
val fail_if_allow_extra_field_td : loc:Location.t -> type_declaration -> unit
33
+
val grammar_any : (core_type, string option) Attribute.t
34
+
val grammar_custom : (core_type, expression) Attribute.t
35
+
val tag_type : (core_type, (expression * expression) list) Attribute.t
36
+
val tag_ld : (label_declaration, (expression * expression) list) Attribute.t
37
+
val tag_cd : (constructor_declaration, (expression * expression) list) Attribute.t
38
+
val tag_poly : (row_field, (expression * expression) list) Attribute.t
39
+
val tags_type : (core_type, expression) Attribute.t
40
+
val tags_ld : (label_declaration, expression) Attribute.t
41
+
val tags_cd : (constructor_declaration, expression) Attribute.t
42
+
val tags_poly : (row_field, expression) Attribute.t
+222
vendor/opam/ppx_sexp_conv/expander/conversion.ml
+222
vendor/opam/ppx_sexp_conv/expander/conversion.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Ast_builder.Default
4
+
open Helpers
5
+
6
+
let maybe_exclave ~loc expr ~stackify =
7
+
match stackify with
8
+
| false -> expr
9
+
| true -> [%expr [%e expr]]
10
+
;;
11
+
12
+
let maybe_constrain ~loc expr = function
13
+
| None -> expr
14
+
| Some cstr -> [%expr ([%e expr] : [%t cstr])]
15
+
;;
16
+
17
+
module Reference = struct
18
+
type t =
19
+
{ types : type_declaration list
20
+
; binds : value_binding list list
21
+
; ident : longident_loc
22
+
; cstr : core_type option
23
+
; args : (arg_label * expression) list
24
+
; after_args : (arg_label * expression) list
25
+
}
26
+
27
+
let bind t binds = { t with binds = binds :: t.binds }
28
+
let bind_types t types = { t with types = types @ t.types }
29
+
30
+
let maybe_apply { types; binds; ident; cstr; args; after_args } ~loc maybe_arg =
31
+
let ident = pexp_ident ~loc ident in
32
+
let args =
33
+
match maybe_arg with
34
+
| None -> args @ after_args
35
+
| Some arg -> args @ [ Nolabel, arg ] @ after_args
36
+
in
37
+
let expr =
38
+
match args with
39
+
| [] -> maybe_constrain ~loc ident cstr
40
+
| _ -> pexp_apply ~loc ident args
41
+
in
42
+
with_types ~loc ~types (with_let ~loc ~binds expr)
43
+
;;
44
+
45
+
let apply t ~loc arg = maybe_apply t ~loc (Some arg)
46
+
let to_expression t ~loc = maybe_apply t ~loc None
47
+
48
+
let to_value_expression t ~loc ~rec_flag ~values_being_defined ~stackify =
49
+
let may_refer_directly_to ident =
50
+
match rec_flag with
51
+
| Nonrecursive -> true
52
+
| Recursive -> not (String.Set.mem (Longident.name ident.txt) values_being_defined)
53
+
in
54
+
match t with
55
+
| { types = []; binds = []; ident; cstr; args = []; after_args = [] }
56
+
when may_refer_directly_to ident ->
57
+
maybe_constrain ~loc (pexp_ident ~loc ident) cstr
58
+
| _ -> fresh_lambda ~loc (fun ~arg -> maybe_exclave ~loc (apply t ~loc arg) ~stackify)
59
+
;;
60
+
end
61
+
62
+
module Lambda = struct
63
+
type t =
64
+
{ types : type_declaration list
65
+
; binds : value_binding list list
66
+
; cases : cases
67
+
}
68
+
69
+
let bind t binds = { t with binds = binds :: t.binds }
70
+
let bind_types t types = { t with types = types @ t.types }
71
+
72
+
(* generic case: use [function] or [match] *)
73
+
let maybe_apply_generic ~loc ~types ~binds maybe_arg cases ~stackify =
74
+
let expr =
75
+
match maybe_arg with
76
+
| None ->
77
+
let cases =
78
+
List.map cases ~f:(fun case ->
79
+
{ case with pc_rhs = maybe_exclave ~loc case.pc_rhs ~stackify })
80
+
in
81
+
pexp_function ~loc cases
82
+
| Some arg -> pexp_match ~loc arg cases
83
+
in
84
+
with_types ~loc ~types (with_let ~loc ~binds expr)
85
+
;;
86
+
87
+
(* zero cases: synthesize an "impossible" case, i.e. [| _ -> .] *)
88
+
let maybe_apply_impossible ~loc ~types ~binds maybe_arg ~stackify =
89
+
[ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(pexp_unreachable ~loc) ]
90
+
|> maybe_apply_generic ~loc ~binds ~types maybe_arg ~stackify
91
+
;;
92
+
93
+
(* one case without guard: use [fun] or [let] *)
94
+
let maybe_apply_simple ~loc ~types ~binds maybe_arg pat body ~stackify =
95
+
let expr =
96
+
match maybe_arg with
97
+
| None -> pexp_fun ~loc Nolabel None pat (maybe_exclave ~loc body ~stackify)
98
+
| Some arg -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr:arg ] body
99
+
in
100
+
with_types ~loc ~types (with_let ~loc ~binds expr)
101
+
;;
102
+
103
+
(* shared special-casing logic for [apply] and [to_expression] *)
104
+
let maybe_apply t ~loc maybe_arg ~stackify =
105
+
match t with
106
+
| { types; binds; cases = [] } ->
107
+
maybe_apply_impossible ~loc ~types ~binds maybe_arg ~stackify
108
+
| { types; binds; cases = [ { pc_lhs; pc_guard = None; pc_rhs } ] } ->
109
+
maybe_apply_simple ~loc ~types ~binds maybe_arg pc_lhs pc_rhs ~stackify
110
+
| { types; binds; cases } ->
111
+
maybe_apply_generic ~loc ~types ~binds maybe_arg cases ~stackify
112
+
;;
113
+
114
+
let apply t ~loc arg = maybe_apply t ~loc (Some arg) ~stackify:false
115
+
let to_expression t ~loc ~stackify = maybe_apply t ~loc None ~stackify
116
+
117
+
let to_value_expression t ~loc ~stackify =
118
+
match t with
119
+
| { types = []; binds = []; cases = _ } ->
120
+
(* lambdas without [let] are already values *)
121
+
let expr = to_expression t ~loc ~stackify in
122
+
assert (is_value_expression expr);
123
+
expr
124
+
| _ -> fresh_lambda ~loc (fun ~arg -> maybe_exclave ~loc (apply t ~loc arg) ~stackify)
125
+
;;
126
+
end
127
+
128
+
type t =
129
+
| Reference of Reference.t
130
+
| Lambda of Lambda.t
131
+
132
+
let of_lambda cases = Lambda { types = []; binds = []; cases }
133
+
134
+
let of_reference_exn ~thunk expr =
135
+
let loc = expr.pexp_loc in
136
+
match Ppxlib_jane.Shim.Expression_desc.of_parsetree expr.pexp_desc ~loc with
137
+
| Pexp_ident ident ->
138
+
Reference { types = []; binds = []; ident; cstr = None; args = []; after_args = [] }
139
+
| Pexp_constraint ({ pexp_desc = Pexp_ident ident; _ }, cstr, _) ->
140
+
Reference { types = []; binds = []; ident; cstr; args = []; after_args = [] }
141
+
| Pexp_apply ({ pexp_desc = Pexp_ident ident; _ }, args) ->
142
+
Reference
143
+
{ types = []
144
+
; binds = []
145
+
; ident
146
+
; cstr = None
147
+
; args
148
+
; after_args = (if thunk then [ Nolabel, [%expr ()] ] else [])
149
+
}
150
+
| _ ->
151
+
Location.raise_errorf
152
+
~loc:expr.pexp_loc
153
+
"ppx_sexp_conv: internal error.\n\
154
+
[Conversion.of_reference_exn] expected an identifier possibly applied to arguments.\n\
155
+
Instead, got:\n\
156
+
%s"
157
+
(Pprintast.string_of_expression expr)
158
+
;;
159
+
160
+
let to_expression t ~loc ~stackify =
161
+
match t with
162
+
| Reference reference -> Reference.to_expression ~loc reference
163
+
| Lambda lambda -> Lambda.to_expression ~loc lambda ~stackify
164
+
;;
165
+
166
+
let to_value_expression t ~loc ~rec_flag ~values_being_defined ~stackify =
167
+
match t with
168
+
| Reference reference ->
169
+
Reference.to_value_expression ~loc ~rec_flag ~values_being_defined reference ~stackify
170
+
| Lambda lambda -> Lambda.to_value_expression ~loc lambda ~stackify
171
+
;;
172
+
173
+
let apply t ~loc e =
174
+
match t with
175
+
| Reference reference -> Reference.apply ~loc reference e
176
+
| Lambda lambda -> Lambda.apply ~loc lambda e
177
+
;;
178
+
179
+
let bind t binds =
180
+
match t with
181
+
| Reference reference -> Reference (Reference.bind reference binds)
182
+
| Lambda lambda -> Lambda (Lambda.bind lambda binds)
183
+
;;
184
+
185
+
let bind_types t types =
186
+
match t with
187
+
| Reference reference -> Reference (Reference.bind_types reference types)
188
+
| Lambda lambda -> Lambda (Lambda.bind_types lambda types)
189
+
;;
190
+
191
+
module Apply_all = struct
192
+
type t =
193
+
{ bindings : value_binding list
194
+
; arguments : pattern list
195
+
; converted : expression list
196
+
}
197
+
end
198
+
199
+
let gen_symbols list ~prefix =
200
+
List.mapi list ~f:(fun i _ -> gen_symbol ~prefix:(prefix ^ Int.to_string i) ())
201
+
;;
202
+
203
+
let zip list1 list2 =
204
+
List.fold_right2 list1 list2 ~init:[] ~f:(fun x y acc -> (x, y) :: acc)
205
+
;;
206
+
207
+
let apply_all ts ~loc =
208
+
let arguments_names = gen_symbols ts ~prefix:"arg" in
209
+
let converted_names = gen_symbols ts ~prefix:"res" in
210
+
let bindings =
211
+
List.map
212
+
(zip ts (zip arguments_names converted_names))
213
+
~f:(fun (t, (arg, conv)) ->
214
+
let expr = apply ~loc t (evar ~loc arg) in
215
+
value_binding ~loc ~pat:(pvar ~loc conv) ~expr)
216
+
in
217
+
({ bindings
218
+
; arguments = List.map arguments_names ~f:(pvar ~loc)
219
+
; converted = List.map converted_names ~f:(evar ~loc)
220
+
}
221
+
: Apply_all.t)
222
+
;;
+60
vendor/opam/ppx_sexp_conv/expander/conversion.mli
+60
vendor/opam/ppx_sexp_conv/expander/conversion.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
(** Sexp conversion function, expressed as either a single expression or as a collection
5
+
of [match] cases. Expressing as cases rather than wrapping directly in [pexp_function]
6
+
allows us to simplify some expressions built on this. *)
7
+
type t
8
+
9
+
(** Construct [t] from a list of pattern/expression cases. *)
10
+
val of_lambda : cases -> t
11
+
12
+
(** Construct [t] from an identifier, possibly applied to arguments. Raise on any other
13
+
form of expression.
14
+
15
+
If [thunk], then [expression] should evaluate to something with type [() -> 'a], and
16
+
[of_reference_exn ~thunk:true |> to_value_expression] will evaluate to something of
17
+
type ['a]. [thunk] should only ever be set when working with unboxed types, as this is
18
+
a trick for circumventing the lack of layout polymorphism ([() -> 'a] has layout value
19
+
even if ['a] is unboxed). *)
20
+
val of_reference_exn : thunk:bool -> expression -> t
21
+
22
+
(** Convert [t] to an expression. *)
23
+
val to_expression : t -> loc:location -> stackify:bool -> expression
24
+
25
+
(** Convert [t] to an expression that is a syntactic value, i.e. a constant, identifier,
26
+
or lambda expression that does no "work", can can be preallocated, and works in the
27
+
context of a [let rec]. *)
28
+
val to_value_expression
29
+
: t
30
+
-> loc:location
31
+
-> rec_flag:rec_flag
32
+
-> values_being_defined:String.Set.t
33
+
-> stackify:bool
34
+
-> expression
35
+
36
+
(** Apply [t] to an argument. *)
37
+
val apply
38
+
: t
39
+
-> loc:location
40
+
-> expression (** argument [t] is applied to *)
41
+
-> expression
42
+
43
+
(** Wrap [t] in [let]-bindings. *)
44
+
val bind : t -> value_binding list -> t
45
+
46
+
(** Wrap [t] in [let open .. in] with type declarations. *)
47
+
val bind_types : t -> type_declaration list -> t
48
+
49
+
module Apply_all : sig
50
+
type t =
51
+
{ bindings : value_binding list
52
+
; arguments : pattern list
53
+
; converted : expression list
54
+
}
55
+
end
56
+
57
+
(** Applies each [t] to a fresh variable, and binds the results to fresh variables.
58
+
Returns the corresponding [value_binding]s, patterns for the argument variables, and
59
+
expressions for the result variables. *)
60
+
val apply_all : t list -> loc:location -> Apply_all.t
+8
vendor/opam/ppx_sexp_conv/expander/dune
+8
vendor/opam/ppx_sexp_conv/expander/dune
···
1
+
(library
2
+
(name ppx_sexp_conv_expander)
3
+
(public_name ppx_sexp_conv.expander)
4
+
(libraries compiler-libs.common ppx_helpers ppxlib ppxlib.metaquot_lifters
5
+
ppxlib_jane ppxlib.stdppx)
6
+
(ppx_runtime_libraries basement ppx_sexp_conv.runtime-lib sexplib0)
7
+
(preprocess
8
+
(pps ppxlib.metaquot ppxlib.traverse)))
+1549
vendor/opam/ppx_sexp_conv/expander/expand_of_sexp.ml
+1549
vendor/opam/ppx_sexp_conv/expander/expand_of_sexp.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Ppxlib.Ast_builder.Default
4
+
open Ppxlib_jane.Ast_builder.Default
5
+
open Helpers
6
+
open Lifted.Monad_infix
7
+
8
+
let of_sexp_function_for_type ?(internal = false) ?functor_:modname typename =
9
+
let name, suffix = Ppx_helpers.demangle_template typename in
10
+
let prefix =
11
+
match modname with
12
+
| Some modname -> modname ^ "__"
13
+
| None -> ""
14
+
in
15
+
let internal_mangling = if internal then "__" else "" in
16
+
internal_mangling ^ prefix ^ name ^ "_of_sexp" ^ internal_mangling ^ suffix
17
+
;;
18
+
19
+
(* Generates the signature for type conversion from S-expressions *)
20
+
module Sig_generate_of_sexp = struct
21
+
let type_of_of_sexp ~loc t =
22
+
let loc = { loc with loc_ghost = true } in
23
+
[%type: Sexplib0.Sexp.t -> [%t t]]
24
+
;;
25
+
26
+
let mk_type td =
27
+
Ppx_helpers.combinator_type_of_type_declaration
28
+
td
29
+
~f:type_of_of_sexp
30
+
~phantom_attr:Attrs.phantom
31
+
;;
32
+
33
+
let sig_of_td ~poly ~portable td =
34
+
let of_sexp_type =
35
+
mk_type td
36
+
|> Ppx_helpers.Polytype.to_core_type
37
+
~universally_quantify_only_if_jkind_annotation:true
38
+
in
39
+
let loc = td.ptype_loc in
40
+
let of_sexp_item =
41
+
psig_value
42
+
~loc
43
+
(Ppxlib_jane.Ast_builder.Default.value_description
44
+
~loc
45
+
~name:(Located.map of_sexp_function_for_type td.ptype_name)
46
+
~type_:of_sexp_type
47
+
~modalities:
48
+
(if portable then Ppxlib_jane.Shim.Modalities.portable ~loc else [])
49
+
~prim:[])
50
+
in
51
+
match poly, is_polymorphic_variant td ~sig_:true with
52
+
| true, `Surely_not ->
53
+
Location.raise_errorf
54
+
~loc
55
+
"Sig_generate_of_sexp.sig_of_td: sexp_poly annotation but type is surely not a \
56
+
polymorphic variant"
57
+
| false, (`Surely_not | `Maybe) -> [ of_sexp_item ]
58
+
| (true | false), `Definitely | true, `Maybe ->
59
+
[ of_sexp_item
60
+
; psig_value
61
+
~loc
62
+
(Ppxlib_jane.Ast_builder.Default.value_description
63
+
~loc
64
+
~name:(Located.map (of_sexp_function_for_type ~internal:true) td.ptype_name)
65
+
~type_:of_sexp_type
66
+
~modalities:
67
+
(if portable then Ppxlib_jane.Shim.Modalities.portable ~loc else [])
68
+
~prim:[])
69
+
]
70
+
;;
71
+
72
+
let mk_sig ~poly ~loc:_ ~path:_ ~unboxed (_rf, tds) ~portable =
73
+
let tds = Ppx_helpers.with_implicit_unboxed_records ~unboxed tds in
74
+
List.concat_map tds ~f:(sig_of_td ~poly ~portable)
75
+
;;
76
+
end
77
+
78
+
module Str_generate_of_sexp = struct
79
+
module Ptag_error_function = struct
80
+
type t =
81
+
| Ptag_no_args
82
+
| Ptag_takes_args
83
+
end
84
+
85
+
module Row_or_constructor = struct
86
+
type t =
87
+
| Row of row_field
88
+
| Constructor of constructor_declaration
89
+
end
90
+
91
+
let with_error_source ~loc ~full_type_name make_body =
92
+
let lifted =
93
+
let name = lazy (Fresh_name.create "error_source" ~loc) in
94
+
make_body ~error_source:(fun () -> Fresh_name.expression (Lazy.force name))
95
+
>>| fun body ->
96
+
match Lazy.is_val name with
97
+
| false ->
98
+
(* no references to [name], no need to define it *)
99
+
body
100
+
| true ->
101
+
(* add a definition for [name] *)
102
+
[%expr
103
+
let [%p Fresh_name.pattern (Lazy.force name)] =
104
+
[%e estring ~loc full_type_name]
105
+
in
106
+
[%e body]]
107
+
in
108
+
Lifted.let_bind_user_expressions lifted ~loc
109
+
;;
110
+
111
+
(* [raising_expr] must be an expression that always raises. Such expressions are
112
+
polymorphic in their return, but not yet layout polymorphic. This makes them layout
113
+
polymorphic. *)
114
+
let wrap_error_for_layout_any ~loc ~unboxed raising_expr =
115
+
if unboxed
116
+
then
117
+
[%expr
118
+
match [%e raising_expr] with
119
+
| (_ : Sexplib0.Sexp_conv_error.nothing) -> .]
120
+
else raising_expr
121
+
;;
122
+
123
+
(* Utility functions for polymorphic variants *)
124
+
125
+
(* Handle backtracking when variants do not match *)
126
+
let handle_no_variant_match loc expr =
127
+
[ [%pat? Sexplib0.Sexp_conv_error.No_variant_match] --> expr ]
128
+
;;
129
+
130
+
(* Generate code depending on whether to generate a match for the last
131
+
case of matching a variant *)
132
+
let handle_variant_match_last loc ~match_last ~fresh_atom matches =
133
+
match match_last, matches with
134
+
| true, [ { pc_lhs = _; pc_guard = None; pc_rhs = expr } ]
135
+
| _, [ { pc_lhs = [%pat? _]; pc_guard = None; pc_rhs = expr } ] -> expr
136
+
| _ -> pexp_match ~loc (Fresh_name.expression fresh_atom) matches
137
+
;;
138
+
139
+
(* Generate code for matching malformed S-expressions *)
140
+
let mk_variant_other_matches ~error_source ~fresh__sexp loc rev_els call =
141
+
let coll_structs acc (loc, cnstr) =
142
+
(pstring ~loc cnstr
143
+
-->
144
+
match (call : Ptag_error_function.t) with
145
+
| Ptag_no_args ->
146
+
[%expr
147
+
Sexplib0.Sexp_conv_error.ptag_no_args
148
+
[%e error_source ()]
149
+
[%e Fresh_name.expression fresh__sexp]]
150
+
| Ptag_takes_args ->
151
+
[%expr
152
+
Sexplib0.Sexp_conv_error.ptag_takes_args
153
+
[%e error_source ()]
154
+
[%e Fresh_name.expression fresh__sexp]])
155
+
:: acc
156
+
in
157
+
let exc_no_variant_match =
158
+
[%pat? _] --> [%expr Sexplib0.Sexp_conv_error.no_variant_match ()]
159
+
in
160
+
List.fold_left ~f:coll_structs ~init:[ exc_no_variant_match ] rev_els
161
+
;;
162
+
163
+
(* Split the row fields of a variant type into lists of atomic variants,
164
+
structured variants, atomic variants + included variant types,
165
+
and structured variants + included variant types. *)
166
+
let split_row_field ~loc (atoms, structs, ainhs, sinhs) row_field =
167
+
match row_field.prf_desc with
168
+
| Rtag ({ txt = cnstr; _ }, true, []) ->
169
+
let tpl = loc, cnstr in
170
+
tpl :: atoms, structs, `A tpl :: ainhs, sinhs
171
+
| Rtag ({ txt = cnstr; _ }, false, [ tp ]) ->
172
+
let loc = tp.ptyp_loc in
173
+
atoms, (loc, cnstr) :: structs, ainhs, `S (loc, cnstr, tp, row_field) :: sinhs
174
+
| Rinherit inh ->
175
+
let iinh = `I inh in
176
+
atoms, structs, iinh :: ainhs, iinh :: sinhs
177
+
| Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) ->
178
+
Location.raise_errorf ~loc "unsupported: polymorphic variant intersection type"
179
+
| Rtag (_, false, []) ->
180
+
Location.raise_errorf ~loc "unsupported: polymorphic variant empty type"
181
+
;;
182
+
183
+
let pat_of_of_sexp ~loc typ =
184
+
let loc = { loc with loc_ghost = true } in
185
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree typ.ptyp_desc with
186
+
| Ptyp_constr (id, _) ->
187
+
Ppx_helpers.type_constr_conv_pat
188
+
~loc
189
+
id
190
+
~f:(of_sexp_function_for_type ?internal:None)
191
+
| Ptyp_var _ ->
192
+
Ast_builder.Default.ppat_extension
193
+
~loc
194
+
(Location.error_extensionf
195
+
~loc
196
+
"Type variables are disallowed here. Instead, consider using a locally \
197
+
abstract type.")
198
+
| _ ->
199
+
Ast_builder.Default.ppat_extension
200
+
~loc
201
+
(Location.error_extensionf
202
+
~loc
203
+
"Only type constructors are allowed here (e.g. [t], ['a t], or [M(X).t]).")
204
+
;;
205
+
206
+
let type_constr_of_sexp ~loc ?internal id args =
207
+
Ppx_helpers.type_constr_conv_expr
208
+
~loc
209
+
id
210
+
args
211
+
~f:(of_sexp_function_for_type ?internal)
212
+
;;
213
+
214
+
(* Conversion of types *)
215
+
let rec type_of_sexp ~error_source ~typevars ?full_type ?(internal = false) typ
216
+
: Conversion.t
217
+
=
218
+
let loc = typ.ptyp_loc in
219
+
match Ppxlib_jane.Shim.Core_type.of_parsetree typ with
220
+
| _ when Option.is_some (Attribute.get Attrs.opaque typ) ->
221
+
Conversion.of_reference_exn ~thunk:false [%expr Sexplib0.Sexp_conv.opaque_of_sexp]
222
+
| { ptyp_desc = Ptyp_any _; _ } ->
223
+
Conversion.of_reference_exn ~thunk:false [%expr Sexplib0.Sexp_conv.opaque_of_sexp]
224
+
| { ptyp_desc = (Ptyp_tuple labeled_tps | Ptyp_unboxed_tuple labeled_tps) as desc; _ }
225
+
->
226
+
let unboxed =
227
+
match desc with
228
+
| Ptyp_unboxed_tuple _ -> true
229
+
| Ptyp_tuple _ -> false
230
+
| _ -> assert false
231
+
in
232
+
(match Ppxlib_jane.as_unlabeled_tuple labeled_tps with
233
+
| Some tps ->
234
+
Conversion.of_lambda (tuple_of_sexp ~error_source ~typevars ~unboxed (loc, tps))
235
+
| None ->
236
+
Conversion.of_reference_exn
237
+
~thunk:unboxed
238
+
(labeled_tuple_of_sexp ~error_source ~typevars ~unboxed ~loc labeled_tps))
239
+
| { ptyp_desc = Ptyp_var (parm, _); _ } ->
240
+
(match String.Map.find_opt parm typevars with
241
+
| Some fresh ->
242
+
Conversion.of_reference_exn ~thunk:false (Fresh_name.expression fresh)
243
+
| None ->
244
+
Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" parm)
245
+
| { ptyp_desc = Ptyp_constr (id, args); _ } ->
246
+
(match typ with
247
+
| [%type: [%t? _] sexp_opaque] ->
248
+
Conversion.of_reference_exn
249
+
~thunk:false
250
+
[%expr Sexplib0.Sexp_conv.opaque_of_sexp]
251
+
| [%type: [%t? ty1] sexp_list] ->
252
+
let arg1 =
253
+
Conversion.to_expression
254
+
~loc
255
+
(type_of_sexp ~error_source ~typevars ty1)
256
+
~stackify:false
257
+
in
258
+
Conversion.of_reference_exn
259
+
~thunk:false
260
+
[%expr Sexplib0.Sexp_conv.list_of_sexp [%e arg1]]
261
+
| [%type: [%t? ty1] sexp_array] ->
262
+
let arg1 =
263
+
Conversion.to_expression
264
+
~loc
265
+
(type_of_sexp ~error_source ~typevars ty1)
266
+
~stackify:false
267
+
in
268
+
Conversion.of_reference_exn
269
+
~thunk:false
270
+
[%expr Sexplib0.Sexp_conv.array_of_sexp [%e arg1]]
271
+
| _ ->
272
+
let args =
273
+
List.filter args ~f:include_param_in_combinator
274
+
|> List.map ~f:(fun arg ->
275
+
Conversion.to_expression
276
+
~loc
277
+
(type_of_sexp ~error_source ~typevars arg)
278
+
~stackify:false)
279
+
in
280
+
Conversion.of_reference_exn
281
+
~thunk:false
282
+
(type_constr_of_sexp ~loc ~internal id args))
283
+
| { ptyp_desc = Ptyp_arrow (_, _, _, _, _); _ } ->
284
+
Conversion.of_reference_exn ~thunk:false [%expr Sexplib0.Sexp_conv.fun_of_sexp]
285
+
| { ptyp_desc = Ptyp_variant (row_fields, Closed, _); _ } ->
286
+
variant_of_sexp ~error_source ~typevars ?full_type (loc, row_fields)
287
+
| { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } ->
288
+
poly_of_sexp ~error_source ~typevars parms poly_tp
289
+
| core_type ->
290
+
Location.raise_errorf
291
+
~loc
292
+
"Type unsupported for ppx [of_sexp] conversion (%s)"
293
+
(Ppxlib_jane.Language_feature_name.of_core_type_desc core_type.ptyp_desc)
294
+
295
+
(* Conversion of (unlabeled) tuples *)
296
+
and tuple_of_sexp ~error_source ~typevars ~unboxed (loc, tps) =
297
+
let fps = List.map ~f:(type_of_sexp ~error_source ~typevars) tps in
298
+
let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
299
+
Conversion.apply_all ~loc fps
300
+
in
301
+
let converted = List.map ~f:(fun e -> None, e) converted in
302
+
let n = List.length fps in
303
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
304
+
let pexp_tuple = if unboxed then pexp_unboxed_tuple else pexp_tuple in
305
+
[ [%pat? Sexplib0.Sexp.List [%p plist ~loc arguments]]
306
+
--> pexp_let ~loc Immutable Nonrecursive bindings (pexp_tuple ~loc converted)
307
+
; Fresh_name.pattern fresh_sexp
308
+
--> ([%expr
309
+
Sexplib0.Sexp_conv_error.tuple_of_size_n_expected
310
+
[%e error_source ()]
311
+
[%e eint ~loc n]
312
+
[%e Fresh_name.expression fresh_sexp]]
313
+
|> wrap_error_for_layout_any ~loc ~unboxed)
314
+
]
315
+
316
+
(* Conversion of labeled tuples *)
317
+
and labeled_tuple_of_sexp ~error_source ~typevars ~unboxed ~loc alist =
318
+
assert (Labeled_tuple.has_any_label alist);
319
+
let fields_expr =
320
+
List.fold_right
321
+
alist
322
+
~init:[%expr Empty]
323
+
~f:(fun (label_option, core_type) rest_expr ->
324
+
let name_expr = estring ~loc (Labeled_tuple.atom_of_label label_option) in
325
+
let conv_expr =
326
+
type_of_sexp ~error_source ~typevars core_type
327
+
|> Conversion.to_expression ~loc:core_type.ptyp_loc ~stackify:false
328
+
in
329
+
let conv_expr =
330
+
let sexp = Fresh_name.create ~loc "sexp" in
331
+
let value = Fresh_name.create ~loc "value" in
332
+
[%expr
333
+
fun [%p Fresh_name.pattern sexp] ->
334
+
let [%p Fresh_name.pattern value] =
335
+
[%e conv_expr] [%e Fresh_name.expression sexp]
336
+
in
337
+
fun () -> [%e Fresh_name.expression value]]
338
+
in
339
+
[%expr
340
+
Field { name = [%e name_expr]; conv = [%e conv_expr]; rest = [%e rest_expr] }])
341
+
in
342
+
let create_expr =
343
+
let pats, exprs =
344
+
let list =
345
+
List.map alist ~f:(fun (label_option, _) ->
346
+
let name = Fresh_name.create ~loc "field" in
347
+
let name_expr = Fresh_name.expression name in
348
+
let expr = [%expr [%e name_expr] ()] in
349
+
Fresh_name.pattern name, (label_option, expr))
350
+
in
351
+
List.map list ~f:fst, List.map list ~f:snd
352
+
in
353
+
let pat =
354
+
List.fold_right pats ~init:(punit ~loc) ~f:(fun pat1 pat2 ->
355
+
ppat_tuple ~loc [ None, pat1; None, pat2 ] Closed)
356
+
in
357
+
let expr =
358
+
Ppxlib_jane.Ast_builder.Default.(
359
+
if unboxed then pexp_unboxed_tuple else pexp_tuple)
360
+
~loc
361
+
exprs
362
+
in
363
+
if unboxed
364
+
then [%expr fun [%p pat] () -> [%e expr]]
365
+
else [%expr fun [%p pat] -> [%e expr]]
366
+
in
367
+
pexp_apply
368
+
~loc
369
+
[%expr Sexplib0.Sexp_conv_labeled_tuple.labeled_tuple_of_sexp]
370
+
[ Labelled "caller", error_source ()
371
+
; Labelled "fields", fields_expr
372
+
; Labelled "create", create_expr
373
+
]
374
+
375
+
(* Generate code for matching included variant types *)
376
+
and handle_variant_inh
377
+
~error_source
378
+
~typevars
379
+
~fresh_atom
380
+
~fresh__sexp
381
+
full_type
382
+
~match_last
383
+
other_matches
384
+
inh
385
+
=
386
+
let loc = inh.ptyp_loc in
387
+
let func_expr = type_of_sexp ~error_source ~typevars ~internal:true inh in
388
+
let app =
389
+
Conversion.of_reference_exn
390
+
~thunk:false
391
+
(Conversion.apply ~loc func_expr (Fresh_name.expression fresh__sexp))
392
+
in
393
+
let match_exc =
394
+
handle_no_variant_match
395
+
loc
396
+
(handle_variant_match_last loc ~match_last ~fresh_atom other_matches)
397
+
in
398
+
let new_other_matches =
399
+
[ [%pat? _]
400
+
--> pexp_try
401
+
~loc
402
+
[%expr
403
+
([%e Conversion.to_expression ~loc app ~stackify:false]
404
+
:> [%t replace_variables_by_underscores full_type])]
405
+
match_exc
406
+
]
407
+
in
408
+
new_other_matches, true
409
+
410
+
(* Generate code for matching atomic variants *)
411
+
and mk_variant_match_atom
412
+
~error_source
413
+
~typevars
414
+
~fresh_atom
415
+
~fresh__sexp
416
+
loc
417
+
full_type
418
+
rev_atoms_inhs
419
+
rev_structs
420
+
=
421
+
let coll (other_matches, match_last) = function
422
+
| `A (loc, cnstr) ->
423
+
let new_match = pstring ~loc cnstr --> pexp_variant ~loc cnstr None in
424
+
new_match :: other_matches, false
425
+
| `I inh ->
426
+
handle_variant_inh
427
+
~error_source
428
+
~typevars
429
+
~fresh_atom
430
+
~fresh__sexp
431
+
full_type
432
+
~match_last
433
+
other_matches
434
+
inh
435
+
in
436
+
let other_matches =
437
+
mk_variant_other_matches ~error_source ~fresh__sexp loc rev_structs Ptag_takes_args
438
+
in
439
+
let match_atoms_inhs, match_last =
440
+
List.fold_left ~f:coll ~init:(other_matches, false) rev_atoms_inhs
441
+
in
442
+
handle_variant_match_last loc ~match_last ~fresh_atom match_atoms_inhs
443
+
444
+
(* Variant conversions *)
445
+
446
+
(* Match arguments of constructors (variants or sum types) *)
447
+
and mk_cnstr_args_match
448
+
~error_source
449
+
~typevars
450
+
~loc
451
+
~is_variant
452
+
~fresh__sexp
453
+
~fresh__tag
454
+
~fresh_sexp_args
455
+
cnstr
456
+
tps
457
+
row
458
+
=
459
+
let cnstr vars_expr =
460
+
if is_variant
461
+
then pexp_variant ~loc cnstr (Some vars_expr)
462
+
else pexp_construct ~loc (Located.lident ~loc cnstr) (Some vars_expr)
463
+
in
464
+
match tps with
465
+
| [ tp ]
466
+
when Option.is_some
467
+
(match (row : Row_or_constructor.t) with
468
+
| Row r -> Attribute.get Attrs.list_poly r
469
+
| Constructor c -> Attribute.get Attrs.list_variant c) ->
470
+
(match tp with
471
+
| [%type: [%t? tp] list] ->
472
+
let cnv =
473
+
Conversion.to_expression
474
+
~loc
475
+
(type_of_sexp ~error_source ~typevars tp)
476
+
~stackify:false
477
+
in
478
+
cnstr
479
+
[%expr
480
+
Sexplib0.Sexp_conv.list_map
481
+
[%e cnv]
482
+
[%e Fresh_name.expression fresh_sexp_args]]
483
+
| _ ->
484
+
(match row with
485
+
| Row _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list"
486
+
| Constructor _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list"))
487
+
| [ [%type: [%t? tp] sexp_list] ] ->
488
+
let cnv =
489
+
Conversion.to_expression
490
+
~loc
491
+
(type_of_sexp ~error_source ~typevars tp)
492
+
~stackify:false
493
+
in
494
+
cnstr
495
+
[%expr
496
+
Sexplib0.Sexp_conv.list_map [%e cnv] [%e Fresh_name.expression fresh_sexp_args]]
497
+
| _ ->
498
+
let bindings, patts, good_arg_match =
499
+
let fps = List.map ~f:(type_of_sexp ~error_source ~typevars) tps in
500
+
let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
501
+
Conversion.apply_all ~loc fps
502
+
in
503
+
let good_arg_match =
504
+
cnstr (Ppxlib.Ast_builder.Default.pexp_tuple ~loc converted)
505
+
in
506
+
bindings, arguments, good_arg_match
507
+
in
508
+
[%expr
509
+
match [%e Fresh_name.expression fresh_sexp_args] with
510
+
| [%p plist ~loc patts] ->
511
+
[%e pexp_let ~loc Immutable Nonrecursive bindings good_arg_match]
512
+
| _ ->
513
+
[%e
514
+
if is_variant
515
+
then
516
+
[%expr
517
+
Sexplib0.Sexp_conv_error.ptag_incorrect_n_args
518
+
[%e error_source ()]
519
+
[%e Fresh_name.expression fresh__tag]
520
+
[%e Fresh_name.expression fresh__sexp]]
521
+
else
522
+
[%expr
523
+
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
524
+
[%e error_source ()]
525
+
[%e Fresh_name.expression fresh__tag]
526
+
[%e Fresh_name.expression fresh__sexp]]]]
527
+
528
+
(* Generate code for matching structured variants *)
529
+
and mk_variant_match_struct
530
+
~error_source
531
+
~typevars
532
+
~fresh_atom
533
+
~fresh__sexp
534
+
~fresh_sexp_args
535
+
loc
536
+
full_type
537
+
rev_structs_inhs
538
+
rev_atoms
539
+
=
540
+
let has_structs_ref = ref false in
541
+
let coll (other_matches, match_last) = function
542
+
| `S (loc, cnstr, tp, row) ->
543
+
has_structs_ref := true;
544
+
let fresh__tag = Fresh_name.create "_tag" ~loc in
545
+
let expr =
546
+
mk_cnstr_args_match
547
+
~error_source
548
+
~typevars
549
+
~loc:tp.ptyp_loc
550
+
~is_variant:true
551
+
~fresh__sexp
552
+
~fresh__tag
553
+
~fresh_sexp_args
554
+
cnstr
555
+
[ tp ]
556
+
(Row row)
557
+
in
558
+
let new_match =
559
+
ppat_alias
560
+
~loc
561
+
[%pat? [%p pstring ~loc cnstr]]
562
+
(Fresh_name.to_string_loc fresh__tag)
563
+
--> expr
564
+
in
565
+
new_match :: other_matches, false
566
+
| `I inh ->
567
+
handle_variant_inh
568
+
~error_source
569
+
~typevars
570
+
~fresh_atom
571
+
~fresh__sexp
572
+
full_type
573
+
~match_last
574
+
other_matches
575
+
inh
576
+
in
577
+
let other_matches =
578
+
mk_variant_other_matches ~error_source ~fresh__sexp loc rev_atoms Ptag_no_args
579
+
in
580
+
let match_structs_inhs, match_last =
581
+
List.fold_left ~f:coll ~init:(other_matches, false) rev_structs_inhs
582
+
in
583
+
( handle_variant_match_last loc ~match_last ~fresh_atom match_structs_inhs
584
+
, !has_structs_ref )
585
+
586
+
(* Generate code for handling atomic and structured variants (i.e. not
587
+
included variant types) *)
588
+
and handle_variant_tag ~error_source ~typevars loc full_type row_field_list =
589
+
let fresh_atom = Fresh_name.create "atom" ~loc in
590
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
591
+
let fresh__sexp = Fresh_name.create "_sexp" ~loc in
592
+
let fresh_sexp_args = Fresh_name.create "sexp_args" ~loc in
593
+
let rev_atoms, rev_structs, rev_atoms_inhs, rev_structs_inhs =
594
+
List.fold_left ~f:(split_row_field ~loc) ~init:([], [], [], []) row_field_list
595
+
in
596
+
let match_struct, has_structs =
597
+
mk_variant_match_struct
598
+
~error_source
599
+
~typevars
600
+
~fresh_atom
601
+
~fresh__sexp
602
+
~fresh_sexp_args
603
+
loc
604
+
full_type
605
+
rev_structs_inhs
606
+
rev_atoms
607
+
in
608
+
let maybe_sexp_args_patt =
609
+
if has_structs then Fresh_name.pattern fresh_sexp_args else [%pat? _]
610
+
in
611
+
[ ppat_alias
612
+
~loc
613
+
[%pat? Sexplib0.Sexp.Atom [%p Fresh_name.pattern fresh_atom]]
614
+
(Fresh_name.to_string_loc fresh__sexp)
615
+
--> mk_variant_match_atom
616
+
~error_source
617
+
~typevars
618
+
~fresh_atom
619
+
~fresh__sexp
620
+
loc
621
+
full_type
622
+
rev_atoms_inhs
623
+
rev_structs
624
+
; ppat_alias
625
+
~loc
626
+
[%pat?
627
+
Sexplib0.Sexp.List
628
+
(Sexplib0.Sexp.Atom [%p Fresh_name.pattern fresh_atom]
629
+
:: [%p maybe_sexp_args_patt])]
630
+
(Fresh_name.to_string_loc fresh__sexp)
631
+
--> match_struct
632
+
; ppat_alias
633
+
~loc
634
+
[%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _)]
635
+
(Fresh_name.to_string_loc fresh_sexp)
636
+
--> [%expr
637
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var
638
+
[%e error_source ()]
639
+
[%e Fresh_name.expression fresh_sexp]]
640
+
; ppat_alias ~loc [%pat? Sexplib0.Sexp.List []] (Fresh_name.to_string_loc fresh_sexp)
641
+
--> [%expr
642
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var
643
+
[%e error_source ()]
644
+
[%e Fresh_name.expression fresh_sexp]]
645
+
]
646
+
647
+
(* Generate matching code for variants *)
648
+
and variant_of_sexp ~error_source ~typevars ?full_type (loc, row_fields) =
649
+
let is_contained, full_type =
650
+
match full_type with
651
+
| None -> true, ptyp_variant ~loc row_fields Closed None
652
+
| Some full_type -> false, full_type
653
+
in
654
+
let top_match =
655
+
let fresh_sexp = Fresh_name.create ~loc "sexp" in
656
+
match row_fields with
657
+
| { prf_desc = Rinherit inh; _ } :: rest ->
658
+
let rec loop inh row_fields =
659
+
let call =
660
+
[%expr
661
+
([%e
662
+
Conversion.to_expression
663
+
~loc
664
+
(type_of_sexp ~error_source ~typevars ~internal:true inh)
665
+
~stackify:false]
666
+
[%e Fresh_name.expression fresh_sexp]
667
+
:> [%t replace_variables_by_underscores full_type])]
668
+
in
669
+
match row_fields with
670
+
| [] -> call
671
+
| h :: t ->
672
+
let expr =
673
+
match h.prf_desc with
674
+
| Rinherit inh -> loop inh t
675
+
| _ ->
676
+
let rftag_matches =
677
+
handle_variant_tag ~error_source ~typevars loc full_type row_fields
678
+
in
679
+
pexp_match ~loc (Fresh_name.expression fresh_sexp) rftag_matches
680
+
in
681
+
pexp_try ~loc call (handle_no_variant_match loc expr)
682
+
in
683
+
[ Fresh_name.pattern fresh_sexp --> loop inh rest ]
684
+
| _ :: _ -> handle_variant_tag ~error_source ~typevars loc full_type row_fields
685
+
| [] ->
686
+
Location.raise_errorf
687
+
~loc
688
+
"of_sexp is not supported for empty polymorphic variants (impossible?)"
689
+
in
690
+
if is_contained
691
+
then (
692
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
693
+
Conversion.of_lambda
694
+
[ Fresh_name.pattern fresh_sexp
695
+
--> [%expr
696
+
try [%e pexp_match ~loc (Fresh_name.expression fresh_sexp) top_match] with
697
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
698
+
Sexplib0.Sexp_conv_error.no_matching_variant_found
699
+
[%e error_source ()]
700
+
[%e Fresh_name.expression fresh_sexp]]
701
+
])
702
+
else Conversion.of_lambda top_match
703
+
704
+
and poly_of_sexp ~error_source ~typevars parms tp =
705
+
let loc = tp.ptyp_loc in
706
+
let typevars =
707
+
List.fold_left parms ~init:typevars ~f:(fun map (parm, _jkind) ->
708
+
String.Map.add parm.txt (Fresh_name.create ("_of_" ^ parm.txt) ~loc:parm.loc) map)
709
+
in
710
+
let bindings =
711
+
let mk_binding (parm, _jkind) =
712
+
let fresh = String.Map.find parm.txt typevars in
713
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
714
+
value_binding
715
+
~loc
716
+
~pat:(Fresh_name.pattern fresh)
717
+
~expr:
718
+
[%expr
719
+
fun [%p Fresh_name.pattern fresh_sexp] ->
720
+
Sexplib0.Sexp_conv_error.record_poly_field_value
721
+
[%e error_source ()]
722
+
[%e Fresh_name.expression fresh_sexp]]
723
+
~modes:[]
724
+
in
725
+
List.map ~f:mk_binding parms
726
+
in
727
+
Conversion.bind (type_of_sexp ~error_source ~typevars tp) bindings
728
+
;;
729
+
730
+
type record_poly_type =
731
+
{ type_and_field_name : Fresh_name.t
732
+
; params : string loc list
733
+
; body : core_type
734
+
}
735
+
736
+
let record_poly_type field =
737
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree field.pld_type.ptyp_desc with
738
+
| Ptyp_poly (params, body) ->
739
+
let type_and_field_name = Fresh_name.of_string_loc field.pld_name in
740
+
let params = List.map params ~f:(fun (name, _jkind) -> name) in
741
+
Some { type_and_field_name; params; body }
742
+
| _ -> None
743
+
;;
744
+
745
+
let close_over_non_value ~loc expr =
746
+
let result = gen_symbol () in
747
+
[%expr
748
+
let [%p pvar ~loc result] = [%e expr] in
749
+
fun () -> [%e evar ~loc result]]
750
+
;;
751
+
752
+
let record_field_conv field ~poly ~loc ~error_source ~typevars =
753
+
match poly with
754
+
| None ->
755
+
let conv =
756
+
type_of_sexp ~error_source ~typevars field.pld_type
757
+
|> Conversion.to_expression ~loc ~stackify:false
758
+
in
759
+
fresh_lambda ~loc (fun ~arg -> close_over_non_value ~loc [%expr [%e conv] [%e arg]])
760
+
| Some { type_and_field_name; params; body } ->
761
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
762
+
let fresh_params =
763
+
List.map params ~f:(fun { loc; txt } -> Fresh_name.create ~loc ("_" ^ txt))
764
+
in
765
+
let pat = Fresh_name.pattern fresh_sexp in
766
+
let body =
767
+
let label = Located.map_lident (Fresh_name.to_string_loc type_and_field_name) in
768
+
let typevars =
769
+
List.fold_left2
770
+
params
771
+
fresh_params
772
+
~init:typevars
773
+
~f:(fun typevars param fresh -> String.Map.add param.txt fresh typevars)
774
+
in
775
+
let expr =
776
+
pexp_let
777
+
~loc
778
+
Immutable
779
+
Nonrecursive
780
+
(List.map fresh_params ~f:(fun fresh ->
781
+
let { loc; txt } = Fresh_name.to_string_loc fresh in
782
+
let expr =
783
+
[%expr
784
+
Sexplib0.Sexp_conv_error.record_poly_field_value [%e error_source ()]]
785
+
in
786
+
value_binding ~loc ~pat:(pvar ~loc txt) ~expr ~modes:[]))
787
+
(Conversion.apply
788
+
(type_of_sexp ~error_source ~typevars body)
789
+
~loc
790
+
(Fresh_name.expression fresh_sexp))
791
+
in
792
+
pexp_record ~loc [ label, expr ] None
793
+
in
794
+
eabstract ~loc [ pat ] (close_over_non_value ~loc body)
795
+
;;
796
+
797
+
let fields_arg_for_record_of_sexp poly_fields ~loc ~error_source ~typevars =
798
+
List.fold_right
799
+
poly_fields
800
+
~init:(Lifted.return [%expr Empty])
801
+
~f:
802
+
(fun
803
+
( poly
804
+
, field
805
+
, (attrs : Record_field_attrs.Of_sexp.t Record_field_attrs.Generic.t) )
806
+
rest_lifted
807
+
->
808
+
rest_lifted
809
+
>>= fun rest_expr ->
810
+
let label_expr = estring ~loc:field.pld_name.loc field.pld_name.txt in
811
+
match attrs with
812
+
| Specific Required ->
813
+
Lifted.return
814
+
[%expr
815
+
Field
816
+
{ name = [%e label_expr]
817
+
; kind = Required
818
+
; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars]
819
+
; rest = [%e rest_expr]
820
+
}]
821
+
| Specific (Default lifted) ->
822
+
lifted
823
+
>>| fun default ->
824
+
[%expr
825
+
Field
826
+
{ name = [%e label_expr]
827
+
; kind = Default (fun () -> [%e default])
828
+
; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars]
829
+
; rest = [%e rest_expr]
830
+
}]
831
+
| Omit_nil ->
832
+
Lifted.return
833
+
[%expr
834
+
Field
835
+
{ name = [%e label_expr]
836
+
; kind = Omit_nil
837
+
; conv = [%e record_field_conv field ~poly ~loc ~error_source ~typevars]
838
+
; rest = [%e rest_expr]
839
+
}]
840
+
| Sexp_bool ->
841
+
Lifted.return
842
+
[%expr
843
+
Field
844
+
{ name = [%e label_expr]
845
+
; kind = Sexp_bool
846
+
; conv = ()
847
+
; rest = [%e rest_expr]
848
+
}]
849
+
| Sexp_array core_type ->
850
+
let conv_expr =
851
+
type_of_sexp ~error_source ~typevars core_type
852
+
|> Conversion.to_expression ~loc ~stackify:false
853
+
in
854
+
Lifted.return
855
+
[%expr
856
+
Field
857
+
{ name = [%e label_expr]
858
+
; kind = Sexp_array
859
+
; conv = [%e conv_expr]
860
+
; rest = [%e rest_expr]
861
+
}]
862
+
| Sexp_list core_type ->
863
+
let conv_expr =
864
+
type_of_sexp ~error_source ~typevars core_type
865
+
|> Conversion.to_expression ~loc ~stackify:false
866
+
in
867
+
Lifted.return
868
+
[%expr
869
+
Field
870
+
{ name = [%e label_expr]
871
+
; kind = Sexp_list
872
+
; conv = [%e conv_expr]
873
+
; rest = [%e rest_expr]
874
+
}]
875
+
| Sexp_option core_type ->
876
+
let conv_expr =
877
+
type_of_sexp ~error_source ~typevars core_type
878
+
|> Conversion.to_expression ~loc ~stackify:false
879
+
in
880
+
Lifted.return
881
+
[%expr
882
+
Field
883
+
{ name = [%e label_expr]
884
+
; kind = Sexp_option
885
+
; conv = [%e conv_expr]
886
+
; rest = [%e rest_expr]
887
+
}]
888
+
| Sexp_or_null core_type ->
889
+
let conv_expr =
890
+
type_of_sexp ~error_source ~typevars core_type
891
+
|> Conversion.to_expression ~loc ~stackify:false
892
+
in
893
+
Lifted.return
894
+
[%expr
895
+
Field
896
+
{ name = [%e label_expr]
897
+
; kind = Sexp_or_null
898
+
; conv = [%e conv_expr]
899
+
; rest = [%e rest_expr]
900
+
}])
901
+
;;
902
+
903
+
let index_of_field_arg_for_record_of_sexp fields ~loc =
904
+
let field_cases =
905
+
List.mapi fields ~f:(fun i (_, field, _) ->
906
+
let lhs = pstring ~loc:field.pld_name.loc field.pld_name.txt in
907
+
let rhs = eint ~loc i in
908
+
case ~lhs ~guard:None ~rhs)
909
+
in
910
+
let default_case = case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(eint ~loc (-1)) in
911
+
let cases = List.concat [ field_cases; [ default_case ] ] in
912
+
pexp_function ~loc cases
913
+
;;
914
+
915
+
let create_arg_for_record_of_sexp td fields ~loc ~constructor ~unboxed =
916
+
let vars =
917
+
List.map
918
+
fields
919
+
~f:
920
+
(fun
921
+
( poly
922
+
, field
923
+
, (attrs : Record_field_attrs.Of_sexp.t Record_field_attrs.Generic.t) )
924
+
->
925
+
let pvar = pvar ~loc:field.pld_name.loc field.pld_name.txt in
926
+
let pat =
927
+
match poly with
928
+
| None -> pvar
929
+
| Some { type_and_field_name; _ } ->
930
+
(* Extract a polymorphic value from a polymorphic record defined explicitly
931
+
for this purpose. *)
932
+
let label =
933
+
Located.map_lident (Fresh_name.to_string_loc type_and_field_name)
934
+
in
935
+
ppat_record ~loc [ label, pvar ] Closed
936
+
in
937
+
let evar = evar ~loc:field.pld_name.loc field.pld_name.txt in
938
+
let pat, rebind, expr =
939
+
match attrs with
940
+
| Specific (Required | Default _) | Omit_nil ->
941
+
pvar, Some (pat, [%expr [%e evar] ()]), evar
942
+
| Sexp_bool | Sexp_array _ | Sexp_list _ | Sexp_option _ | Sexp_or_null _ ->
943
+
pat, None, evar
944
+
in
945
+
pat, rebind, (Located.map_lident field.pld_name, expr))
946
+
in
947
+
let pat =
948
+
List.fold_right
949
+
vars
950
+
~init:[%pat? ()]
951
+
~f:(fun (head, _, _) tail -> ppat_tuple ~loc [ None, head; None, tail ] Closed)
952
+
in
953
+
let body =
954
+
let record_expr =
955
+
(if unboxed
956
+
then Ppxlib_jane.Ast_builder.Default.pexp_record_unboxed_product ?attrs:None
957
+
else pexp_record)
958
+
~loc
959
+
(List.map vars ~f:(fun (_, _, field) -> field))
960
+
None
961
+
in
962
+
let record_or_variant_expr =
963
+
match constructor with
964
+
| None -> record_expr
965
+
| Some label ->
966
+
(* variant constructor with inline record *)
967
+
pexp_construct ~loc label (Some record_expr)
968
+
in
969
+
List.fold_right vars ~init:record_or_variant_expr ~f:(fun (_, rebind, _) body ->
970
+
match rebind with
971
+
| None -> body
972
+
| Some (pat, expr) ->
973
+
[%expr
974
+
let [%p pat] = [%e expr] in
975
+
[%e body]])
976
+
in
977
+
let core_type =
978
+
ptyp_constr
979
+
~loc
980
+
(Located.map_lident td.ptype_name)
981
+
(List.map td.ptype_params ~f:(fun (core_type, _) ->
982
+
ptyp_any ~loc:core_type.ptyp_loc))
983
+
in
984
+
Ppxlib_jane.Ast_builder.Default.eabstract
985
+
~loc
986
+
(if unboxed then [ pat; [%pat? ()] ] else [ pat ])
987
+
body
988
+
~return_constraint:core_type
989
+
;;
990
+
991
+
let polymorphic_record_types_for_record_of_sexp fields ~loc =
992
+
(* Define fresh types to contain polymorphic values parsed from sexps. *)
993
+
List.filter_map fields ~f:(fun (poly, _, _) ->
994
+
match poly with
995
+
| Some { type_and_field_name; params; body } ->
996
+
let fresh_field =
997
+
label_declaration
998
+
~loc
999
+
~name:(Fresh_name.to_string_loc type_and_field_name)
1000
+
~modalities:[]
1001
+
~mutable_:Immutable
1002
+
~type_:
1003
+
(strip_attributes#core_type
1004
+
(Ppxlib.Ast_builder.Default.ptyp_poly ~loc params body))
1005
+
in
1006
+
let type_decl =
1007
+
type_declaration
1008
+
~loc
1009
+
~name:(Fresh_name.to_string_loc type_and_field_name)
1010
+
~params:[]
1011
+
~cstrs:[]
1012
+
~kind:(Ptype_record [ fresh_field ])
1013
+
~private_:Public
1014
+
~manifest:None
1015
+
()
1016
+
in
1017
+
Some
1018
+
{ type_decl with
1019
+
ptype_attributes =
1020
+
(* define unboxed types to avoid allocation *)
1021
+
[ { attr_loc = loc
1022
+
; attr_name = { loc; txt = "unboxed" }
1023
+
; attr_payload = PStr []
1024
+
}
1025
+
]
1026
+
}
1027
+
| None -> None)
1028
+
;;
1029
+
1030
+
let args_for_record_of_sexp
1031
+
td
1032
+
fields
1033
+
~loc
1034
+
~error_source
1035
+
~typevars
1036
+
~constructor
1037
+
~allow_extra_fields
1038
+
~unboxed
1039
+
=
1040
+
let caller_expr = error_source () in
1041
+
let allow_extra_fields_expr = ebool ~loc allow_extra_fields in
1042
+
let fields =
1043
+
List.map fields ~f:(fun field ->
1044
+
record_poly_type field, field, Record_field_attrs.Of_sexp.create ~loc field)
1045
+
in
1046
+
let index_of_field_expr = index_of_field_arg_for_record_of_sexp fields ~loc in
1047
+
let create_expr =
1048
+
create_arg_for_record_of_sexp td fields ~loc ~constructor ~unboxed
1049
+
in
1050
+
let fields_expr_lifted =
1051
+
fields_arg_for_record_of_sexp fields ~loc ~error_source ~typevars
1052
+
in
1053
+
fields_expr_lifted
1054
+
>>| fun fields_expr ->
1055
+
let types = polymorphic_record_types_for_record_of_sexp fields ~loc in
1056
+
let args =
1057
+
[ Labelled "caller", caller_expr
1058
+
; Labelled "fields", fields_expr
1059
+
; Labelled "index_of_field", index_of_field_expr
1060
+
; Labelled "allow_extra_fields", allow_extra_fields_expr
1061
+
; Labelled "create", create_expr
1062
+
]
1063
+
in
1064
+
types, args
1065
+
;;
1066
+
1067
+
(* Generate matching code for records *)
1068
+
let record_of_sexp ~error_source ~typevars ~allow_extra_fields ~unboxed td (loc, flds) =
1069
+
args_for_record_of_sexp
1070
+
td
1071
+
flds
1072
+
~loc
1073
+
~error_source
1074
+
~typevars
1075
+
~constructor:None
1076
+
~allow_extra_fields
1077
+
~unboxed
1078
+
>>| fun (types, args) ->
1079
+
let conv =
1080
+
pexp_apply ~loc [%expr Sexplib0.Sexp_conv_record.record_of_sexp] args
1081
+
|> Conversion.of_reference_exn ~thunk:unboxed
1082
+
in
1083
+
Conversion.bind_types conv types
1084
+
;;
1085
+
1086
+
(* Sum type conversions *)
1087
+
1088
+
(* Generate matching code for well-formed S-expressions wrt. sum types *)
1089
+
let mk_good_sum_matches ~error_source ~typevars td (_, cds) =
1090
+
List.map cds ~f:(fun cd ->
1091
+
let loc = cd.pcd_loc in
1092
+
match cd with
1093
+
| { pcd_name = constructor; pcd_args = Pcstr_record fields; _ } ->
1094
+
let allow_extra_fields =
1095
+
Option.is_some (Attribute.get Attrs.allow_extra_fields_cd cd)
1096
+
in
1097
+
args_for_record_of_sexp
1098
+
td
1099
+
fields
1100
+
~loc
1101
+
~error_source
1102
+
~typevars
1103
+
~constructor:(Some (Located.map_lident constructor))
1104
+
~allow_extra_fields
1105
+
~unboxed:false
1106
+
>>| fun (types, args) ->
1107
+
let string_pat =
1108
+
let loc = constructor.loc in
1109
+
ppat_or
1110
+
~loc
1111
+
(pstring ~loc (String.uncapitalize_ascii constructor.txt))
1112
+
(pstring ~loc constructor.txt)
1113
+
in
1114
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
1115
+
let fresh_sexps = Fresh_name.create "sexps" ~loc in
1116
+
ppat_alias
1117
+
~loc
1118
+
[%pat?
1119
+
Sexplib0.Sexp.List
1120
+
(Sexplib0.Sexp.Atom [%p string_pat] :: [%p Fresh_name.pattern fresh_sexps])]
1121
+
(Fresh_name.to_string_loc fresh_sexp)
1122
+
--> (pexp_apply
1123
+
~loc
1124
+
[%expr Sexplib0.Sexp_conv_record.record_of_sexps]
1125
+
(List.concat
1126
+
[ [ Labelled "context", Fresh_name.expression fresh_sexp ]
1127
+
; args
1128
+
; [ Nolabel, Fresh_name.expression fresh_sexps ]
1129
+
])
1130
+
|> with_types ~loc ~types)
1131
+
| { pcd_name = cnstr; pcd_args = Pcstr_tuple []; _ } ->
1132
+
Attrs.fail_if_allow_extra_field_cd ~loc cd;
1133
+
let lcstr = pstring ~loc (String.uncapitalize_ascii cnstr.txt) in
1134
+
let str = pstring ~loc cnstr.txt in
1135
+
[%pat? Sexplib0.Sexp.Atom ([%p lcstr] | [%p str])]
1136
+
--> pexp_construct ~loc (Located.lident ~loc cnstr.txt) None
1137
+
|> Lifted.return
1138
+
| { pcd_name = cnstr; pcd_args = Pcstr_tuple (_ :: _ as args); _ } ->
1139
+
let tps = List.map args ~f:Ppxlib_jane.Shim.Pcstr_tuple_arg.to_core_type in
1140
+
Attrs.fail_if_allow_extra_field_cd ~loc cd;
1141
+
let lcstr = pstring ~loc (String.uncapitalize_ascii cnstr.txt) in
1142
+
let str = pstring ~loc cnstr.txt in
1143
+
let fresh__sexp = Fresh_name.create "_sexp" ~loc in
1144
+
let fresh__tag = Fresh_name.create "_tag" ~loc in
1145
+
let fresh_sexp_args = Fresh_name.create "sexp_args" ~loc in
1146
+
ppat_alias
1147
+
~loc
1148
+
[%pat?
1149
+
Sexplib0.Sexp.List
1150
+
(Sexplib0.Sexp.Atom
1151
+
[%p
1152
+
ppat_alias
1153
+
~loc
1154
+
[%pat? [%p lcstr] | [%p str]]
1155
+
(Fresh_name.to_string_loc fresh__tag)]
1156
+
:: [%p Fresh_name.pattern fresh_sexp_args])]
1157
+
(Fresh_name.to_string_loc fresh__sexp)
1158
+
--> mk_cnstr_args_match
1159
+
~error_source
1160
+
~typevars
1161
+
~loc
1162
+
~is_variant:false
1163
+
~fresh__sexp
1164
+
~fresh__tag
1165
+
~fresh_sexp_args
1166
+
cnstr.txt
1167
+
tps
1168
+
(Constructor cd)
1169
+
|> Lifted.return)
1170
+
;;
1171
+
1172
+
(* Generate matching code for malformed S-expressions with good tags
1173
+
wrt. sum types *)
1174
+
let mk_bad_sum_matches ~error_source (loc, cds) =
1175
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
1176
+
let no_payload, yes_payload =
1177
+
List.partition_map
1178
+
(function
1179
+
| { pcd_name = cnstr; pcd_args = Pcstr_tuple []; _ } -> Left cnstr
1180
+
| { pcd_name = cnstr; pcd_args = Pcstr_tuple (_ :: _) | Pcstr_record _; _ } ->
1181
+
Right cnstr)
1182
+
cds
1183
+
in
1184
+
let or_constructors list =
1185
+
(* "constructor1" | "Constructor1" | "constructor2" | "Constructor2" | ... *)
1186
+
match
1187
+
List.concat_map list ~f:(fun constructor ->
1188
+
[ Loc.map constructor ~f:String.uncapitalize_ascii
1189
+
; Loc.map constructor ~f:String.capitalize_ascii
1190
+
])
1191
+
|> List.map ~f:(fun { loc; txt } -> pstring ~loc txt)
1192
+
with
1193
+
| [] -> None
1194
+
| head :: tail -> Some (List.fold_left ~init:head tail ~f:(ppat_or ~loc))
1195
+
in
1196
+
let no_payload =
1197
+
Option.map (or_constructors no_payload) ~f:(fun constructor_pattern ->
1198
+
ppat_alias
1199
+
~loc
1200
+
[%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.Atom [%p constructor_pattern] :: _)]
1201
+
(Fresh_name.to_string_loc fresh_sexp)
1202
+
--> [%expr
1203
+
Sexplib0.Sexp_conv_error.stag_no_args
1204
+
[%e error_source ()]
1205
+
[%e Fresh_name.expression fresh_sexp]])
1206
+
in
1207
+
let yes_payload =
1208
+
Option.map (or_constructors yes_payload) ~f:(fun constructor_pattern ->
1209
+
ppat_alias
1210
+
~loc
1211
+
[%pat? Sexplib0.Sexp.Atom [%p constructor_pattern]]
1212
+
(Fresh_name.to_string_loc fresh_sexp)
1213
+
--> [%expr
1214
+
Sexplib0.Sexp_conv_error.stag_takes_args
1215
+
[%e error_source ()]
1216
+
[%e Fresh_name.expression fresh_sexp]])
1217
+
in
1218
+
List.filter_opt [ no_payload; yes_payload ]
1219
+
;;
1220
+
1221
+
(* Generate matching code for sum types *)
1222
+
let sum_of_sexp ~error_source ~typevars td (loc, alts) =
1223
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
1224
+
let alts_strings =
1225
+
elist
1226
+
~loc
1227
+
(List.map alts ~f:(fun alt ->
1228
+
let { txt; loc } = alt.pcd_name in
1229
+
estring ~loc txt))
1230
+
in
1231
+
[ mk_good_sum_matches ~error_source ~typevars td (loc, alts) |> Lifted.all
1232
+
; mk_bad_sum_matches ~error_source (loc, alts) |> Lifted.return
1233
+
; [ ppat_alias
1234
+
~loc
1235
+
[%pat? Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _)]
1236
+
(Fresh_name.to_string_loc fresh_sexp)
1237
+
--> [%expr
1238
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum
1239
+
[%e error_source ()]
1240
+
[%e Fresh_name.expression fresh_sexp]]
1241
+
; ppat_alias
1242
+
~loc
1243
+
[%pat? Sexplib0.Sexp.List []]
1244
+
(Fresh_name.to_string_loc fresh_sexp)
1245
+
--> [%expr
1246
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum
1247
+
[%e error_source ()]
1248
+
[%e Fresh_name.expression fresh_sexp]]
1249
+
; Fresh_name.pattern fresh_sexp
1250
+
--> [%expr
1251
+
Sexplib0.Sexp_conv_error.unexpected_stag
1252
+
[%e error_source ()]
1253
+
[%e alts_strings]
1254
+
[%e Fresh_name.expression fresh_sexp]]
1255
+
]
1256
+
|> Lifted.return
1257
+
]
1258
+
|> Lifted.all
1259
+
>>| List.concat
1260
+
>>| Conversion.of_lambda
1261
+
;;
1262
+
1263
+
(* Empty type *)
1264
+
let nil_of_sexp ~error_source loc : Conversion.t =
1265
+
Conversion.of_reference_exn
1266
+
~thunk:false
1267
+
[%expr Sexplib0.Sexp_conv_error.empty_type [%e error_source ()]]
1268
+
;;
1269
+
1270
+
(* Generate code from type definitions *)
1271
+
1272
+
let td_of_sexp ~typevars ~loc:_ ~poly ~path ~rec_flag ~values_being_defined ~portable td
1273
+
=
1274
+
let tps =
1275
+
List.filter td.ptype_params ~f:(fun (p, _) -> include_param_in_combinator p)
1276
+
|> List.map ~f:Ppxlib_jane.get_type_param_name_and_jkind
1277
+
in
1278
+
let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in
1279
+
let full_type =
1280
+
core_type_of_type_declaration td |> replace_variables_by_underscores
1281
+
in
1282
+
let is_private =
1283
+
match td.ptype_private with
1284
+
| Private -> true
1285
+
| Public -> false
1286
+
in
1287
+
if is_private
1288
+
then Location.raise_errorf ~loc "of_sexp is not supported for private type";
1289
+
let create_internal_function =
1290
+
match is_polymorphic_variant td ~sig_:false with
1291
+
| `Definitely -> true
1292
+
| `Maybe -> poly
1293
+
| `Surely_not ->
1294
+
if poly
1295
+
then
1296
+
Location.raise_errorf
1297
+
~loc
1298
+
"sexp_poly annotation on a type that is surely not a polymorphic variant";
1299
+
false
1300
+
in
1301
+
let body ~error_source =
1302
+
let body =
1303
+
match Ppxlib_jane.Shim.Type_kind.of_parsetree td.ptype_kind with
1304
+
| Ptype_variant alts ->
1305
+
Attrs.fail_if_allow_extra_field_td ~loc td;
1306
+
sum_of_sexp ~error_source ~typevars td (td.ptype_loc, alts)
1307
+
| Ptype_record lbls ->
1308
+
record_of_sexp
1309
+
~error_source
1310
+
~typevars
1311
+
~allow_extra_fields:
1312
+
(Option.is_some (Attribute.get Attrs.allow_extra_fields_td td))
1313
+
~unboxed:false
1314
+
td
1315
+
(loc, lbls)
1316
+
| Ptype_record_unboxed_product lbls ->
1317
+
record_of_sexp
1318
+
~error_source
1319
+
~typevars
1320
+
~allow_extra_fields:
1321
+
(Option.is_some (Attribute.get Attrs.allow_extra_fields_td td))
1322
+
~unboxed:true
1323
+
td
1324
+
(loc, lbls)
1325
+
| Ptype_open ->
1326
+
Location.raise_errorf ~loc "ppx_sexp_conv: open types not supported"
1327
+
| Ptype_abstract ->
1328
+
Attrs.fail_if_allow_extra_field_td ~loc td;
1329
+
(match td.ptype_manifest with
1330
+
| None -> nil_of_sexp ~error_source td.ptype_loc |> Lifted.return
1331
+
| Some ty ->
1332
+
type_of_sexp
1333
+
~error_source
1334
+
~full_type
1335
+
~typevars
1336
+
~internal:create_internal_function
1337
+
ty
1338
+
|> Lifted.return)
1339
+
in
1340
+
(* Prevent violation of value restriction, problems with recursive types, and
1341
+
toplevel effects by eta-expanding function definitions *)
1342
+
body
1343
+
>>| Conversion.to_value_expression
1344
+
~loc
1345
+
~rec_flag
1346
+
~values_being_defined
1347
+
~stackify:false
1348
+
in
1349
+
let name ~internal = of_sexp_function_for_type ~internal type_name in
1350
+
let arg_patts, arg_exprs =
1351
+
let list =
1352
+
List.map
1353
+
~f:(fun (tp, _) ->
1354
+
let name = String.Map.find tp.txt typevars in
1355
+
Fresh_name.pattern name, Fresh_name.expression name)
1356
+
tps
1357
+
in
1358
+
List.map list ~f:fst, List.map list ~f:snd
1359
+
in
1360
+
let full_type_name =
1361
+
Printf.sprintf "%s.%s" path (Ppx_helpers.mangle_unboxed type_name)
1362
+
in
1363
+
let internal_fun_body =
1364
+
if create_internal_function
1365
+
then
1366
+
Some
1367
+
(with_error_source ~loc ~full_type_name (fun ~error_source ->
1368
+
body ~error_source
1369
+
>>| fun body ->
1370
+
eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body)))
1371
+
else None
1372
+
in
1373
+
let external_fun_body =
1374
+
let body_below_lambdas ~error_source =
1375
+
let fresh_sexp = Fresh_name.create "sexp" ~loc in
1376
+
if create_internal_function
1377
+
then (
1378
+
let no_variant_match_mc =
1379
+
[ [%pat? Sexplib0.Sexp_conv_error.No_variant_match]
1380
+
--> [%expr
1381
+
Sexplib0.Sexp_conv_error.no_matching_variant_found
1382
+
[%e error_source ()]
1383
+
[%e Fresh_name.expression fresh_sexp]]
1384
+
]
1385
+
in
1386
+
let internal_call =
1387
+
let internal_expr =
1388
+
pexp_ident ~loc { loc; txt = Lident (name ~internal:true) }
1389
+
in
1390
+
eapply ~loc internal_expr (arg_exprs @ [ Fresh_name.expression fresh_sexp ])
1391
+
in
1392
+
let try_with = pexp_try ~loc internal_call no_variant_match_mc in
1393
+
[%expr fun [%p Fresh_name.pattern fresh_sexp] -> [%e try_with]] |> Lifted.return)
1394
+
else body ~error_source
1395
+
in
1396
+
let body_with_lambdas ~error_source =
1397
+
body_below_lambdas ~error_source
1398
+
>>| fun body ->
1399
+
eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc arg_patts body)
1400
+
in
1401
+
with_error_source ~loc ~full_type_name body_with_lambdas
1402
+
in
1403
+
let typ = Sig_generate_of_sexp.mk_type td in
1404
+
let mk_binding func_name body =
1405
+
let ({ vars = tps; body = typ; loc = _ } : Ppx_helpers.Polytype.t) = typ in
1406
+
constrained_function_binding loc td typ ~tps ~func_name ~portable body
1407
+
in
1408
+
let internal_bindings =
1409
+
match internal_fun_body with
1410
+
| None -> []
1411
+
| Some body -> [ mk_binding (name ~internal:true) body ]
1412
+
in
1413
+
let name = name ~internal:false in
1414
+
let external_binding = mk_binding name external_fun_body in
1415
+
internal_bindings, [ external_binding ], name
1416
+
;;
1417
+
1418
+
(* Generate code from type definitions *)
1419
+
let tds_of_sexp ~loc ~poly ~path ~portable ~unboxed (rec_flag, tds) =
1420
+
let tds = List.map ~f:name_type_params_in_td tds in
1421
+
let tds = Ppx_helpers.with_implicit_unboxed_records ~unboxed tds in
1422
+
let typevars td =
1423
+
List.fold_left td.ptype_params ~init:String.Map.empty ~f:(fun map param ->
1424
+
let name = get_type_param_name param in
1425
+
String.Map.add name.txt (Fresh_name.create ("_of_" ^ name.txt) ~loc:name.loc) map)
1426
+
in
1427
+
let singleton =
1428
+
match tds with
1429
+
| [ _ ] -> true
1430
+
| _ -> false
1431
+
in
1432
+
let values_being_defined =
1433
+
List.map tds ~f:(fun td -> of_sexp_function_for_type td.ptype_name.txt)
1434
+
|> String.Set.of_list
1435
+
in
1436
+
let rec_flag = really_recursive_respecting_opaque rec_flag tds in
1437
+
let bindings, names =
1438
+
if singleton
1439
+
then (
1440
+
match rec_flag with
1441
+
| Recursive ->
1442
+
let bindings_and_names =
1443
+
List.map tds ~f:(fun td ->
1444
+
let typevars = typevars td in
1445
+
let internals, externals, name =
1446
+
td_of_sexp
1447
+
~typevars
1448
+
~loc
1449
+
~poly
1450
+
~path
1451
+
~rec_flag
1452
+
~values_being_defined
1453
+
~portable
1454
+
td
1455
+
in
1456
+
internals @ externals, name)
1457
+
in
1458
+
let bindings = List.concat_map bindings_and_names ~f:fst in
1459
+
let names = List.map bindings_and_names ~f:snd in
1460
+
pstr_value_list ~loc Recursive bindings, names
1461
+
| Nonrecursive ->
1462
+
let bindings_and_names =
1463
+
List.map tds ~f:(fun td ->
1464
+
let typevars = typevars td in
1465
+
let internals, externals, name =
1466
+
td_of_sexp
1467
+
~typevars
1468
+
~loc
1469
+
~poly
1470
+
~path
1471
+
~rec_flag
1472
+
~values_being_defined
1473
+
~portable
1474
+
td
1475
+
in
1476
+
( pstr_value_list ~loc Nonrecursive internals
1477
+
@ pstr_value_list ~loc Nonrecursive externals
1478
+
, name ))
1479
+
in
1480
+
let bindings = List.concat_map bindings_and_names ~f:fst in
1481
+
let names = List.map bindings_and_names ~f:snd in
1482
+
bindings, names)
1483
+
else (
1484
+
(* If there are any polymorphic variants, the binding needs to be recursive (even if
1485
+
the types are not) in order for e.g. [t_of_sexp] to be able to reference
1486
+
[__t_of_sexp__]. *)
1487
+
let rec_flag =
1488
+
if List.exists tds ~f:(function
1489
+
| { ptype_manifest = Some { ptyp_desc = Ptyp_variant _; _ }; _ } -> true
1490
+
| _ -> false)
1491
+
then Recursive
1492
+
else rec_flag
1493
+
in
1494
+
let bindings_and_names =
1495
+
List.map tds ~f:(fun td ->
1496
+
let typevars = typevars td in
1497
+
let internals, externals, name =
1498
+
td_of_sexp
1499
+
~typevars
1500
+
~poly
1501
+
~loc
1502
+
~path
1503
+
~rec_flag
1504
+
~values_being_defined
1505
+
~portable
1506
+
td
1507
+
in
1508
+
internals @ externals, name)
1509
+
in
1510
+
let bindings = List.concat_map bindings_and_names ~f:fst in
1511
+
let names = List.map bindings_and_names ~f:snd in
1512
+
pstr_value_list ~loc rec_flag bindings, names)
1513
+
in
1514
+
if portable
1515
+
then
1516
+
[ [%stri include [%m pmod_structure ~loc bindings]]
1517
+
; pstr_value
1518
+
~loc
1519
+
Nonrecursive
1520
+
(List.map names ~f:(fun name ->
1521
+
value_binding
1522
+
~loc
1523
+
~pat:[%pat? _]
1524
+
~expr:(evar ~loc name)
1525
+
~modes:[ { loc; txt = Mode "portable" } ]))
1526
+
]
1527
+
else bindings
1528
+
;;
1529
+
1530
+
let core_type_of_sexp ~path core_type =
1531
+
let loc = { core_type.ptyp_loc with loc_ghost = true } in
1532
+
let full_type_name =
1533
+
Printf.sprintf
1534
+
"%s line %i: %s"
1535
+
path
1536
+
loc.loc_start.pos_lnum
1537
+
(string_of_core_type core_type)
1538
+
in
1539
+
with_error_source ~loc ~full_type_name (fun ~error_source ->
1540
+
type_of_sexp ~error_source ~typevars:String.Map.empty core_type
1541
+
|> Conversion.to_value_expression
1542
+
~loc
1543
+
~rec_flag:Nonrecursive
1544
+
~values_being_defined:String.Set.empty
1545
+
~stackify:false
1546
+
|> Merlin_helpers.hide_expression
1547
+
|> Lifted.return)
1548
+
;;
1549
+
end
+35
vendor/opam/ppx_sexp_conv/expander/expand_of_sexp.mli
+35
vendor/opam/ppx_sexp_conv/expander/expand_of_sexp.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
module Sig_generate_of_sexp : sig
5
+
(** Given a type, produce the type of its [of_sexp] conversion. *)
6
+
val type_of_of_sexp : loc:location -> core_type -> core_type
7
+
8
+
(** Derive an [of_sexp] interface for a list of type declarations. *)
9
+
val mk_sig
10
+
: poly:bool
11
+
-> loc:location
12
+
-> path:string
13
+
-> unboxed:bool
14
+
-> rec_flag * type_declaration list
15
+
-> portable:bool
16
+
-> signature_item list
17
+
end
18
+
19
+
module Str_generate_of_sexp : sig
20
+
(** Given a type, produce a pattern for that type's [of_sexp] conversion. *)
21
+
val pat_of_of_sexp : loc:location -> core_type -> pattern
22
+
23
+
(** Given a type, produce its [of_sexp] conversion. *)
24
+
val core_type_of_sexp : path:string -> core_type -> expression
25
+
26
+
(** Derive an [of_sexp] implementation for a list of type declarations. *)
27
+
val tds_of_sexp
28
+
: loc:location
29
+
-> poly:bool
30
+
-> path:string
31
+
-> portable:bool
32
+
-> unboxed:bool
33
+
-> rec_flag * type_declaration list
34
+
-> structure_item list
35
+
end
+1056
vendor/opam/ppx_sexp_conv/expander/expand_sexp_of.ml
+1056
vendor/opam/ppx_sexp_conv/expander/expand_sexp_of.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Ppxlib.Ast_builder.Default
4
+
open Ppxlib_jane.Ast_builder.Default
5
+
open Helpers
6
+
open Lifted.Monad_infix
7
+
8
+
let fmt ~stackify : _ format =
9
+
match stackify with
10
+
| false -> "sexp_of_%s%s"
11
+
| true -> "sexp_of_%s%s__stack"
12
+
;;
13
+
14
+
let sexp_of_typename ~stackify ~prefix typename =
15
+
Printf.sprintf (fmt ~stackify) prefix (Ppx_helpers.mangle_unboxed typename)
16
+
;;
17
+
18
+
let list_map ~loc ~stackify =
19
+
match stackify with
20
+
| false -> [%expr Sexplib0.Sexp_conv.list_map]
21
+
| true -> [%expr Sexplib0.Sexp_conv.list_map__stack]
22
+
;;
23
+
24
+
let sexp_of_opaque ~loc ~stackify =
25
+
match stackify with
26
+
| false -> [%expr (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _)]
27
+
| true -> [%expr (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _)]
28
+
;;
29
+
30
+
(* Generates the signature for type conversion to S-expressions *)
31
+
module Sig_generate_sexp_of = struct
32
+
let type_of_sexp_of ~loc t ~stackify =
33
+
let loc = { loc with loc_ghost = true } in
34
+
match stackify with
35
+
| false -> [%type: [%t t] -> Sexplib0.Sexp.t]
36
+
| true -> [%type: [%t t] -> Sexplib0.Sexp.t]
37
+
;;
38
+
39
+
let mk_type td ~stackify =
40
+
Ppx_helpers.combinator_type_of_type_declaration
41
+
td
42
+
~f:(type_of_sexp_of ~stackify)
43
+
~phantom_attr:Attrs.phantom
44
+
;;
45
+
46
+
let mk_val td ~stackify ~portable =
47
+
let loc = td.ptype_loc in
48
+
let name = Located.map (sexp_of_typename ~stackify ~prefix:"") td.ptype_name in
49
+
psig_value
50
+
~loc
51
+
(Ppxlib_jane.Ast_builder.Default.value_description
52
+
~loc
53
+
~name
54
+
~type_:
55
+
(mk_type td ~stackify
56
+
|> Ppx_helpers.Polytype.to_core_type
57
+
~universally_quantify_only_if_jkind_annotation:true)
58
+
~modalities:(if portable then Ppxlib_jane.Shim.Modalities.portable ~loc else [])
59
+
~prim:[])
60
+
;;
61
+
62
+
let mk_sig ~loc:_ ~path:_ ~unboxed (_rf, tds) ~stackify ~portable =
63
+
let tds = Ppx_helpers.with_implicit_unboxed_records ~unboxed tds in
64
+
List.map tds ~f:(mk_val ~stackify ~portable)
65
+
;;
66
+
67
+
let mk_sig_exn ~loc:_ ~path:_ _te = []
68
+
end
69
+
70
+
module Str_generate_sexp_of = struct
71
+
module Types_being_defined = struct
72
+
type t =
73
+
| Nonrec
74
+
| Rec of String.Set.t
75
+
76
+
let to_rec_flag = function
77
+
| Nonrec -> Nonrecursive
78
+
| Rec _ -> Recursive
79
+
;;
80
+
81
+
let to_values_being_defined t ~stackify =
82
+
match t with
83
+
| Nonrec -> String.Set.empty
84
+
| Rec types -> String.Set.map (sexp_of_typename ~stackify ~prefix:"") types
85
+
;;
86
+
end
87
+
88
+
let sexp_of_ident_for_constr_conv ~stackify ?functor_:modname typename =
89
+
let prefix =
90
+
match modname with
91
+
| Some modname -> modname ^ "__"
92
+
| None -> ""
93
+
in
94
+
sexp_of_typename ~stackify ~prefix typename
95
+
;;
96
+
97
+
let pat_of_sexp_of ~loc typ ~stackify =
98
+
let loc = { loc with loc_ghost = true } in
99
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree typ.ptyp_desc with
100
+
| Ptyp_constr (id, _) ->
101
+
Ppx_helpers.type_constr_conv_pat
102
+
~loc
103
+
id
104
+
~f:(sexp_of_ident_for_constr_conv ~stackify)
105
+
| Ptyp_var _ ->
106
+
Ast_builder.Default.ppat_extension
107
+
~loc
108
+
(Location.error_extensionf
109
+
~loc
110
+
"Type variables are disallowed here. Instead, consider using a locally \
111
+
abstract type.")
112
+
| _ ->
113
+
Ast_builder.Default.ppat_extension
114
+
~loc
115
+
(Location.error_extensionf
116
+
~loc
117
+
"Only type constructors are allowed here (e.g. [t], ['a t], or [M(X).t]).")
118
+
;;
119
+
120
+
let sexp_of_type_constr ~loc id args ~stackify =
121
+
Ppx_helpers.type_constr_conv_expr
122
+
~loc
123
+
id
124
+
~f:(sexp_of_ident_for_constr_conv ~stackify)
125
+
args
126
+
;;
127
+
128
+
(* Conversion of types *)
129
+
let rec sexp_of_type ~renaming typ ~stackify : Conversion.t =
130
+
let loc = { typ.ptyp_loc with loc_ghost = true } in
131
+
match Ppxlib_jane.Shim.Core_type.of_parsetree typ with
132
+
| _ when Option.is_some (Attribute.get Attrs.opaque typ) ->
133
+
Conversion.of_reference_exn ~thunk:false (sexp_of_opaque ~loc ~stackify)
134
+
| { ptyp_desc = Ptyp_any _; _ } ->
135
+
Conversion.of_lambda [ ppat_any ~loc --> [%expr Sexplib0.Sexp.Atom "_"] ]
136
+
| { ptyp_desc = (Ptyp_tuple labeled_tps | Ptyp_unboxed_tuple labeled_tps) as desc; _ }
137
+
->
138
+
let unboxed =
139
+
match desc with
140
+
| Ptyp_unboxed_tuple _ -> true
141
+
| Ptyp_tuple _ -> false
142
+
| _ -> assert false
143
+
in
144
+
(match Ppxlib_jane.as_unlabeled_tuple labeled_tps with
145
+
| Some tps ->
146
+
Conversion.of_lambda [ sexp_of_tuple ~renaming ~unboxed (loc, tps) ~stackify ]
147
+
| None ->
148
+
Conversion.of_lambda
149
+
[ sexp_of_labeled_tuple ~renaming ~loc ~unboxed labeled_tps ~stackify ])
150
+
| { ptyp_desc = Ptyp_var (parm, _); _ } ->
151
+
(match Renaming.binding_kind renaming parm ~loc with
152
+
| Universally_bound fresh ->
153
+
Conversion.of_reference_exn ~thunk:false (Fresh_name.expression fresh)
154
+
| Existentially_bound -> sexp_of_type ~renaming [%type: _] ~stackify)
155
+
| { ptyp_desc = Ptyp_constr (id, args); _ } ->
156
+
(match typ with
157
+
| [%type: [%t? _] sexp_opaque] ->
158
+
Conversion.of_reference_exn ~thunk:false (sexp_of_opaque ~loc ~stackify)
159
+
| _ ->
160
+
Conversion.of_reference_exn
161
+
~thunk:false
162
+
(sexp_of_type_constr
163
+
~loc
164
+
id
165
+
(List.filter args ~f:include_param_in_combinator
166
+
|> List.map ~f:(fun tp ->
167
+
Conversion.to_expression
168
+
~loc
169
+
(sexp_of_type ~renaming tp ~stackify)
170
+
~stackify))
171
+
~stackify))
172
+
| { ptyp_desc = Ptyp_arrow (_, _, _, _, _); _ } ->
173
+
Conversion.of_lambda
174
+
[ ppat_any ~loc
175
+
--> [%expr Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore]
176
+
]
177
+
| { ptyp_desc = Ptyp_variant (row_fields, Closed, _); _ } ->
178
+
sexp_of_variant ~renaming (loc, row_fields) ~stackify
179
+
| { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } ->
180
+
sexp_of_poly ~renaming parms poly_tp ~stackify
181
+
| core_type ->
182
+
Location.raise_errorf
183
+
~loc
184
+
"Type unsupported for ppx [sexp_of] conversion (%s)"
185
+
(Ppxlib_jane.Language_feature_name.of_core_type_desc core_type.ptyp_desc)
186
+
187
+
(* Conversion of (unlabeled) tuples *)
188
+
and sexp_of_tuple ~renaming ~unboxed (loc, tps) ~stackify =
189
+
let fps = List.map ~f:(fun tp -> sexp_of_type ~renaming tp ~stackify) tps in
190
+
let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
191
+
Conversion.apply_all ~loc fps
192
+
in
193
+
let in_expr = [%expr Sexplib0.Sexp.List [%e elist ~loc converted]] in
194
+
let expr = pexp_let ~loc Immutable Nonrecursive bindings in_expr in
195
+
let arguments = List.map arguments ~f:(fun p -> None, p) in
196
+
let ppat_tuple = if unboxed then ppat_unboxed_tuple else ppat_tuple in
197
+
ppat_tuple ~loc arguments Closed --> expr
198
+
199
+
(* Conversion of labeled tuples *)
200
+
and sexp_of_labeled_tuple ~renaming ~loc ~unboxed alist ~stackify =
201
+
let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
202
+
List.map alist ~f:(fun (_, core_type) -> sexp_of_type ~renaming core_type ~stackify)
203
+
|> Conversion.apply_all ~loc
204
+
in
205
+
let expr =
206
+
let sexp_exprs =
207
+
(* Constructor inference allows to to leave off [Sexplib0.Sexp.] here. *)
208
+
List.map2 alist converted ~f:(fun (label_option, _) expr ->
209
+
[%expr
210
+
List
211
+
[ Atom [%e estring ~loc (Labeled_tuple.atom_of_label label_option)]
212
+
; [%e expr]
213
+
]])
214
+
in
215
+
[%expr Sexplib0.Sexp.List [%e elist ~loc sexp_exprs]]
216
+
|> pexp_let ~loc Immutable Nonrecursive bindings
217
+
in
218
+
let ppat_tuple = if unboxed then ppat_unboxed_tuple else ppat_tuple in
219
+
let pat =
220
+
ppat_tuple
221
+
~loc
222
+
(List.map2 alist arguments ~f:(fun (label_option, _) arg -> label_option, arg))
223
+
Closed
224
+
in
225
+
pat --> expr
226
+
227
+
(* Conversion of variant types *)
228
+
and sexp_of_variant
229
+
~renaming
230
+
((loc, row_fields) : Location.t * row_field list)
231
+
~stackify
232
+
: Conversion.t
233
+
=
234
+
let item row =
235
+
match row.prf_desc with
236
+
| Rtag ({ txt = cnstr; _ }, true, []) ->
237
+
ppat_variant ~loc cnstr None
238
+
--> [%expr Sexplib0.Sexp.Atom [%e estring ~loc cnstr]]
239
+
| Rtag ({ txt = cnstr; _ }, _, [ tp ])
240
+
when Option.is_some (Attribute.get Attrs.list_poly row) ->
241
+
(match tp with
242
+
| [%type: [%t? tp] list] ->
243
+
let cnv_expr =
244
+
Conversion.to_expression ~loc (sexp_of_type ~renaming tp ~stackify) ~stackify
245
+
in
246
+
let name = Fresh_name.create "l" ~loc in
247
+
ppat_variant ~loc cnstr (Some (Fresh_name.pattern name))
248
+
--> [%expr
249
+
Sexplib0.Sexp.List
250
+
(Sexplib0.Sexp.Atom [%e estring ~loc cnstr]
251
+
:: [%e list_map ~loc ~stackify]
252
+
[%e cnv_expr]
253
+
[%e Fresh_name.expression name])]
254
+
| _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list")
255
+
| Rtag ({ txt = cnstr; _ }, _, [ [%type: [%t? tp] sexp_list] ]) ->
256
+
let cnv_expr =
257
+
Conversion.to_expression ~loc (sexp_of_type ~renaming tp ~stackify) ~stackify
258
+
in
259
+
let name = Fresh_name.create "l" ~loc in
260
+
ppat_variant ~loc cnstr (Some (Fresh_name.pattern name))
261
+
--> [%expr
262
+
Sexplib0.Sexp.List
263
+
(Sexplib0.Sexp.Atom [%e estring ~loc cnstr]
264
+
:: [%e list_map ~loc ~stackify]
265
+
[%e cnv_expr]
266
+
[%e Fresh_name.expression name])]
267
+
| Rtag ({ txt = cnstr; _ }, false, [ tp ]) ->
268
+
let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e estring ~loc cnstr]] in
269
+
let fresh = Fresh_name.create "v" ~loc in
270
+
let cnstr_arg =
271
+
Conversion.apply
272
+
~loc
273
+
(sexp_of_type ~renaming tp ~stackify)
274
+
(Fresh_name.expression fresh)
275
+
in
276
+
let expr = [%expr Sexplib0.Sexp.List [%e elist ~loc [ cnstr_expr; cnstr_arg ]]] in
277
+
ppat_variant ~loc cnstr (Some (Fresh_name.pattern fresh)) --> expr
278
+
| Rinherit { ptyp_desc = Ptyp_constr (id, []); _ } ->
279
+
let name = Fresh_name.create "v" ~loc in
280
+
ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name)
281
+
--> sexp_of_type_constr ~loc id [ Fresh_name.expression name ] ~stackify
282
+
| Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) ->
283
+
Location.raise_errorf ~loc "unsupported: polymorphic variant intersection type"
284
+
| Rinherit ({ ptyp_desc = Ptyp_constr (id, _ :: _); _ } as typ) ->
285
+
let call =
286
+
Conversion.to_expression ~loc (sexp_of_type ~renaming typ ~stackify) ~stackify
287
+
in
288
+
let name = Fresh_name.create "v" ~loc in
289
+
ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name)
290
+
--> [%expr [%e call] [%e Fresh_name.expression name]]
291
+
| Rinherit _ ->
292
+
Location.raise_errorf
293
+
~loc
294
+
"unsupported: polymorphic variant with invalid (non-identifier) inherited type"
295
+
| Rtag (_, false, []) ->
296
+
Location.raise_errorf ~loc "unsupported: polymorphic variant empty type"
297
+
in
298
+
Conversion.of_lambda (List.map ~f:item row_fields)
299
+
300
+
(* Polymorphic record fields *)
301
+
and sexp_of_poly ~renaming parms tp ~stackify =
302
+
let loc = tp.ptyp_loc in
303
+
let renaming =
304
+
List.fold_left parms ~init:renaming ~f:(fun renaming (name, _jkind) ->
305
+
Renaming.add_universally_bound renaming name ~prefix:"_of_")
306
+
in
307
+
let bindings =
308
+
let mk_binding (parm, _jkind) =
309
+
let name =
310
+
match Renaming.binding_kind renaming parm.txt ~loc:parm.loc with
311
+
| Universally_bound name -> name
312
+
| Existentially_bound -> assert false
313
+
in
314
+
value_binding
315
+
~loc
316
+
~pat:(Fresh_name.pattern name)
317
+
~expr:(sexp_of_opaque ~loc ~stackify)
318
+
~modes:[]
319
+
in
320
+
List.map ~f:mk_binding parms
321
+
in
322
+
Conversion.bind (sexp_of_type ~renaming tp ~stackify) bindings
323
+
;;
324
+
325
+
(* Conversion of record types *)
326
+
327
+
let mk_rec_patt loc patt name fresh =
328
+
let p = Loc.make (Longident.Lident name) ~loc, Fresh_name.pattern fresh in
329
+
patt @ [ p ]
330
+
;;
331
+
332
+
type is_empty_expr =
333
+
| Inspect_value of (location -> expression -> expression)
334
+
| Inspect_sexp of (cnv_expr:expression -> location -> expression -> expression)
335
+
336
+
let sexp_of_record_field
337
+
~renaming
338
+
~bnds
339
+
patt
340
+
expr
341
+
name
342
+
tp
343
+
?sexp_of
344
+
is_empty_expr
345
+
~stackify
346
+
=
347
+
let loc = tp.ptyp_loc in
348
+
let fresh = Fresh_name.create name ~loc in
349
+
let patt = mk_rec_patt loc patt name fresh in
350
+
let cnv_expr =
351
+
Conversion.to_expression ~loc (sexp_of_type ~renaming tp ~stackify) ~stackify
352
+
in
353
+
let cnv_expr =
354
+
match sexp_of with
355
+
| None -> cnv_expr
356
+
| Some sexp_of -> [%expr [%e sexp_of] [%e cnv_expr]]
357
+
in
358
+
let bnd = Fresh_name.create "bnd" ~loc in
359
+
let arg = Fresh_name.create "arg" ~loc in
360
+
let expr =
361
+
[%expr
362
+
let [%p Fresh_name.pattern bnds] =
363
+
[%e
364
+
match is_empty_expr with
365
+
| Inspect_value is_empty_expr ->
366
+
[%expr
367
+
if [%e is_empty_expr loc (Fresh_name.expression fresh)]
368
+
then [%e Fresh_name.expression bnds]
369
+
else (
370
+
let [%p Fresh_name.pattern arg] =
371
+
[%e cnv_expr] [%e Fresh_name.expression fresh]
372
+
in
373
+
let [%p Fresh_name.pattern bnd] =
374
+
Sexplib0.Sexp.List
375
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
376
+
; [%e Fresh_name.expression arg]
377
+
]
378
+
in
379
+
([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
380
+
: _ Stdlib.List.t))]
381
+
| Inspect_sexp is_empty_expr ->
382
+
[%expr
383
+
let [%p Fresh_name.pattern arg] =
384
+
[%e cnv_expr] [%e Fresh_name.expression fresh]
385
+
in
386
+
if [%e is_empty_expr ~cnv_expr loc (Fresh_name.expression arg)]
387
+
then [%e Fresh_name.expression bnds]
388
+
else (
389
+
let [%p Fresh_name.pattern bnd] =
390
+
Sexplib0.Sexp.List
391
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
392
+
; [%e Fresh_name.expression arg]
393
+
]
394
+
in
395
+
([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
396
+
: _ Stdlib.List.t))]]
397
+
in
398
+
[%e expr]]
399
+
in
400
+
patt, expr
401
+
;;
402
+
403
+
let disallow_type_variables_and_recursive_occurrences
404
+
~types_being_defined
405
+
~loc
406
+
~attr_name
407
+
tp
408
+
=
409
+
let disallow_variables =
410
+
let iter =
411
+
object
412
+
inherit Ast_traverse.iter as super
413
+
414
+
method! core_type_desc t =
415
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree t with
416
+
| Ptyp_var (v, _) ->
417
+
Location.raise_errorf
418
+
~loc
419
+
"[@%s] was used, but the type of the field contains a type variable: '%s.\n\
420
+
Comparison is not avaiable for type variables.\n\
421
+
Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead."
422
+
attr_name
423
+
v
424
+
| _ -> super#core_type_desc t
425
+
end
426
+
in
427
+
iter#core_type
428
+
in
429
+
let disallow_recursive_occurrences =
430
+
match (types_being_defined : Types_being_defined.t) with
431
+
| Nonrec -> fun _ -> ()
432
+
| Rec types_being_defined ->
433
+
let iter =
434
+
object
435
+
inherit Ast_traverse.iter as super
436
+
437
+
method! core_type_desc =
438
+
function
439
+
| Ptyp_constr ({ loc = _; txt = Lident s }, _) as t ->
440
+
if String.Set.mem s types_being_defined
441
+
then
442
+
Location.raise_errorf
443
+
~loc
444
+
"[@%s] was used, but the type of the field contains a type defined \
445
+
in the current recursive block: %s.\n\
446
+
This is not supported.\n\
447
+
Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] \
448
+
instead."
449
+
attr_name
450
+
s;
451
+
super#core_type_desc t
452
+
| t -> super#core_type_desc t
453
+
end
454
+
in
455
+
iter#core_type
456
+
in
457
+
disallow_variables tp;
458
+
disallow_recursive_occurrences tp
459
+
;;
460
+
461
+
let sexp_of_default_field
462
+
~types_being_defined
463
+
how
464
+
~renaming
465
+
~bnds
466
+
patt
467
+
expr
468
+
name
469
+
tp
470
+
?sexp_of
471
+
default
472
+
~stackify
473
+
=
474
+
let is_empty =
475
+
let inspect_value equality_f =
476
+
Inspect_value (fun loc expr -> [%expr [%e equality_f loc] [%e default] [%e expr]])
477
+
in
478
+
match (how : Record_field_attrs.Sexp_of.Drop.t) with
479
+
| Sexp ->
480
+
Inspect_sexp
481
+
(fun ~cnv_expr loc sexp_expr ->
482
+
[%expr Sexplib0.Sexp_conv.( = ) ([%e cnv_expr] [%e default]) [%e sexp_expr]])
483
+
|> Lifted.return
484
+
| Func lifted -> lifted >>| fun f -> inspect_value (fun _ -> f)
485
+
| Compare ->
486
+
inspect_value (fun loc ->
487
+
disallow_type_variables_and_recursive_occurrences
488
+
~types_being_defined
489
+
~attr_name:"sexp_drop_default.compare"
490
+
~loc
491
+
tp;
492
+
[%expr [%compare.equal: [%t tp]]])
493
+
|> Lifted.return
494
+
| Equal ->
495
+
inspect_value (fun loc ->
496
+
disallow_type_variables_and_recursive_occurrences
497
+
~types_being_defined
498
+
~attr_name:"sexp_drop_default.equal"
499
+
~loc
500
+
tp;
501
+
[%expr [%equal: [%t tp]]])
502
+
|> Lifted.return
503
+
in
504
+
is_empty >>| sexp_of_record_field ~renaming ~bnds patt expr name tp ?sexp_of ~stackify
505
+
;;
506
+
507
+
let sexp_of_label_declaration_list
508
+
~types_being_defined
509
+
~renaming
510
+
loc
511
+
flds
512
+
~wrap_expr
513
+
~stackify
514
+
~unboxed
515
+
=
516
+
let bnds = Fresh_name.create "bnds" ~loc in
517
+
let list_empty_expr =
518
+
Inspect_value
519
+
(fun loc lst ->
520
+
[%expr
521
+
match [%e lst] with
522
+
| [] -> true
523
+
| _ -> false])
524
+
in
525
+
let array_empty_expr =
526
+
Inspect_value
527
+
(fun loc arr ->
528
+
[%expr
529
+
match [%e arr] with
530
+
| [||] -> true
531
+
| _ -> false])
532
+
in
533
+
let coll lifted ld =
534
+
lifted
535
+
>>= fun ((patt : (Longident.t loc * pattern) list), expr) ->
536
+
let name = ld.pld_name.txt in
537
+
let loc = ld.pld_name.loc in
538
+
let fresh = Fresh_name.create name ~loc in
539
+
match Record_field_attrs.Sexp_of.create ~loc ld with
540
+
| Sexp_option tp ->
541
+
let v = Fresh_name.create "v" ~loc in
542
+
let bnd = Fresh_name.create "bnd" ~loc in
543
+
let arg = Fresh_name.create "arg" ~loc in
544
+
let patt = mk_rec_patt loc patt name fresh in
545
+
let vname = Fresh_name.expression v in
546
+
let cnv_expr =
547
+
Conversion.apply ~loc (sexp_of_type ~renaming tp ~stackify) vname
548
+
in
549
+
let expr =
550
+
[%expr
551
+
let [%p Fresh_name.pattern bnds] =
552
+
match [%e Fresh_name.expression fresh] with
553
+
| Stdlib.Option.None -> [%e Fresh_name.expression bnds]
554
+
| Stdlib.Option.Some [%p Fresh_name.pattern v] ->
555
+
let [%p Fresh_name.pattern arg] = [%e cnv_expr] in
556
+
let [%p Fresh_name.pattern bnd] =
557
+
Sexplib0.Sexp.List
558
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
559
+
; [%e Fresh_name.expression arg]
560
+
]
561
+
in
562
+
([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
563
+
: _ Stdlib.List.t)
564
+
in
565
+
[%e expr]]
566
+
in
567
+
Lifted.return (patt, expr)
568
+
| Sexp_or_null tp ->
569
+
let v = Fresh_name.create "v" ~loc in
570
+
let bnd = Fresh_name.create "bnd" ~loc in
571
+
let arg = Fresh_name.create "arg" ~loc in
572
+
let patt = mk_rec_patt loc patt name fresh in
573
+
let vname = Fresh_name.expression v in
574
+
let cnv_expr =
575
+
Conversion.apply ~loc (sexp_of_type ~renaming tp ~stackify) vname
576
+
in
577
+
let expr =
578
+
[%expr
579
+
let [%p Fresh_name.pattern bnds] =
580
+
match [%e Fresh_name.expression fresh] with
581
+
| Ppx_sexp_conv_lib.Or_null.Null -> [%e Fresh_name.expression bnds]
582
+
| Ppx_sexp_conv_lib.Or_null.This [%p Fresh_name.pattern v] ->
583
+
let [%p Fresh_name.pattern arg] = [%e cnv_expr] in
584
+
let [%p Fresh_name.pattern bnd] =
585
+
Sexplib0.Sexp.List
586
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
587
+
; [%e Fresh_name.expression arg]
588
+
]
589
+
in
590
+
([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
591
+
: _ Stdlib.List.t)
592
+
in
593
+
[%e expr]]
594
+
in
595
+
Lifted.return (patt, expr)
596
+
| Sexp_bool ->
597
+
let patt = mk_rec_patt loc patt name fresh in
598
+
let bnd = Fresh_name.create "bnd" ~loc in
599
+
let expr =
600
+
[%expr
601
+
let [%p Fresh_name.pattern bnds] =
602
+
if [%e Fresh_name.expression fresh]
603
+
then (
604
+
let [%p Fresh_name.pattern bnd] =
605
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ]
606
+
in
607
+
([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
608
+
: _ Stdlib.List.t))
609
+
else [%e Fresh_name.expression bnds]
610
+
in
611
+
[%e expr]]
612
+
in
613
+
Lifted.return (patt, expr)
614
+
| Sexp_list tp ->
615
+
sexp_of_record_field
616
+
~renaming
617
+
~bnds
618
+
patt
619
+
expr
620
+
name
621
+
tp
622
+
~sexp_of:
623
+
(* deliberately using whatever [sexp_of_list] is in scope *)
624
+
(match stackify with
625
+
| false -> [%expr sexp_of_list]
626
+
| true -> [%expr sexp_of_list__stack])
627
+
list_empty_expr
628
+
~stackify
629
+
|> Lifted.return
630
+
| Sexp_array tp ->
631
+
sexp_of_record_field
632
+
~renaming
633
+
~bnds
634
+
patt
635
+
expr
636
+
name
637
+
tp
638
+
~sexp_of:
639
+
(* deliberately using whatever [sexp_of_array] is in scope *)
640
+
(match stackify with
641
+
| false -> [%expr sexp_of_array]
642
+
| true -> [%expr sexp_of_array__stack])
643
+
array_empty_expr
644
+
~stackify
645
+
|> Lifted.return
646
+
| Specific (Drop_default how) ->
647
+
let tp = ld.pld_type in
648
+
(match Attribute.get Attrs.default ld with
649
+
| None -> Location.raise_errorf ~loc "no default to drop"
650
+
| Some { to_lift = default } ->
651
+
Record_field_attrs.lift_default ~loc ld default
652
+
>>= sexp_of_default_field
653
+
~types_being_defined
654
+
how
655
+
~renaming
656
+
~bnds
657
+
patt
658
+
expr
659
+
name
660
+
tp
661
+
~stackify)
662
+
| Specific (Drop_if test) ->
663
+
test
664
+
>>| fun test ->
665
+
let tp = ld.pld_type in
666
+
sexp_of_record_field
667
+
~renaming
668
+
~bnds
669
+
patt
670
+
expr
671
+
name
672
+
tp
673
+
(Inspect_value (fun loc expr -> [%expr [%e test] [%e expr]]))
674
+
~stackify
675
+
| Omit_nil ->
676
+
let tp = ld.pld_type in
677
+
let patt = mk_rec_patt loc patt name fresh in
678
+
let vname = Fresh_name.expression fresh in
679
+
let arg = Fresh_name.create "arg" ~loc in
680
+
let cnv_expr =
681
+
Conversion.apply ~loc (sexp_of_type ~renaming tp ~stackify) vname
682
+
in
683
+
let bnds_expr =
684
+
[%expr
685
+
match [%e cnv_expr] with
686
+
| Sexplib0.Sexp.List [] -> [%e Fresh_name.expression bnds]
687
+
| [%p Fresh_name.pattern arg] ->
688
+
(Sexplib0.Sexp.List
689
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
690
+
; [%e Fresh_name.expression arg]
691
+
]
692
+
:: [%e Fresh_name.expression bnds]
693
+
: _ Stdlib.List.t)]
694
+
in
695
+
( patt
696
+
, [%expr
697
+
let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in
698
+
[%e expr]] )
699
+
|> Lifted.return
700
+
| Specific Keep ->
701
+
let tp = ld.pld_type in
702
+
let patt = mk_rec_patt loc patt name fresh in
703
+
let vname = Fresh_name.expression fresh in
704
+
let arg = Fresh_name.create "arg" ~loc in
705
+
let cnv_expr =
706
+
Conversion.apply ~loc (sexp_of_type ~renaming tp ~stackify) vname
707
+
in
708
+
let bnds_expr =
709
+
[%expr
710
+
let [%p Fresh_name.pattern arg] = [%e cnv_expr] in
711
+
(Sexplib0.Sexp.List
712
+
[ Sexplib0.Sexp.Atom [%e estring ~loc name]
713
+
; [%e Fresh_name.expression arg]
714
+
]
715
+
:: [%e Fresh_name.expression bnds]
716
+
: _ Stdlib.List.t)]
717
+
in
718
+
( patt
719
+
, [%expr
720
+
let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in
721
+
[%e expr]] )
722
+
|> Lifted.return
723
+
in
724
+
let init_expr = wrap_expr (Fresh_name.expression bnds) in
725
+
List.fold_left ~f:coll ~init:(Lifted.return ([], init_expr)) flds
726
+
>>| fun (patt, expr) ->
727
+
( (if unboxed
728
+
then Ppxlib_jane.Ast_builder.Default.ppat_record_unboxed_product ?attrs:None
729
+
else ppat_record)
730
+
~loc
731
+
patt
732
+
Closed
733
+
, [%expr
734
+
let [%p Fresh_name.pattern bnds] = ([] : _ Stdlib.List.t) in
735
+
[%e expr]] )
736
+
;;
737
+
738
+
(* Conversion of sum types *)
739
+
740
+
let branch_sum
741
+
row
742
+
inline_attr
743
+
~types_being_defined
744
+
renaming
745
+
~loc
746
+
constr_lid
747
+
constr_str
748
+
args
749
+
~stackify
750
+
=
751
+
match args with
752
+
| Pcstr_record lds ->
753
+
let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e constr_str]] in
754
+
sexp_of_label_declaration_list
755
+
~types_being_defined
756
+
~renaming
757
+
loc
758
+
lds
759
+
~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List ([%e cnstr_expr] :: [%e expr])])
760
+
~stackify
761
+
~unboxed:false
762
+
>>| fun (patt, expr) -> ppat_construct ~loc constr_lid (Some patt) --> expr
763
+
| Pcstr_tuple pcd_args ->
764
+
(match pcd_args with
765
+
| [] ->
766
+
ppat_construct ~loc constr_lid None
767
+
--> [%expr Sexplib0.Sexp.Atom [%e constr_str]]
768
+
|> Lifted.return
769
+
| args ->
770
+
let args = List.map args ~f:Ppxlib_jane.Shim.Pcstr_tuple_arg.to_core_type in
771
+
(match args with
772
+
| [ tp ] when Option.is_some (Attribute.get inline_attr row) ->
773
+
(match tp with
774
+
| [%type: [%t? tp] list] ->
775
+
let cnv_expr =
776
+
Conversion.to_expression
777
+
~loc
778
+
(sexp_of_type ~renaming tp ~stackify)
779
+
~stackify
780
+
in
781
+
let name = Fresh_name.create "l" ~loc in
782
+
ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name))
783
+
--> [%expr
784
+
Sexplib0.Sexp.List
785
+
(Sexplib0.Sexp.Atom [%e constr_str]
786
+
:: [%e list_map ~loc ~stackify]
787
+
[%e cnv_expr]
788
+
[%e Fresh_name.expression name])]
789
+
| _ -> Attrs.invalid_attribute ~loc inline_attr "_ list")
790
+
| [ [%type: [%t? tp] sexp_list] ] ->
791
+
let cnv_expr =
792
+
Conversion.to_expression
793
+
~loc
794
+
(sexp_of_type ~renaming tp ~stackify)
795
+
~stackify
796
+
in
797
+
let name = Fresh_name.create "l" ~loc in
798
+
ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name))
799
+
--> [%expr
800
+
Sexplib0.Sexp.List
801
+
(Sexplib0.Sexp.Atom [%e constr_str]
802
+
:: [%e list_map ~loc ~stackify]
803
+
[%e cnv_expr]
804
+
[%e Fresh_name.expression name])]
805
+
| _ ->
806
+
let sexp_of_args = List.map ~f:(sexp_of_type ~renaming ~stackify) args in
807
+
let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e constr_str]] in
808
+
let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
809
+
Conversion.apply_all ~loc sexp_of_args
810
+
in
811
+
let patt =
812
+
match arguments with
813
+
| [ arg ] -> arg
814
+
| _ -> Ppxlib.Ast_builder.Default.ppat_tuple ~loc arguments
815
+
in
816
+
ppat_construct ~loc constr_lid (Some patt)
817
+
--> pexp_let
818
+
~loc
819
+
Immutable
820
+
Nonrecursive
821
+
bindings
822
+
[%expr Sexplib0.Sexp.List [%e elist ~loc (cnstr_expr :: converted)]])
823
+
|> Lifted.return)
824
+
;;
825
+
826
+
let sexp_of_sum ~types_being_defined ~renaming tps cds ~stackify =
827
+
List.map cds ~f:(fun cd ->
828
+
let renaming =
829
+
Renaming.with_constructor_declaration renaming ~type_parameters:tps cd
830
+
in
831
+
let constr_lid = Located.map lident cd.pcd_name in
832
+
let constr_str = estring ~loc:cd.pcd_name.loc cd.pcd_name.txt in
833
+
branch_sum
834
+
cd
835
+
Attrs.list_variant
836
+
~types_being_defined
837
+
renaming
838
+
~loc:cd.pcd_loc
839
+
constr_lid
840
+
constr_str
841
+
cd.pcd_args
842
+
~stackify)
843
+
|> Lifted.all
844
+
>>| Conversion.of_lambda
845
+
;;
846
+
847
+
(* Empty type *)
848
+
let sexp_of_nil loc = Conversion.of_lambda [ ppat_any ~loc --> [%expr assert false] ]
849
+
850
+
(* Generate code from type definitions *)
851
+
852
+
let sexp_of_td ~types_being_defined td ~stackify ~portable =
853
+
let td = name_type_params_in_td td in
854
+
let tps =
855
+
List.filter td.ptype_params ~f:(fun (p, _) -> include_param_in_combinator p)
856
+
|> List.map ~f:Ppxlib_jane.get_type_param_name_and_jkind
857
+
in
858
+
let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in
859
+
let renaming = Renaming.of_type_declaration td ~prefix:"_of_" in
860
+
let body =
861
+
let body =
862
+
match Ppxlib_jane.Shim.Type_kind.of_parsetree td.ptype_kind with
863
+
| Ptype_variant cds ->
864
+
sexp_of_sum
865
+
~renaming
866
+
~types_being_defined
867
+
(List.map tps ~f:(fun (x, _) -> x.txt))
868
+
cds
869
+
~stackify
870
+
| Ptype_record lds ->
871
+
sexp_of_label_declaration_list
872
+
~renaming
873
+
loc
874
+
lds
875
+
~types_being_defined
876
+
~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List [%e expr]])
877
+
~stackify
878
+
~unboxed:false
879
+
>>| fun (patt, expr) -> Conversion.of_lambda [ patt --> expr ]
880
+
| Ptype_record_unboxed_product lds ->
881
+
sexp_of_label_declaration_list
882
+
~renaming
883
+
loc
884
+
lds
885
+
~types_being_defined
886
+
~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List [%e expr]])
887
+
~stackify
888
+
~unboxed:true
889
+
>>| fun (patt, expr) -> Conversion.of_lambda [ patt --> expr ]
890
+
| Ptype_open ->
891
+
Location.raise_errorf ~loc "ppx_sexp_conv: open types not supported"
892
+
| Ptype_abstract ->
893
+
(match td.ptype_manifest with
894
+
| None -> sexp_of_nil loc
895
+
| Some ty -> sexp_of_type ~renaming ty ~stackify)
896
+
|> Lifted.return
897
+
in
898
+
body
899
+
>>| fun body ->
900
+
let is_private_alias =
901
+
match td.ptype_kind, td.ptype_manifest, td.ptype_private with
902
+
| Ptype_abstract, Some _, Private -> true
903
+
| _ -> false
904
+
in
905
+
if is_private_alias
906
+
then (
907
+
(* Replace all type variable by _ to avoid generalization problems *)
908
+
let ty_src =
909
+
core_type_of_type_declaration td |> replace_variables_by_underscores
910
+
in
911
+
let manifest =
912
+
match td.ptype_manifest with
913
+
| Some manifest -> manifest
914
+
| None -> Location.raise_errorf ~loc "sexp_of_td/no-manifest"
915
+
in
916
+
let ty_dst = replace_variables_by_underscores manifest in
917
+
let v = Fresh_name.create "v" ~loc in
918
+
let coercion =
919
+
[%expr ([%e Fresh_name.expression v] : [%t ty_src] :> [%t ty_dst])]
920
+
in
921
+
let arg = Fresh_name.pattern v in
922
+
let body = Conversion.apply ~loc body coercion in
923
+
let body =
924
+
match stackify with
925
+
| false -> body
926
+
| true -> [%expr [%e body]]
927
+
in
928
+
[%expr fun [%p arg] -> [%e body]])
929
+
else
930
+
(* Prevent violation of value restriction, problems with recursive types, and
931
+
top-level effects by eta-expanding function definitions *)
932
+
Conversion.to_value_expression
933
+
~loc
934
+
~rec_flag:(Types_being_defined.to_rec_flag types_being_defined)
935
+
~values_being_defined:
936
+
(Types_being_defined.to_values_being_defined types_being_defined ~stackify)
937
+
body
938
+
~stackify
939
+
in
940
+
let typ = Sig_generate_sexp_of.mk_type td ~stackify in
941
+
let func_name = sexp_of_typename ~stackify ~prefix:"" type_name in
942
+
let body =
943
+
body
944
+
>>| fun body ->
945
+
let patts =
946
+
List.map tps ~f:(fun (id, _) ->
947
+
match Renaming.binding_kind renaming id.txt ~loc:id.loc with
948
+
| Universally_bound name -> Fresh_name.pattern name
949
+
| Existentially_bound -> assert false)
950
+
in
951
+
let rec_flag = Types_being_defined.to_rec_flag types_being_defined in
952
+
eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts body)
953
+
in
954
+
let body = Lifted.let_bind_user_expressions ~loc body in
955
+
let sexp_of =
956
+
let ({ body = typ; vars = _; loc = _ } : Ppx_helpers.Polytype.t) = typ in
957
+
constrained_function_binding loc td typ ~tps ~func_name ~portable body
958
+
in
959
+
sexp_of, func_name
960
+
;;
961
+
962
+
let sexp_of_tds ~loc ~path:_ ~unboxed (rec_flag, tds) ~stackify ~portable =
963
+
let rec_flag = really_recursive_respecting_opaque rec_flag tds in
964
+
let tds = Ppx_helpers.with_implicit_unboxed_records ~unboxed tds in
965
+
let (types_being_defined : Types_being_defined.t) =
966
+
match rec_flag with
967
+
| Nonrecursive -> Nonrec
968
+
| Recursive ->
969
+
Rec
970
+
(String.Set.of_list
971
+
(List.map tds ~f:(fun td -> Ppx_helpers.mangle_unboxed td.ptype_name.txt)))
972
+
in
973
+
let stackify =
974
+
match stackify with
975
+
| false -> [ false ]
976
+
| true -> [ false; true ]
977
+
in
978
+
let bindings_and_names =
979
+
List.map stackify ~f:(fun stackify ->
980
+
let bindings_and_names =
981
+
List.map tds ~f:(sexp_of_td ~types_being_defined ~stackify ~portable)
982
+
in
983
+
let bindings = List.map bindings_and_names ~f:fst in
984
+
let names = List.map bindings_and_names ~f:snd in
985
+
pstr_value_list ~loc rec_flag bindings, names)
986
+
in
987
+
let bindings = List.concat_map bindings_and_names ~f:fst in
988
+
let names = List.concat_map bindings_and_names ~f:snd in
989
+
if portable
990
+
then
991
+
[ [%stri include [%m pmod_structure ~loc bindings]]
992
+
; pstr_value
993
+
~loc
994
+
Nonrecursive
995
+
(List.map names ~f:(fun name ->
996
+
value_binding
997
+
~loc
998
+
~pat:[%pat? _]
999
+
~expr:(evar ~loc name)
1000
+
~modes:[ { loc; txt = Mode "portable" } ]))
1001
+
]
1002
+
else bindings
1003
+
;;
1004
+
1005
+
let sexp_of_exn ~loc:_ ~path ec =
1006
+
let renaming = Renaming.without_type () in
1007
+
let get_full_cnstr str = path ^ "." ^ str in
1008
+
let loc = ec.ptyexn_loc in
1009
+
let expr =
1010
+
match ec.ptyexn_constructor with
1011
+
| { pext_name = cnstr
1012
+
; pext_kind = Pext_decl (_, extension_constructor_kind, None)
1013
+
; _
1014
+
} ->
1015
+
let constr_lid = Located.map lident cnstr in
1016
+
branch_sum
1017
+
ec
1018
+
Attrs.list_exception
1019
+
~types_being_defined:Nonrec
1020
+
renaming
1021
+
~loc
1022
+
constr_lid
1023
+
(estring ~loc (get_full_cnstr cnstr.txt))
1024
+
extension_constructor_kind
1025
+
~stackify:false
1026
+
>>| fun converter ->
1027
+
let assert_false = ppat_any ~loc --> [%expr assert false] in
1028
+
[%expr
1029
+
Sexplib0.Sexp_conv.Exn_converter.add
1030
+
[%extension_constructor [%e pexp_construct ~loc constr_lid None]]
1031
+
[%e
1032
+
Conversion.to_expression
1033
+
~loc
1034
+
(Conversion.of_lambda [ converter; assert_false ])
1035
+
~stackify:false]]
1036
+
| { pext_kind = Pext_decl (_, _, Some _); _ } ->
1037
+
Location.raise_errorf ~loc "sexp_of_exn/:"
1038
+
| { pext_kind = Pext_rebind _; _ } ->
1039
+
Location.raise_errorf ~loc "sexp_of_exn/rebind"
1040
+
in
1041
+
let expr = Lifted.let_bind_user_expressions ~loc expr in
1042
+
[ pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:[%pat? ()] ~expr ~modes:[] ]
1043
+
]
1044
+
;;
1045
+
1046
+
let sexp_of_core_type core_type ~stackify =
1047
+
let loc = { core_type.ptyp_loc with loc_ghost = true } in
1048
+
sexp_of_type ~renaming:(Renaming.without_type ()) core_type ~stackify
1049
+
|> Conversion.to_value_expression
1050
+
~loc
1051
+
~rec_flag:Nonrecursive
1052
+
~values_being_defined:String.Set.empty
1053
+
~stackify
1054
+
|> Merlin_helpers.hide_expression
1055
+
;;
1056
+
end
+41
vendor/opam/ppx_sexp_conv/expander/expand_sexp_of.mli
+41
vendor/opam/ppx_sexp_conv/expander/expand_sexp_of.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
module Sig_generate_sexp_of : sig
5
+
(** Given a type, produce the type of its [sexp_of] conversion. *)
6
+
val type_of_sexp_of : loc:location -> core_type -> stackify:bool -> core_type
7
+
8
+
(** Derive a [sexp_of] interface for a list of type declarations. *)
9
+
val mk_sig
10
+
: loc:location
11
+
-> path:string
12
+
-> unboxed:bool
13
+
-> rec_flag * type_declaration list
14
+
-> stackify:bool
15
+
-> portable:bool
16
+
-> signature_item list
17
+
18
+
(** Derive a [sexp_of] interface for an exception declaration. *)
19
+
val mk_sig_exn : loc:location -> path:string -> type_exception -> signature_item list
20
+
end
21
+
22
+
module Str_generate_sexp_of : sig
23
+
(** Given a type, produce a pattern for that type's [sexp_of] conversion. *)
24
+
val pat_of_sexp_of : loc:location -> core_type -> stackify:bool -> pattern
25
+
26
+
(** Given a type, produce its [sexp_of] conversion. *)
27
+
val sexp_of_core_type : core_type -> stackify:bool -> expression
28
+
29
+
(** Derive a [sexp_of] implementation for a list of type declarations. *)
30
+
val sexp_of_tds
31
+
: loc:location
32
+
-> path:string
33
+
-> unboxed:bool
34
+
-> rec_flag * type_declaration list
35
+
-> stackify:bool
36
+
-> portable:bool
37
+
-> structure_item list
38
+
39
+
(** Derive a [sexp_of] implementation for an exception declaration. *)
40
+
val sexp_of_exn : loc:location -> path:string -> type_exception -> structure_item list
41
+
end
+14
vendor/opam/ppx_sexp_conv/expander/fresh_name.ml
+14
vendor/opam/ppx_sexp_conv/expander/fresh_name.ml
···
1
+
open! Stdppx
2
+
open Ppxlib
3
+
open Ast_builder.Default
4
+
5
+
type t =
6
+
{ loc : location
7
+
; unique_name : string
8
+
}
9
+
10
+
let create string ~loc = { loc; unique_name = gen_symbol ~prefix:string () }
11
+
let of_string_loc { loc; txt } = create txt ~loc
12
+
let to_string_loc { loc; unique_name } = { loc; txt = unique_name }
13
+
let expression { loc; unique_name } = evar unique_name ~loc
14
+
let pattern { loc; unique_name } = pvar unique_name ~loc
+21
vendor/opam/ppx_sexp_conv/expander/fresh_name.mli
+21
vendor/opam/ppx_sexp_conv/expander/fresh_name.mli
···
1
+
(** Represents freshly generated names at ppx expansion time. *)
2
+
3
+
open! Stdppx
4
+
open Ppxlib
5
+
6
+
type t
7
+
8
+
(** Creates a new fresh name using the given string as a prefix. *)
9
+
val create : string -> loc:location -> t
10
+
11
+
(** [of_string_loc { loc; txt }] is equivalent to [create txt ~loc] *)
12
+
val of_string_loc : string loc -> t
13
+
14
+
(** Extracts the freshly created name and its location. *)
15
+
val to_string_loc : t -> string loc
16
+
17
+
(** Constructs an expression referring to the fresh name. *)
18
+
val expression : t -> expression
19
+
20
+
(** Constructs a pattern binding the fresh name. *)
21
+
val pattern : t -> pattern
+300
vendor/opam/ppx_sexp_conv/expander/helpers.ml
+300
vendor/opam/ppx_sexp_conv/expander/helpers.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Ast_builder.Default
4
+
5
+
let ( --> ) lhs rhs = case ~guard:None ~lhs ~rhs
6
+
7
+
(* Utility functions *)
8
+
9
+
let replace_variables_by_underscores =
10
+
let map =
11
+
object
12
+
inherit Ast_traverse.map as super
13
+
14
+
method! core_type_desc t =
15
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree t with
16
+
| Ptyp_var (_, jkind) ->
17
+
Ppxlib_jane.Shim.Core_type_desc.to_parsetree (Ptyp_any jkind)
18
+
| _ -> super#core_type_desc t
19
+
end
20
+
in
21
+
map#core_type
22
+
;;
23
+
24
+
let make_rigid_types tps =
25
+
List.fold_left tps ~init:String.Map.empty ~f:(fun map (tp, jkind) ->
26
+
String.Map.update
27
+
tp.txt
28
+
(function
29
+
| None -> Some (Fresh_name.of_string_loc tp, jkind)
30
+
| Some (fresh, jkind) ->
31
+
(* Ignore duplicate names, the typechecker will raise after expansion. *)
32
+
Some (fresh, jkind))
33
+
map)
34
+
;;
35
+
36
+
let find_rigid_type ~loc ~rigid_types name =
37
+
match String.Map.find_opt name rigid_types with
38
+
| Some (tp, jkind) -> Fresh_name.to_string_loc tp, jkind
39
+
| None ->
40
+
(* Ignore unbound type names, the typechecker will raise after expansion. *)
41
+
{ txt = name; loc }, None
42
+
;;
43
+
44
+
let find_rigid_type_constr ~loc ~rigid_types name =
45
+
let name, _jkind = find_rigid_type ~loc ~rigid_types name in
46
+
Ptyp_constr (Located.map_lident name, [])
47
+
;;
48
+
49
+
let make_type_rigid ~rigid_types =
50
+
let map =
51
+
object
52
+
inherit Ast_traverse.map as super
53
+
54
+
method! core_type ty =
55
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ty.ptyp_desc with
56
+
| Ptyp_var (name, _) ->
57
+
let ptyp_desc = find_rigid_type_constr ~loc:ty.ptyp_loc ~rigid_types name in
58
+
{ ty with ptyp_desc }
59
+
| _ -> super#core_type ty
60
+
end
61
+
in
62
+
map#core_type
63
+
;;
64
+
65
+
(* Generates the quantified type [ ! 'a .. 'z . (make_mono_type t ('a .. 'z)) ] or
66
+
[type a .. z. make_mono_type t (a .. z)] when [use_rigid_variables] is true.
67
+
Annotation are needed for non regular recursive datatypes and gadt when the return type
68
+
of constructors are constrained. Unfortunately, putting rigid variables everywhere does
69
+
not work because of certains types with constraints. We thus only use rigid variables
70
+
for sum types without constraints, which includes all GADTs. *)
71
+
72
+
type bound_var = string loc * Ppxlib_jane.jkind_annotation option
73
+
74
+
let tvars_of_core_type : core_type -> bound_var list =
75
+
let add_binding_to_list (bindings : bound_var list) (bound : bound_var) =
76
+
let { txt = bound_name; loc = _ }, _annot = bound in
77
+
match
78
+
List.exists bindings ~f:(fun b' ->
79
+
let { txt = bound_name'; loc = _ }, _annot' = b' in
80
+
String.equal bound_name bound_name')
81
+
with
82
+
| true -> bindings
83
+
| false -> bound :: bindings
84
+
in
85
+
let tvars =
86
+
object
87
+
inherit [bound_var list] Ast_traverse.fold as super
88
+
89
+
method! core_type x acc =
90
+
let loc = x.ptyp_loc in
91
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree x.ptyp_desc with
92
+
| Ptyp_var (bound_name, jkind) ->
93
+
add_binding_to_list acc ({ txt = bound_name; loc }, jkind)
94
+
| _ -> super#core_type x acc
95
+
end
96
+
in
97
+
fun typ -> List.rev (tvars#core_type typ [])
98
+
;;
99
+
100
+
let constrained_function_binding
101
+
(* placing a suitably polymorphic or rigid type constraint on the pattern or body *)
102
+
(loc : Location.t)
103
+
(td : type_declaration)
104
+
(typ : core_type)
105
+
~(tps : (string loc * Ppxlib_jane.jkind_annotation option) list)
106
+
~(func_name : string)
107
+
~portable
108
+
(body : expression)
109
+
=
110
+
let bound_vars = tvars_of_core_type typ in
111
+
let has_vars =
112
+
match bound_vars with
113
+
| [] -> false
114
+
| _ :: _ -> true
115
+
in
116
+
let pat =
117
+
let pat = pvar ~loc func_name in
118
+
if not has_vars
119
+
then pat
120
+
else (
121
+
let annot = Ppxlib_jane.Ast_builder.Default.ptyp_poly ~loc bound_vars typ in
122
+
ppat_constraint ~loc pat annot)
123
+
in
124
+
let body =
125
+
let use_rigid_variables =
126
+
match td.ptype_cstrs, td.ptype_kind with
127
+
| [], Ptype_variant _ -> true
128
+
| _ -> false
129
+
in
130
+
if use_rigid_variables
131
+
then (
132
+
let rigid_types = make_rigid_types tps in
133
+
List.fold_right
134
+
tps
135
+
~f:(fun (tp, _) body ->
136
+
let name, jkind = find_rigid_type ~loc:tp.loc ~rigid_types tp.txt in
137
+
match jkind with
138
+
| None -> pexp_newtype ~loc name body
139
+
| Some jkind ->
140
+
Ppxlib_jane.Ast_builder.Default.pexp_newtype ~loc name (Some jkind) body)
141
+
~init:(pexp_constraint ~loc body (make_type_rigid ~rigid_types typ)))
142
+
else if has_vars
143
+
then body
144
+
else pexp_constraint ~loc body typ
145
+
in
146
+
Ppxlib_jane.Ast_builder.Default.value_binding
147
+
~loc
148
+
~pat
149
+
~expr:body
150
+
~modes:(if portable then [ { txt = Mode "portable"; loc } ] else [])
151
+
;;
152
+
153
+
let with_let ~loc ~binds body =
154
+
List.fold_right binds ~init:body ~f:(fun bind body ->
155
+
if List.is_empty bind then body else pexp_let ~loc Nonrecursive bind body)
156
+
;;
157
+
158
+
let with_types ~loc ~types body =
159
+
if List.is_empty types
160
+
then body
161
+
else
162
+
pexp_open
163
+
~loc
164
+
(open_infos
165
+
~loc
166
+
~override:Fresh
167
+
~expr:
168
+
(pmod_structure
169
+
~loc
170
+
(List.map types ~f:(fun type_decl -> pstr_type ~loc Recursive [ type_decl ]))))
171
+
body
172
+
;;
173
+
174
+
let fresh_lambda ~loc apply =
175
+
let var = gen_symbol ~prefix:"x" () in
176
+
let pat = pvar ~loc var in
177
+
let arg = evar ~loc var in
178
+
let body = apply ~arg in
179
+
pexp_fun ~loc Nolabel None pat body
180
+
;;
181
+
182
+
let rec is_value_expression expr =
183
+
match
184
+
Ppxlib_jane.Shim.Expression_desc.of_parsetree expr.pexp_desc ~loc:expr.pexp_loc
185
+
with
186
+
(* Syntactic values. *)
187
+
| Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_lazy _ -> true
188
+
(* Type-only wrappers; we check their contents. *)
189
+
| Pexp_constraint (expr, (_ : core_type option), _)
190
+
| Pexp_coerce (expr, (_ : core_type option), (_ : core_type))
191
+
| Pexp_newtype ((_ : string loc), (_ : Ppxlib_jane.jkind_annotation option), expr)
192
+
| Pexp_stack expr -> is_value_expression expr
193
+
(* Allocating constructors; they are only values if all of their contents are. *)
194
+
| Pexp_tuple lexprs -> List.for_all lexprs ~f:(fun (_, e) -> is_value_expression e)
195
+
| Pexp_unboxed_tuple lexprs ->
196
+
List.for_all lexprs ~f:(fun (_, e) -> is_value_expression e)
197
+
| Pexp_construct (_, None) -> true
198
+
| Pexp_construct (_, Some expr) -> is_value_expression expr
199
+
| Pexp_variant (_, None) -> true
200
+
| Pexp_variant (_, Some expr) -> is_value_expression expr
201
+
| Pexp_record (fields, maybe_expr) | Pexp_record_unboxed_product (fields, maybe_expr) ->
202
+
List.for_all fields ~f:(fun (_, expr) -> is_value_expression expr)
203
+
&&
204
+
(match maybe_expr with
205
+
| None -> true
206
+
| Some expr -> is_value_expression expr)
207
+
(* Not values, or not always values. We make a conservative approximation. *)
208
+
| Pexp_unreachable
209
+
| Pexp_let _
210
+
| Pexp_apply _
211
+
| Pexp_match _
212
+
| Pexp_try _
213
+
| Pexp_field _
214
+
| Pexp_unboxed_field _
215
+
| Pexp_setfield _
216
+
| Pexp_array _
217
+
| Pexp_idx _
218
+
| Pexp_ifthenelse _
219
+
| Pexp_sequence _
220
+
| Pexp_while _
221
+
| Pexp_for _
222
+
| Pexp_send _
223
+
| Pexp_new _
224
+
| Pexp_setvar _
225
+
| Pexp_override _
226
+
| Pexp_letmodule _
227
+
| Pexp_letexception _
228
+
| Pexp_assert _
229
+
| Pexp_poly _
230
+
| Pexp_object _
231
+
| Pexp_pack _
232
+
| Pexp_open _
233
+
| Pexp_letop _
234
+
| Pexp_extension _
235
+
| Pexp_comprehension _
236
+
| Pexp_overwrite _
237
+
| Pexp_quote _
238
+
| Pexp_splice _
239
+
| Pexp_hole -> false
240
+
;;
241
+
242
+
let really_recursive_respecting_opaque rec_flag tds =
243
+
(object
244
+
inherit type_is_recursive rec_flag tds as super
245
+
246
+
method! core_type ctype =
247
+
match ctype with
248
+
| _ when Option.is_some (Attribute.get ~mark_as_seen:false Attrs.opaque ctype) ->
249
+
()
250
+
| [%type: [%t? _] sexp_opaque] -> ()
251
+
| _ -> super#core_type ctype
252
+
end)
253
+
#go
254
+
()
255
+
;;
256
+
257
+
let strip_attributes =
258
+
object
259
+
inherit Ppxlib_jane.Ast_traverse.map
260
+
261
+
method! attribute attr =
262
+
Location.raise_errorf ~loc:attr.attr_loc "failed to strip attribute from syntax"
263
+
264
+
method! attributes _ = []
265
+
266
+
method! signature_items items =
267
+
List.filter items ~f:(fun item ->
268
+
match item.psig_desc with
269
+
| Psig_attribute _ -> false
270
+
| _ -> true)
271
+
272
+
method! structure items =
273
+
List.filter items ~f:(fun item ->
274
+
match item.pstr_desc with
275
+
| Pstr_attribute _ -> false
276
+
| _ -> true)
277
+
278
+
method! class_signature csig =
279
+
{ csig with
280
+
pcsig_fields =
281
+
List.filter csig.pcsig_fields ~f:(fun field ->
282
+
match field.pctf_desc with
283
+
| Pctf_attribute _ -> false
284
+
| _ -> true)
285
+
}
286
+
287
+
method! class_structure cstr =
288
+
{ cstr with
289
+
pcstr_fields =
290
+
List.filter cstr.pcstr_fields ~f:(fun field ->
291
+
match field.pcf_desc with
292
+
| Pcf_attribute _ -> false
293
+
| _ -> true)
294
+
}
295
+
end
296
+
;;
297
+
298
+
let include_param_in_combinator param =
299
+
not (Option.is_some (Attribute.get Attrs.phantom param))
300
+
;;
+44
vendor/opam/ppx_sexp_conv/expander/helpers.mli
+44
vendor/opam/ppx_sexp_conv/expander/helpers.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
(** Constructs a branch of a [match] or [function] expression with no guard. *)
5
+
val ( --> ) : pattern -> expression -> case
6
+
7
+
(** Replace all type variables like ['a] with wildcard ([_]) types. *)
8
+
val replace_variables_by_underscores : core_type -> core_type
9
+
10
+
(** Create a binding for a derived function, adding a type annotation if required. *)
11
+
val constrained_function_binding
12
+
: location (** location to use for the binding *)
13
+
-> type_declaration (** type declaration used to derive the function *)
14
+
-> core_type (** type of the function *)
15
+
-> tps:(string loc * Ppxlib_jane.Shim.jkind_annotation option) list
16
+
(** names and jkinds of type parameters in the declaration *)
17
+
-> func_name:string (** name to bind the function to *)
18
+
-> portable:bool (** Whether the function should be marked as portable. *)
19
+
-> expression (** expression representing the function *)
20
+
-> value_binding
21
+
22
+
(** Wraps an expression in layers of non-recursive [let] bindings, with the bindings
23
+
sorted from outermost to innermost. *)
24
+
val with_let : loc:location -> binds:value_binding list list -> expression -> expression
25
+
26
+
(** Wraps an expression in [let open] containing type declarations, if non-empty. *)
27
+
val with_types : loc:location -> types:type_declaration list -> expression -> expression
28
+
29
+
(** Constructs a lambda of a fresh variable. Passes a reference to that variable as [arg]
30
+
to construct the lambda's body. *)
31
+
val fresh_lambda : loc:location -> (arg:expression -> expression) -> expression
32
+
33
+
(** Conservative approximation of which expressions are syntactically values, i.e.
34
+
constants, variables, or lambdas. When [true], these expressions have no effects
35
+
(other than possibly closure allocation) and can be used in [let rec] definitions.
36
+
When [false], they may need to be eta-expanded or wrapped in [lazy]. *)
37
+
val is_value_expression : expression -> bool
38
+
39
+
(** Shadows [Ppxlib.really_recursive] with a version that respects the [[@opaque]]
40
+
attribute. *)
41
+
val really_recursive_respecting_opaque : rec_flag -> type_declaration list -> rec_flag
42
+
43
+
val strip_attributes : Ppxlib_jane.Ast_traverse.map
44
+
val include_param_in_combinator : core_type -> bool
+8
vendor/opam/ppx_sexp_conv/expander/labeled_tuple.ml
+8
vendor/opam/ppx_sexp_conv/expander/labeled_tuple.ml
+8
vendor/opam/ppx_sexp_conv/expander/labeled_tuple.mli
+8
vendor/opam/ppx_sexp_conv/expander/labeled_tuple.mli
···
1
+
(* Support for labeled tuples, a language feature currently only implemented in Jane
2
+
Street's experimental branch of the compiler
3
+
(https://github.com/ocaml-flambda/flambda-backend/). *)
4
+
5
+
open! Stdppx
6
+
7
+
val has_any_label : (string option * _) list -> bool
8
+
val atom_of_label : string option -> string
+54
vendor/opam/ppx_sexp_conv/expander/lifted.ml
+54
vendor/opam/ppx_sexp_conv/expander/lifted.ml
···
1
+
open! Stdppx
2
+
open Ppxlib
3
+
open Ast_builder.Default
4
+
5
+
type 'a t =
6
+
{ value_bindings : value_binding list
7
+
; body : 'a
8
+
}
9
+
10
+
let return body = { value_bindings = []; body }
11
+
12
+
let bind a ~f =
13
+
let b = f a.body in
14
+
{ value_bindings = a.value_bindings @ b.value_bindings; body = b.body }
15
+
;;
16
+
17
+
let map a ~f = { a with body = f a.body }
18
+
19
+
module Monad_infix = struct
20
+
let ( >>| ) a f = map a ~f
21
+
let ( >>= ) a f = bind a ~f
22
+
end
23
+
24
+
open Monad_infix
25
+
26
+
let all list =
27
+
List.fold_right list ~init:(return []) ~f:(fun head tail ->
28
+
head >>= fun head -> tail >>| fun tail -> head :: tail)
29
+
;;
30
+
31
+
let create ~loc ~prefix ~ty rhs =
32
+
let name = gen_symbol ~prefix () in
33
+
let lhs = pvar ~loc name in
34
+
let body = evar ~loc name in
35
+
let ty, rhs, body =
36
+
if Helpers.is_value_expression rhs
37
+
then ty, rhs, body
38
+
else (
39
+
(* Thunkify the value to evaluate when referred to. *)
40
+
let ty = [%type: Stdlib.Unit.t -> [%t ty]] in
41
+
let rhs = [%expr fun () -> [%e rhs]] in
42
+
let body = [%expr [%e body] ()] in
43
+
ty, rhs, body)
44
+
in
45
+
{ value_bindings = [ value_binding ~loc ~pat:(ppat_constraint ~loc lhs ty) ~expr:rhs ]
46
+
; body
47
+
}
48
+
;;
49
+
50
+
let let_bind_user_expressions { value_bindings; body } ~loc =
51
+
if List.is_empty value_bindings
52
+
then body
53
+
else pexp_let ~loc Nonrecursive value_bindings body
54
+
;;
+29
vendor/opam/ppx_sexp_conv/expander/lifted.mli
+29
vendor/opam/ppx_sexp_conv/expander/lifted.mli
···
1
+
open! Stdppx
2
+
open Ppxlib
3
+
4
+
(** Represents an ['a], along with some user expressions that should lifted out of the
5
+
scope of internal bindings. For example, if a user writes [[@@default x]], they mean
6
+
[x] in the surface code, not some temporary variable [x] added by ppx machinery. *)
7
+
type 'a t
8
+
9
+
(** As a monad, combines all client expressions so they can be lifted to the outermost
10
+
level of generated code. *)
11
+
12
+
val return : 'a -> 'a t
13
+
val map : 'a t -> f:('a -> 'b) -> 'b t
14
+
val bind : 'a t -> f:('a -> 'b t) -> 'b t
15
+
val all : 'a t list -> 'a list t
16
+
17
+
module Monad_infix : sig
18
+
val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
19
+
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
20
+
end
21
+
22
+
(** Lifts the given expression and binds it to a fresh variable starting with [prefix].
23
+
The expression is evaluated each time it is referred to. The binding is annotated with
24
+
[ty]. Uses [loc] for generated code. *)
25
+
val create : loc:location -> prefix:string -> ty:core_type -> expression -> expression t
26
+
27
+
(** Uses [let] to bind all lifted user expressions, with the contained expression as the
28
+
body. Should be called in whatever scope the user should be able to refer to. *)
29
+
val let_bind_user_expressions : expression t -> loc:location -> expression
+132
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_expander.ml
+132
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_expander.ml
···
1
+
open Stdppx
2
+
open Ppxlib
3
+
module Attrs = Attrs
4
+
module Record_field_attrs = Record_field_attrs
5
+
open Expand_sexp_of
6
+
open Expand_of_sexp
7
+
8
+
module Sexp_of = struct
9
+
let type_extension ty ~stackify =
10
+
Sig_generate_sexp_of.type_of_sexp_of
11
+
~loc:{ ty.ptyp_loc with loc_ghost = true }
12
+
ty
13
+
~stackify
14
+
;;
15
+
16
+
let pattern_extension ty ~stackify =
17
+
Str_generate_sexp_of.pat_of_sexp_of
18
+
~loc:{ ty.ptyp_loc with loc_ghost = true }
19
+
ty
20
+
~stackify
21
+
;;
22
+
23
+
let core_type = Str_generate_sexp_of.sexp_of_core_type
24
+
25
+
let sig_type_decl ~loc ~path ~unboxed tds ~stackify ~portable =
26
+
let stackify =
27
+
match stackify with
28
+
| false -> [ false ]
29
+
| true -> [ false; true ]
30
+
in
31
+
List.concat_map stackify ~f:(fun stackify ->
32
+
Sig_generate_sexp_of.mk_sig ~loc ~path ~unboxed tds ~stackify ~portable)
33
+
;;
34
+
35
+
let sig_exception = Sig_generate_sexp_of.mk_sig_exn
36
+
let str_type_decl = Str_generate_sexp_of.sexp_of_tds
37
+
let str_exception = Str_generate_sexp_of.sexp_of_exn
38
+
end
39
+
40
+
module Sexp_grammar = Ppx_sexp_conv_grammar
41
+
42
+
module Of_sexp = struct
43
+
let type_extension ty = Sig_generate_of_sexp.type_of_of_sexp ~loc:ty.ptyp_loc ty
44
+
let pattern_extension ty = Str_generate_of_sexp.pat_of_of_sexp ~loc:ty.ptyp_loc ty
45
+
let core_type = Str_generate_of_sexp.core_type_of_sexp
46
+
47
+
let sig_type_decl ~poly ~loc ~path ~unboxed tds ~portable =
48
+
Sig_generate_of_sexp.mk_sig ~poly ~loc ~path ~unboxed tds ~portable
49
+
;;
50
+
51
+
let str_type_decl ~loc ~poly ~path ~unboxed tds =
52
+
Str_generate_of_sexp.tds_of_sexp ~loc ~poly ~path ~unboxed tds
53
+
;;
54
+
end
55
+
56
+
module Sig_sexp = struct
57
+
let mk_sig ~loc ~path ~unboxed decls ~stackify ~portable =
58
+
List.concat
59
+
[ Sig_generate_sexp_of.mk_sig ~loc ~path ~unboxed decls ~stackify:false ~portable
60
+
; (if stackify
61
+
then
62
+
Sig_generate_sexp_of.mk_sig ~loc ~path ~unboxed decls ~stackify:true ~portable
63
+
else [])
64
+
; Sig_generate_of_sexp.mk_sig ~poly:false ~loc ~path ~unboxed decls ~portable
65
+
]
66
+
;;
67
+
68
+
module Is_value = struct
69
+
type t =
70
+
| Value
71
+
| Maybe_non_value
72
+
73
+
let rec of_jkind (jkind : Ppxlib_jane.Shim.jkind_annotation) =
74
+
match jkind.pjkind_desc with
75
+
| Pjk_default | Pjk_kind_of _ ->
76
+
(* [t : _] or [t : kind_of u] *)
77
+
None
78
+
| Pjk_abbreviation ("value" | "immediate64" | "immediate") ->
79
+
(* [t : value] or [t : immediate64] or [t : immediate] *)
80
+
Some Value
81
+
| Pjk_abbreviation _ | Pjk_product _ ->
82
+
(* [t : k] or [t : k1 & k2]*)
83
+
Some Maybe_non_value
84
+
| Pjk_mod (jkind, _) | Pjk_with (jkind, _, _) ->
85
+
(* [t : k mod m] or [t : k with t] *)
86
+
of_jkind jkind
87
+
;;
88
+
end
89
+
90
+
let sig_type_decl ~loc ~path ~unboxed (rf, tds) ~stackify ~portable =
91
+
let tds = Ppx_helpers.with_implicit_unboxed_records ~unboxed tds in
92
+
let include_infos =
93
+
match tds with
94
+
| [] | _ :: _ :: _ -> None
95
+
| [ td ] ->
96
+
let sg_name =
97
+
let has_jkind_annotation =
98
+
match Ppxlib_jane.Shim.Type_declaration.extract_jkind_annotation td with
99
+
| None -> None
100
+
| Some jkind -> Is_value.of_jkind jkind
101
+
in
102
+
let default_is_value : Is_value.t =
103
+
match
104
+
Ppxlib_jane.Shim.Type_kind.of_parsetree td.ptype_kind, td.ptype_manifest
105
+
with
106
+
| (Ptype_variant _ | Ptype_record _ | Ptype_open), _ | Ptype_abstract, None ->
107
+
Value (* not necessarily true if the type is [@@unboxed] *)
108
+
| Ptype_record_unboxed_product _, _ | Ptype_abstract, Some _ ->
109
+
Maybe_non_value
110
+
in
111
+
match Option.value has_jkind_annotation ~default:default_is_value with
112
+
| Value -> "Sexplib0.Sexpable.S"
113
+
| Maybe_non_value -> "Sexplib0.Sexpable.S_any"
114
+
in
115
+
mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant:false [ td ]
116
+
in
117
+
match include_infos with
118
+
| Some include_infos ->
119
+
let include_infos =
120
+
match stackify with
121
+
| false -> include_infos
122
+
| true -> Ppxlib_jane.stackify_include_sig include_infos
123
+
in
124
+
[ Ppxlib_jane.Ast_builder.Default.psig_include
125
+
~loc
126
+
~modalities:
127
+
(if portable then [ Loc.make ~loc (Ppxlib_jane.Modality "portable") ] else [])
128
+
include_infos
129
+
]
130
+
| None -> mk_sig ~loc ~path ~unboxed:false (rf, tds) ~stackify ~portable
131
+
;;
132
+
end
+93
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_expander.mli
+93
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_expander.mli
···
1
+
open Ppxlib
2
+
module Attrs = Attrs
3
+
module Record_field_attrs = Record_field_attrs
4
+
5
+
module Sexp_of : sig
6
+
val type_extension : core_type -> stackify:bool -> core_type
7
+
val pattern_extension : core_type -> stackify:bool -> pattern
8
+
val core_type : core_type -> stackify:bool -> expression
9
+
10
+
val sig_type_decl
11
+
: loc:Location.t
12
+
-> path:string
13
+
-> unboxed:bool
14
+
-> rec_flag * type_declaration list
15
+
-> stackify:bool
16
+
-> portable:bool
17
+
-> signature_item list
18
+
19
+
val sig_exception
20
+
: loc:Location.t
21
+
-> path:string
22
+
-> type_exception
23
+
-> signature_item list
24
+
25
+
val str_type_decl
26
+
: loc:Location.t
27
+
-> path:string
28
+
-> unboxed:bool
29
+
-> rec_flag * type_declaration list
30
+
-> stackify:bool
31
+
-> portable:bool
32
+
-> structure
33
+
34
+
val str_exception : loc:Location.t -> path:string -> type_exception -> structure
35
+
end
36
+
37
+
module Of_sexp : sig
38
+
val type_extension : core_type -> core_type
39
+
val pattern_extension : core_type -> pattern
40
+
val core_type : path:string -> core_type -> expression
41
+
42
+
val sig_type_decl
43
+
: poly:bool
44
+
-> loc:Location.t
45
+
-> path:string
46
+
-> unboxed:bool
47
+
-> rec_flag * type_declaration list
48
+
-> portable:bool
49
+
-> signature_item list
50
+
51
+
val str_type_decl
52
+
: loc:Location.t
53
+
-> poly:bool (** the type is annotated with sexp_poly instead of sexp *)
54
+
-> path:string (** the module path within the file *)
55
+
-> unboxed:bool
56
+
-> rec_flag * type_declaration list
57
+
-> portable:bool
58
+
-> structure
59
+
end
60
+
61
+
module Sexp_grammar : sig
62
+
val type_extension : ctxt:Expansion_context.Extension.t -> core_type -> core_type
63
+
val pattern_extension : ctxt:Expansion_context.Extension.t -> core_type -> pattern
64
+
65
+
val core_type
66
+
: tags_of_doc_comments:bool
67
+
-> ctxt:Expansion_context.Extension.t
68
+
-> core_type
69
+
-> expression
70
+
71
+
val sig_type_decl
72
+
: ctxt:Expansion_context.Deriver.t
73
+
-> rec_flag * type_declaration list
74
+
-> nonportable:bool
75
+
-> signature_item list
76
+
77
+
val str_type_decl
78
+
: ctxt:Expansion_context.Deriver.t
79
+
-> rec_flag * type_declaration list
80
+
-> bool (** [true] means capture doc comments as tags *)
81
+
-> structure
82
+
end
83
+
84
+
module Sig_sexp : sig
85
+
val sig_type_decl
86
+
: loc:Location.t
87
+
-> path:string
88
+
-> unboxed:bool
89
+
-> rec_flag * type_declaration list
90
+
-> stackify:bool
91
+
-> portable:bool
92
+
-> signature_item list
93
+
end
+790
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.ml
+790
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Ast_builder.Default
4
+
5
+
let copy =
6
+
object
7
+
inherit Ast_traverse.map
8
+
method! location loc = { loc with loc_ghost = true }
9
+
method! attributes _ = []
10
+
end
11
+
;;
12
+
13
+
let unsupported ~loc string =
14
+
Location.raise_errorf ~loc "sexp_grammar: %s are unsupported" string
15
+
;;
16
+
17
+
let ewith_tag ~loc ~key ~value grammar =
18
+
[%expr { key = [%e key]; value = [%e value]; grammar = [%e grammar] }]
19
+
;;
20
+
21
+
let eno_tag ~loc grammar = [%expr No_tag [%e grammar]]
22
+
let etag ~loc with_tag = [%expr Tag [%e with_tag]]
23
+
let etagged ~loc with_tag = [%expr Tagged [%e with_tag]]
24
+
25
+
let tag_of_doc_comment ~loc comment =
26
+
( [%expr Ppx_sexp_conv_lib.Sexp_grammar.doc_comment_tag]
27
+
, [%expr Atom [%e estring ~loc comment]] )
28
+
;;
29
+
30
+
module Tags = struct
31
+
type t =
32
+
{ defined_using_tags : expression option
33
+
; defined_using_tag : (expression * expression) list
34
+
}
35
+
36
+
let get x ~tags ~tag =
37
+
{ defined_using_tags = Attribute.get tags x
38
+
; defined_using_tag = Attribute.get tag x |> Option.value ~default:[]
39
+
}
40
+
;;
41
+
end
42
+
43
+
let rec with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags =
44
+
match tags_expr with
45
+
| [%expr []] -> grammar
46
+
| [%expr ([%e? key], [%e? value]) :: [%e? tags_expr]] ->
47
+
wrap_tag
48
+
~loc
49
+
(ewith_tag
50
+
~loc
51
+
~key
52
+
~value
53
+
(with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags))
54
+
| _ -> wrap_tags grammar ~loc ~tags_expr
55
+
;;
56
+
57
+
let with_tags grammar ~wrap_tag ~wrap_tags ~loc ~(tags : Tags.t) ~comments =
58
+
let tags_from_comments = List.map comments ~f:(tag_of_doc_comment ~loc) in
59
+
let init =
60
+
match tags.defined_using_tags with
61
+
| None -> grammar
62
+
| Some tags_expr -> with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags
63
+
in
64
+
List.fold_right
65
+
(List.concat [ tags_from_comments; tags.defined_using_tag ])
66
+
~init
67
+
~f:(fun (key, value) grammar -> wrap_tag ~loc (ewith_tag ~loc ~key ~value grammar))
68
+
;;
69
+
70
+
let with_tags_as_list grammar ~core_type ~loc ~tags ~comments =
71
+
let wrap_tags grammar ~loc ~tags_expr =
72
+
[%expr
73
+
Sexplib0.Sexp_conv.sexp_grammar_with_tag_list
74
+
([%e grammar] : [%t core_type] Sexplib0.Sexp_grammar.with_tag_list)
75
+
~tags:[%e tags_expr]]
76
+
in
77
+
with_tags (eno_tag ~loc grammar) ~wrap_tag:etag ~wrap_tags ~loc ~tags ~comments
78
+
;;
79
+
80
+
let with_tags_as_grammar grammar ~loc ~tags ~comments =
81
+
let wrap_tags grammar ~loc ~tags_expr =
82
+
[%expr Sexplib0.Sexp_conv.sexp_grammar_with_tags [%e grammar] ~tags:[%e tags_expr]]
83
+
in
84
+
with_tags grammar ~wrap_tag:etagged ~wrap_tags ~loc ~tags ~comments
85
+
;;
86
+
87
+
let grammar_name ?functor_:modname name =
88
+
let name, suffix = Ppx_helpers.demangle_template name in
89
+
let module_infix =
90
+
match modname with
91
+
| Some modname -> modname ^ "__"
92
+
| None -> ""
93
+
in
94
+
module_infix ^ name ^ "_sexp_grammar" ^ suffix
95
+
;;
96
+
97
+
let tyvar_grammar_name name = "_'" ^ name ^ "_sexp_grammar"
98
+
let estr { loc; txt } = estring ~loc txt
99
+
100
+
let grammar_type ~loc core_type =
101
+
[%type: [%t copy#core_type core_type] Sexplib0.Sexp_grammar.t]
102
+
;;
103
+
104
+
let abstract_grammar ~ctxt ~loc id =
105
+
let module_name =
106
+
ctxt |> Expansion_context.Deriver.code_path |> Code_path.fully_qualified_path
107
+
in
108
+
[%expr Any [%e estr { id with txt = String.concat ~sep:"." [ module_name; id.txt ] }]]
109
+
;;
110
+
111
+
let arrow_grammar ~loc = [%expr Sexplib0.Sexp_conv.fun_sexp_grammar.untyped]
112
+
let opaque_grammar ~loc = [%expr Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped]
113
+
let any_grammar ~loc name = [%expr Any [%e estring ~loc name]]
114
+
let list_grammar ~loc expr = [%expr List [%e expr]]
115
+
let many_grammar ~loc expr = [%expr Many [%e expr]]
116
+
let fields_grammar ~loc expr = [%expr Fields [%e expr]]
117
+
let tyvar_grammar ~loc expr = [%expr Tyvar [%e expr]]
118
+
let recursive_grammar ~loc name args = [%expr Recursive ([%e name], [%e args])]
119
+
120
+
let tycon_grammar ~loc tycon_name params defns =
121
+
[%expr Tycon ([%e tycon_name], [%e params], [%e defns])]
122
+
;;
123
+
124
+
let defns_type ~loc =
125
+
[%type: Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t]
126
+
;;
127
+
128
+
let untyped_grammar ~loc expr =
129
+
match expr with
130
+
| [%expr { untyped = [%e? untyped] }] -> untyped
131
+
| _ -> [%expr [%e expr].untyped]
132
+
;;
133
+
134
+
let typed_grammar ~loc expr =
135
+
match expr with
136
+
| [%expr [%e? typed].untyped] -> typed
137
+
| _ -> [%expr { untyped = [%e expr] }]
138
+
;;
139
+
140
+
let annotated_grammar ~loc expr core_type =
141
+
pexp_constraint ~loc expr (grammar_type ~loc core_type)
142
+
;;
143
+
144
+
let defn_expr ~loc ~tycon ~tyvars ~grammar =
145
+
[%expr { tycon = [%e tycon]; tyvars = [%e tyvars]; grammar = [%e grammar] }]
146
+
;;
147
+
148
+
let union_grammar ~loc exprs =
149
+
match exprs with
150
+
| [] -> [%expr Union []]
151
+
| [ expr ] -> expr
152
+
| _ -> [%expr Union [%e elist ~loc exprs]]
153
+
;;
154
+
155
+
let tuple_grammar ~loc exprs =
156
+
List.fold_right exprs ~init:[%expr Empty] ~f:(fun expr rest ->
157
+
[%expr Cons ([%e expr], [%e rest])])
158
+
;;
159
+
160
+
let atom_clause ~loc = [%expr Atom_clause]
161
+
let list_clause ~loc args = [%expr List_clause { args = [%e args] }]
162
+
163
+
module Variant_clause_type = struct
164
+
type t =
165
+
{ name : label loc
166
+
; comments : string list
167
+
; tags : Tags.t
168
+
; clause_kind : expression
169
+
}
170
+
171
+
let to_grammar_expr { name; comments; tags; clause_kind } ~loc =
172
+
[%expr { name = [%e estr name]; clause_kind = [%e clause_kind] }]
173
+
|> with_tags_as_list
174
+
~loc:name.loc
175
+
~comments
176
+
~tags
177
+
~core_type:[%type: Sexplib0.Sexp_grammar.clause]
178
+
;;
179
+
end
180
+
181
+
let variant_grammars ~loc ~case_sensitivity ~clauses =
182
+
match List.is_empty clauses with
183
+
| true -> []
184
+
| false ->
185
+
let clause_exprs = List.map clauses ~f:(Variant_clause_type.to_grammar_expr ~loc) in
186
+
let grammar =
187
+
[%expr
188
+
Variant
189
+
{ case_sensitivity = [%e case_sensitivity]
190
+
; clauses = [%e elist ~loc clause_exprs]
191
+
}]
192
+
in
193
+
[ grammar ]
194
+
;;
195
+
196
+
(* Wrap [expr] in [fun a b ... ->] for type parameters. *)
197
+
let td_params_fun td expr =
198
+
let loc = td.ptype_loc in
199
+
let params =
200
+
List.map td.ptype_params ~f:(fun param ->
201
+
let { loc; txt } = get_type_param_name param in
202
+
pvar ~loc (tyvar_grammar_name txt))
203
+
in
204
+
eabstract ~loc params expr
205
+
;;
206
+
207
+
module Row_field_type = struct
208
+
type t =
209
+
| Inherit of core_type
210
+
| Tag_no_arg of string loc
211
+
| Tag_with_arg of string loc * core_type
212
+
213
+
let of_row_field ~loc row_field =
214
+
match row_field with
215
+
| Rinherit core_type -> Inherit core_type
216
+
| Rtag (name, possibly_no_arg, possible_type_args) ->
217
+
(match possibly_no_arg, possible_type_args with
218
+
| true, [] -> Tag_no_arg name
219
+
| false, [ core_type ] -> Tag_with_arg (name, core_type)
220
+
| false, [] -> unsupported ~loc "empty polymorphic variant types"
221
+
| true, _ :: _ | false, _ :: _ :: _ -> unsupported ~loc "intersection types")
222
+
;;
223
+
end
224
+
225
+
let attr_doc_comments attributes ~tags_of_doc_comments =
226
+
match tags_of_doc_comments with
227
+
| false -> []
228
+
| true ->
229
+
let doc_pattern = Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) in
230
+
List.filter_map attributes ~f:(fun attribute ->
231
+
match attribute.attr_name.txt with
232
+
| "ocaml.doc" | "doc" ->
233
+
Ast_pattern.parse
234
+
doc_pattern
235
+
attribute.attr_loc
236
+
attribute.attr_payload
237
+
~on_error:(fun () -> None)
238
+
(fun doc -> Some doc)
239
+
| _ -> None)
240
+
;;
241
+
242
+
let grammar_of_type_tags core_type grammar ~tags_of_doc_comments =
243
+
let tags = Tags.get core_type ~tags:Attrs.tags_type ~tag:Attrs.tag_type in
244
+
let loc = core_type.ptyp_loc in
245
+
let comments = attr_doc_comments ~tags_of_doc_comments core_type.ptyp_attributes in
246
+
with_tags_as_grammar grammar ~loc ~tags ~comments
247
+
;;
248
+
249
+
let grammar_of_field_tags field grammar ~tags_of_doc_comments =
250
+
let tags = Tags.get field ~tags:Attrs.tags_ld ~tag:Attrs.tag_ld in
251
+
let loc = field.pld_loc in
252
+
let comments = attr_doc_comments ~tags_of_doc_comments field.pld_attributes in
253
+
with_tags_as_list
254
+
grammar
255
+
~loc
256
+
~tags
257
+
~comments
258
+
~core_type:[%type: Sexplib0.Sexp_grammar.field]
259
+
;;
260
+
261
+
let rec grammar_of_type core_type ~rec_flag ~tags_of_doc_comments =
262
+
let loc = core_type.ptyp_loc in
263
+
let grammar =
264
+
let from_attribute =
265
+
match
266
+
( Attribute.get Attrs.grammar_custom core_type
267
+
, Attribute.get Attrs.grammar_any core_type )
268
+
with
269
+
| Some _, Some _ ->
270
+
Some
271
+
[%expr
272
+
[%ocaml.warning
273
+
"[@sexp_grammar.custom] and [@sexp_grammar.any] are mutually exclusive"]]
274
+
| Some expr, None ->
275
+
Some (untyped_grammar ~loc (annotated_grammar ~loc expr core_type))
276
+
| None, Some maybe_name ->
277
+
Some (any_grammar ~loc (Option.value maybe_name ~default:"ANY"))
278
+
| None, None ->
279
+
(* only check [[@sexp.opaque]] if neither other attribute is present, so that it
280
+
only counts as using the attribute when we actually base the grammar on it *)
281
+
(match Attribute.get Attrs.opaque core_type with
282
+
| Some () -> Some (opaque_grammar ~loc)
283
+
| None -> None)
284
+
in
285
+
match from_attribute with
286
+
| Some expr -> expr
287
+
| None ->
288
+
(match Ppxlib_jane.Shim.Core_type_desc.of_parsetree core_type.ptyp_desc with
289
+
| Ptyp_any _ -> any_grammar ~loc "_"
290
+
| Ptyp_var (name, _) ->
291
+
(match rec_flag with
292
+
| Recursive ->
293
+
(* For recursive grammars, [grammar_of_type] for any type variables is called
294
+
inside a [defn]. The variables should therefore be resolved as [Tyvar]
295
+
grammars. *)
296
+
tyvar_grammar ~loc (estring ~loc name)
297
+
| Nonrecursive ->
298
+
(* Outside recursive [defn]s, type variables are passed in as function
299
+
arguments. *)
300
+
unapplied_type_constr_conv
301
+
~loc
302
+
~f:tyvar_grammar_name
303
+
(Located.lident ~loc name)
304
+
|> untyped_grammar ~loc)
305
+
| Ptyp_arrow _ -> arrow_grammar ~loc
306
+
| Ptyp_tuple labeled_tps ->
307
+
(match Ppxlib_jane.as_unlabeled_tuple labeled_tps with
308
+
| Some tps ->
309
+
List.map ~f:(grammar_of_type ~rec_flag ~tags_of_doc_comments) tps
310
+
|> tuple_grammar ~loc
311
+
|> list_grammar ~loc
312
+
| None ->
313
+
grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments labeled_tps)
314
+
| Ptyp_unboxed_tuple _ -> unsupported ~loc "unboxed tuple types"
315
+
| Ptyp_constr (id, args) ->
316
+
List.map args ~f:(fun core_type ->
317
+
let loc = core_type.ptyp_loc in
318
+
grammar_of_type ~rec_flag ~tags_of_doc_comments core_type |> typed_grammar ~loc)
319
+
|> Ppx_helpers.type_constr_conv_expr ~loc ~f:grammar_name id
320
+
|> untyped_grammar ~loc
321
+
| Ptyp_object _ -> unsupported ~loc "object types"
322
+
| Ptyp_class _ -> unsupported ~loc "class types"
323
+
| Ptyp_alias _ -> unsupported ~loc "type aliases"
324
+
| Ptyp_variant (rows, closed_flag, (_ : string list option)) ->
325
+
(match closed_flag with
326
+
| Open -> unsupported ~loc "open polymorphic variant types"
327
+
| Closed ->
328
+
grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows)
329
+
| Ptyp_poly _ -> unsupported ~loc "explicitly polymorphic types"
330
+
| Ptyp_package _ -> unsupported ~loc "first-class module types"
331
+
| Ptyp_quote _ -> unsupported ~loc "quoted types"
332
+
| Ptyp_splice _ -> unsupported ~loc "spliced types"
333
+
| Ptyp_of_kind _ -> unsupported ~loc "type of a fixed kind"
334
+
| Ptyp_extension _ -> unsupported ~loc "unexpanded ppx extensions")
335
+
in
336
+
grammar_of_type_tags core_type grammar ~tags_of_doc_comments
337
+
338
+
and grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments alist =
339
+
assert (Labeled_tuple.has_any_label alist);
340
+
let fields =
341
+
List.concat_map alist ~f:(fun (lbl, typ) ->
342
+
let lbl = Labeled_tuple.atom_of_label lbl in
343
+
let field = grammar_of_type ~rec_flag ~tags_of_doc_comments typ in
344
+
let clauses : Variant_clause_type.t list =
345
+
(* Labeled tuples are encoded as a list of singleton variants, where the
346
+
constructor name is used for the label. *)
347
+
[ { name = { txt = lbl; loc }
348
+
; comments = []
349
+
; tags =
350
+
{ defined_using_tags = None; defined_using_tag = [] }
351
+
(* We can use empty comments and tags because it's not possible to attach an
352
+
attribute to a labeled tuple field. *)
353
+
; clause_kind = list_clause ~loc [%expr Cons ([%e field], Empty)]
354
+
}
355
+
]
356
+
in
357
+
let case_sensitivity = [%expr Case_sensitive] in
358
+
variant_grammars ~loc ~case_sensitivity ~clauses)
359
+
in
360
+
list_grammar ~loc (tuple_grammar ~loc fields)
361
+
362
+
and grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows =
363
+
let inherits, clauses =
364
+
List.partition_map
365
+
(fun row : (_, Variant_clause_type.t) Either.t ->
366
+
let tags = Tags.get row ~tags:Attrs.tags_poly ~tag:Attrs.tag_poly in
367
+
let comments = attr_doc_comments ~tags_of_doc_comments row.prf_attributes in
368
+
match Attribute.get Attrs.list_poly row with
369
+
| Some () ->
370
+
(match Row_field_type.of_row_field ~loc row.prf_desc with
371
+
| Tag_with_arg (name, [%type: [%t? ty] list]) ->
372
+
let clause_kind =
373
+
grammar_of_type ~rec_flag ~tags_of_doc_comments ty
374
+
|> many_grammar ~loc
375
+
|> list_clause ~loc
376
+
in
377
+
Right { name; comments; tags; clause_kind }
378
+
| _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list")
379
+
| None ->
380
+
(match Row_field_type.of_row_field ~loc row.prf_desc with
381
+
| Inherit core_type ->
382
+
Left
383
+
(grammar_of_type ~rec_flag ~tags_of_doc_comments core_type
384
+
|> with_tags_as_grammar ~loc ~tags ~comments)
385
+
| Tag_no_arg name ->
386
+
Right { name; comments; tags; clause_kind = atom_clause ~loc }
387
+
| Tag_with_arg (name, core_type) ->
388
+
let clause_kind =
389
+
[ grammar_of_type ~rec_flag ~tags_of_doc_comments core_type ]
390
+
|> tuple_grammar ~loc
391
+
|> list_clause ~loc
392
+
in
393
+
Right { name; comments; tags; clause_kind }))
394
+
rows
395
+
in
396
+
variant_grammars ~loc ~case_sensitivity:[%expr Case_sensitive] ~clauses
397
+
|> List.append inherits
398
+
|> union_grammar ~loc
399
+
;;
400
+
401
+
let record_expr ~loc ~rec_flag ~tags_of_doc_comments ~extra_attr syntax fields =
402
+
let fields =
403
+
List.map fields ~f:(fun field ->
404
+
let loc = field.pld_loc in
405
+
let field_kind = Record_field_attrs.Of_sexp.create ~loc field in
406
+
let required =
407
+
match field_kind with
408
+
| Specific Required -> true
409
+
| Specific (Default _)
410
+
| Sexp_bool
411
+
| Sexp_option _
412
+
| Sexp_or_null _
413
+
| Sexp_array _
414
+
| Sexp_list _
415
+
| Omit_nil -> false
416
+
in
417
+
let args =
418
+
match field_kind with
419
+
| Specific Required | Specific (Default _) | Omit_nil ->
420
+
[%expr
421
+
Cons
422
+
([%e grammar_of_type ~tags_of_doc_comments ~rec_flag field.pld_type], Empty)]
423
+
| Sexp_bool -> [%expr Empty]
424
+
| Sexp_option ty | Sexp_or_null ty ->
425
+
[%expr Cons ([%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty], Empty)]
426
+
| Sexp_list ty | Sexp_array ty ->
427
+
[%expr
428
+
Cons
429
+
(List (Many [%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty]), Empty)]
430
+
in
431
+
[%expr
432
+
{ name = [%e estr field.pld_name]
433
+
; required = [%e ebool ~loc required]
434
+
; args = [%e args]
435
+
}]
436
+
|> grammar_of_field_tags field ~tags_of_doc_comments)
437
+
in
438
+
let allow_extra_fields =
439
+
match Attribute.get extra_attr syntax with
440
+
| Some () -> true
441
+
| None -> false
442
+
in
443
+
[%expr
444
+
{ allow_extra_fields = [%e ebool ~loc allow_extra_fields]
445
+
; fields = [%e elist ~loc fields]
446
+
}]
447
+
;;
448
+
449
+
let grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clause_decls =
450
+
let clauses =
451
+
List.map clause_decls ~f:(fun clause : Variant_clause_type.t ->
452
+
let loc = clause.pcd_loc in
453
+
let tags = Tags.get clause ~tags:Attrs.tags_cd ~tag:Attrs.tag_cd in
454
+
let comments = attr_doc_comments ~tags_of_doc_comments clause.pcd_attributes in
455
+
match Attribute.get Attrs.list_variant clause with
456
+
| Some () ->
457
+
(match clause.pcd_args with
458
+
| Pcstr_tuple [ arg ] ->
459
+
let core_type = Ppxlib_jane.Shim.Pcstr_tuple_arg.to_core_type arg in
460
+
(match core_type with
461
+
| [%type: [%t? ty] list] ->
462
+
let args =
463
+
many_grammar ~loc (grammar_of_type ty ~rec_flag ~tags_of_doc_comments)
464
+
in
465
+
{ name = clause.pcd_name
466
+
; comments
467
+
; tags
468
+
; clause_kind = list_clause ~loc args
469
+
}
470
+
| _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list")
471
+
| _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list")
472
+
| None ->
473
+
(match clause.pcd_args with
474
+
| Pcstr_tuple [] ->
475
+
{ name = clause.pcd_name; comments; tags; clause_kind = atom_clause ~loc }
476
+
| Pcstr_tuple (_ :: _ as args) ->
477
+
let args =
478
+
tuple_grammar
479
+
~loc
480
+
(List.map args ~f:(fun arg ->
481
+
Ppxlib_jane.Shim.Pcstr_tuple_arg.to_core_type arg
482
+
|> grammar_of_type ~rec_flag ~tags_of_doc_comments))
483
+
in
484
+
{ name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args }
485
+
| Pcstr_record fields ->
486
+
let args =
487
+
record_expr
488
+
~loc
489
+
~rec_flag
490
+
~tags_of_doc_comments
491
+
~extra_attr:Attrs.allow_extra_fields_cd
492
+
clause
493
+
fields
494
+
|> fields_grammar ~loc
495
+
in
496
+
{ name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args }))
497
+
in
498
+
variant_grammars
499
+
~loc
500
+
~case_sensitivity:[%expr Case_sensitive_except_first_character]
501
+
~clauses
502
+
|> union_grammar ~loc
503
+
;;
504
+
505
+
let grammar_of_td ~ctxt ~rec_flag ~tags_of_doc_comments td =
506
+
let loc = td.ptype_loc in
507
+
match Ppxlib_jane.Shim.Type_kind.of_parsetree td.ptype_kind with
508
+
| Ptype_open -> unsupported ~loc "open types"
509
+
| Ptype_record fields ->
510
+
record_expr
511
+
~loc
512
+
~rec_flag
513
+
~tags_of_doc_comments
514
+
~extra_attr:Attrs.allow_extra_fields_td
515
+
td
516
+
fields
517
+
|> fields_grammar ~loc
518
+
|> list_grammar ~loc
519
+
| Ptype_record_unboxed_product _ -> unsupported ~loc "unboxed record types"
520
+
| Ptype_variant clauses ->
521
+
grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clauses
522
+
| Ptype_abstract ->
523
+
(match td.ptype_manifest with
524
+
| None -> abstract_grammar ~ctxt ~loc td.ptype_name
525
+
| Some core_type -> grammar_of_type ~rec_flag ~tags_of_doc_comments core_type)
526
+
;;
527
+
528
+
let pattern_of_td td =
529
+
let { loc; txt } = td.ptype_name in
530
+
ppat_constraint
531
+
~loc
532
+
(pvar ~loc (grammar_name txt))
533
+
(Ppxlib_jane.Ast_builder.Default.ptyp_poly
534
+
~loc
535
+
(List.map td.ptype_params ~f:Ppxlib_jane.get_type_param_name_and_jkind)
536
+
(combinator_type_of_type_declaration td ~f:grammar_type))
537
+
;;
538
+
539
+
(* To avoid top-level effects (in particular, allocations, which both increase binary size
540
+
and start-up time), we wrap generated grammars in [lazy] if they might do non-trivial
541
+
work. In general, this should just be function applications, but to be conservative, we
542
+
always wrap with [lazy] unless they are clearly (recursively) static allocations:
543
+
- variant constructors, record constructors, tuple constructors
544
+
- field accesses
545
+
- variable lookups (note: even if the value that the variable points to is not
546
+
statically allocated, the compiler is still able to statically allocate the
547
+
new constructors)
548
+
*)
549
+
let rec grammar_is_statically_allocated expr =
550
+
match
551
+
Ppxlib_jane.Shim.Expression_desc.of_parsetree ~loc:expr.pexp_loc expr.pexp_desc
552
+
with
553
+
| Pexp_ident _ | Pexp_constant _ -> true
554
+
| Pexp_constraint (expr, _, _)
555
+
| Pexp_coerce (expr, _, _)
556
+
| Pexp_open (_, expr)
557
+
| Pexp_field (expr, _) -> grammar_is_statically_allocated expr
558
+
| Pexp_tuple args ->
559
+
List.for_all ~f:(fun (_, e) -> grammar_is_statically_allocated e) args
560
+
| Pexp_variant (_, None) | Pexp_construct (_, None) -> true
561
+
| Pexp_variant (_, Some arg) | Pexp_construct (_, Some arg) ->
562
+
grammar_is_statically_allocated arg
563
+
| Pexp_record (fields, maybe_template) ->
564
+
List.for_all fields ~f:(fun (_, expr) -> grammar_is_statically_allocated expr)
565
+
&&
566
+
(match maybe_template with
567
+
| None -> true
568
+
| Some template -> grammar_is_statically_allocated template)
569
+
| _ ->
570
+
(* We conservatively assume unhandled code structures allocate at runtime *)
571
+
false
572
+
;;
573
+
574
+
let lazy_grammar ~loc td expr =
575
+
if List.is_empty td.ptype_params
576
+
(* polymorphic types generate functions, so the body does not need a [lazy] wrapper *)
577
+
&& not (grammar_is_statically_allocated expr)
578
+
then
579
+
[%expr
580
+
Lazy
581
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
582
+
[%e expr]))]
583
+
else expr
584
+
;;
585
+
586
+
let force_expr ~loc expr = [%expr Basement.Portable_lazy.force [%e expr]]
587
+
588
+
(* Definitions of grammars that do not refer to each other. *)
589
+
let nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments td_lists =
590
+
List.concat_map td_lists ~f:(fun tds ->
591
+
List.map tds ~f:(fun td ->
592
+
let td = name_type_params_in_td td in
593
+
let loc = td.ptype_loc in
594
+
let pat = pattern_of_td td in
595
+
let expr =
596
+
grammar_of_td ~ctxt ~rec_flag:Nonrecursive ~tags_of_doc_comments td
597
+
|> lazy_grammar td ~loc
598
+
|> typed_grammar ~loc
599
+
|> td_params_fun td
600
+
in
601
+
value_binding ~loc ~pat ~expr)
602
+
|> pstr_value_list ~loc Nonrecursive)
603
+
;;
604
+
605
+
(* Type constructor grammars used to "tie the knot" for (mutally) recursive grammars. *)
606
+
let recursive_grammar_tycons tds =
607
+
List.map tds ~f:(fun td ->
608
+
let td = name_type_params_in_td td in
609
+
let loc = td.ptype_loc in
610
+
let pat = pattern_of_td td in
611
+
let expr =
612
+
recursive_grammar
613
+
~loc
614
+
(estr td.ptype_name)
615
+
(List.map td.ptype_params ~f:(fun param ->
616
+
let { loc; txt } = get_type_param_name param in
617
+
tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc)
618
+
|> elist ~loc)
619
+
|> typed_grammar ~loc
620
+
|> td_params_fun td
621
+
in
622
+
value_binding ~loc ~pat ~expr)
623
+
;;
624
+
625
+
(* Recursive grammar definitions, based on the type constructors from above. *)
626
+
let recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds =
627
+
List.map tds ~f:(fun td ->
628
+
let td = name_type_params_in_td td in
629
+
let loc = td.ptype_loc in
630
+
let tycon = estr td.ptype_name in
631
+
let tyvars =
632
+
List.map td.ptype_params ~f:(fun param -> estr (get_type_param_name param))
633
+
|> elist ~loc
634
+
in
635
+
let grammar = grammar_of_td ~ctxt ~rec_flag:Recursive ~tags_of_doc_comments td in
636
+
defn_expr ~loc ~tycon ~tyvars ~grammar)
637
+
|> elist ~loc
638
+
;;
639
+
640
+
(* Grammar expression using [Recursive] and a shared definition of grammar definitions.
641
+
The shared definitions are wrapped in [lazy] to avoid toplevel side effects. *)
642
+
let recursive_grammar_expr ~defns_name td =
643
+
let td = name_type_params_in_td td in
644
+
let loc = td.ptype_loc in
645
+
let pat = pattern_of_td td in
646
+
let expr =
647
+
let tyvars =
648
+
List.map td.ptype_params ~f:(fun param ->
649
+
let { loc; txt } = get_type_param_name param in
650
+
tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc)
651
+
|> elist ~loc
652
+
in
653
+
tycon_grammar
654
+
~loc
655
+
(estr td.ptype_name)
656
+
tyvars
657
+
(evar ~loc defns_name |> force_expr ~loc)
658
+
|> lazy_grammar td ~loc
659
+
|> typed_grammar ~loc
660
+
|> td_params_fun td
661
+
in
662
+
value_binding ~loc ~pat ~expr
663
+
;;
664
+
665
+
(* Puts together recursive grammar definitions from the parts implemented above. *)
666
+
let recursive_grammars ~ctxt ~loc ~tags_of_doc_comments tds =
667
+
match List.is_empty tds with
668
+
| true -> []
669
+
| false ->
670
+
let defns_name = gen_symbol ~prefix:"grammars" () in
671
+
let defns_item =
672
+
let expr =
673
+
recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds
674
+
|> pexp_let ~loc Nonrecursive (recursive_grammar_tycons tds)
675
+
in
676
+
let expr =
677
+
[%expr
678
+
Basement.Portable_lazy.from_fun
679
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
680
+
(fun () : Sexplib0.Sexp_grammar.defn list -> [%e expr]))]
681
+
in
682
+
let pat = ppat_constraint ~loc (pvar ~loc defns_name) (defns_type ~loc) in
683
+
pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ]
684
+
in
685
+
let grammars_item =
686
+
List.map tds ~f:(recursive_grammar_expr ~defns_name) |> pstr_value ~loc Nonrecursive
687
+
in
688
+
[%str
689
+
include struct
690
+
open struct
691
+
[%%i defns_item]
692
+
end
693
+
694
+
[%%i grammars_item]
695
+
end]
696
+
;;
697
+
698
+
let partition_recursive_and_nonrecursive ~rec_flag tds =
699
+
match (rec_flag : rec_flag) with
700
+
| Nonrecursive -> [], [ tds ]
701
+
| Recursive ->
702
+
(* Pulling out non-recursive references repeatedly means we only "tie the knot" for
703
+
variables that actually need it, and we don't have to manually [ignore] the added
704
+
bindings in case they are unused. *)
705
+
let rec loop tds ~acc =
706
+
let obj =
707
+
object
708
+
inherit type_is_recursive Recursive tds
709
+
710
+
method recursion td =
711
+
let type_names_list = [ td.ptype_name.txt ] in
712
+
{<type_names = type_names_list>}#go ()
713
+
end
714
+
in
715
+
let recursive, nonrecursive =
716
+
List.partition tds ~f:(fun td ->
717
+
match obj#recursion td with
718
+
| Recursive -> true
719
+
| Nonrecursive -> false)
720
+
in
721
+
if List.is_empty recursive || List.is_empty nonrecursive
722
+
then recursive, nonrecursive :: acc
723
+
else loop recursive ~acc:(nonrecursive :: acc)
724
+
in
725
+
loop tds ~acc:[]
726
+
;;
727
+
728
+
let str_type_decl ~ctxt (rec_flag, tds) tags_of_doc_comments =
729
+
let loc = Expansion_context.Deriver.derived_item_loc ctxt in
730
+
let recursive, nonrecursive = partition_recursive_and_nonrecursive ~rec_flag tds in
731
+
[ recursive_grammars ~ctxt ~loc ~tags_of_doc_comments recursive
732
+
; nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments nonrecursive
733
+
]
734
+
|> List.concat
735
+
;;
736
+
737
+
let sig_type_decl ~ctxt:_ (_rec_flag, tds) ~nonportable =
738
+
List.map tds ~f:(fun td ->
739
+
let td = Ppxlib.name_type_params_in_td td in
740
+
let loc = td.ptype_loc in
741
+
Ppxlib_jane.Ast_builder.Default.value_description
742
+
~loc
743
+
~name:(Loc.map td.ptype_name ~f:grammar_name)
744
+
~type_:
745
+
(Ppxlib_jane.Ast_builder.Default.ptyp_poly
746
+
~loc
747
+
(List.map td.ptype_params ~f:Ppxlib_jane.get_type_param_name_and_jkind)
748
+
(combinator_type_of_type_declaration td ~f:grammar_type))
749
+
~prim:[]
750
+
~modalities:(if nonportable then [] else Ppxlib_jane.Shim.Modalities.portable ~loc)
751
+
|> psig_value ~loc)
752
+
;;
753
+
754
+
let extension_loc ~ctxt =
755
+
let loc = Expansion_context.Extension.extension_point_loc ctxt in
756
+
{ loc with loc_ghost = true }
757
+
;;
758
+
759
+
let core_type ~tags_of_doc_comments ~ctxt core_type =
760
+
let loc = extension_loc ~ctxt in
761
+
pexp_constraint
762
+
~loc
763
+
(core_type
764
+
|> grammar_of_type ~rec_flag:Nonrecursive ~tags_of_doc_comments
765
+
|> typed_grammar ~loc)
766
+
(core_type |> grammar_type ~loc)
767
+
|> Merlin_helpers.hide_expression
768
+
;;
769
+
770
+
let type_extension ~ctxt core_type =
771
+
assert_no_attributes_in#core_type core_type;
772
+
let loc = extension_loc ~ctxt in
773
+
core_type |> grammar_type ~loc
774
+
;;
775
+
776
+
let pattern_extension ~ctxt core_type =
777
+
assert_no_attributes_in#core_type core_type;
778
+
let loc = extension_loc ~ctxt in
779
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree core_type.ptyp_desc with
780
+
| Ptyp_constr (id, _) -> Ppx_helpers.type_constr_conv_pat ~loc:id.loc id ~f:grammar_name
781
+
| Ptyp_var (id, _) ->
782
+
[%pat? ([%p pvar ~loc (tyvar_grammar_name id)] : [%t grammar_type ~loc core_type])]
783
+
| _ ->
784
+
Ast_builder.Default.ppat_extension
785
+
~loc
786
+
(Location.error_extensionf
787
+
~loc
788
+
"Only type variables and constructors are allowed here (e.g. ['a], [t], ['a t], \
789
+
or [M(X).t]).")
790
+
;;
+23
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.mli
+23
vendor/opam/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
val type_extension : ctxt:Expansion_context.Extension.t -> core_type -> core_type
5
+
val pattern_extension : ctxt:Expansion_context.Extension.t -> core_type -> pattern
6
+
7
+
val core_type
8
+
: tags_of_doc_comments:bool
9
+
-> ctxt:Expansion_context.Extension.t
10
+
-> core_type
11
+
-> expression
12
+
13
+
val sig_type_decl
14
+
: ctxt:Expansion_context.Deriver.t
15
+
-> rec_flag * type_declaration list
16
+
-> nonportable:bool
17
+
-> signature_item list
18
+
19
+
val str_type_decl
20
+
: ctxt:Expansion_context.Deriver.t
21
+
-> rec_flag * type_declaration list
22
+
-> bool (** [true] means capture doc comments as tags *)
23
+
-> structure
+136
vendor/opam/ppx_sexp_conv/expander/record_field_attrs.ml
+136
vendor/opam/ppx_sexp_conv/expander/record_field_attrs.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
open Attrs
4
+
5
+
module Generic = struct
6
+
type 'specific t =
7
+
| Omit_nil
8
+
| Sexp_array of core_type
9
+
| Sexp_bool
10
+
| Sexp_list of core_type
11
+
| Sexp_option of core_type
12
+
| Sexp_or_null of core_type
13
+
| Specific of 'specific
14
+
end
15
+
16
+
open Generic
17
+
18
+
let get_attribute attr ld ~f =
19
+
Option.map (Attribute.get attr ld) ~f:(fun x -> f x, Attribute.name attr)
20
+
;;
21
+
22
+
let create ~loc specific_getters ld ~if_no_attribute =
23
+
let generic_getters =
24
+
[ get_attribute omit_nil ~f:(fun () -> Omit_nil)
25
+
; (fun ld ->
26
+
match ld.pld_type with
27
+
| ty when Option.is_some (Attribute.get bool ld) ->
28
+
(match ty with
29
+
| [%type: bool] -> Some (Sexp_bool, "[@sexp.bool]")
30
+
| _ -> invalid_attribute ~loc bool "bool")
31
+
| ty when Option.is_some (Attribute.get option ld) ->
32
+
(match ty with
33
+
| [%type: [%t? ty] option] -> Some (Sexp_option ty, "[@sexp.option]")
34
+
| _ -> invalid_attribute ~loc option "_ option")
35
+
| ty when Option.is_some (Attribute.get or_null ld) ->
36
+
(match ty with
37
+
| [%type: [%t? ty] or_null] -> Some (Sexp_or_null ty, "[@sexp.or_null]")
38
+
| _ -> invalid_attribute ~loc or_null "_ or_null")
39
+
| ty when Option.is_some (Attribute.get list ld) ->
40
+
(match ty with
41
+
| [%type: [%t? ty] list] -> Some (Sexp_list ty, "[@sexp.list]")
42
+
| _ -> invalid_attribute ~loc list "_ list")
43
+
| ty when Option.is_some (Attribute.get array ld) ->
44
+
(match ty with
45
+
| [%type: [%t? ty] array] -> Some (Sexp_array ty, "[@sexp.array]")
46
+
| _ -> invalid_attribute ~loc array "_ array")
47
+
| _ -> None)
48
+
]
49
+
in
50
+
let getters =
51
+
let wrapped_getters =
52
+
List.map specific_getters ~f:(fun get ld ->
53
+
Option.map (get ld) ~f:(fun (specific, string) -> Specific specific, string))
54
+
in
55
+
List.concat [ wrapped_getters; generic_getters ]
56
+
in
57
+
match List.filter_map getters ~f:(fun f -> f ld) with
58
+
| [] -> Specific if_no_attribute
59
+
| [ (v, _) ] -> v
60
+
| _ :: _ :: _ as attributes ->
61
+
Location.raise_errorf
62
+
~loc
63
+
"The following elements are mutually exclusive: %s"
64
+
(String.concat ~sep:" " (List.map attributes ~f:snd))
65
+
;;
66
+
67
+
let strip_attributes =
68
+
object
69
+
inherit Ast_traverse.map
70
+
method! attributes _ = []
71
+
end
72
+
;;
73
+
74
+
let lift_default ~loc ld expr =
75
+
let ty = strip_attributes#core_type ld.pld_type in
76
+
Lifted.create ~loc ~prefix:"default" ~ty expr
77
+
;;
78
+
79
+
let lift_drop_default ~loc ld expr =
80
+
let ty = strip_attributes#core_type ld.pld_type in
81
+
Lifted.create
82
+
~loc
83
+
~prefix:"drop_default"
84
+
~ty:[%type: [%t ty] -> [%t ty] -> Stdlib.Bool.t]
85
+
expr
86
+
;;
87
+
88
+
let lift_drop_if ~loc ld expr =
89
+
let ty = strip_attributes#core_type ld.pld_type in
90
+
Lifted.create ~loc ~prefix:"drop_if" ~ty:[%type: [%t ty] -> Stdlib.Bool.t] expr
91
+
;;
92
+
93
+
module Of_sexp = struct
94
+
type t =
95
+
| Default of expression Lifted.t
96
+
| Required
97
+
98
+
let create ~loc ld =
99
+
create
100
+
~loc
101
+
[ get_attribute default ~f:(fun { to_lift = default } ->
102
+
Default (lift_default ~loc ld default))
103
+
]
104
+
ld
105
+
~if_no_attribute:Required
106
+
;;
107
+
end
108
+
109
+
module Sexp_of = struct
110
+
module Drop = struct
111
+
type t =
112
+
| Compare
113
+
| Equal
114
+
| Sexp
115
+
| Func of expression Lifted.t
116
+
end
117
+
118
+
type t =
119
+
| Drop_default of Drop.t
120
+
| Drop_if of expression Lifted.t
121
+
| Keep
122
+
123
+
let create ~loc ld =
124
+
create
125
+
~loc
126
+
[ get_attribute drop_default ~f:(fun { to_lift = e } ->
127
+
Drop_default (Func (lift_drop_default ~loc ld e)))
128
+
; get_attribute drop_default_equal ~f:(fun () -> Drop_default Equal)
129
+
; get_attribute drop_default_compare ~f:(fun () -> Drop_default Compare)
130
+
; get_attribute drop_default_sexp ~f:(fun () -> Drop_default Sexp)
131
+
; get_attribute drop_if ~f:(fun { to_lift = x } -> Drop_if (lift_drop_if ~loc ld x))
132
+
]
133
+
ld
134
+
~if_no_attribute:Keep
135
+
;;
136
+
end
+41
vendor/opam/ppx_sexp_conv/expander/record_field_attrs.mli
+41
vendor/opam/ppx_sexp_conv/expander/record_field_attrs.mli
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
module Generic : sig
5
+
type 'specific t =
6
+
| Omit_nil
7
+
| Sexp_array of core_type
8
+
| Sexp_bool
9
+
| Sexp_list of core_type
10
+
| Sexp_option of core_type
11
+
| Sexp_or_null of core_type
12
+
| Specific of 'specific
13
+
end
14
+
15
+
module Of_sexp : sig
16
+
type t =
17
+
| Default of expression Lifted.t
18
+
| Required
19
+
20
+
val create : loc:Location.t -> label_declaration -> t Generic.t
21
+
end
22
+
23
+
module Sexp_of : sig
24
+
module Drop : sig
25
+
type t =
26
+
| Compare
27
+
| Equal
28
+
| Sexp
29
+
| Func of expression Lifted.t
30
+
end
31
+
32
+
type t =
33
+
| Drop_default of Drop.t
34
+
| Drop_if of expression Lifted.t
35
+
| Keep
36
+
37
+
val create : loc:Location.t -> label_declaration -> t Generic.t
38
+
end
39
+
40
+
(** Lift the contents of [Attrs.default]. *)
41
+
val lift_default : loc:location -> label_declaration -> expression -> expression Lifted.t
+125
vendor/opam/ppx_sexp_conv/expander/renaming.ml
+125
vendor/opam/ppx_sexp_conv/expander/renaming.ml
···
1
+
open! Stdppx
2
+
open! Ppxlib
3
+
4
+
type t =
5
+
{ universal : (Fresh_name.t, string loc) result String.Map.t
6
+
; existential : bool
7
+
}
8
+
9
+
module Binding_kind = struct
10
+
type t =
11
+
| Universally_bound of Fresh_name.t
12
+
| Existentially_bound
13
+
end
14
+
15
+
let add_universally_bound t name ~prefix =
16
+
{ t with
17
+
universal =
18
+
String.Map.add
19
+
name.txt
20
+
(Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc))
21
+
t.universal
22
+
}
23
+
;;
24
+
25
+
let binding_kind t var ~loc =
26
+
match String.Map.find_opt var t.universal with
27
+
| None ->
28
+
if t.existential
29
+
then Binding_kind.Existentially_bound
30
+
else Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" var
31
+
| Some (Ok fresh) -> Binding_kind.Universally_bound fresh
32
+
| Some (Error { loc; txt }) -> Location.raise_errorf ~loc "%s" txt
33
+
;;
34
+
35
+
(* Return a map translating type variables appearing in the return type of a GADT
36
+
constructor to their name in the type parameter list.
37
+
38
+
For instance:
39
+
40
+
{[
41
+
type ('a, 'b) t = X : 'x * 'y -> ('x, 'y) t
42
+
]}
43
+
44
+
will produce:
45
+
46
+
{v
47
+
"x" -> Ok "a"
48
+
"y" -> Ok "b"
49
+
v}
50
+
51
+
If a variable appears twice in the return type it will map to [Error _]. If a
52
+
variable cannot be mapped to a parameter of the type declaration, it will map to
53
+
[Error] (for instance [A : 'a -> 'a list t]).
54
+
55
+
It returns [original] on user error, to let the typer give the error message *)
56
+
let with_constructor_declaration original cd ~type_parameters:tps =
57
+
(* Add all type variables of a type to a map. *)
58
+
let add_typevars =
59
+
object
60
+
inherit [t] Ast_traverse.fold as super
61
+
62
+
method! core_type ty t =
63
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ty.ptyp_desc with
64
+
| Ptyp_var (var, _) ->
65
+
let error =
66
+
{ loc = ty.ptyp_loc
67
+
; txt =
68
+
Printf.sprintf
69
+
"ppx_sexp_conv: variable is not a parameter of the type constructor. \
70
+
Hint: mark all appearances of '%s in the constructor's arguments as \
71
+
[@sexp.opaque]."
72
+
var
73
+
}
74
+
in
75
+
{ t with universal = String.Map.add var (Error error) t.universal }
76
+
| _ -> super#core_type ty t
77
+
end
78
+
in
79
+
let aux t tp_name tp_in_return_type =
80
+
match Ppxlib_jane.Shim.Core_type_desc.of_parsetree tp_in_return_type.ptyp_desc with
81
+
| Ptyp_var (var, _) ->
82
+
let data =
83
+
let loc = tp_in_return_type.ptyp_loc in
84
+
if String.Map.mem var t.universal
85
+
then Error { loc; txt = "ppx_sexp_conv: duplicate variable" }
86
+
else (
87
+
match String.Map.find_opt tp_name original.universal with
88
+
| Some result -> result
89
+
| None -> Error { loc; txt = "ppx_sexp_conv: unbound type parameter" })
90
+
in
91
+
{ t with universal = String.Map.add var data t.universal }
92
+
| _ -> add_typevars#core_type tp_in_return_type t
93
+
in
94
+
match cd.pcd_res with
95
+
| None -> original
96
+
| Some ty ->
97
+
(match ty.ptyp_desc with
98
+
| Ptyp_constr (_, params) ->
99
+
if List.length params <> List.length tps
100
+
then original
101
+
else
102
+
Stdlib.ListLabels.fold_left2
103
+
tps
104
+
params
105
+
~init:{ existential = true; universal = String.Map.empty }
106
+
~f:aux
107
+
| _ -> original)
108
+
;;
109
+
110
+
let of_type_declaration decl ~prefix =
111
+
{ existential = false
112
+
; universal =
113
+
List.fold_left decl.ptype_params ~init:String.Map.empty ~f:(fun map param ->
114
+
let name = get_type_param_name param in
115
+
String.Map.update
116
+
name.txt
117
+
(function
118
+
| None -> Some (Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc))
119
+
| Some _ ->
120
+
Some (Error { loc = name.loc; txt = "ppx_sexp_conv: duplicate variable" }))
121
+
map)
122
+
}
123
+
;;
124
+
125
+
let without_type () = { existential = false; universal = String.Map.empty }
+52
vendor/opam/ppx_sexp_conv/expander/renaming.mli
+52
vendor/opam/ppx_sexp_conv/expander/renaming.mli
···
1
+
(* A renaming is a mapping from type variable name to type variable name.
2
+
In definitions such as:
3
+
4
+
type 'a t =
5
+
| A : <type> -> 'b t
6
+
| B of 'a
7
+
8
+
we generate a function that takes an sexp_of parameter named after 'a, but 'a is not in
9
+
scope in <type> when handling the constructor A (because A is a gadt constructor).
10
+
Instead the type variables in scope are the ones defined in the return type of A,
11
+
namely 'b. There could be less or more type variable in cases such as:
12
+
13
+
type _ less = Less : int less
14
+
type _ more = More : ('a * 'a) more
15
+
16
+
If for instance, <type> is ['b * 'c], when we find 'b, we will look for ['b] in the
17
+
renaming and find ['a] (only in that gadt branch, it could be something else in other
18
+
branches), at which point we can call the previously bound sexp_of parameter named
19
+
after 'a.
20
+
If we can't find a resulting name, like when looking up ['c] in the renaming, then we
21
+
assume the variable is existentially quantified and treat it as [_] (which is ok,
22
+
assuming there are no constraints). *)
23
+
open! Stdppx
24
+
open! Ppxlib
25
+
26
+
type t
27
+
28
+
(** Renaming for contexts outside a type declaration, such as expression extensions. *)
29
+
val without_type : unit -> t
30
+
31
+
(** Renaming for a type declaration. Adds [prefix] to bindings for type parameters. *)
32
+
val of_type_declaration : type_declaration -> prefix:string -> t
33
+
34
+
(** Adds a new name with the given [prefix] for a universally bound type variable. *)
35
+
val add_universally_bound : t -> string loc -> prefix:string -> t
36
+
37
+
module Binding_kind : sig
38
+
type t =
39
+
| Universally_bound of Fresh_name.t
40
+
| Existentially_bound
41
+
end
42
+
43
+
(** Looks up the binding for a type variable. *)
44
+
val binding_kind : t -> string -> loc:location -> Binding_kind.t
45
+
46
+
(** Extends the renaming of a type declaration with GADT context for a constructor
47
+
declaration, if any. *)
48
+
val with_constructor_declaration
49
+
: t
50
+
-> constructor_declaration
51
+
-> type_parameters:string list
52
+
-> t
+25
vendor/opam/ppx_sexp_conv/ppx_sexp_conv.opam
+25
vendor/opam/ppx_sexp_conv/ppx_sexp_conv.opam
···
1
+
opam-version: "2.0"
2
+
maintainer: "Jane Street developers"
3
+
authors: ["Jane Street Group, LLC"]
4
+
homepage: "https://github.com/janestreet/ppx_sexp_conv"
5
+
bug-reports: "https://github.com/janestreet/ppx_sexp_conv/issues"
6
+
dev-repo: "git+https://github.com/janestreet/ppx_sexp_conv.git"
7
+
doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_sexp_conv/index.html"
8
+
license: "MIT"
9
+
build: [
10
+
["dune" "build" "-p" name "-j" jobs]
11
+
]
12
+
depends: [
13
+
"ocaml" {>= "5.1.0"}
14
+
"basement"
15
+
"ppx_helpers"
16
+
"ppxlib_jane"
17
+
"sexplib0"
18
+
"dune" {>= "3.17.0"}
19
+
"ppxlib" {>= "0.33.0" & < "0.36.0"}
20
+
]
21
+
available: arch != "arm32" & arch != "x86_32"
22
+
synopsis: "[@@deriving] plugin to generate S-expression conversion functions"
23
+
description: "
24
+
Part of the Jane Street's PPX rewriters collection.
25
+
"
+5
vendor/opam/ppx_sexp_conv/runtime-lib/dune
+5
vendor/opam/ppx_sexp_conv/runtime-lib/dune
+12
vendor/opam/ppx_sexp_conv/runtime-lib/ppx_sexp_conv_lib.ml
+12
vendor/opam/ppx_sexp_conv/runtime-lib/ppx_sexp_conv_lib.ml
···
1
+
module Conv = Sexplib0.Sexp_conv
2
+
module Conv_error = Sexplib0.Sexp_conv_error
3
+
module Or_null = Basement.Or_null_shim
4
+
module Sexp_grammar = Sexplib0.Sexp_grammar
5
+
6
+
module Sexp = struct
7
+
include Sexplib0.Sexp
8
+
9
+
let t_sexp_grammar = Conv.sexp_t_sexp_grammar
10
+
end
11
+
12
+
module Sexpable = Sexplib0.Sexpable
+6
vendor/opam/ppx_sexp_conv/src/dune
+6
vendor/opam/ppx_sexp_conv/src/dune
+275
vendor/opam/ppx_sexp_conv/src/ppx_sexp_conv.ml
+275
vendor/opam/ppx_sexp_conv/src/ppx_sexp_conv.ml
···
1
+
(* sexp_conv: Preprocessing Module for Automated S-expression Conversions *)
2
+
3
+
open StdLabels
4
+
open Ppxlib
5
+
6
+
let register_extension name f =
7
+
let extension = Extension.declare name Expression Ast_pattern.(ptyp __) f in
8
+
Driver.register_transformation
9
+
("Ppxlib.Deriving." ^ name)
10
+
~rules:[ Context_free.Rule.extension extension ]
11
+
;;
12
+
13
+
let portable_and_unboxed_args () =
14
+
Deriving.Args.(empty +> flag "portable" +> flag "unboxed")
15
+
;;
16
+
17
+
let nonportable_arg () = Deriving.Args.(empty +> flag "nonportable")
18
+
19
+
let stackify_portable_unboxed_args () =
20
+
Deriving.Args.(empty +> flag "stackify" +> flag "portable" +> flag "unboxed")
21
+
;;
22
+
23
+
module Sexp_grammar = struct
24
+
module E = Ppx_sexp_conv_expander.Sexp_grammar
25
+
26
+
let name = "sexp_grammar"
27
+
let flags = Deriving.Args.(empty +> flag "tags_of_doc_comments")
28
+
let str_type_decl = Deriving.Generator.V2.make flags E.str_type_decl
29
+
30
+
let sig_type_decl =
31
+
Deriving.Generator.V2.make (nonportable_arg ()) (fun ~ctxt tds nonportable ->
32
+
E.sig_type_decl ~ctxt tds ~nonportable)
33
+
;;
34
+
35
+
let deriver = Deriving.add name ~sig_type_decl ~str_type_decl
36
+
37
+
(* We default to [tags_of_doc_comments=true] in this case, because doc comments in a
38
+
[%sexp_grammar] expression have no other purpose. *)
39
+
let expr_extension =
40
+
Extension.V3.declare
41
+
name
42
+
Expression
43
+
Ast_pattern.(ptyp __)
44
+
(E.core_type ~tags_of_doc_comments:true)
45
+
;;
46
+
47
+
let type_extension =
48
+
Extension.V3.declare name Core_type Ast_pattern.(ptyp __) E.type_extension
49
+
;;
50
+
51
+
let pattern_extension =
52
+
Extension.V3.declare name Pattern Ast_pattern.(ptyp __) E.pattern_extension
53
+
;;
54
+
55
+
let () =
56
+
Driver.register_transformation
57
+
"Ppxlib.Deriving.sexp_grammar"
58
+
~rules:
59
+
[ Context_free.Rule.extension expr_extension
60
+
; Context_free.Rule.extension type_extension
61
+
; Context_free.Rule.extension pattern_extension
62
+
]
63
+
;;
64
+
end
65
+
66
+
module Sexp_of = struct
67
+
module E = Ppx_sexp_conv_expander.Sexp_of
68
+
69
+
type stackify_kind =
70
+
| For_deriving
71
+
| For_extension
72
+
73
+
let name ~stackify =
74
+
match stackify with
75
+
| None -> "sexp_of"
76
+
| Some For_deriving -> "sexp_of__stack"
77
+
| Some For_extension -> "sexp_of_stack"
78
+
;;
79
+
80
+
let str_type_decl =
81
+
Deriving.Generator.make
82
+
(stackify_portable_unboxed_args ())
83
+
(fun ~loc ~path tds stackify portable unboxed ->
84
+
E.str_type_decl ~loc ~path ~unboxed tds ~stackify ~portable)
85
+
;;
86
+
87
+
let str_type_decl_stack =
88
+
Deriving.Generator.make
89
+
(portable_and_unboxed_args ())
90
+
(fun ~loc ~path tds portable unboxed ->
91
+
E.str_type_decl ~loc ~path ~unboxed tds ~stackify:true ~portable)
92
+
;;
93
+
94
+
let str_exception = Deriving.Generator.make_noarg E.str_exception
95
+
96
+
let sig_type_decl =
97
+
Deriving.Generator.make
98
+
(stackify_portable_unboxed_args ())
99
+
(fun ~loc ~path tds stackify portable unboxed ->
100
+
E.sig_type_decl ~loc ~path ~unboxed tds ~stackify ~portable)
101
+
;;
102
+
103
+
let sig_type_decl_stack =
104
+
Deriving.Generator.make
105
+
(portable_and_unboxed_args ())
106
+
(fun ~loc ~path tds portable unboxed ->
107
+
E.sig_type_decl ~loc ~path ~unboxed tds ~stackify:true ~portable)
108
+
;;
109
+
110
+
let sig_exception = Deriving.Generator.make_noarg E.sig_exception
111
+
112
+
let deriver =
113
+
Deriving.add
114
+
(name ~stackify:None)
115
+
~str_type_decl
116
+
~str_exception
117
+
~sig_type_decl
118
+
~sig_exception
119
+
;;
120
+
121
+
let deriver_stack =
122
+
Deriving.add
123
+
(name ~stackify:(Some For_deriving))
124
+
~str_type_decl:str_type_decl_stack
125
+
~sig_type_decl:sig_type_decl_stack
126
+
;;
127
+
128
+
let () =
129
+
List.iter [ None; Some For_extension ] ~f:(fun stackify ->
130
+
register_extension (name ~stackify) (fun ~loc:_ ~path:_ ctyp ->
131
+
E.core_type ctyp ~stackify:(Option.is_some stackify)))
132
+
;;
133
+
134
+
let () =
135
+
let rules =
136
+
List.concat_map [ None; Some For_extension ] ~f:(fun stackify ->
137
+
[ Context_free.Rule.extension
138
+
(Extension.declare
139
+
(name ~stackify)
140
+
Core_type
141
+
Ast_pattern.(ptyp __)
142
+
(fun ~loc:_ ~path:_ ty ->
143
+
E.type_extension ty ~stackify:(Option.is_some stackify)))
144
+
; Context_free.Rule.extension
145
+
(Extension.declare
146
+
(name ~stackify)
147
+
Pattern
148
+
Ast_pattern.(ptyp __)
149
+
(fun ~loc:_ ~path:_ ty ->
150
+
E.pattern_extension ty ~stackify:(Option.is_some stackify)))
151
+
])
152
+
in
153
+
Driver.register_transformation (name ~stackify:None) ~rules
154
+
;;
155
+
end
156
+
157
+
module Of_sexp = struct
158
+
module E = Ppx_sexp_conv_expander.Of_sexp
159
+
160
+
let name = "of_sexp"
161
+
162
+
let str_type_decl =
163
+
Deriving.Generator.make
164
+
(portable_and_unboxed_args ())
165
+
(fun ~loc ~path tds portable unboxed ->
166
+
E.str_type_decl ~loc ~path ~unboxed tds ~poly:false ~portable)
167
+
;;
168
+
169
+
let sig_type_decl =
170
+
Deriving.Generator.make
171
+
(portable_and_unboxed_args ())
172
+
(fun ~loc ~path tds portable unboxed ->
173
+
E.sig_type_decl ~poly:false ~loc ~path ~unboxed tds ~portable)
174
+
;;
175
+
176
+
let deriver = Deriving.add name ~str_type_decl ~sig_type_decl
177
+
let extension ~loc:_ ~path ctyp = E.core_type ~path ctyp
178
+
let () = register_extension name extension
179
+
180
+
let () =
181
+
Driver.register_transformation
182
+
name
183
+
~rules:
184
+
[ Context_free.Rule.extension
185
+
(Extension.declare
186
+
name
187
+
Core_type
188
+
Ast_pattern.(ptyp __)
189
+
(fun ~loc:_ ~path:_ ty -> E.type_extension ty))
190
+
; Context_free.Rule.extension
191
+
(Extension.declare
192
+
name
193
+
Pattern
194
+
Ast_pattern.(ptyp __)
195
+
(fun ~loc:_ ~path:_ ty -> E.pattern_extension ty))
196
+
]
197
+
;;
198
+
end
199
+
200
+
module Of_sexp_poly = struct
201
+
module E = Ppx_sexp_conv_expander.Of_sexp
202
+
203
+
let str_type_decl =
204
+
Deriving.Generator.make
205
+
(portable_and_unboxed_args ())
206
+
(fun ~loc ~path tds portable unboxed ->
207
+
E.str_type_decl ~poly:true ~loc ~path ~unboxed tds ~portable)
208
+
;;
209
+
210
+
let sig_type_decl =
211
+
Deriving.Generator.make
212
+
(portable_and_unboxed_args ())
213
+
(fun ~loc ~path tds portable unboxed ->
214
+
E.sig_type_decl ~poly:true ~loc ~path ~unboxed tds ~portable)
215
+
;;
216
+
217
+
let deriver = Deriving.add "of_sexp_poly" ~sig_type_decl ~str_type_decl
218
+
end
219
+
220
+
let sexp_of = Sexp_of.deriver
221
+
let sexp_of__stack = Sexp_of.deriver_stack
222
+
let of_sexp = Of_sexp.deriver
223
+
let of_sexp_poly = Of_sexp_poly.deriver
224
+
let sexp_grammar = Sexp_grammar.deriver
225
+
226
+
module Sexp_in_sig = struct
227
+
module E = Ppx_sexp_conv_expander.Sig_sexp
228
+
229
+
let sig_type_decl =
230
+
Deriving.Generator.make
231
+
(stackify_portable_unboxed_args ())
232
+
(fun ~loc ~path tds stackify portable unboxed ->
233
+
E.sig_type_decl ~loc ~path ~unboxed tds ~stackify ~portable)
234
+
;;
235
+
236
+
let sig_type_decl_stack =
237
+
Deriving.Generator.make
238
+
(portable_and_unboxed_args ())
239
+
(fun ~loc ~path tds portable unboxed ->
240
+
E.sig_type_decl ~loc ~path ~unboxed tds ~stackify:true ~portable)
241
+
;;
242
+
243
+
let deriver =
244
+
Deriving.add
245
+
"ppx_sexp_conv: let this be a string that wouldn't parse if put in the source"
246
+
~sig_type_decl
247
+
;;
248
+
249
+
let deriver_stack =
250
+
Deriving.add
251
+
"ppx_sexp_conv: let this be a string that wouldn't parse if put in the source \
252
+
_stack"
253
+
~sig_type_decl:sig_type_decl_stack
254
+
;;
255
+
end
256
+
257
+
let sexp =
258
+
Deriving.add_alias
259
+
"sexp"
260
+
[ sexp_of; of_sexp ]
261
+
~sig_type_decl:[ Sexp_in_sig.deriver ]
262
+
~str_exception:[ sexp_of ]
263
+
~sig_exception:[ sexp_of ]
264
+
;;
265
+
266
+
let sexp__stack =
267
+
Deriving.add_alias
268
+
"sexp__stack"
269
+
[ sexp_of__stack; of_sexp ]
270
+
~sig_type_decl:[ Sexp_in_sig.deriver_stack ]
271
+
~str_exception:[ sexp_of__stack ]
272
+
~sig_exception:[ sexp_of__stack ]
273
+
;;
274
+
275
+
let sexp_poly = Deriving.add_alias "sexp_poly" [ sexp_of; of_sexp_poly ]
+10
vendor/opam/ppx_sexp_conv/src/ppx_sexp_conv.mli
+10
vendor/opam/ppx_sexp_conv/src/ppx_sexp_conv.mli
+8
vendor/opam/ppx_sexp_conv/test/dune
+8
vendor/opam/ppx_sexp_conv/test/dune
···
1
+
(library
2
+
(name ppx_sexp_conv_test)
3
+
(libraries base expect_test_helpers_core.expect_test_helpers_base sexplib
4
+
stdio)
5
+
(flags :standard -w -30)
6
+
(preprocess
7
+
(pps ppxlib ppx_sexp_conv ppx_compare ppx_disable_unused_warnings ppx_here
8
+
ppx_inline_test ppx_expect ppx_template)))
+382
vendor/opam/ppx_sexp_conv/test/errors.mlt
+382
vendor/opam/ppx_sexp_conv/test/errors.mlt
···
1
+
type t = { a : int [@sexp_drop_default ( = )] [@sexp.omit_nil] }
2
+
[@@deriving sexp_of ~stackify]
3
+
4
+
[%%expect
5
+
{|
6
+
Line _, characters _-_:
7
+
Error: The following elements are mutually exclusive: sexp.sexp_drop_default sexp.omit_nil
8
+
|}]
9
+
10
+
type t = { a : int list [@sexp.list] [@sexp.omit_nil] } [@@deriving sexp_of ~stackify]
11
+
12
+
[%%expect
13
+
{|
14
+
Line _, characters _-_:
15
+
Error: The following elements are mutually exclusive: sexp.omit_nil [@sexp.list]
16
+
|}]
17
+
18
+
type t = { a : int [@default 0] [@sexp.omit_nil] } [@@deriving of_sexp]
19
+
20
+
[%%expect
21
+
{|
22
+
Line _, characters _-_:
23
+
Error: The following elements are mutually exclusive: sexp.default sexp.omit_nil
24
+
|}]
25
+
26
+
type t = int [@@deriving sexp ~stackify] [@@sexp.allow_extra_fields]
27
+
28
+
[%%expect
29
+
{|
30
+
Line _, characters _-_:
31
+
Error: ppx_sexp_conv: [@@allow_extra_fields] is only allowed on records.
32
+
|}]
33
+
34
+
type 'a t = 'a option =
35
+
| None
36
+
| Some of 'a
37
+
[@@deriving sexp ~stackify] [@@sexp.allow_extra_fields]
38
+
39
+
[%%expect
40
+
{|
41
+
Line _, characters _-_:
42
+
Error: ppx_sexp_conv: [@@allow_extra_fields] is only allowed on records.
43
+
|}]
44
+
45
+
type 'a t = Some of { a : int } [@@deriving sexp ~stackify] [@@sexp.allow_extra_fields]
46
+
47
+
[%%expect
48
+
{|
49
+
Line _, characters _-_:
50
+
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]
51
+
|}]
52
+
53
+
type 'a t =
54
+
| Some of { a : int }
55
+
| None [@sexp.allow_extra_fields]
56
+
[@@deriving sexp ~stackify]
57
+
58
+
[%%expect
59
+
{|
60
+
Line _, characters _-_:
61
+
Error: ppx_sexp_conv: [@allow_extra_fields] is only allowed on inline records.
62
+
|}]
63
+
64
+
type t =
65
+
| Non
66
+
| Som of { next : t [@default Non] [@sexp_drop_default.equal] }
67
+
[@@deriving sexp ~stackify]
68
+
69
+
[%%expect
70
+
{|
71
+
Line _, characters _-_:
72
+
Error: [@sexp_drop_default.equal] was used, but the type of the field contains a type defined in the current recursive block: t.
73
+
This is not supported.
74
+
Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead.
75
+
|}]
76
+
77
+
type nonrec 'a t = { foo : 'a option [@default None] [@sexp_drop_default.equal] }
78
+
[@@deriving sexp ~stackify]
79
+
80
+
[%%expect
81
+
{|
82
+
Line _, characters _-_:
83
+
Error: [@sexp_drop_default.equal] was used, but the type of the field contains a type variable: 'a.
84
+
Comparison is not avaiable for type variables.
85
+
Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead.
86
+
|}]
87
+
88
+
open Base
89
+
90
+
type t = { a : int [@default 8] [@sexp_drop_default] } [@@deriving sexp_of ~stackify]
91
+
92
+
[%%expect
93
+
{|
94
+
Line _, characters _-_:
95
+
Error: Unsupported [@sexp_drop_default] payload; please use one of:
96
+
- [@sexp_drop_default f] and give an explicit equality function [f]
97
+
- [@sexp_drop_default.compare] if the type supports [%compare]
98
+
- [@sexp_drop_default.equal] if the type supports [%equal]
99
+
- [@sexp_drop_default.sexp] if you want to compare the sexp representations
100
+
|}]
101
+
102
+
type t = { x : unit [@sexp.opaque] } [@@deriving sexp_of ~stackify]
103
+
type t = { x : unit [@sexp.opaque] } [@@deriving of_sexp]
104
+
type t = { x : unit [@sexp.opaque] } [@@deriving sexp_grammar]
105
+
106
+
[%%expect
107
+
{|
108
+
Line _, characters _-_:
109
+
Error: Attribute `sexp.opaque' was not used.
110
+
Hint: `sexp.opaque' is available for core types but is used here in
111
+
the
112
+
context of a label declaration.
113
+
Did you put it at the wrong level?
114
+
115
+
Line _, characters _-_:
116
+
Error: Attribute `sexp.opaque' was not used.
117
+
Hint: `sexp.opaque' is available for core types but is used here in
118
+
the
119
+
context of a label declaration.
120
+
Did you put it at the wrong level?
121
+
122
+
Line _, characters _-_:
123
+
Error: Attribute `sexp.opaque' was not used.
124
+
Hint: `sexp.opaque' is available for core types but is used here in
125
+
the
126
+
context of a label declaration.
127
+
Did you put it at the wrong level?
128
+
|}]
129
+
130
+
type t = { x : unit [@sexp.option] } [@@deriving sexp_of ~stackify]
131
+
type t = { x : unit [@sexp.option] } [@@deriving of_sexp]
132
+
type t = { x : unit [@sexp.option] } [@@deriving sexp_grammar]
133
+
134
+
[%%expect
135
+
{|
136
+
Line _, characters _-_:
137
+
Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option].
138
+
139
+
Line _, characters _-_:
140
+
Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option].
141
+
142
+
Line _, characters _-_:
143
+
Error: ppx_sexp_conv: [@sexp.option] is only allowed on type [_ option].
144
+
|}]
145
+
146
+
type t = { x : unit [@sexp.or_null] } [@@deriving sexp_of ~stackify]
147
+
type t = { x : unit [@sexp.or_null] } [@@deriving of_sexp]
148
+
type t = { x : unit [@sexp.or_null] } [@@deriving sexp_grammar]
149
+
150
+
[%%expect
151
+
{|
152
+
Line _, characters _-_:
153
+
Error: ppx_sexp_conv: [@sexp.or_null] is only allowed on type [_ or_null].
154
+
155
+
Line _, characters _-_:
156
+
Error: ppx_sexp_conv: [@sexp.or_null] is only allowed on type [_ or_null].
157
+
158
+
Line _, characters _-_:
159
+
Error: ppx_sexp_conv: [@sexp.or_null] is only allowed on type [_ or_null].
160
+
|}]
161
+
162
+
type t = { x : unit [@sexp.list] } [@@deriving sexp_of ~stackify]
163
+
type t = { x : unit [@sexp.list] } [@@deriving of_sexp]
164
+
type t = { x : unit [@sexp.list] } [@@deriving sexp_grammar]
165
+
166
+
[%%expect
167
+
{|
168
+
Line _, characters _-_:
169
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
170
+
171
+
Line _, characters _-_:
172
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
173
+
174
+
Line _, characters _-_:
175
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
176
+
|}]
177
+
178
+
type t = { x : unit [@sexp.array] } [@@deriving sexp_of ~stackify]
179
+
type t = { x : unit [@sexp.array] } [@@deriving of_sexp]
180
+
type t = { x : unit [@sexp.array] } [@@deriving sexp_grammar]
181
+
182
+
[%%expect
183
+
{|
184
+
Line _, characters _-_:
185
+
Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array].
186
+
187
+
Line _, characters _-_:
188
+
Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array].
189
+
190
+
Line _, characters _-_:
191
+
Error: ppx_sexp_conv: [@sexp.array] is only allowed on type [_ array].
192
+
|}]
193
+
194
+
type t = { x : unit [@sexp.bool] } [@@deriving sexp_of ~stackify]
195
+
type t = { x : unit [@sexp.bool] } [@@deriving of_sexp]
196
+
type t = { x : unit [@sexp.bool] } [@@deriving sexp_grammar]
197
+
198
+
[%%expect
199
+
{|
200
+
Line _, characters _-_:
201
+
Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool].
202
+
203
+
Line _, characters _-_:
204
+
Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool].
205
+
206
+
Line _, characters _-_:
207
+
Error: ppx_sexp_conv: [@sexp.bool] is only allowed on type [bool].
208
+
|}]
209
+
210
+
type t = A of unit [@sexp.list] [@@deriving sexp_of ~stackify]
211
+
type t = A of unit [@sexp.list] [@@deriving of_sexp]
212
+
type t = A of unit [@sexp.list] [@@deriving sexp_grammar]
213
+
214
+
[%%expect
215
+
{|
216
+
Line _, characters _-_:
217
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
218
+
219
+
Line _, characters _-_:
220
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
221
+
222
+
Line _, characters _-_:
223
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
224
+
|}]
225
+
226
+
type t = [ `A of unit [@sexp.list] ] [@@deriving sexp_of ~stackify]
227
+
type t = [ `A of unit [@sexp.list] ] [@@deriving of_sexp]
228
+
type t = [ `A of unit [@sexp.list] ] [@@deriving sexp_grammar]
229
+
230
+
[%%expect
231
+
{|
232
+
Line _, characters _-_:
233
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
234
+
235
+
Line _, characters _-_:
236
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
237
+
238
+
Line _, characters _-_:
239
+
Error: ppx_sexp_conv: [@sexp.list] is only allowed on type [_ list].
240
+
|}]
241
+
242
+
let (_ : _) = [%sexp_grammar: 'k -> 'v -> ('k * 'v) list]
243
+
244
+
[%%expect {| |}]
245
+
246
+
let (_ : _) = [%sexp_grammar: < for_all : 'k 'v. ('k * 'v) list > ]
247
+
248
+
[%%expect
249
+
{|
250
+
Line _, characters _-_:
251
+
Error: sexp_grammar: object types are unsupported
252
+
|}]
253
+
254
+
let (_ : _) = [%sexp_grammar: < other : 'k 'v. ('k * 'v) list > ]
255
+
256
+
[%%expect
257
+
{|
258
+
Line _, characters _-_:
259
+
Error: sexp_grammar: object types are unsupported
260
+
|}]
261
+
262
+
type t = < for_all : 'k 'v. ('k * 'v) list > [@@deriving sexp_grammar]
263
+
264
+
[%%expect
265
+
{|
266
+
Line _, characters _-_:
267
+
Error: sexp_grammar: object types are unsupported
268
+
|}]
269
+
270
+
type t = < other : 'k 'v. ('k * 'v) list > [@@deriving sexp_grammar]
271
+
272
+
[%%expect
273
+
{|
274
+
Line _, characters _-_:
275
+
Error: sexp_grammar: object types are unsupported
276
+
|}]
277
+
278
+
type t = T : 'a -> t [@@deriving sexp_grammar]
279
+
280
+
[%%expect
281
+
{|
282
+
Line _, characters _-_:
283
+
Error: Unbound value _'a_sexp_grammar
284
+
Hint: Did you mean char_sexp_grammar, int_sexp_grammar or ref_sexp_grammar?
285
+
|}]
286
+
287
+
(* If we can sensibly derive [sexp_grammar], we might as well, because the user might
288
+
still be able to pair it with a consistent hand-written [t_of_sexp]. *)
289
+
type _ t = T : int -> string t [@@deriving sexp_grammar]
290
+
291
+
[%%expect {| |}]
292
+
293
+
type _ t = T : int -> string t [@@deriving of_sexp]
294
+
295
+
[%%expect
296
+
{|
297
+
Line _, characters _-_:
298
+
Error: This expression has type string t
299
+
but an expression was expected of type a__110_ t
300
+
Type string is not compatible with type a__110_
301
+
|}]
302
+
303
+
type t = exn [@@deriving sexp_of ~stackify]
304
+
305
+
[%%expect
306
+
{|
307
+
Line _, characters _-_:
308
+
Error: Unbound value sexp_of_exn__stack
309
+
Hint: Did you mean sexp_of_int__stack or sexp_of_ref__stack?
310
+
|}]
311
+
312
+
let [%sexp_of: M.t] = ()
313
+
314
+
[%%expect
315
+
{|
316
+
Line _, characters _-_:
317
+
Error: Invalid identifier M.t for converter in pattern position. Only simple
318
+
identifiers (like t or string) or applications of functors with simple
319
+
identifiers (like M(K).t) are supported.
320
+
|}]
321
+
322
+
let [%sexp_of: 'a M.t] = ()
323
+
324
+
[%%expect
325
+
{|
326
+
Line _, characters _-_:
327
+
Error: Invalid identifier M.t for converter in pattern position. Only simple
328
+
identifiers (like t or string) or applications of functors with simple
329
+
identifiers (like M(K).t) are supported.
330
+
|}]
331
+
332
+
let [%sexp_of: M.F(N).t] = ()
333
+
334
+
[%%expect
335
+
{|
336
+
Line _, characters _-_:
337
+
Error: Invalid identifier M.F(N).t for converter in pattern position. Only
338
+
simple identifiers (like t or string) or applications of functors with
339
+
simple identifiers (like M(K).t) are supported.
340
+
|}]
341
+
342
+
let [%sexp_grammar: M.F(N).t] = ()
343
+
344
+
[%%expect
345
+
{|
346
+
Line _, characters _-_:
347
+
Error: Invalid identifier M.F(N).t for converter in pattern position. Only
348
+
simple identifiers (like t or string) or applications of functors with
349
+
simple identifiers (like M(K).t) are supported.
350
+
|}]
351
+
352
+
let [%sexp_grammar: _] = ()
353
+
354
+
[%%expect
355
+
{|
356
+
Line _, characters _-_:
357
+
Error: Only type variables and constructors are allowed here (e.g. ['a], [t],
358
+
['a t], or [M(X).t]).
359
+
|}]
360
+
361
+
(* Passing ~portable to sexp can give you better error messages in
362
+
structure context.
363
+
*)
364
+
365
+
module Non_portable : sig
366
+
type t [@@deriving sexp]
367
+
end @ nonportable =
368
+
Int
369
+
370
+
type t =
371
+
{ non_portable : Non_portable.t
372
+
; other : int
373
+
}
374
+
[@@deriving sexp ~portable]
375
+
376
+
[%%expect
377
+
{|
378
+
Line _, characters _-_:
379
+
Error: The value Non_portable.t_of_sexp is nonportable
380
+
but is expected to be portable because it is used inside a function
381
+
which is expected to be portable.
382
+
|}]
+201
vendor/opam/ppx_sexp_conv/test/examples.mlt
+201
vendor/opam/ppx_sexp_conv/test/examples.mlt
···
1
+
module Position_for_polymorphic_variant_errors = struct
2
+
type t1 = [ `A ] [@@deriving of_sexp]
3
+
type t2 = [ `B ] [@@deriving of_sexp]
4
+
type t3 = A of [ t1 | t2 ] [@@deriving of_sexp]
5
+
6
+
let (_ : t3) = t3_of_sexp (List [ Atom "A"; Atom "C" ])
7
+
end
8
+
9
+
[%%expect
10
+
{|
11
+
Exception:
12
+
(Of_sexp_error
13
+
"examples.mlt.Position_for_polymorphic_variant_errors.t3_of_sexp: no matching variant found"
14
+
(invalid_sexp C))
15
+
|}]
16
+
17
+
let _ = [%sexp_of: 'a]
18
+
19
+
[%%expect
20
+
{|
21
+
Line _, characters _-_:
22
+
Error: ppx_sexp_conv: unbound type variable 'a
23
+
|}]
24
+
25
+
let _ = [%sexp_of_stack: 'a]
26
+
27
+
[%%expect
28
+
{|
29
+
Line _, characters _-_:
30
+
Error: ppx_sexp_conv: unbound type variable 'a
31
+
|}]
32
+
33
+
let _ = [%of_sexp: 'a]
34
+
35
+
[%%expect
36
+
{|
37
+
Line _, characters _-_:
38
+
Error: ppx_sexp_conv: unbound type variable 'a
39
+
|}]
40
+
41
+
module type S = sig
42
+
val x : [%sexp_of: 'a]
43
+
end
44
+
45
+
[%%expect {| |}]
46
+
47
+
module type S = sig
48
+
val x : [%sexp_of_stack: 'a]
49
+
end
50
+
51
+
[%%expect {| |}]
52
+
53
+
let _ = [%sexp (() : 'a)]
54
+
55
+
[%%expect
56
+
{|
57
+
Line _, characters _-_:
58
+
Error: ppx_sexp_conv: unbound type variable 'a
59
+
|}]
60
+
61
+
type 'a t =
62
+
| None
63
+
| Something_else of { value : 'a }
64
+
[@@deriving sexp ~stackify]
65
+
66
+
[%%expect {| |}]
67
+
68
+
module Record_with_defaults = struct
69
+
open Sexplib0.Sexp_conv
70
+
71
+
let a_field = "a_field"
72
+
let b_field = "b_field"
73
+
74
+
type record_with_defaults =
75
+
{ a : string [@default a_field]
76
+
; b : string [@default b_field]
77
+
}
78
+
[@@deriving of_sexp]
79
+
end
80
+
81
+
[%%expect {| |}]
82
+
83
+
module Polymorphic_recursion = struct
84
+
type 'a t = T of 'a t t [@@deriving sexp_grammar]
85
+
end
86
+
87
+
[%%expect {| |}]
88
+
89
+
module type Sexpable = sig
90
+
type t [@@deriving sexp, sexp_grammar]
91
+
end
92
+
93
+
module Define_sexp_converters_manually : sig
94
+
type t [@@deriving sexp, sexp_grammar]
95
+
96
+
module Functor (M : Sexpable) : Sexpable with type t = t
97
+
module T : Sexpable with type t = t
98
+
99
+
type with_functor = { x : Functor(T).t } [@@deriving sexp, sexp_grammar]
100
+
101
+
module Parameterized : sig
102
+
type 'a t [@@deriving sexp, sexp_grammar]
103
+
end
104
+
end = struct
105
+
open Base
106
+
107
+
type t = unit
108
+
109
+
let [%sexp_of: t] = [%sexp_of: unit]
110
+
let [%of_sexp: t] = [%of_sexp: unit]
111
+
let [%sexp_grammar: t] = [%sexp_grammar: unit]
112
+
113
+
module T = struct
114
+
type nonrec t = t
115
+
116
+
let [%sexp_of: t] = [%sexp_of: t]
117
+
let [%of_sexp: t] = [%of_sexp: t]
118
+
let [%sexp_grammar: t] = [%sexp_grammar: t]
119
+
end
120
+
121
+
module Functor (M : Sexpable) = struct
122
+
module _ = M
123
+
124
+
type nonrec t = t [@@deriving sexp, sexp_grammar]
125
+
end
126
+
127
+
(* the raison d'etre *)
128
+
let [%sexp_of: Functor(T).t] = fun (module M : Sexpable) -> [%sexp_of: t]
129
+
let [%of_sexp: Functor(T).t] = fun (module M : Sexpable) -> [%of_sexp: t]
130
+
let [%sexp_grammar: Functor(T).t] = fun (module M : Sexpable) -> [%sexp_grammar: t]
131
+
132
+
type with_functor = { x : Functor(T).t } [@@deriving sexp, sexp_grammar]
133
+
134
+
module Parameterized = struct
135
+
type 'a t = 'a * 'a
136
+
137
+
let [%sexp_of: a t] = fun [%sexp_of: a] -> [%sexp_of: a * a]
138
+
let [%of_sexp: a t] = fun [%of_sexp: a] -> [%of_sexp: a * a]
139
+
let [%sexp_grammar: 'a t] = fun [%sexp_grammar: 'a] -> [%sexp_grammar: 'a * 'a]
140
+
end
141
+
end
142
+
143
+
[%%expect {| |}]
144
+
145
+
(* Banning this is fine because it's also banned in expression position. *)
146
+
let [%sexp_of: 'a] = ()
147
+
148
+
[%%expect
149
+
{|
150
+
Line _, characters _-_:
151
+
Error: Type variables are disallowed here. Instead, consider using a locally
152
+
abstract type.
153
+
|}]
154
+
155
+
(* Banning this is fine because it's also banned in expression position. *)
156
+
let [%of_sexp: 'a] = ()
157
+
158
+
[%%expect
159
+
{|
160
+
Line _, characters _-_:
161
+
Error: Type variables are disallowed here. Instead, consider using a locally
162
+
abstract type.
163
+
|}]
164
+
165
+
let [%sexp_of: _] = ()
166
+
167
+
[%%expect
168
+
{|
169
+
Line _, characters _-_:
170
+
Error: Only type constructors are allowed here (e.g. [t], ['a t], or
171
+
[M(X).t]).
172
+
|}]
173
+
174
+
let [%of_sexp: _] = ()
175
+
176
+
[%%expect
177
+
{|
178
+
Line _, characters _-_:
179
+
Error: Only type constructors are allowed here (e.g. [t], ['a t], or
180
+
[M(X).t]).
181
+
|}]
182
+
183
+
let [%sexp_of: M.N(X).t] = ()
184
+
185
+
[%%expect
186
+
{|
187
+
Line _, characters _-_:
188
+
Error: Invalid identifier M.N(X).t for converter in pattern position. Only
189
+
simple identifiers (like t or string) or applications of functors with
190
+
simple identifiers (like M(K).t) are supported.
191
+
|}]
192
+
193
+
let [%of_sexp: M.N(X).t] = ()
194
+
195
+
[%%expect
196
+
{|
197
+
Line _, characters _-_:
198
+
Error: Invalid identifier M.N(X).t for converter in pattern position. Only
199
+
simple identifiers (like t or string) or applications of functors with
200
+
simple identifiers (like M(K).t) are supported.
201
+
|}]
+64
vendor/opam/ppx_sexp_conv/test/examples_gadt_indexes.mlt
+64
vendor/opam/ppx_sexp_conv/test/examples_gadt_indexes.mlt
···
1
+
open Base
2
+
3
+
(* This test documents the behavior of [@@deriving sexp_of] on GADTs with type indexes. *)
4
+
5
+
(* These GADTs are handled by ppx_sexp_conv, where the ['a] is implicitly opaqueified: *)
6
+
7
+
module Silently_opaqueified = struct
8
+
type t1 = X1 : 'a -> t1 [@@deriving sexp_of]
9
+
type _ t2 = X2 : 'a -> 'b t2 [@@deriving sexp_of]
10
+
11
+
let t1 = sexp_of_t1 (X1 1)
12
+
let t2 = sexp_of_t2 [%sexp_of: int] (X2 2)
13
+
let () = Stdio.print_s t1
14
+
let () = Stdio.print_s t2
15
+
end
16
+
17
+
[%%expect
18
+
{|
19
+
(X1 _)
20
+
(X2 _)
21
+
|}]
22
+
23
+
(* This GADT is handled by ppx_sexp_conv, where [sexp_of_a] is passed in by the caller:
24
+
*)
25
+
26
+
module Not_opaque = struct
27
+
type _ t3 = X3 : 'a -> 'a t3 [@@deriving sexp_of]
28
+
29
+
let t3 = sexp_of_t3 [%sexp_of: int] (X3 3)
30
+
let () = Stdio.print_s t3
31
+
end
32
+
33
+
[%%expect
34
+
{|
35
+
(X3 3)
36
+
|}]
37
+
38
+
(* This GADT is **NOT** handleable by ppx_sexp_conv without opaqueifying the constructor:
39
+
the type variable ['a] that appears in the constructor argument ['a] is not a simple
40
+
index of the "return type" ['a list t4] (instead, ['a list] is the index): *)
41
+
42
+
module Error_if_not_opaqueified = struct
43
+
type _ t4 = X4 : 'a -> 'a list t4 [@@deriving sexp_of]
44
+
end
45
+
46
+
[%%expect
47
+
{|
48
+
Line _, characters _-_:
49
+
Error: ppx_sexp_conv: variable is not a parameter of the type constructor. Hint: mark all appearances of 'a in the constructor's arguments as [@sexp.opaque].
50
+
|}]
51
+
52
+
(* The error message encourages users to opt in to the explicitly-opaqueified version: *)
53
+
54
+
module Explicitly_opaqueified = struct
55
+
type _ t5 = X5 : ('a[@sexp.opaque]) -> 'a list t5 [@@deriving sexp_of]
56
+
57
+
let t5 = sexp_of_t5 [%sexp_of: int list] (X5 5)
58
+
let () = Stdio.print_s t5
59
+
end
60
+
61
+
[%%expect
62
+
{|
63
+
(X5 <opaque>)
64
+
|}]
+2140
vendor/opam/ppx_sexp_conv/test/expansion.ml
+2140
vendor/opam/ppx_sexp_conv/test/expansion.ml
···
1
+
open! Base
2
+
3
+
[@@@disable_unused_warnings]
4
+
5
+
open struct
6
+
type _shadow_constructors =
7
+
| []
8
+
| ( :: )
9
+
| None
10
+
| Some
11
+
end
12
+
13
+
module%template Abstract = struct
14
+
type t [@@deriving_inline sexp [@alloc stack]]
15
+
16
+
let _ = fun (_ : t) -> ()
17
+
18
+
let t_of_sexp =
19
+
(let error_source__002_ = "expansion.ml.Abstract.t" in
20
+
fun x__003_ -> Sexplib0.Sexp_conv_error.empty_type error_source__002_ x__003_
21
+
: Sexplib0.Sexp.t -> t)
22
+
;;
23
+
24
+
let _ = t_of_sexp
25
+
let sexp_of_t = (fun _ -> assert false : t -> Sexplib0.Sexp.t)
26
+
let _ = sexp_of_t
27
+
let sexp_of_t__stack = (fun _ -> assert false : t -> Sexplib0.Sexp.t)
28
+
let _ = sexp_of_t__stack
29
+
30
+
[@@@end]
31
+
end
32
+
33
+
module Tuple = struct
34
+
type t = int * int * int [@@deriving_inline sexp ~stackify]
35
+
36
+
let _ = fun (_ : t) -> ()
37
+
38
+
let t_of_sexp =
39
+
(let error_source__012_ = "expansion.ml.Tuple.t" in
40
+
function
41
+
| Sexplib0.Sexp.List [ arg0__005_; arg1__006_; arg2__007_ ] ->
42
+
let res0__008_ = int_of_sexp arg0__005_
43
+
and res1__009_ = int_of_sexp arg1__006_
44
+
and res2__010_ = int_of_sexp arg2__007_ in
45
+
res0__008_, res1__009_, res2__010_
46
+
| sexp__011_ ->
47
+
Sexplib0.Sexp_conv_error.tuple_of_size_n_expected error_source__012_ 3 sexp__011_
48
+
: Sexplib0.Sexp.t -> t)
49
+
;;
50
+
51
+
let _ = t_of_sexp
52
+
53
+
let sexp_of_t =
54
+
(fun (arg0__013_, arg1__014_, arg2__015_) ->
55
+
let res0__016_ = sexp_of_int arg0__013_
56
+
and res1__017_ = sexp_of_int arg1__014_
57
+
and res2__018_ = sexp_of_int arg2__015_ in
58
+
Sexplib0.Sexp.List [ res0__016_; res1__017_; res2__018_ ]
59
+
: t -> Sexplib0.Sexp.t)
60
+
;;
61
+
62
+
let _ = sexp_of_t
63
+
64
+
let sexp_of_t__stack =
65
+
(fun (arg0__019_, arg1__020_, arg2__021_) ->
66
+
let res0__022_ = sexp_of_int__stack arg0__019_
67
+
and res1__023_ = sexp_of_int__stack arg1__020_
68
+
and res2__024_ = sexp_of_int__stack arg2__021_ in
69
+
Sexplib0.Sexp.List [ res0__022_; res1__023_; res2__024_ ]
70
+
: t -> Sexplib0.Sexp.t)
71
+
;;
72
+
73
+
let _ = sexp_of_t__stack
74
+
75
+
[@@@end]
76
+
end
77
+
78
+
module Record = struct
79
+
type t =
80
+
{ a : int
81
+
; b : int
82
+
; c : int
83
+
}
84
+
[@@deriving_inline sexp ~stackify]
85
+
86
+
let _ = fun (_ : t) -> ()
87
+
88
+
let t_of_sexp =
89
+
(let error_source__026_ = "expansion.ml.Record.t" in
90
+
fun x__033_ ->
91
+
Sexplib0.Sexp_conv_record.record_of_sexp
92
+
~caller:error_source__026_
93
+
~fields:
94
+
(Field
95
+
{ name = "a"
96
+
; kind = Required
97
+
; conv =
98
+
(fun x__031_ ->
99
+
let _x__032_ = int_of_sexp x__031_ in
100
+
fun () -> _x__032_)
101
+
; rest =
102
+
Field
103
+
{ name = "b"
104
+
; kind = Required
105
+
; conv =
106
+
(fun x__029_ ->
107
+
let _x__030_ = int_of_sexp x__029_ in
108
+
fun () -> _x__030_)
109
+
; rest =
110
+
Field
111
+
{ name = "c"
112
+
; kind = Required
113
+
; conv =
114
+
(fun x__027_ ->
115
+
let _x__028_ = int_of_sexp x__027_ in
116
+
fun () -> _x__028_)
117
+
; rest = Empty
118
+
}
119
+
}
120
+
})
121
+
~index_of_field:(function
122
+
| "a" -> 0
123
+
| "b" -> 1
124
+
| "c" -> 2
125
+
| _ -> -1)
126
+
~allow_extra_fields:false
127
+
~create:(fun (a, (b, (c, ()))) : t ->
128
+
let a = a () in
129
+
let b = b () in
130
+
let c = c () in
131
+
{ a; b; c })
132
+
x__033_
133
+
: Sexplib0.Sexp.t -> t)
134
+
;;
135
+
136
+
let _ = t_of_sexp
137
+
138
+
let sexp_of_t =
139
+
(fun { a = a__035_; b = b__037_; c = c__039_ } ->
140
+
let bnds__034_ = ([] : _ Stdlib.List.t) in
141
+
let bnds__034_ =
142
+
let arg__040_ = sexp_of_int c__039_ in
143
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__040_ ] :: bnds__034_
144
+
: _ Stdlib.List.t)
145
+
in
146
+
let bnds__034_ =
147
+
let arg__038_ = sexp_of_int b__037_ in
148
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__038_ ] :: bnds__034_
149
+
: _ Stdlib.List.t)
150
+
in
151
+
let bnds__034_ =
152
+
let arg__036_ = sexp_of_int a__035_ in
153
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__036_ ] :: bnds__034_
154
+
: _ Stdlib.List.t)
155
+
in
156
+
Sexplib0.Sexp.List bnds__034_
157
+
: t -> Sexplib0.Sexp.t)
158
+
;;
159
+
160
+
let _ = sexp_of_t
161
+
162
+
let sexp_of_t__stack =
163
+
(fun { a = a__042_; b = b__044_; c = c__046_ } ->
164
+
let bnds__041_ = ([] : _ Stdlib.List.t) in
165
+
let bnds__041_ =
166
+
let arg__047_ = sexp_of_int__stack c__046_ in
167
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__047_ ] :: bnds__041_
168
+
: _ Stdlib.List.t)
169
+
in
170
+
let bnds__041_ =
171
+
let arg__045_ = sexp_of_int__stack b__044_ in
172
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__045_ ] :: bnds__041_
173
+
: _ Stdlib.List.t)
174
+
in
175
+
let bnds__041_ =
176
+
let arg__043_ = sexp_of_int__stack a__042_ in
177
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__043_ ] :: bnds__041_
178
+
: _ Stdlib.List.t)
179
+
in
180
+
Sexplib0.Sexp.List bnds__041_
181
+
: t -> Sexplib0.Sexp.t)
182
+
;;
183
+
184
+
let _ = sexp_of_t__stack
185
+
186
+
[@@@end]
187
+
end
188
+
189
+
module Mutable_record = struct
190
+
type t =
191
+
{ mutable a : int
192
+
; mutable b : int
193
+
; mutable c : int
194
+
}
195
+
[@@deriving_inline sexp ~stackify]
196
+
197
+
let _ = fun (_ : t) -> ()
198
+
199
+
let t_of_sexp =
200
+
(let error_source__049_ = "expansion.ml.Mutable_record.t" in
201
+
fun x__056_ ->
202
+
Sexplib0.Sexp_conv_record.record_of_sexp
203
+
~caller:error_source__049_
204
+
~fields:
205
+
(Field
206
+
{ name = "a"
207
+
; kind = Required
208
+
; conv =
209
+
(fun x__054_ ->
210
+
let _x__055_ = int_of_sexp x__054_ in
211
+
fun () -> _x__055_)
212
+
; rest =
213
+
Field
214
+
{ name = "b"
215
+
; kind = Required
216
+
; conv =
217
+
(fun x__052_ ->
218
+
let _x__053_ = int_of_sexp x__052_ in
219
+
fun () -> _x__053_)
220
+
; rest =
221
+
Field
222
+
{ name = "c"
223
+
; kind = Required
224
+
; conv =
225
+
(fun x__050_ ->
226
+
let _x__051_ = int_of_sexp x__050_ in
227
+
fun () -> _x__051_)
228
+
; rest = Empty
229
+
}
230
+
}
231
+
})
232
+
~index_of_field:(function
233
+
| "a" -> 0
234
+
| "b" -> 1
235
+
| "c" -> 2
236
+
| _ -> -1)
237
+
~allow_extra_fields:false
238
+
~create:(fun (a, (b, (c, ()))) : t ->
239
+
let a = a () in
240
+
let b = b () in
241
+
let c = c () in
242
+
{ a; b; c })
243
+
x__056_
244
+
: Sexplib0.Sexp.t -> t)
245
+
;;
246
+
247
+
let _ = t_of_sexp
248
+
249
+
let sexp_of_t =
250
+
(fun { a = a__058_; b = b__060_; c = c__062_ } ->
251
+
let bnds__057_ = ([] : _ Stdlib.List.t) in
252
+
let bnds__057_ =
253
+
let arg__063_ = sexp_of_int c__062_ in
254
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__063_ ] :: bnds__057_
255
+
: _ Stdlib.List.t)
256
+
in
257
+
let bnds__057_ =
258
+
let arg__061_ = sexp_of_int b__060_ in
259
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__061_ ] :: bnds__057_
260
+
: _ Stdlib.List.t)
261
+
in
262
+
let bnds__057_ =
263
+
let arg__059_ = sexp_of_int a__058_ in
264
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__059_ ] :: bnds__057_
265
+
: _ Stdlib.List.t)
266
+
in
267
+
Sexplib0.Sexp.List bnds__057_
268
+
: t -> Sexplib0.Sexp.t)
269
+
;;
270
+
271
+
let _ = sexp_of_t
272
+
273
+
let sexp_of_t__stack =
274
+
(fun { a = a__065_; b = b__067_; c = c__069_ } ->
275
+
let bnds__064_ = ([] : _ Stdlib.List.t) in
276
+
let bnds__064_ =
277
+
let arg__070_ = sexp_of_int__stack c__069_ in
278
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__070_ ] :: bnds__064_
279
+
: _ Stdlib.List.t)
280
+
in
281
+
let bnds__064_ =
282
+
let arg__068_ = sexp_of_int__stack b__067_ in
283
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__068_ ] :: bnds__064_
284
+
: _ Stdlib.List.t)
285
+
in
286
+
let bnds__064_ =
287
+
let arg__066_ = sexp_of_int__stack a__065_ in
288
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__066_ ] :: bnds__064_
289
+
: _ Stdlib.List.t)
290
+
in
291
+
Sexplib0.Sexp.List bnds__064_
292
+
: t -> Sexplib0.Sexp.t)
293
+
;;
294
+
295
+
let _ = sexp_of_t__stack
296
+
297
+
[@@@end]
298
+
end
299
+
300
+
module Variant = struct
301
+
type t =
302
+
| A
303
+
| B of int * int
304
+
| C of
305
+
{ a : int
306
+
; b : int
307
+
; d : int
308
+
}
309
+
| D of
310
+
{ mutable a : int
311
+
; mutable b : int
312
+
; mutable t : int
313
+
}
314
+
[@@deriving_inline sexp ~stackify]
315
+
316
+
let _ = fun (_ : t) -> ()
317
+
318
+
let t_of_sexp =
319
+
(let error_source__073_ = "expansion.ml.Variant.t" in
320
+
function
321
+
| Sexplib0.Sexp.Atom ("a" | "A") -> A
322
+
| Sexplib0.Sexp.List
323
+
(Sexplib0.Sexp.Atom (("b" | "B") as _tag__076_) :: sexp_args__077_) as
324
+
_sexp__075_ ->
325
+
(match sexp_args__077_ with
326
+
| [ arg0__078_; arg1__079_ ] ->
327
+
let res0__080_ = int_of_sexp arg0__078_
328
+
and res1__081_ = int_of_sexp arg1__079_ in
329
+
B (res0__080_, res1__081_)
330
+
| _ ->
331
+
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
332
+
error_source__073_
333
+
_tag__076_
334
+
_sexp__075_)
335
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("c" | "C") :: sexps__089_) as sexp__088_ ->
336
+
Sexplib0.Sexp_conv_record.record_of_sexps
337
+
~context:sexp__088_
338
+
~caller:error_source__073_
339
+
~fields:
340
+
(Field
341
+
{ name = "a"
342
+
; kind = Required
343
+
; conv =
344
+
(fun x__086_ ->
345
+
let _x__087_ = int_of_sexp x__086_ in
346
+
fun () -> _x__087_)
347
+
; rest =
348
+
Field
349
+
{ name = "b"
350
+
; kind = Required
351
+
; conv =
352
+
(fun x__084_ ->
353
+
let _x__085_ = int_of_sexp x__084_ in
354
+
fun () -> _x__085_)
355
+
; rest =
356
+
Field
357
+
{ name = "d"
358
+
; kind = Required
359
+
; conv =
360
+
(fun x__082_ ->
361
+
let _x__083_ = int_of_sexp x__082_ in
362
+
fun () -> _x__083_)
363
+
; rest = Empty
364
+
}
365
+
}
366
+
})
367
+
~index_of_field:(function
368
+
| "a" -> 0
369
+
| "b" -> 1
370
+
| "d" -> 2
371
+
| _ -> -1)
372
+
~allow_extra_fields:false
373
+
~create:(fun (a, (b, (d, ()))) : t ->
374
+
let a = a () in
375
+
let b = b () in
376
+
let d = d () in
377
+
C { a; b; d })
378
+
sexps__089_
379
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("d" | "D") :: sexps__097_) as sexp__096_ ->
380
+
Sexplib0.Sexp_conv_record.record_of_sexps
381
+
~context:sexp__096_
382
+
~caller:error_source__073_
383
+
~fields:
384
+
(Field
385
+
{ name = "a"
386
+
; kind = Required
387
+
; conv =
388
+
(fun x__094_ ->
389
+
let _x__095_ = int_of_sexp x__094_ in
390
+
fun () -> _x__095_)
391
+
; rest =
392
+
Field
393
+
{ name = "b"
394
+
; kind = Required
395
+
; conv =
396
+
(fun x__092_ ->
397
+
let _x__093_ = int_of_sexp x__092_ in
398
+
fun () -> _x__093_)
399
+
; rest =
400
+
Field
401
+
{ name = "t"
402
+
; kind = Required
403
+
; conv =
404
+
(fun x__090_ ->
405
+
let _x__091_ = int_of_sexp x__090_ in
406
+
fun () -> _x__091_)
407
+
; rest = Empty
408
+
}
409
+
}
410
+
})
411
+
~index_of_field:(function
412
+
| "a" -> 0
413
+
| "b" -> 1
414
+
| "t" -> 2
415
+
| _ -> -1)
416
+
~allow_extra_fields:false
417
+
~create:(fun (a, (b, (t, ()))) : t ->
418
+
let a = a () in
419
+
let b = b () in
420
+
let t = t () in
421
+
D { a; b; t })
422
+
sexps__097_
423
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("a" | "A") :: _) as sexp__074_ ->
424
+
Sexplib0.Sexp_conv_error.stag_no_args error_source__073_ sexp__074_
425
+
| Sexplib0.Sexp.Atom ("b" | "B" | "c" | "C" | "d" | "D") as sexp__074_ ->
426
+
Sexplib0.Sexp_conv_error.stag_takes_args error_source__073_ sexp__074_
427
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__072_ ->
428
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__073_ sexp__072_
429
+
| Sexplib0.Sexp.List [] as sexp__072_ ->
430
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__073_ sexp__072_
431
+
| sexp__072_ ->
432
+
Sexplib0.Sexp_conv_error.unexpected_stag
433
+
error_source__073_
434
+
[ "A"; "B"; "C"; "D" ]
435
+
sexp__072_
436
+
: Sexplib0.Sexp.t -> t)
437
+
;;
438
+
439
+
let _ = t_of_sexp
440
+
441
+
let sexp_of_t =
442
+
(function
443
+
| A -> Sexplib0.Sexp.Atom "A"
444
+
| B (arg0__098_, arg1__099_) ->
445
+
let res0__100_ = sexp_of_int arg0__098_
446
+
and res1__101_ = sexp_of_int arg1__099_ in
447
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__100_; res1__101_ ]
448
+
| C { a = a__103_; b = b__105_; d = d__107_ } ->
449
+
let bnds__102_ = ([] : _ Stdlib.List.t) in
450
+
let bnds__102_ =
451
+
let arg__108_ = sexp_of_int d__107_ in
452
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__108_ ] :: bnds__102_
453
+
: _ Stdlib.List.t)
454
+
in
455
+
let bnds__102_ =
456
+
let arg__106_ = sexp_of_int b__105_ in
457
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__106_ ] :: bnds__102_
458
+
: _ Stdlib.List.t)
459
+
in
460
+
let bnds__102_ =
461
+
let arg__104_ = sexp_of_int a__103_ in
462
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__104_ ] :: bnds__102_
463
+
: _ Stdlib.List.t)
464
+
in
465
+
Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "C" :: bnds__102_)
466
+
| D { a = a__110_; b = b__112_; t = t__114_ } ->
467
+
let bnds__109_ = ([] : _ Stdlib.List.t) in
468
+
let bnds__109_ =
469
+
let arg__115_ = sexp_of_int t__114_ in
470
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "t"; arg__115_ ] :: bnds__109_
471
+
: _ Stdlib.List.t)
472
+
in
473
+
let bnds__109_ =
474
+
let arg__113_ = sexp_of_int b__112_ in
475
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__113_ ] :: bnds__109_
476
+
: _ Stdlib.List.t)
477
+
in
478
+
let bnds__109_ =
479
+
let arg__111_ = sexp_of_int a__110_ in
480
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__111_ ] :: bnds__109_
481
+
: _ Stdlib.List.t)
482
+
in
483
+
Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "D" :: bnds__109_)
484
+
: t -> Sexplib0.Sexp.t)
485
+
;;
486
+
487
+
let _ = sexp_of_t
488
+
489
+
let sexp_of_t__stack =
490
+
(function
491
+
| A -> Sexplib0.Sexp.Atom "A"
492
+
| B (arg0__116_, arg1__117_) ->
493
+
let res0__118_ = sexp_of_int__stack arg0__116_
494
+
and res1__119_ = sexp_of_int__stack arg1__117_ in
495
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__118_; res1__119_ ]
496
+
| C { a = a__121_; b = b__123_; d = d__125_ } ->
497
+
let bnds__120_ = ([] : _ Stdlib.List.t) in
498
+
let bnds__120_ =
499
+
let arg__126_ = sexp_of_int__stack d__125_ in
500
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__126_ ] :: bnds__120_
501
+
: _ Stdlib.List.t)
502
+
in
503
+
let bnds__120_ =
504
+
let arg__124_ = sexp_of_int__stack b__123_ in
505
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__124_ ] :: bnds__120_
506
+
: _ Stdlib.List.t)
507
+
in
508
+
let bnds__120_ =
509
+
let arg__122_ = sexp_of_int__stack a__121_ in
510
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__122_ ] :: bnds__120_
511
+
: _ Stdlib.List.t)
512
+
in
513
+
Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "C" :: bnds__120_)
514
+
| D { a = a__128_; b = b__130_; t = t__132_ } ->
515
+
let bnds__127_ = ([] : _ Stdlib.List.t) in
516
+
let bnds__127_ =
517
+
let arg__133_ = sexp_of_int__stack t__132_ in
518
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "t"; arg__133_ ] :: bnds__127_
519
+
: _ Stdlib.List.t)
520
+
in
521
+
let bnds__127_ =
522
+
let arg__131_ = sexp_of_int__stack b__130_ in
523
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__131_ ] :: bnds__127_
524
+
: _ Stdlib.List.t)
525
+
in
526
+
let bnds__127_ =
527
+
let arg__129_ = sexp_of_int__stack a__128_ in
528
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__129_ ] :: bnds__127_
529
+
: _ Stdlib.List.t)
530
+
in
531
+
Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "D" :: bnds__127_)
532
+
: t -> Sexplib0.Sexp.t)
533
+
;;
534
+
535
+
let _ = sexp_of_t__stack
536
+
537
+
[@@@end]
538
+
end
539
+
540
+
module Poly_variant = struct
541
+
type t =
542
+
[ `A
543
+
| `B of int
544
+
]
545
+
[@@deriving_inline sexp ~stackify]
546
+
547
+
let _ = fun (_ : t) -> ()
548
+
549
+
let __t_of_sexp__ =
550
+
(let error_source__139_ = "expansion.ml.Poly_variant.t" in
551
+
function
552
+
| Sexplib0.Sexp.Atom atom__135_ as _sexp__137_ ->
553
+
(match atom__135_ with
554
+
| "A" -> `A
555
+
| "B" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__139_ _sexp__137_
556
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
557
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__135_ :: sexp_args__138_) as
558
+
_sexp__137_ ->
559
+
(match atom__135_ with
560
+
| "B" as _tag__140_ ->
561
+
(match sexp_args__138_ with
562
+
| arg0__141_ :: [] ->
563
+
let res0__142_ = int_of_sexp arg0__141_ in
564
+
`B res0__142_
565
+
| _ ->
566
+
Sexplib0.Sexp_conv_error.ptag_incorrect_n_args
567
+
error_source__139_
568
+
_tag__140_
569
+
_sexp__137_)
570
+
| "A" -> Sexplib0.Sexp_conv_error.ptag_no_args error_source__139_ _sexp__137_
571
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
572
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__136_ ->
573
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__139_ sexp__136_
574
+
| Sexplib0.Sexp.List [] as sexp__136_ ->
575
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__139_ sexp__136_
576
+
: Sexplib0.Sexp.t -> t)
577
+
;;
578
+
579
+
let _ = __t_of_sexp__
580
+
581
+
let t_of_sexp =
582
+
(let error_source__144_ = "expansion.ml.Poly_variant.t" in
583
+
fun sexp__143_ ->
584
+
try __t_of_sexp__ sexp__143_ with
585
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
586
+
Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__144_ sexp__143_
587
+
: Sexplib0.Sexp.t -> t)
588
+
;;
589
+
590
+
let _ = t_of_sexp
591
+
592
+
let sexp_of_t =
593
+
(function
594
+
| `A -> Sexplib0.Sexp.Atom "A"
595
+
| `B v__145_ -> Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; sexp_of_int v__145_ ]
596
+
: t -> Sexplib0.Sexp.t)
597
+
;;
598
+
599
+
let _ = sexp_of_t
600
+
601
+
let sexp_of_t__stack =
602
+
(function
603
+
| `A -> Sexplib0.Sexp.Atom "A"
604
+
| `B v__146_ ->
605
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; sexp_of_int__stack v__146_ ]
606
+
: t -> Sexplib0.Sexp.t)
607
+
;;
608
+
609
+
let _ = sexp_of_t__stack
610
+
611
+
[@@@end]
612
+
end
613
+
614
+
module Inline_poly_variant = struct
615
+
type t =
616
+
[ Poly_variant.t
617
+
| `C of int * int
618
+
]
619
+
[@@deriving_inline sexp]
620
+
621
+
let _ = fun (_ : t) -> ()
622
+
623
+
let __t_of_sexp__ =
624
+
(let error_source__158_ = "expansion.ml.Inline_poly_variant.t" in
625
+
fun sexp__147_ ->
626
+
try (Poly_variant.__t_of_sexp__ sexp__147_ :> t) with
627
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
628
+
(match sexp__147_ with
629
+
| Sexplib0.Sexp.Atom atom__148_ as _sexp__150_ ->
630
+
(match atom__148_ with
631
+
| "C" ->
632
+
Sexplib0.Sexp_conv_error.ptag_takes_args error_source__158_ _sexp__150_
633
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
634
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__148_ :: sexp_args__151_) as
635
+
_sexp__150_ ->
636
+
(match atom__148_ with
637
+
| "C" as _tag__152_ ->
638
+
(match sexp_args__151_ with
639
+
| arg0__159_ :: [] ->
640
+
let res0__160_ =
641
+
match arg0__159_ with
642
+
| Sexplib0.Sexp.List [ arg0__153_; arg1__154_ ] ->
643
+
let res0__155_ = int_of_sexp arg0__153_
644
+
and res1__156_ = int_of_sexp arg1__154_ in
645
+
res0__155_, res1__156_
646
+
| sexp__157_ ->
647
+
Sexplib0.Sexp_conv_error.tuple_of_size_n_expected
648
+
error_source__158_
649
+
2
650
+
sexp__157_
651
+
in
652
+
`C res0__160_
653
+
| _ ->
654
+
Sexplib0.Sexp_conv_error.ptag_incorrect_n_args
655
+
error_source__158_
656
+
_tag__152_
657
+
_sexp__150_)
658
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
659
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__149_ ->
660
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var
661
+
error_source__158_
662
+
sexp__149_
663
+
| Sexplib0.Sexp.List [] as sexp__149_ ->
664
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var
665
+
error_source__158_
666
+
sexp__149_)
667
+
: Sexplib0.Sexp.t -> t)
668
+
;;
669
+
670
+
let _ = __t_of_sexp__
671
+
672
+
let t_of_sexp =
673
+
(let error_source__162_ = "expansion.ml.Inline_poly_variant.t" in
674
+
fun sexp__161_ ->
675
+
try __t_of_sexp__ sexp__161_ with
676
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
677
+
Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__162_ sexp__161_
678
+
: Sexplib0.Sexp.t -> t)
679
+
;;
680
+
681
+
let _ = t_of_sexp
682
+
683
+
let sexp_of_t =
684
+
(function
685
+
| #Poly_variant.t as v__163_ -> Poly_variant.sexp_of_t v__163_
686
+
| `C v__164_ ->
687
+
Sexplib0.Sexp.List
688
+
[ Sexplib0.Sexp.Atom "C"
689
+
; (let arg0__165_, arg1__166_ = v__164_ in
690
+
let res0__167_ = sexp_of_int arg0__165_
691
+
and res1__168_ = sexp_of_int arg1__166_ in
692
+
Sexplib0.Sexp.List [ res0__167_; res1__168_ ])
693
+
]
694
+
: t -> Sexplib0.Sexp.t)
695
+
;;
696
+
697
+
let _ = sexp_of_t
698
+
699
+
[@@@end]
700
+
end
701
+
702
+
module Recursive = struct
703
+
type t =
704
+
| Banana of t
705
+
| Orange
706
+
[@@deriving_inline sexp]
707
+
708
+
let _ = fun (_ : t) -> ()
709
+
710
+
let rec t_of_sexp =
711
+
(let error_source__171_ = "expansion.ml.Recursive.t" in
712
+
function
713
+
| Sexplib0.Sexp.List
714
+
(Sexplib0.Sexp.Atom (("banana" | "Banana") as _tag__174_) :: sexp_args__175_) as
715
+
_sexp__173_ ->
716
+
(match sexp_args__175_ with
717
+
| arg0__176_ :: [] ->
718
+
let res0__177_ = t_of_sexp arg0__176_ in
719
+
Banana res0__177_
720
+
| _ ->
721
+
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
722
+
error_source__171_
723
+
_tag__174_
724
+
_sexp__173_)
725
+
| Sexplib0.Sexp.Atom ("orange" | "Orange") -> Orange
726
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("orange" | "Orange") :: _) as sexp__172_ ->
727
+
Sexplib0.Sexp_conv_error.stag_no_args error_source__171_ sexp__172_
728
+
| Sexplib0.Sexp.Atom ("banana" | "Banana") as sexp__172_ ->
729
+
Sexplib0.Sexp_conv_error.stag_takes_args error_source__171_ sexp__172_
730
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__170_ ->
731
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__171_ sexp__170_
732
+
| Sexplib0.Sexp.List [] as sexp__170_ ->
733
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__171_ sexp__170_
734
+
| sexp__170_ ->
735
+
Sexplib0.Sexp_conv_error.unexpected_stag
736
+
error_source__171_
737
+
[ "Banana"; "Orange" ]
738
+
sexp__170_
739
+
: Sexplib0.Sexp.t -> t)
740
+
;;
741
+
742
+
let _ = t_of_sexp
743
+
744
+
let rec sexp_of_t =
745
+
(function
746
+
| Banana arg0__178_ ->
747
+
let res0__179_ = sexp_of_t arg0__178_ in
748
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Banana"; res0__179_ ]
749
+
| Orange -> Sexplib0.Sexp.Atom "Orange"
750
+
: t -> Sexplib0.Sexp.t)
751
+
;;
752
+
753
+
let _ = sexp_of_t
754
+
755
+
[@@@end]
756
+
end
757
+
758
+
module Nonrecursive = struct
759
+
open Recursive
760
+
761
+
type nonrec t = t [@@deriving_inline sexp]
762
+
763
+
let _ = fun (_ : t) -> ()
764
+
let t_of_sexp = (t_of_sexp : Sexplib0.Sexp.t -> t)
765
+
let _ = t_of_sexp
766
+
let sexp_of_t = (sexp_of_t : t -> Sexplib0.Sexp.t)
767
+
let _ = sexp_of_t
768
+
769
+
[@@@end]
770
+
end
771
+
772
+
module Mutually_recursive = struct
773
+
type a =
774
+
| A
775
+
| B of b
776
+
| C of
777
+
{ a : a
778
+
; b : b
779
+
; c : c
780
+
}
781
+
782
+
and b =
783
+
{ a : a
784
+
; b : b
785
+
}
786
+
787
+
and c = a [@@deriving_inline sexp]
788
+
789
+
let _ = fun (_ : a) -> ()
790
+
let _ = fun (_ : b) -> ()
791
+
let _ = fun (_ : c) -> ()
792
+
793
+
let rec a_of_sexp =
794
+
(let error_source__183_ = "expansion.ml.Mutually_recursive.a" in
795
+
function
796
+
| Sexplib0.Sexp.Atom ("a" | "A") -> A
797
+
| Sexplib0.Sexp.List
798
+
(Sexplib0.Sexp.Atom (("b" | "B") as _tag__186_) :: sexp_args__187_) as
799
+
_sexp__185_ ->
800
+
(match sexp_args__187_ with
801
+
| arg0__188_ :: [] ->
802
+
let res0__189_ = b_of_sexp arg0__188_ in
803
+
B res0__189_
804
+
| _ ->
805
+
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
806
+
error_source__183_
807
+
_tag__186_
808
+
_sexp__185_)
809
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("c" | "C") :: sexps__197_) as sexp__196_ ->
810
+
Sexplib0.Sexp_conv_record.record_of_sexps
811
+
~context:sexp__196_
812
+
~caller:error_source__183_
813
+
~fields:
814
+
(Field
815
+
{ name = "a"
816
+
; kind = Required
817
+
; conv =
818
+
(fun x__194_ ->
819
+
let _x__195_ = a_of_sexp x__194_ in
820
+
fun () -> _x__195_)
821
+
; rest =
822
+
Field
823
+
{ name = "b"
824
+
; kind = Required
825
+
; conv =
826
+
(fun x__192_ ->
827
+
let _x__193_ = b_of_sexp x__192_ in
828
+
fun () -> _x__193_)
829
+
; rest =
830
+
Field
831
+
{ name = "c"
832
+
; kind = Required
833
+
; conv =
834
+
(fun x__190_ ->
835
+
let _x__191_ = c_of_sexp x__190_ in
836
+
fun () -> _x__191_)
837
+
; rest = Empty
838
+
}
839
+
}
840
+
})
841
+
~index_of_field:(function
842
+
| "a" -> 0
843
+
| "b" -> 1
844
+
| "c" -> 2
845
+
| _ -> -1)
846
+
~allow_extra_fields:false
847
+
~create:(fun (a, (b, (c, ()))) : a ->
848
+
let a = a () in
849
+
let b = b () in
850
+
let c = c () in
851
+
C { a; b; c })
852
+
sexps__197_
853
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("a" | "A") :: _) as sexp__184_ ->
854
+
Sexplib0.Sexp_conv_error.stag_no_args error_source__183_ sexp__184_
855
+
| Sexplib0.Sexp.Atom ("b" | "B" | "c" | "C") as sexp__184_ ->
856
+
Sexplib0.Sexp_conv_error.stag_takes_args error_source__183_ sexp__184_
857
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__182_ ->
858
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__183_ sexp__182_
859
+
| Sexplib0.Sexp.List [] as sexp__182_ ->
860
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__183_ sexp__182_
861
+
| sexp__182_ ->
862
+
Sexplib0.Sexp_conv_error.unexpected_stag
863
+
error_source__183_
864
+
[ "A"; "B"; "C" ]
865
+
sexp__182_
866
+
: Sexplib0.Sexp.t -> a)
867
+
868
+
and b_of_sexp =
869
+
(let error_source__199_ = "expansion.ml.Mutually_recursive.b" in
870
+
fun x__204_ ->
871
+
Sexplib0.Sexp_conv_record.record_of_sexp
872
+
~caller:error_source__199_
873
+
~fields:
874
+
(Field
875
+
{ name = "a"
876
+
; kind = Required
877
+
; conv =
878
+
(fun x__202_ ->
879
+
let _x__203_ = a_of_sexp x__202_ in
880
+
fun () -> _x__203_)
881
+
; rest =
882
+
Field
883
+
{ name = "b"
884
+
; kind = Required
885
+
; conv =
886
+
(fun x__200_ ->
887
+
let _x__201_ = b_of_sexp x__200_ in
888
+
fun () -> _x__201_)
889
+
; rest = Empty
890
+
}
891
+
})
892
+
~index_of_field:(function
893
+
| "a" -> 0
894
+
| "b" -> 1
895
+
| _ -> -1)
896
+
~allow_extra_fields:false
897
+
~create:(fun (a, (b, ())) : b ->
898
+
let a = a () in
899
+
let b = b () in
900
+
{ a; b })
901
+
x__204_
902
+
: Sexplib0.Sexp.t -> b)
903
+
904
+
and c_of_sexp = (fun x__206_ -> a_of_sexp x__206_ : Sexplib0.Sexp.t -> c)
905
+
906
+
let _ = a_of_sexp
907
+
and _ = b_of_sexp
908
+
and _ = c_of_sexp
909
+
910
+
let rec sexp_of_a =
911
+
(function
912
+
| A -> Sexplib0.Sexp.Atom "A"
913
+
| B arg0__207_ ->
914
+
let res0__208_ = sexp_of_b arg0__207_ in
915
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__208_ ]
916
+
| C { a = a__210_; b = b__212_; c = c__214_ } ->
917
+
let bnds__209_ = ([] : _ Stdlib.List.t) in
918
+
let bnds__209_ =
919
+
let arg__215_ = sexp_of_c c__214_ in
920
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__215_ ] :: bnds__209_
921
+
: _ Stdlib.List.t)
922
+
in
923
+
let bnds__209_ =
924
+
let arg__213_ = sexp_of_b b__212_ in
925
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__213_ ] :: bnds__209_
926
+
: _ Stdlib.List.t)
927
+
in
928
+
let bnds__209_ =
929
+
let arg__211_ = sexp_of_a a__210_ in
930
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__211_ ] :: bnds__209_
931
+
: _ Stdlib.List.t)
932
+
in
933
+
Sexplib0.Sexp.List (Sexplib0.Sexp.Atom "C" :: bnds__209_)
934
+
: a -> Sexplib0.Sexp.t)
935
+
936
+
and sexp_of_b =
937
+
(fun { a = a__217_; b = b__219_ } ->
938
+
let bnds__216_ = ([] : _ Stdlib.List.t) in
939
+
let bnds__216_ =
940
+
let arg__220_ = sexp_of_b b__219_ in
941
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__220_ ] :: bnds__216_
942
+
: _ Stdlib.List.t)
943
+
in
944
+
let bnds__216_ =
945
+
let arg__218_ = sexp_of_a a__217_ in
946
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__218_ ] :: bnds__216_
947
+
: _ Stdlib.List.t)
948
+
in
949
+
Sexplib0.Sexp.List bnds__216_
950
+
: b -> Sexplib0.Sexp.t)
951
+
952
+
and sexp_of_c = (fun x__221_ -> sexp_of_a x__221_ : c -> Sexplib0.Sexp.t)
953
+
954
+
let _ = sexp_of_a
955
+
and _ = sexp_of_b
956
+
and _ = sexp_of_c
957
+
958
+
[@@@end]
959
+
end
960
+
961
+
module Alias = struct
962
+
type t = Recursive.t [@@deriving_inline sexp]
963
+
964
+
let _ = fun (_ : t) -> ()
965
+
let t_of_sexp = (Recursive.t_of_sexp : Sexplib0.Sexp.t -> t)
966
+
let _ = t_of_sexp
967
+
let sexp_of_t = (Recursive.sexp_of_t : t -> Sexplib0.Sexp.t)
968
+
let _ = sexp_of_t
969
+
970
+
[@@@end]
971
+
end
972
+
973
+
module Re_export = struct
974
+
type t = Recursive.t =
975
+
| Banana of t
976
+
| Orange
977
+
[@@deriving_inline sexp]
978
+
979
+
let _ = fun (_ : t) -> ()
980
+
981
+
let rec t_of_sexp =
982
+
(let error_source__225_ = "expansion.ml.Re_export.t" in
983
+
function
984
+
| Sexplib0.Sexp.List
985
+
(Sexplib0.Sexp.Atom (("banana" | "Banana") as _tag__228_) :: sexp_args__229_) as
986
+
_sexp__227_ ->
987
+
(match sexp_args__229_ with
988
+
| arg0__230_ :: [] ->
989
+
let res0__231_ = t_of_sexp arg0__230_ in
990
+
Banana res0__231_
991
+
| _ ->
992
+
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
993
+
error_source__225_
994
+
_tag__228_
995
+
_sexp__227_)
996
+
| Sexplib0.Sexp.Atom ("orange" | "Orange") -> Orange
997
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom ("orange" | "Orange") :: _) as sexp__226_ ->
998
+
Sexplib0.Sexp_conv_error.stag_no_args error_source__225_ sexp__226_
999
+
| Sexplib0.Sexp.Atom ("banana" | "Banana") as sexp__226_ ->
1000
+
Sexplib0.Sexp_conv_error.stag_takes_args error_source__225_ sexp__226_
1001
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__224_ ->
1002
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__225_ sexp__224_
1003
+
| Sexplib0.Sexp.List [] as sexp__224_ ->
1004
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__225_ sexp__224_
1005
+
| sexp__224_ ->
1006
+
Sexplib0.Sexp_conv_error.unexpected_stag
1007
+
error_source__225_
1008
+
[ "Banana"; "Orange" ]
1009
+
sexp__224_
1010
+
: Sexplib0.Sexp.t -> t)
1011
+
;;
1012
+
1013
+
let _ = t_of_sexp
1014
+
1015
+
let rec sexp_of_t =
1016
+
(function
1017
+
| Banana arg0__232_ ->
1018
+
let res0__233_ = sexp_of_t arg0__232_ in
1019
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Banana"; res0__233_ ]
1020
+
| Orange -> Sexplib0.Sexp.Atom "Orange"
1021
+
: t -> Sexplib0.Sexp.t)
1022
+
;;
1023
+
1024
+
let _ = sexp_of_t
1025
+
1026
+
[@@@end]
1027
+
end
1028
+
1029
+
module Unary = struct
1030
+
type 'a t = 'a list option [@@deriving_inline sexp]
1031
+
1032
+
let _ = fun (_ : 'a t) -> ()
1033
+
1034
+
let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t =
1035
+
fun _of_a__234_ x__236_ -> option_of_sexp (list_of_sexp _of_a__234_) x__236_
1036
+
;;
1037
+
1038
+
let _ = t_of_sexp
1039
+
1040
+
let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t =
1041
+
fun _of_a__237_ x__238_ -> sexp_of_option (sexp_of_list _of_a__237_) x__238_
1042
+
;;
1043
+
1044
+
let _ = sexp_of_t
1045
+
1046
+
[@@@end]
1047
+
end
1048
+
1049
+
module Binary = struct
1050
+
type ('a, 'b) t = ('a, 'b) Either.t [@@deriving_inline sexp]
1051
+
1052
+
let _ = fun (_ : ('a, 'b) t) -> ()
1053
+
1054
+
let t_of_sexp
1055
+
: 'a 'b.
1056
+
(Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t
1057
+
=
1058
+
Either.t_of_sexp
1059
+
;;
1060
+
1061
+
let _ = t_of_sexp
1062
+
1063
+
let sexp_of_t
1064
+
: 'a 'b.
1065
+
('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t
1066
+
=
1067
+
Either.sexp_of_t
1068
+
;;
1069
+
1070
+
let _ = sexp_of_t
1071
+
1072
+
[@@@end]
1073
+
end
1074
+
1075
+
module First_order = struct
1076
+
type 'a t = 'a -> 'a [@@deriving_inline sexp]
1077
+
1078
+
let _ = fun (_ : 'a t) -> ()
1079
+
1080
+
let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t =
1081
+
fun _of_a__246_ -> Sexplib0.Sexp_conv.fun_of_sexp
1082
+
;;
1083
+
1084
+
let _ = t_of_sexp
1085
+
1086
+
let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t =
1087
+
fun _of_a__248_ _ -> Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore
1088
+
;;
1089
+
1090
+
let _ = sexp_of_t
1091
+
1092
+
[@@@end]
1093
+
end
1094
+
1095
+
module Second_order = struct
1096
+
type ('a, 'b) t = ('a -> 'a) -> ('a -> 'b) -> ('b -> 'b) -> 'a -> 'b
1097
+
[@@deriving_inline sexp]
1098
+
1099
+
let _ = fun (_ : ('a, 'b) t) -> ()
1100
+
1101
+
let t_of_sexp
1102
+
: 'a 'b.
1103
+
(Sexplib0.Sexp.t -> 'a) -> (Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> ('a, 'b) t
1104
+
=
1105
+
fun _of_a__249_ _of_b__250_ -> Sexplib0.Sexp_conv.fun_of_sexp
1106
+
;;
1107
+
1108
+
let _ = t_of_sexp
1109
+
1110
+
let sexp_of_t
1111
+
: 'a 'b.
1112
+
('a -> Sexplib0.Sexp.t) -> ('b -> Sexplib0.Sexp.t) -> ('a, 'b) t -> Sexplib0.Sexp.t
1113
+
=
1114
+
fun _of_a__252_ _of_b__253_ _ ->
1115
+
Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore
1116
+
;;
1117
+
1118
+
let _ = sexp_of_t
1119
+
1120
+
[@@@end]
1121
+
end
1122
+
1123
+
module Named_arguments = struct
1124
+
type t = ?a:int -> b:int -> int -> int [@@deriving_inline sexp]
1125
+
1126
+
let _ = fun (_ : t) -> ()
1127
+
let t_of_sexp = (Sexplib0.Sexp_conv.fun_of_sexp : Sexplib0.Sexp.t -> t)
1128
+
let _ = t_of_sexp
1129
+
1130
+
let sexp_of_t =
1131
+
(fun _ -> Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore
1132
+
: t -> Sexplib0.Sexp.t)
1133
+
;;
1134
+
1135
+
let _ = sexp_of_t
1136
+
1137
+
[@@@end]
1138
+
end
1139
+
1140
+
module Gadt = struct
1141
+
type _ t =
1142
+
| A : _ option t
1143
+
| B : int -> int t
1144
+
| C : 'a list -> unit t
1145
+
[@@deriving_inline sexp_of]
1146
+
1147
+
let _ = fun (_ : _ t) -> ()
1148
+
1149
+
let sexp_of_t : 'a__255_. ('a__255_ -> Sexplib0.Sexp.t) -> 'a__255_ t -> Sexplib0.Sexp.t
1150
+
=
1151
+
fun (type a__261_) : ((a__261_ -> Sexplib0.Sexp.t) -> a__261_ t -> Sexplib0.Sexp.t) ->
1152
+
fun _of_a__256_ -> function
1153
+
| A -> Sexplib0.Sexp.Atom "A"
1154
+
| B arg0__257_ ->
1155
+
let res0__258_ = sexp_of_int arg0__257_ in
1156
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "B"; res0__258_ ]
1157
+
| C arg0__259_ ->
1158
+
let res0__260_ = sexp_of_list (fun _ -> Sexplib0.Sexp.Atom "_") arg0__259_ in
1159
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "C"; res0__260_ ]
1160
+
;;
1161
+
1162
+
let _ = sexp_of_t
1163
+
1164
+
[@@@end]
1165
+
end
1166
+
1167
+
module Recursive_record_containing_variant = struct
1168
+
type t =
1169
+
{ a : [ `A of t ]
1170
+
; b : [ `B ] [@sexp_drop_default Poly.equal] [@default `B]
1171
+
}
1172
+
[@@deriving_inline sexp]
1173
+
1174
+
let _ = fun (_ : t) -> ()
1175
+
1176
+
let rec t_of_sexp =
1177
+
(let default__264_ : [ `B ] = `B in
1178
+
let error_source__263_ = "expansion.ml.Recursive_record_containing_variant.t" in
1179
+
fun x__284_ ->
1180
+
Sexplib0.Sexp_conv_record.record_of_sexp
1181
+
~caller:error_source__263_
1182
+
~fields:
1183
+
(Field
1184
+
{ name = "a"
1185
+
; kind = Required
1186
+
; conv =
1187
+
(fun x__282_ ->
1188
+
let _x__283_ =
1189
+
(fun sexp__281_ ->
1190
+
try
1191
+
match sexp__281_ with
1192
+
| Sexplib0.Sexp.Atom atom__274_ as _sexp__276_ ->
1193
+
(match atom__274_ with
1194
+
| "A" ->
1195
+
Sexplib0.Sexp_conv_error.ptag_takes_args
1196
+
error_source__263_
1197
+
_sexp__276_
1198
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1199
+
| Sexplib0.Sexp.List
1200
+
(Sexplib0.Sexp.Atom atom__274_ :: sexp_args__277_) as
1201
+
_sexp__276_ ->
1202
+
(match atom__274_ with
1203
+
| "A" as _tag__278_ ->
1204
+
(match sexp_args__277_ with
1205
+
| arg0__279_ :: [] ->
1206
+
let res0__280_ = t_of_sexp arg0__279_ in
1207
+
`A res0__280_
1208
+
| _ ->
1209
+
Sexplib0.Sexp_conv_error.ptag_incorrect_n_args
1210
+
error_source__263_
1211
+
_tag__278_
1212
+
_sexp__276_)
1213
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1214
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__275_
1215
+
->
1216
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var
1217
+
error_source__263_
1218
+
sexp__275_
1219
+
| Sexplib0.Sexp.List [] as sexp__275_ ->
1220
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var
1221
+
error_source__263_
1222
+
sexp__275_
1223
+
with
1224
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
1225
+
Sexplib0.Sexp_conv_error.no_matching_variant_found
1226
+
error_source__263_
1227
+
sexp__281_)
1228
+
x__282_
1229
+
in
1230
+
fun () -> _x__283_)
1231
+
; rest =
1232
+
Field
1233
+
{ name = "b"
1234
+
; kind = Default (fun () -> default__264_)
1235
+
; conv =
1236
+
(fun x__271_ ->
1237
+
let _x__272_ =
1238
+
(fun sexp__270_ ->
1239
+
try
1240
+
match sexp__270_ with
1241
+
| Sexplib0.Sexp.Atom atom__266_ as _sexp__268_ ->
1242
+
(match atom__266_ with
1243
+
| "B" -> `B
1244
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1245
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__266_ :: _)
1246
+
as _sexp__268_ ->
1247
+
(match atom__266_ with
1248
+
| "B" ->
1249
+
Sexplib0.Sexp_conv_error.ptag_no_args
1250
+
error_source__263_
1251
+
_sexp__268_
1252
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1253
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as
1254
+
sexp__267_ ->
1255
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var
1256
+
error_source__263_
1257
+
sexp__267_
1258
+
| Sexplib0.Sexp.List [] as sexp__267_ ->
1259
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var
1260
+
error_source__263_
1261
+
sexp__267_
1262
+
with
1263
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
1264
+
Sexplib0.Sexp_conv_error.no_matching_variant_found
1265
+
error_source__263_
1266
+
sexp__270_)
1267
+
x__271_
1268
+
in
1269
+
fun () -> _x__272_)
1270
+
; rest = Empty
1271
+
}
1272
+
})
1273
+
~index_of_field:(function
1274
+
| "a" -> 0
1275
+
| "b" -> 1
1276
+
| _ -> -1)
1277
+
~allow_extra_fields:false
1278
+
~create:(fun (a, (b, ())) : t ->
1279
+
let a = a () in
1280
+
let b = b () in
1281
+
{ a; b })
1282
+
x__284_
1283
+
: Sexplib0.Sexp.t -> t)
1284
+
;;
1285
+
1286
+
let _ = t_of_sexp
1287
+
1288
+
let rec sexp_of_t =
1289
+
(let default__291_ : [ `B ] = `B
1290
+
and drop_default__290_ : [ `B ] -> [ `B ] -> Stdlib.Bool.t = Poly.equal in
1291
+
fun { a = a__286_; b = b__292_ } ->
1292
+
let bnds__285_ = ([] : _ Stdlib.List.t) in
1293
+
let bnds__285_ =
1294
+
if drop_default__290_ default__291_ b__292_
1295
+
then bnds__285_
1296
+
else (
1297
+
let arg__294_ = (fun `B -> Sexplib0.Sexp.Atom "B") b__292_ in
1298
+
let bnd__293_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__294_ ] in
1299
+
(bnd__293_ :: bnds__285_ : _ Stdlib.List.t))
1300
+
in
1301
+
let bnds__285_ =
1302
+
let arg__287_ =
1303
+
let (`A v__288_) = a__286_ in
1304
+
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "A"; sexp_of_t v__288_ ]
1305
+
in
1306
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__287_ ] :: bnds__285_
1307
+
: _ Stdlib.List.t)
1308
+
in
1309
+
Sexplib0.Sexp.List bnds__285_
1310
+
: t -> Sexplib0.Sexp.t)
1311
+
;;
1312
+
1313
+
let _ = sexp_of_t
1314
+
1315
+
[@@@end]
1316
+
end
1317
+
1318
+
module Poly_record = struct
1319
+
type t =
1320
+
{ a : 'a. 'a list
1321
+
; b : 'b. 'b option
1322
+
; c : 'c. 'c
1323
+
}
1324
+
[@@deriving_inline sexp]
1325
+
1326
+
let _ = fun (_ : t) -> ()
1327
+
1328
+
let t_of_sexp =
1329
+
(let error_source__296_ = "expansion.ml.Poly_record.t" in
1330
+
fun x__309_ ->
1331
+
let open struct
1332
+
type a__297_ = { a__297_ : 'a. 'a list } [@@unboxed]
1333
+
type b__298_ = { b__298_ : 'b. 'b option } [@@unboxed]
1334
+
type c__299_ = { c__299_ : 'c. 'c } [@@unboxed]
1335
+
end in
1336
+
Sexplib0.Sexp_conv_record.record_of_sexp
1337
+
~caller:error_source__296_
1338
+
~fields:
1339
+
(Field
1340
+
{ name = "a"
1341
+
; kind = Required
1342
+
; conv =
1343
+
(fun sexp__306_ ->
1344
+
let _x__308_ =
1345
+
{ a__297_ =
1346
+
(let _a__307_ =
1347
+
Sexplib0.Sexp_conv_error.record_poly_field_value
1348
+
error_source__296_
1349
+
in
1350
+
list_of_sexp _a__307_ sexp__306_)
1351
+
}
1352
+
in
1353
+
fun () -> _x__308_)
1354
+
; rest =
1355
+
Field
1356
+
{ name = "b"
1357
+
; kind = Required
1358
+
; conv =
1359
+
(fun sexp__303_ ->
1360
+
let _x__305_ =
1361
+
{ b__298_ =
1362
+
(let _b__304_ =
1363
+
Sexplib0.Sexp_conv_error.record_poly_field_value
1364
+
error_source__296_
1365
+
in
1366
+
option_of_sexp _b__304_ sexp__303_)
1367
+
}
1368
+
in
1369
+
fun () -> _x__305_)
1370
+
; rest =
1371
+
Field
1372
+
{ name = "c"
1373
+
; kind = Required
1374
+
; conv =
1375
+
(fun sexp__300_ ->
1376
+
let _x__302_ =
1377
+
{ c__299_ =
1378
+
(let _c__301_ =
1379
+
Sexplib0.Sexp_conv_error.record_poly_field_value
1380
+
error_source__296_
1381
+
in
1382
+
_c__301_ sexp__300_)
1383
+
}
1384
+
in
1385
+
fun () -> _x__302_)
1386
+
; rest = Empty
1387
+
}
1388
+
}
1389
+
})
1390
+
~index_of_field:(function
1391
+
| "a" -> 0
1392
+
| "b" -> 1
1393
+
| "c" -> 2
1394
+
| _ -> -1)
1395
+
~allow_extra_fields:false
1396
+
~create:(fun (a, (b, (c, ()))) : t ->
1397
+
let { a__297_ = a } = a () in
1398
+
let { b__298_ = b } = b () in
1399
+
let { c__299_ = c } = c () in
1400
+
{ a; b; c })
1401
+
x__309_
1402
+
: Sexplib0.Sexp.t -> t)
1403
+
;;
1404
+
1405
+
let _ = t_of_sexp
1406
+
1407
+
let sexp_of_t =
1408
+
(fun { a = a__311_; b = b__314_; c = c__317_ } ->
1409
+
let bnds__310_ = ([] : _ Stdlib.List.t) in
1410
+
let bnds__310_ =
1411
+
let arg__318_ =
1412
+
let _of_c__319_ = (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _) in
1413
+
_of_c__319_ c__317_
1414
+
in
1415
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__318_ ] :: bnds__310_
1416
+
: _ Stdlib.List.t)
1417
+
in
1418
+
let bnds__310_ =
1419
+
let arg__315_ =
1420
+
let _of_b__316_ = (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _) in
1421
+
sexp_of_option _of_b__316_ b__314_
1422
+
in
1423
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__315_ ] :: bnds__310_
1424
+
: _ Stdlib.List.t)
1425
+
in
1426
+
let bnds__310_ =
1427
+
let arg__312_ =
1428
+
let _of_a__313_ = (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _) in
1429
+
sexp_of_list _of_a__313_ a__311_
1430
+
in
1431
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__312_ ] :: bnds__310_
1432
+
: _ Stdlib.List.t)
1433
+
in
1434
+
Sexplib0.Sexp.List bnds__310_
1435
+
: t -> Sexplib0.Sexp.t)
1436
+
;;
1437
+
1438
+
let _ = sexp_of_t
1439
+
1440
+
[@@@end]
1441
+
end
1442
+
1443
+
module Record_with_defaults = struct
1444
+
type t =
1445
+
{ a : int [@default 0]
1446
+
; b : int [@default 0] [@sexp_drop_default.compare]
1447
+
; c : int [@default 0] [@sexp_drop_default.equal]
1448
+
; d : int [@default 0] [@sexp_drop_default.sexp]
1449
+
; e : int [@default 0] [@sexp_drop_default ( = )]
1450
+
; f : int [@sexp_drop_if ( = ) 0]
1451
+
}
1452
+
[@@deriving_inline sexp]
1453
+
1454
+
let _ = fun (_ : t) -> ()
1455
+
1456
+
let t_of_sexp =
1457
+
(let default__326_ : int = 0
1458
+
and default__325_ : int = 0
1459
+
and default__324_ : int = 0
1460
+
and default__323_ : int = 0
1461
+
and default__322_ : int = 0 in
1462
+
let error_source__321_ = "expansion.ml.Record_with_defaults.t" in
1463
+
fun x__339_ ->
1464
+
Sexplib0.Sexp_conv_record.record_of_sexp
1465
+
~caller:error_source__321_
1466
+
~fields:
1467
+
(Field
1468
+
{ name = "a"
1469
+
; kind = Default (fun () -> default__322_)
1470
+
; conv =
1471
+
(fun x__337_ ->
1472
+
let _x__338_ = int_of_sexp x__337_ in
1473
+
fun () -> _x__338_)
1474
+
; rest =
1475
+
Field
1476
+
{ name = "b"
1477
+
; kind = Default (fun () -> default__323_)
1478
+
; conv =
1479
+
(fun x__335_ ->
1480
+
let _x__336_ = int_of_sexp x__335_ in
1481
+
fun () -> _x__336_)
1482
+
; rest =
1483
+
Field
1484
+
{ name = "c"
1485
+
; kind = Default (fun () -> default__324_)
1486
+
; conv =
1487
+
(fun x__333_ ->
1488
+
let _x__334_ = int_of_sexp x__333_ in
1489
+
fun () -> _x__334_)
1490
+
; rest =
1491
+
Field
1492
+
{ name = "d"
1493
+
; kind = Default (fun () -> default__325_)
1494
+
; conv =
1495
+
(fun x__331_ ->
1496
+
let _x__332_ = int_of_sexp x__331_ in
1497
+
fun () -> _x__332_)
1498
+
; rest =
1499
+
Field
1500
+
{ name = "e"
1501
+
; kind = Default (fun () -> default__326_)
1502
+
; conv =
1503
+
(fun x__329_ ->
1504
+
let _x__330_ = int_of_sexp x__329_ in
1505
+
fun () -> _x__330_)
1506
+
; rest =
1507
+
Field
1508
+
{ name = "f"
1509
+
; kind = Required
1510
+
; conv =
1511
+
(fun x__327_ ->
1512
+
let _x__328_ = int_of_sexp x__327_ in
1513
+
fun () -> _x__328_)
1514
+
; rest = Empty
1515
+
}
1516
+
}
1517
+
}
1518
+
}
1519
+
}
1520
+
})
1521
+
~index_of_field:(function
1522
+
| "a" -> 0
1523
+
| "b" -> 1
1524
+
| "c" -> 2
1525
+
| "d" -> 3
1526
+
| "e" -> 4
1527
+
| "f" -> 5
1528
+
| _ -> -1)
1529
+
~allow_extra_fields:false
1530
+
~create:(fun (a, (b, (c, (d, (e, (f, ())))))) : t ->
1531
+
let a = a () in
1532
+
let b = b () in
1533
+
let c = c () in
1534
+
let d = d () in
1535
+
let e = e () in
1536
+
let f = f () in
1537
+
{ a; b; c; d; e; f })
1538
+
x__339_
1539
+
: Sexplib0.Sexp.t -> t)
1540
+
;;
1541
+
1542
+
let _ = t_of_sexp
1543
+
1544
+
let sexp_of_t =
1545
+
(let default__344_ : int = 0
1546
+
and default__349_ : int = 0
1547
+
and default__354_ : int = 0
1548
+
and default__360_ : int = 0
1549
+
and drop_default__359_ : int -> int -> Stdlib.Bool.t = ( = )
1550
+
and drop_if__365_ : Stdlib.Unit.t -> int -> Stdlib.Bool.t = fun () -> ( = ) 0 in
1551
+
fun { a = a__341_; b = b__345_; c = c__350_; d = d__355_; e = e__361_; f = f__366_ } ->
1552
+
let bnds__340_ = ([] : _ Stdlib.List.t) in
1553
+
let bnds__340_ =
1554
+
if (drop_if__365_ ()) f__366_
1555
+
then bnds__340_
1556
+
else (
1557
+
let arg__368_ = sexp_of_int f__366_ in
1558
+
let bnd__367_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "f"; arg__368_ ] in
1559
+
(bnd__367_ :: bnds__340_ : _ Stdlib.List.t))
1560
+
in
1561
+
let bnds__340_ =
1562
+
if drop_default__359_ default__360_ e__361_
1563
+
then bnds__340_
1564
+
else (
1565
+
let arg__363_ = sexp_of_int e__361_ in
1566
+
let bnd__362_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "e"; arg__363_ ] in
1567
+
(bnd__362_ :: bnds__340_ : _ Stdlib.List.t))
1568
+
in
1569
+
let bnds__340_ =
1570
+
let arg__357_ = sexp_of_int d__355_ in
1571
+
if Sexplib0.Sexp_conv.( = ) (sexp_of_int default__354_) arg__357_
1572
+
then bnds__340_
1573
+
else (
1574
+
let bnd__356_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__357_ ] in
1575
+
(bnd__356_ :: bnds__340_ : _ Stdlib.List.t))
1576
+
in
1577
+
let bnds__340_ =
1578
+
if [%equal: int] default__349_ c__350_
1579
+
then bnds__340_
1580
+
else (
1581
+
let arg__352_ = sexp_of_int c__350_ in
1582
+
let bnd__351_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__352_ ] in
1583
+
(bnd__351_ :: bnds__340_ : _ Stdlib.List.t))
1584
+
in
1585
+
let bnds__340_ =
1586
+
if [%compare.equal: int] default__344_ b__345_
1587
+
then bnds__340_
1588
+
else (
1589
+
let arg__347_ = sexp_of_int b__345_ in
1590
+
let bnd__346_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__347_ ] in
1591
+
(bnd__346_ :: bnds__340_ : _ Stdlib.List.t))
1592
+
in
1593
+
let bnds__340_ =
1594
+
let arg__342_ = sexp_of_int a__341_ in
1595
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__342_ ] :: bnds__340_
1596
+
: _ Stdlib.List.t)
1597
+
in
1598
+
Sexplib0.Sexp.List bnds__340_
1599
+
: t -> Sexplib0.Sexp.t)
1600
+
;;
1601
+
1602
+
let _ = sexp_of_t
1603
+
1604
+
[@@@end]
1605
+
end
1606
+
1607
+
module Record_with_special_types = struct
1608
+
type t =
1609
+
{ a : int option [@sexp.option]
1610
+
; b : int list [@sexp.list]
1611
+
; c : int array [@sexp.array]
1612
+
; d : bool [@sexp.bool]
1613
+
; e : int or_null [@sexp.or_null]
1614
+
}
1615
+
[@@deriving_inline sexp]
1616
+
1617
+
let _ = fun (_ : t) -> ()
1618
+
1619
+
let t_of_sexp =
1620
+
(let error_source__376_ = "expansion.ml.Record_with_special_types.t" in
1621
+
fun x__377_ ->
1622
+
Sexplib0.Sexp_conv_record.record_of_sexp
1623
+
~caller:error_source__376_
1624
+
~fields:
1625
+
(Field
1626
+
{ name = "a"
1627
+
; kind = Sexp_option
1628
+
; conv = int_of_sexp
1629
+
; rest =
1630
+
Field
1631
+
{ name = "b"
1632
+
; kind = Sexp_list
1633
+
; conv = int_of_sexp
1634
+
; rest =
1635
+
Field
1636
+
{ name = "c"
1637
+
; kind = Sexp_array
1638
+
; conv = int_of_sexp
1639
+
; rest =
1640
+
Field
1641
+
{ name = "d"
1642
+
; kind = Sexp_bool
1643
+
; conv = ()
1644
+
; rest =
1645
+
Field
1646
+
{ name = "e"
1647
+
; kind = Sexp_or_null
1648
+
; conv = int_of_sexp
1649
+
; rest = Empty
1650
+
}
1651
+
}
1652
+
}
1653
+
}
1654
+
})
1655
+
~index_of_field:(function
1656
+
| "a" -> 0
1657
+
| "b" -> 1
1658
+
| "c" -> 2
1659
+
| "d" -> 3
1660
+
| "e" -> 4
1661
+
| _ -> -1)
1662
+
~allow_extra_fields:false
1663
+
~create:(fun (a, (b, (c, (d, (e, ()))))) : t -> { a; b; c; d; e })
1664
+
x__377_
1665
+
: Sexplib0.Sexp.t -> t)
1666
+
;;
1667
+
1668
+
let _ = t_of_sexp
1669
+
1670
+
let sexp_of_t =
1671
+
(fun { a = a__379_; b = b__384_; c = c__388_; d = d__391_; e = e__393_ } ->
1672
+
let bnds__378_ = ([] : _ Stdlib.List.t) in
1673
+
let bnds__378_ =
1674
+
match e__393_ with
1675
+
| Ppx_sexp_conv_lib.Or_null.Null -> bnds__378_
1676
+
| Ppx_sexp_conv_lib.Or_null.This v__394_ ->
1677
+
let arg__396_ = sexp_of_int v__394_ in
1678
+
let bnd__395_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "e"; arg__396_ ] in
1679
+
(bnd__395_ :: bnds__378_ : _ Stdlib.List.t)
1680
+
in
1681
+
let bnds__378_ =
1682
+
if d__391_
1683
+
then (
1684
+
let bnd__392_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d" ] in
1685
+
(bnd__392_ :: bnds__378_ : _ Stdlib.List.t))
1686
+
else bnds__378_
1687
+
in
1688
+
let bnds__378_ =
1689
+
if match c__388_ with
1690
+
| [||] -> true
1691
+
| _ -> false
1692
+
then bnds__378_
1693
+
else (
1694
+
let arg__390_ = (sexp_of_array sexp_of_int) c__388_ in
1695
+
let bnd__389_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__390_ ] in
1696
+
(bnd__389_ :: bnds__378_ : _ Stdlib.List.t))
1697
+
in
1698
+
let bnds__378_ =
1699
+
if match b__384_ with
1700
+
| [] -> true
1701
+
| _ -> false
1702
+
then bnds__378_
1703
+
else (
1704
+
let arg__386_ = (sexp_of_list sexp_of_int) b__384_ in
1705
+
let bnd__385_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__386_ ] in
1706
+
(bnd__385_ :: bnds__378_ : _ Stdlib.List.t))
1707
+
in
1708
+
let bnds__378_ =
1709
+
match a__379_ with
1710
+
| Stdlib.Option.None -> bnds__378_
1711
+
| Stdlib.Option.Some v__380_ ->
1712
+
let arg__382_ = sexp_of_int v__380_ in
1713
+
let bnd__381_ = Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__382_ ] in
1714
+
(bnd__381_ :: bnds__378_ : _ Stdlib.List.t)
1715
+
in
1716
+
Sexplib0.Sexp.List bnds__378_
1717
+
: t -> Sexplib0.Sexp.t)
1718
+
;;
1719
+
1720
+
let _ = sexp_of_t
1721
+
1722
+
[@@@end]
1723
+
end
1724
+
1725
+
module Record_with_omit_nil = struct
1726
+
type t =
1727
+
{ a : int option [@sexp.omit_nil]
1728
+
; b : int list [@sexp.omit_nil]
1729
+
; c : unit [@sexp.omit_nil]
1730
+
; d : int [@sexp.omit_nil]
1731
+
}
1732
+
[@@deriving_inline sexp]
1733
+
1734
+
let _ = fun (_ : t) -> ()
1735
+
1736
+
let t_of_sexp =
1737
+
(let error_source__398_ = "expansion.ml.Record_with_omit_nil.t" in
1738
+
fun x__407_ ->
1739
+
Sexplib0.Sexp_conv_record.record_of_sexp
1740
+
~caller:error_source__398_
1741
+
~fields:
1742
+
(Field
1743
+
{ name = "a"
1744
+
; kind = Omit_nil
1745
+
; conv =
1746
+
(fun x__405_ ->
1747
+
let _x__406_ = (option_of_sexp int_of_sexp) x__405_ in
1748
+
fun () -> _x__406_)
1749
+
; rest =
1750
+
Field
1751
+
{ name = "b"
1752
+
; kind = Omit_nil
1753
+
; conv =
1754
+
(fun x__403_ ->
1755
+
let _x__404_ = (list_of_sexp int_of_sexp) x__403_ in
1756
+
fun () -> _x__404_)
1757
+
; rest =
1758
+
Field
1759
+
{ name = "c"
1760
+
; kind = Omit_nil
1761
+
; conv =
1762
+
(fun x__401_ ->
1763
+
let _x__402_ = unit_of_sexp x__401_ in
1764
+
fun () -> _x__402_)
1765
+
; rest =
1766
+
Field
1767
+
{ name = "d"
1768
+
; kind = Omit_nil
1769
+
; conv =
1770
+
(fun x__399_ ->
1771
+
let _x__400_ = int_of_sexp x__399_ in
1772
+
fun () -> _x__400_)
1773
+
; rest = Empty
1774
+
}
1775
+
}
1776
+
}
1777
+
})
1778
+
~index_of_field:(function
1779
+
| "a" -> 0
1780
+
| "b" -> 1
1781
+
| "c" -> 2
1782
+
| "d" -> 3
1783
+
| _ -> -1)
1784
+
~allow_extra_fields:false
1785
+
~create:(fun (a, (b, (c, (d, ())))) : t ->
1786
+
let a = a () in
1787
+
let b = b () in
1788
+
let c = c () in
1789
+
let d = d () in
1790
+
{ a; b; c; d })
1791
+
x__407_
1792
+
: Sexplib0.Sexp.t -> t)
1793
+
;;
1794
+
1795
+
let _ = t_of_sexp
1796
+
1797
+
let sexp_of_t =
1798
+
(fun { a = a__409_; b = b__411_; c = c__413_; d = d__415_ } ->
1799
+
let bnds__408_ = ([] : _ Stdlib.List.t) in
1800
+
let bnds__408_ =
1801
+
match sexp_of_int d__415_ with
1802
+
| Sexplib0.Sexp.List [] -> bnds__408_
1803
+
| arg__416_ ->
1804
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "d"; arg__416_ ] :: bnds__408_
1805
+
: _ Stdlib.List.t)
1806
+
in
1807
+
let bnds__408_ =
1808
+
match sexp_of_unit c__413_ with
1809
+
| Sexplib0.Sexp.List [] -> bnds__408_
1810
+
| arg__414_ ->
1811
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "c"; arg__414_ ] :: bnds__408_
1812
+
: _ Stdlib.List.t)
1813
+
in
1814
+
let bnds__408_ =
1815
+
match sexp_of_list sexp_of_int b__411_ with
1816
+
| Sexplib0.Sexp.List [] -> bnds__408_
1817
+
| arg__412_ ->
1818
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__412_ ] :: bnds__408_
1819
+
: _ Stdlib.List.t)
1820
+
in
1821
+
let bnds__408_ =
1822
+
match sexp_of_option sexp_of_int a__409_ with
1823
+
| Sexplib0.Sexp.List [] -> bnds__408_
1824
+
| arg__410_ ->
1825
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__410_ ] :: bnds__408_
1826
+
: _ Stdlib.List.t)
1827
+
in
1828
+
Sexplib0.Sexp.List bnds__408_
1829
+
: t -> Sexplib0.Sexp.t)
1830
+
;;
1831
+
1832
+
let _ = sexp_of_t
1833
+
1834
+
[@@@end]
1835
+
end
1836
+
1837
+
module Variant_with_sexp_list = struct
1838
+
type t = A of int list [@sexp.list] [@@deriving_inline sexp]
1839
+
1840
+
let _ = fun (_ : t) -> ()
1841
+
1842
+
let t_of_sexp =
1843
+
(let error_source__419_ = "expansion.ml.Variant_with_sexp_list.t" in
1844
+
function
1845
+
| Sexplib0.Sexp.List
1846
+
(Sexplib0.Sexp.Atom (("a" | "A") as _tag__422_) :: sexp_args__423_) as
1847
+
_sexp__421_ -> A (Sexplib0.Sexp_conv.list_map int_of_sexp sexp_args__423_)
1848
+
| Sexplib0.Sexp.Atom ("a" | "A") as sexp__420_ ->
1849
+
Sexplib0.Sexp_conv_error.stag_takes_args error_source__419_ sexp__420_
1850
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__418_ ->
1851
+
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__419_ sexp__418_
1852
+
| Sexplib0.Sexp.List [] as sexp__418_ ->
1853
+
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__419_ sexp__418_
1854
+
| sexp__418_ ->
1855
+
Sexplib0.Sexp_conv_error.unexpected_stag error_source__419_ [ "A" ] sexp__418_
1856
+
: Sexplib0.Sexp.t -> t)
1857
+
;;
1858
+
1859
+
let _ = t_of_sexp
1860
+
1861
+
let sexp_of_t =
1862
+
(fun (A l__424_) ->
1863
+
Sexplib0.Sexp.List
1864
+
(Sexplib0.Sexp.Atom "A" :: Sexplib0.Sexp_conv.list_map sexp_of_int l__424_)
1865
+
: t -> Sexplib0.Sexp.t)
1866
+
;;
1867
+
1868
+
let _ = sexp_of_t
1869
+
1870
+
[@@@end]
1871
+
end
1872
+
1873
+
module Poly_variant_with_sexp_list = struct
1874
+
type t = [ `A of int list [@sexp.list] ] [@@deriving_inline sexp]
1875
+
1876
+
let _ = fun (_ : t) -> ()
1877
+
1878
+
let __t_of_sexp__ =
1879
+
(let error_source__431_ = "expansion.ml.Poly_variant_with_sexp_list.t" in
1880
+
function
1881
+
| Sexplib0.Sexp.Atom atom__426_ as _sexp__428_ ->
1882
+
(match atom__426_ with
1883
+
| "A" -> Sexplib0.Sexp_conv_error.ptag_takes_args error_source__431_ _sexp__428_
1884
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1885
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.Atom atom__426_ :: sexp_args__429_) as
1886
+
_sexp__428_ ->
1887
+
(match atom__426_ with
1888
+
| "A" as _tag__430_ ->
1889
+
`A (Sexplib0.Sexp_conv.list_map int_of_sexp sexp_args__429_)
1890
+
| _ -> Sexplib0.Sexp_conv_error.no_variant_match ())
1891
+
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__427_ ->
1892
+
Sexplib0.Sexp_conv_error.nested_list_invalid_poly_var error_source__431_ sexp__427_
1893
+
| Sexplib0.Sexp.List [] as sexp__427_ ->
1894
+
Sexplib0.Sexp_conv_error.empty_list_invalid_poly_var error_source__431_ sexp__427_
1895
+
: Sexplib0.Sexp.t -> t)
1896
+
;;
1897
+
1898
+
let _ = __t_of_sexp__
1899
+
1900
+
let t_of_sexp =
1901
+
(let error_source__433_ = "expansion.ml.Poly_variant_with_sexp_list.t" in
1902
+
fun sexp__432_ ->
1903
+
try __t_of_sexp__ sexp__432_ with
1904
+
| Sexplib0.Sexp_conv_error.No_variant_match ->
1905
+
Sexplib0.Sexp_conv_error.no_matching_variant_found error_source__433_ sexp__432_
1906
+
: Sexplib0.Sexp.t -> t)
1907
+
;;
1908
+
1909
+
let _ = t_of_sexp
1910
+
1911
+
let sexp_of_t =
1912
+
(fun (`A l__434_) ->
1913
+
Sexplib0.Sexp.List
1914
+
(Sexplib0.Sexp.Atom "A" :: Sexplib0.Sexp_conv.list_map sexp_of_int l__434_)
1915
+
: t -> Sexplib0.Sexp.t)
1916
+
;;
1917
+
1918
+
let _ = sexp_of_t
1919
+
1920
+
[@@@end]
1921
+
end
1922
+
1923
+
module Record_allowing_extra_fields = struct
1924
+
type t = { a : int } [@@allow_extra_fields] [@@deriving_inline sexp]
1925
+
1926
+
let _ = fun (_ : t) -> ()
1927
+
1928
+
let t_of_sexp =
1929
+
(let error_source__436_ = "expansion.ml.Record_allowing_extra_fields.t" in
1930
+
fun x__439_ ->
1931
+
Sexplib0.Sexp_conv_record.record_of_sexp
1932
+
~caller:error_source__436_
1933
+
~fields:
1934
+
(Field
1935
+
{ name = "a"
1936
+
; kind = Required
1937
+
; conv =
1938
+
(fun x__437_ ->
1939
+
let _x__438_ = int_of_sexp x__437_ in
1940
+
fun () -> _x__438_)
1941
+
; rest = Empty
1942
+
})
1943
+
~index_of_field:(function
1944
+
| "a" -> 0
1945
+
| _ -> -1)
1946
+
~allow_extra_fields:true
1947
+
~create:(fun (a, ()) : t ->
1948
+
let a = a () in
1949
+
{ a })
1950
+
x__439_
1951
+
: Sexplib0.Sexp.t -> t)
1952
+
;;
1953
+
1954
+
let _ = t_of_sexp
1955
+
1956
+
let sexp_of_t =
1957
+
(fun { a = a__441_ } ->
1958
+
let bnds__440_ = ([] : _ Stdlib.List.t) in
1959
+
let bnds__440_ =
1960
+
let arg__442_ = sexp_of_int a__441_ in
1961
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__442_ ] :: bnds__440_
1962
+
: _ Stdlib.List.t)
1963
+
in
1964
+
Sexplib0.Sexp.List bnds__440_
1965
+
: t -> Sexplib0.Sexp.t)
1966
+
;;
1967
+
1968
+
let _ = sexp_of_t
1969
+
1970
+
[@@@end]
1971
+
end
1972
+
1973
+
module Opaque = struct
1974
+
type t = (int[@sexp.opaque]) list [@@deriving_inline sexp]
1975
+
1976
+
let _ = fun (_ : t) -> ()
1977
+
1978
+
let t_of_sexp =
1979
+
(fun x__444_ -> list_of_sexp Sexplib0.Sexp_conv.opaque_of_sexp x__444_
1980
+
: Sexplib0.Sexp.t -> t)
1981
+
;;
1982
+
1983
+
let _ = t_of_sexp
1984
+
1985
+
let sexp_of_t =
1986
+
(fun x__445_ -> sexp_of_list (Sexplib0.Sexp_conv.sexp_of_opaque : _ -> _) x__445_
1987
+
: t -> Sexplib0.Sexp.t)
1988
+
;;
1989
+
1990
+
let _ = sexp_of_t
1991
+
1992
+
[@@@end]
1993
+
end
1994
+
1995
+
[@@@expand_inline
1996
+
let [%sexp_of: Functor(T).t] = ()
1997
+
let [%of_sexp: Functor(T).t] = ()]
1998
+
1999
+
let sexp_of_functor__t = ()
2000
+
let functor__t_of_sexp = ()
2001
+
2002
+
[@@@end]
2003
+
2004
+
module Portable = struct
2005
+
type t =
2006
+
{ u : int u
2007
+
; b : int
2008
+
}
2009
+
2010
+
and 'a u =
2011
+
{ t : t
2012
+
; a : 'a
2013
+
}
2014
+
[@@deriving_inline sexp ~portable]
2015
+
2016
+
let _ = fun (_ : t) -> ()
2017
+
let _ = fun (_ : 'a u) -> ()
2018
+
2019
+
include struct
2020
+
let rec t_of_sexp =
2021
+
(let error_source__447_ = "expansion.ml.Portable.t" in
2022
+
fun x__452_ ->
2023
+
Sexplib0.Sexp_conv_record.record_of_sexp
2024
+
~caller:error_source__447_
2025
+
~fields:
2026
+
(Field
2027
+
{ name = "u"
2028
+
; kind = Required
2029
+
; conv =
2030
+
(fun x__450_ ->
2031
+
let _x__451_ = (u_of_sexp int_of_sexp) x__450_ in
2032
+
fun () -> _x__451_)
2033
+
; rest =
2034
+
Field
2035
+
{ name = "b"
2036
+
; kind = Required
2037
+
; conv =
2038
+
(fun x__448_ ->
2039
+
let _x__449_ = int_of_sexp x__448_ in
2040
+
fun () -> _x__449_)
2041
+
; rest = Empty
2042
+
}
2043
+
})
2044
+
~index_of_field:(function
2045
+
| "u" -> 0
2046
+
| "b" -> 1
2047
+
| _ -> -1)
2048
+
~allow_extra_fields:false
2049
+
~create:(fun (u, (b, ())) : t ->
2050
+
let u = u () in
2051
+
let b = b () in
2052
+
{ u; b })
2053
+
x__452_
2054
+
: Sexplib0.Sexp.t -> t)
2055
+
2056
+
and u_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a u =
2057
+
let error_source__455_ = "expansion.ml.Portable.u" in
2058
+
fun _of_a__453_ x__460_ ->
2059
+
Sexplib0.Sexp_conv_record.record_of_sexp
2060
+
~caller:error_source__455_
2061
+
~fields:
2062
+
(Field
2063
+
{ name = "t"
2064
+
; kind = Required
2065
+
; conv =
2066
+
(fun x__458_ ->
2067
+
let _x__459_ = t_of_sexp x__458_ in
2068
+
fun () -> _x__459_)
2069
+
; rest =
2070
+
Field
2071
+
{ name = "a"
2072
+
; kind = Required
2073
+
; conv =
2074
+
(fun x__456_ ->
2075
+
let _x__457_ = _of_a__453_ x__456_ in
2076
+
fun () -> _x__457_)
2077
+
; rest = Empty
2078
+
}
2079
+
})
2080
+
~index_of_field:(function
2081
+
| "t" -> 0
2082
+
| "a" -> 1
2083
+
| _ -> -1)
2084
+
~allow_extra_fields:false
2085
+
~create:(fun (t, (a, ())) : _ u ->
2086
+
let t = t () in
2087
+
let a = a () in
2088
+
{ t; a })
2089
+
x__460_
2090
+
;;
2091
+
2092
+
let _ = t_of_sexp
2093
+
and _ = u_of_sexp
2094
+
end
2095
+
2096
+
let _ = t_of_sexp
2097
+
and _ = u_of_sexp
2098
+
2099
+
include struct
2100
+
let rec sexp_of_t =
2101
+
(fun { u = u__462_; b = b__464_ } ->
2102
+
let bnds__461_ = ([] : _ Stdlib.List.t) in
2103
+
let bnds__461_ =
2104
+
let arg__465_ = sexp_of_int b__464_ in
2105
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "b"; arg__465_ ] :: bnds__461_
2106
+
: _ Stdlib.List.t)
2107
+
in
2108
+
let bnds__461_ =
2109
+
let arg__463_ = sexp_of_u sexp_of_int u__462_ in
2110
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "u"; arg__463_ ] :: bnds__461_
2111
+
: _ Stdlib.List.t)
2112
+
in
2113
+
Sexplib0.Sexp.List bnds__461_
2114
+
: t -> Sexplib0.Sexp.t)
2115
+
2116
+
and sexp_of_u : 'a. ('a -> Sexplib0.Sexp.t) -> 'a u -> Sexplib0.Sexp.t =
2117
+
fun _of_a__466_ { t = t__468_; a = a__470_ } ->
2118
+
let bnds__467_ = ([] : _ Stdlib.List.t) in
2119
+
let bnds__467_ =
2120
+
let arg__471_ = _of_a__466_ a__470_ in
2121
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "a"; arg__471_ ] :: bnds__467_
2122
+
: _ Stdlib.List.t)
2123
+
in
2124
+
let bnds__467_ =
2125
+
let arg__469_ = sexp_of_t t__468_ in
2126
+
(Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "t"; arg__469_ ] :: bnds__467_
2127
+
: _ Stdlib.List.t)
2128
+
in
2129
+
Sexplib0.Sexp.List bnds__467_
2130
+
;;
2131
+
2132
+
let _ = sexp_of_t
2133
+
and _ = sexp_of_u
2134
+
end
2135
+
2136
+
let _ = sexp_of_t
2137
+
and _ = sexp_of_u
2138
+
2139
+
[@@@end]
2140
+
end
+476
vendor/opam/ppx_sexp_conv/test/expansion.mli
+476
vendor/opam/ppx_sexp_conv/test/expansion.mli
···
1
+
open! Base
2
+
3
+
module%template Abstract : sig
4
+
type t [@@deriving_inline sexp [@alloc stack]]
5
+
6
+
include sig
7
+
[@@@ocaml.warning "-32"]
8
+
9
+
include Sexplib0.Sexpable.S__stack with type t := t
10
+
end
11
+
[@@ocaml.doc "@inline"]
12
+
13
+
[@@@end]
14
+
end
15
+
16
+
module Tuple : sig
17
+
type t = int * int * int [@@deriving_inline sexp]
18
+
19
+
include sig
20
+
[@@@ocaml.warning "-32"]
21
+
22
+
include Sexplib0.Sexpable.S_any with type t := t
23
+
end
24
+
[@@ocaml.doc "@inline"]
25
+
26
+
[@@@end]
27
+
end
28
+
29
+
module Record : sig
30
+
type t =
31
+
{ a : int
32
+
; b : int
33
+
; c : int
34
+
}
35
+
[@@deriving_inline sexp]
36
+
37
+
include sig
38
+
[@@@ocaml.warning "-32"]
39
+
40
+
include Sexplib0.Sexpable.S with type t := t
41
+
end
42
+
[@@ocaml.doc "@inline"]
43
+
44
+
[@@@end]
45
+
end
46
+
47
+
module Mutable_record : sig
48
+
type t =
49
+
{ mutable a : int
50
+
; mutable b : int
51
+
; mutable c : int
52
+
}
53
+
[@@deriving_inline sexp]
54
+
55
+
include sig
56
+
[@@@ocaml.warning "-32"]
57
+
58
+
include Sexplib0.Sexpable.S with type t := t
59
+
end
60
+
[@@ocaml.doc "@inline"]
61
+
62
+
[@@@end]
63
+
end
64
+
65
+
module Variant : sig
66
+
type t =
67
+
| A
68
+
| B of int * int
69
+
| C of
70
+
{ a : int
71
+
; b : int
72
+
; d : int
73
+
}
74
+
| D of
75
+
{ mutable a : int
76
+
; mutable b : int
77
+
; mutable t : int
78
+
}
79
+
[@@deriving_inline sexp]
80
+
81
+
include sig
82
+
[@@@ocaml.warning "-32"]
83
+
84
+
include Sexplib0.Sexpable.S with type t := t
85
+
end
86
+
[@@ocaml.doc "@inline"]
87
+
88
+
[@@@end]
89
+
end
90
+
91
+
module Poly_variant : sig
92
+
type t =
93
+
[ `A
94
+
| `B of int
95
+
]
96
+
[@@deriving_inline sexp]
97
+
98
+
include sig
99
+
[@@@ocaml.warning "-32"]
100
+
101
+
val sexp_of_t : t -> Sexplib0.Sexp.t
102
+
val t_of_sexp : Sexplib0.Sexp.t -> t
103
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
104
+
end
105
+
[@@ocaml.doc "@inline"]
106
+
107
+
[@@@end]
108
+
end
109
+
110
+
module Inline_poly_variant : sig
111
+
type t =
112
+
[ Poly_variant.t
113
+
| `C of int * int
114
+
]
115
+
[@@deriving_inline sexp]
116
+
117
+
include sig
118
+
[@@@ocaml.warning "-32"]
119
+
120
+
val sexp_of_t : t -> Sexplib0.Sexp.t
121
+
val t_of_sexp : Sexplib0.Sexp.t -> t
122
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
123
+
end
124
+
[@@ocaml.doc "@inline"]
125
+
126
+
[@@@end]
127
+
end
128
+
129
+
module Recursive : sig
130
+
type t =
131
+
| Banana of t
132
+
| Orange
133
+
[@@deriving_inline sexp]
134
+
135
+
include sig
136
+
[@@@ocaml.warning "-32"]
137
+
138
+
include Sexplib0.Sexpable.S with type t := t
139
+
end
140
+
[@@ocaml.doc "@inline"]
141
+
142
+
[@@@end]
143
+
end
144
+
145
+
module Nonrecursive : sig
146
+
open Recursive
147
+
148
+
type nonrec t = t [@@deriving_inline sexp]
149
+
150
+
include sig
151
+
[@@@ocaml.warning "-32"]
152
+
153
+
include Sexplib0.Sexpable.S_any with type t := t
154
+
end
155
+
[@@ocaml.doc "@inline"]
156
+
157
+
[@@@end]
158
+
end
159
+
160
+
module Mutually_recursive : sig
161
+
type a =
162
+
| A
163
+
| B of b
164
+
| C of
165
+
{ a : a
166
+
; b : b
167
+
; c : c
168
+
}
169
+
170
+
and b =
171
+
{ a : a
172
+
; b : b
173
+
}
174
+
175
+
and c = a [@@deriving_inline sexp]
176
+
177
+
include sig
178
+
[@@@ocaml.warning "-32"]
179
+
180
+
val sexp_of_a : a -> Sexplib0.Sexp.t
181
+
val sexp_of_b : b -> Sexplib0.Sexp.t
182
+
val sexp_of_c : c -> Sexplib0.Sexp.t
183
+
val a_of_sexp : Sexplib0.Sexp.t -> a
184
+
val b_of_sexp : Sexplib0.Sexp.t -> b
185
+
val c_of_sexp : Sexplib0.Sexp.t -> c
186
+
end
187
+
[@@ocaml.doc "@inline"]
188
+
189
+
[@@@end]
190
+
end
191
+
192
+
module Alias : sig
193
+
type t = Recursive.t [@@deriving_inline sexp]
194
+
195
+
include sig
196
+
[@@@ocaml.warning "-32"]
197
+
198
+
include Sexplib0.Sexpable.S_any with type t := t
199
+
end
200
+
[@@ocaml.doc "@inline"]
201
+
202
+
[@@@end]
203
+
end
204
+
205
+
module Re_export : sig
206
+
type t = Recursive.t =
207
+
| Banana of t
208
+
| Orange
209
+
[@@deriving_inline sexp]
210
+
211
+
include sig
212
+
[@@@ocaml.warning "-32"]
213
+
214
+
include Sexplib0.Sexpable.S with type t := t
215
+
end
216
+
[@@ocaml.doc "@inline"]
217
+
218
+
[@@@end]
219
+
end
220
+
221
+
module Unary : sig
222
+
type 'a t = 'a list option [@@deriving_inline sexp]
223
+
224
+
include sig
225
+
[@@@ocaml.warning "-32"]
226
+
227
+
include Sexplib0.Sexpable.S_any1 with type 'a t := 'a t
228
+
end
229
+
[@@ocaml.doc "@inline"]
230
+
231
+
[@@@end]
232
+
end
233
+
234
+
module Binary : sig
235
+
type ('a, 'b) t = ('a, 'b) Either.t [@@deriving_inline sexp]
236
+
237
+
include sig
238
+
[@@@ocaml.warning "-32"]
239
+
240
+
include Sexplib0.Sexpable.S_any2 with type ('a, 'b) t := ('a, 'b) t
241
+
end
242
+
[@@ocaml.doc "@inline"]
243
+
244
+
[@@@end]
245
+
end
246
+
247
+
module First_order : sig
248
+
type 'a t = 'a -> 'a [@@deriving_inline sexp]
249
+
250
+
include sig
251
+
[@@@ocaml.warning "-32"]
252
+
253
+
include Sexplib0.Sexpable.S_any1 with type 'a t := 'a t
254
+
end
255
+
[@@ocaml.doc "@inline"]
256
+
257
+
[@@@end]
258
+
end
259
+
260
+
module Second_order : sig
261
+
type ('a, 'b) t = ('a -> 'a) -> ('a -> 'b) -> ('b -> 'b) -> 'a -> 'b
262
+
[@@deriving_inline sexp]
263
+
264
+
include sig
265
+
[@@@ocaml.warning "-32"]
266
+
267
+
include Sexplib0.Sexpable.S_any2 with type ('a, 'b) t := ('a, 'b) t
268
+
end
269
+
[@@ocaml.doc "@inline"]
270
+
271
+
[@@@end]
272
+
end
273
+
274
+
module Named_arguments : sig
275
+
type t = ?a:int -> b:int -> int -> int [@@deriving_inline sexp]
276
+
277
+
include sig
278
+
[@@@ocaml.warning "-32"]
279
+
280
+
include Sexplib0.Sexpable.S_any with type t := t
281
+
end
282
+
[@@ocaml.doc "@inline"]
283
+
284
+
[@@@end]
285
+
end
286
+
287
+
module Gadt : sig
288
+
type _ t =
289
+
| A : _ option t
290
+
| B : int -> int t
291
+
| C : 'a list -> unit t
292
+
[@@deriving_inline sexp_of]
293
+
294
+
include sig
295
+
[@@@ocaml.warning "-32"]
296
+
297
+
val sexp_of_t : ('a__001_ -> Sexplib0.Sexp.t) -> 'a__001_ t -> Sexplib0.Sexp.t
298
+
end
299
+
[@@ocaml.doc "@inline"]
300
+
301
+
[@@@end]
302
+
end
303
+
304
+
module Recursive_record_containing_variant : sig
305
+
type t =
306
+
{ a : [ `A of t ]
307
+
; b : [ `B ]
308
+
}
309
+
[@@deriving_inline sexp]
310
+
311
+
include sig
312
+
[@@@ocaml.warning "-32"]
313
+
314
+
include Sexplib0.Sexpable.S with type t := t
315
+
end
316
+
[@@ocaml.doc "@inline"]
317
+
318
+
[@@@end]
319
+
end
320
+
321
+
module Poly_record : sig
322
+
type t =
323
+
{ a : 'a. 'a list
324
+
; b : 'b. 'b option
325
+
; c : 'c. 'c
326
+
}
327
+
[@@deriving_inline sexp]
328
+
329
+
include sig
330
+
[@@@ocaml.warning "-32"]
331
+
332
+
include Sexplib0.Sexpable.S with type t := t
333
+
end
334
+
[@@ocaml.doc "@inline"]
335
+
336
+
[@@@end]
337
+
end
338
+
339
+
module Record_with_defaults : sig
340
+
type t =
341
+
{ a : int
342
+
; b : int
343
+
; c : int
344
+
; d : int
345
+
; e : int
346
+
; f : int
347
+
}
348
+
[@@deriving_inline sexp]
349
+
350
+
include sig
351
+
[@@@ocaml.warning "-32"]
352
+
353
+
include Sexplib0.Sexpable.S with type t := t
354
+
end
355
+
[@@ocaml.doc "@inline"]
356
+
357
+
[@@@end]
358
+
end
359
+
360
+
module Record_with_special_types : sig
361
+
type t =
362
+
{ a : int option
363
+
; b : int list
364
+
; c : int array
365
+
; d : bool
366
+
; e : int or_null
367
+
}
368
+
[@@deriving_inline sexp]
369
+
370
+
include sig
371
+
[@@@ocaml.warning "-32"]
372
+
373
+
include Sexplib0.Sexpable.S with type t := t
374
+
end
375
+
[@@ocaml.doc "@inline"]
376
+
377
+
[@@@end]
378
+
end
379
+
380
+
module Record_with_omit_nil : sig
381
+
type t =
382
+
{ a : int option
383
+
; b : int list
384
+
; c : unit
385
+
; d : int
386
+
}
387
+
[@@deriving_inline sexp]
388
+
389
+
include sig
390
+
[@@@ocaml.warning "-32"]
391
+
392
+
include Sexplib0.Sexpable.S with type t := t
393
+
end
394
+
[@@ocaml.doc "@inline"]
395
+
396
+
[@@@end]
397
+
end
398
+
399
+
module Variant_with_sexp_list : sig
400
+
type t = A of int list [@@deriving_inline sexp]
401
+
402
+
include sig
403
+
[@@@ocaml.warning "-32"]
404
+
405
+
include Sexplib0.Sexpable.S with type t := t
406
+
end
407
+
[@@ocaml.doc "@inline"]
408
+
409
+
[@@@end]
410
+
end
411
+
412
+
module Poly_variant_with_sexp_list : sig
413
+
type t = [ `A of int list ] [@@deriving_inline sexp]
414
+
415
+
include sig
416
+
[@@@ocaml.warning "-32"]
417
+
418
+
val sexp_of_t : t -> Sexplib0.Sexp.t
419
+
val t_of_sexp : Sexplib0.Sexp.t -> t
420
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
421
+
end
422
+
[@@ocaml.doc "@inline"]
423
+
424
+
[@@@end]
425
+
end
426
+
427
+
module Record_allowing_extra_fields : sig
428
+
type t = { a : int } [@@deriving_inline sexp]
429
+
430
+
include sig
431
+
[@@@ocaml.warning "-32"]
432
+
433
+
include Sexplib0.Sexpable.S with type t := t
434
+
end
435
+
[@@ocaml.doc "@inline"]
436
+
437
+
[@@@end]
438
+
end
439
+
440
+
module Opaque : sig
441
+
type t = int list [@@deriving_inline sexp]
442
+
443
+
include sig
444
+
[@@@ocaml.warning "-32"]
445
+
446
+
include Sexplib0.Sexpable.S_any with type t := t
447
+
end
448
+
[@@ocaml.doc "@inline"]
449
+
450
+
[@@@end]
451
+
end
452
+
453
+
module Portable : sig
454
+
type t =
455
+
{ u : int u
456
+
; b : int
457
+
}
458
+
459
+
and 'a u =
460
+
{ t : t
461
+
; a : 'a
462
+
}
463
+
[@@deriving_inline sexp ~portable]
464
+
465
+
include sig
466
+
[@@@ocaml.warning "-32"]
467
+
468
+
val sexp_of_t : t -> Sexplib0.Sexp.t
469
+
val sexp_of_u : ('a -> Sexplib0.Sexp.t) -> 'a u -> Sexplib0.Sexp.t
470
+
val t_of_sexp : Sexplib0.Sexp.t -> t
471
+
val u_of_sexp : (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a u
472
+
end
473
+
[@@ocaml.doc "@inline"]
474
+
475
+
[@@@end]
476
+
end
+59
vendor/opam/ppx_sexp_conv/test/lib/conv_test.ml
+59
vendor/opam/ppx_sexp_conv/test/lib/conv_test.ml
···
1
+
open Ppx_sexp_conv_lib
2
+
open Conv
3
+
4
+
module%test Exceptions = struct
5
+
let check_sexp exn string =
6
+
match sexp_of_exn_opt exn with
7
+
| None -> raise exn
8
+
| Some sexp ->
9
+
let sexp_as_string = Ppx_sexp_conv_lib.Sexp.to_string sexp in
10
+
if sexp_as_string <> string then failwith sexp_as_string
11
+
;;
12
+
13
+
(* first global exceptions, checking different arities since they
14
+
don't have the same representation *)
15
+
exception Arg0 [@@deriving sexp]
16
+
exception Arg1 of int [@@deriving sexp]
17
+
exception Arg2 of int * int [@@deriving sexp]
18
+
19
+
let%test_unit _ = check_sexp Arg0 "conv_test.ml.Arg0"
20
+
let%test_unit _ = check_sexp (Arg1 1) "(conv_test.ml.Arg1 1)"
21
+
let%test_unit _ = check_sexp (Arg2 (2, 3)) "(conv_test.ml.Arg2 2 3)"
22
+
23
+
(* now local exceptions *)
24
+
let exn (type a) a sexp_of_a =
25
+
let module M = struct
26
+
exception E of a [@@deriving sexp]
27
+
end
28
+
in
29
+
M.E a
30
+
;;
31
+
32
+
let%test_unit "incompatible exceptions with the same name" =
33
+
let e_int = exn 1 sexp_of_int in
34
+
let e_string = exn "a" sexp_of_string in
35
+
check_sexp e_int "(conv_test.ml.E 1)";
36
+
check_sexp e_string "(conv_test.ml.E a)"
37
+
;;
38
+
39
+
let%test_unit "sexp converters are finalized properly for local exceptions" =
40
+
Gc.compact ();
41
+
Gc.compact ();
42
+
let size_before = Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size () in
43
+
let e = exn 2.5 sexp_of_float in
44
+
let size_after_local_exn =
45
+
Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size ()
46
+
in
47
+
let e_finalized = ref false in
48
+
Gc.finalise (fun _ -> e_finalized := true) e;
49
+
check_sexp e "(conv_test.ml.E 2.5)";
50
+
Gc.compact ();
51
+
Gc.compact ();
52
+
assert !e_finalized;
53
+
let size_after_gc =
54
+
Ppx_sexp_conv_lib.Conv.Exn_converter.For_unit_tests_only.size ()
55
+
in
56
+
assert (size_before + 1 = size_after_local_exn);
57
+
assert (size_before = size_after_gc)
58
+
;;
59
+
end
+1
vendor/opam/ppx_sexp_conv/test/lib/conv_test.mli
+1
vendor/opam/ppx_sexp_conv/test/lib/conv_test.mli
···
1
+
(*_ This signature is deliberately empty. *)
+5
vendor/opam/ppx_sexp_conv/test/lib/dune
+5
vendor/opam/ppx_sexp_conv/test/lib/dune
+1
vendor/opam/ppx_sexp_conv/test/lib/ppx_sexp_conv_lib_test.ml
+1
vendor/opam/ppx_sexp_conv/test/lib/ppx_sexp_conv_lib_test.ml
···
1
+
module Conv_test = Conv_test
+9
vendor/opam/ppx_sexp_conv/test/non_recursive_type_and.ml
+9
vendor/opam/ppx_sexp_conv/test/non_recursive_type_and.ml
+9
vendor/opam/ppx_sexp_conv/test/non_recursive_type_and.mli
+9
vendor/opam/ppx_sexp_conv/test/non_recursive_type_and.mli
+118
vendor/opam/ppx_sexp_conv/test/nonrec_test.ml
+118
vendor/opam/ppx_sexp_conv/test/nonrec_test.ml
···
1
+
open Ppx_sexp_conv_lib.Conv
2
+
3
+
type t = float [@@deriving sexp ~stackify]
4
+
5
+
module M : sig
6
+
type t = float list [@@deriving sexp ~stackify]
7
+
end = struct
8
+
type nonrec t = t list [@@deriving sexp ~stackify]
9
+
end
10
+
11
+
type 'a u = 'a [@@deriving sexp ~stackify]
12
+
13
+
module M2 : sig
14
+
type 'a u = 'a list [@@deriving sexp ~stackify]
15
+
end = struct
16
+
type nonrec 'a u = 'a u list [@@deriving sexp ~stackify]
17
+
end
18
+
19
+
type 'a v = 'a w
20
+
and 'a w = A of 'a v [@@deriving sexp ~stackify]
21
+
22
+
type 'a v_ = 'a v [@@deriving sexp ~stackify]
23
+
type 'a w_ = 'a w [@@deriving sexp ~stackify]
24
+
25
+
module M3 : sig
26
+
type 'a v = 'a w_ [@@deriving sexp ~stackify]
27
+
type 'a w = 'a v_ [@@deriving sexp ~stackify]
28
+
end = struct
29
+
type nonrec 'a v = 'a w
30
+
and 'a w = 'a v [@@deriving sexp ~stackify]
31
+
end
32
+
33
+
type t0 = A of t0 [@@deriving sexp ~stackify]
34
+
35
+
module B : sig
36
+
type nonrec t0 = t0 [@@deriving sexp ~stackify]
37
+
end = struct
38
+
type nonrec t0 = t0 = A of t0 [@@deriving sexp ~stackify]
39
+
end
40
+
41
+
type t1 = A of t2
42
+
and t2 = B of t1 [@@deriving sexp ~stackify]
43
+
44
+
module C : sig
45
+
type nonrec t1 = t1 [@@deriving sexp ~stackify]
46
+
type nonrec t2 = t2 [@@deriving sexp ~stackify]
47
+
end = struct
48
+
type nonrec t1 = t1 = A of t2
49
+
and t2 = t2 = B of t1 [@@deriving sexp ~stackify]
50
+
end
51
+
52
+
type 'a v1 = A of 'a v2
53
+
and 'a v2 = B of 'a v1 [@@deriving sexp ~stackify]
54
+
55
+
module D : sig
56
+
type nonrec 'a v1 = 'a v1 [@@deriving sexp ~stackify]
57
+
type nonrec 'a v2 = 'a v2 [@@deriving sexp ~stackify]
58
+
end = struct
59
+
type nonrec 'a v1 = 'a v1 = A of 'a v2
60
+
and 'a v2 = 'a v2 = B of 'a v1 [@@deriving sexp ~stackify]
61
+
end
62
+
63
+
type +'a w1
64
+
65
+
module E = struct
66
+
type nonrec +'a w1 = 'a w1
67
+
end
68
+
69
+
type 'a y1 = A of 'a y2
70
+
and 'a y2 = B of 'a y1
71
+
72
+
module F : sig
73
+
type nonrec 'a y2 = B of 'a y1
74
+
type nonrec 'a y1 = 'a y1
75
+
end = struct
76
+
type nonrec 'a y1 = 'a y1 = A of 'a y2
77
+
and 'a y2 = B of 'a y1
78
+
end
79
+
80
+
type z1 = A of z1
81
+
82
+
module G : sig
83
+
module A : sig
84
+
type z2 = A of z2
85
+
end
86
+
87
+
module B : sig
88
+
type z2 = A of z2
89
+
end
90
+
91
+
module C : sig
92
+
type z2 = A of z2
93
+
end
94
+
end = struct
95
+
type z2 = z1 = A of z1
96
+
97
+
module A = struct
98
+
type nonrec z2 = z1 = A of z2
99
+
end
100
+
101
+
module B = struct
102
+
type nonrec z2 = z2 = A of z2
103
+
end
104
+
105
+
module C = struct
106
+
type nonrec z2 = z2 = A of z1
107
+
end
108
+
end
109
+
110
+
type ('a, 'b) zz = A of 'a * 'b
111
+
112
+
module H = struct
113
+
type nonrec ('a, 'b) zz = ('a, 'b) zz = A of 'a * 'b
114
+
end
115
+
116
+
module I = struct
117
+
type nonrec 'a zz = ('a, 'a) zz
118
+
end
+100
vendor/opam/ppx_sexp_conv/test/phantom.ml
+100
vendor/opam/ppx_sexp_conv/test/phantom.ml
···
1
+
open Base
2
+
open Ppx_sexp_conv_lib.Conv
3
+
4
+
type 'a[@phantom] t = int [@@deriving sexp]
5
+
type ('a[@phantom], 'b) u = 'b list [@@deriving sexp]
6
+
type ('a[@phantom], 'b[@phantom]) v = string [@@deriving sexp]
7
+
type ('a, 'b[@phantom]) w = 'a option [@@deriving sexp]
8
+
9
+
let print_s sexp = Stdio.print_endline (Sexp.to_string_hum sexp)
10
+
11
+
let%expect_test "phantom type parameters work correctly" =
12
+
let x : int t = 42 in
13
+
let sexp = sexp_of_t x in
14
+
print_s sexp;
15
+
[%expect {| 42 |}];
16
+
let y : string t = t_of_sexp sexp in
17
+
Expect_test_helpers_base.require_equal (module Int) x y;
18
+
[%expect {| |}];
19
+
let x : (int, string) u = [ "hello"; "world" ] in
20
+
let sexp = sexp_of_u sexp_of_string x in
21
+
print_s sexp;
22
+
[%expect {| (hello world) |}];
23
+
let y : (bool, string) u = u_of_sexp string_of_sexp sexp in
24
+
Expect_test_helpers_base.require_equal
25
+
(module struct
26
+
type t = string list [@@deriving equal, sexp_of]
27
+
end)
28
+
x
29
+
y;
30
+
[%expect {| |}];
31
+
let x : (int, string) v = "test" in
32
+
let sexp = sexp_of_v x in
33
+
print_s sexp;
34
+
[%expect {| test |}];
35
+
let y : (bool, float) v = v_of_sexp sexp in
36
+
Expect_test_helpers_base.require_equal (module String) x y;
37
+
[%expect {| |}];
38
+
let x : (int, string) w = Some 42 in
39
+
let sexp = sexp_of_w sexp_of_int x in
40
+
print_s sexp;
41
+
[%expect {| (42) |}];
42
+
let y : (int, bool) w = w_of_sexp int_of_sexp sexp in
43
+
Expect_test_helpers_base.require_equal
44
+
(module struct
45
+
type t = int option [@@deriving equal, sexp_of]
46
+
end)
47
+
x
48
+
y;
49
+
[%expect {| |}]
50
+
;;
51
+
52
+
let%expect_test "also in extensions" =
53
+
let open struct
54
+
(* versions of types with no sexps derived *)
55
+
type foo_int = int
56
+
type foo_string = string
57
+
type foo_bool = bool
58
+
type foo_float = float
59
+
end in
60
+
let x : foo_int t = 42 in
61
+
let sexp = [%sexp_of: (foo_int[@phantom]) t] x in
62
+
print_s sexp;
63
+
[%expect {| 42 |}];
64
+
let y : foo_string t = [%of_sexp: (foo_string[@phantom]) t] sexp in
65
+
Expect_test_helpers_base.require_equal (module Int) x y;
66
+
[%expect {| |}];
67
+
let x : (foo_int, string) u = [ "hello"; "world" ] in
68
+
let sexp = [%sexp_of: ((foo_int[@phantom]), string) u] x in
69
+
print_s sexp;
70
+
[%expect {| (hello world) |}];
71
+
let y : (foo_bool, string) u = [%of_sexp: ((foo_bool[@phantom]), string) u] sexp in
72
+
Expect_test_helpers_base.require_equal
73
+
(module struct
74
+
type t = string list [@@deriving equal, sexp_of]
75
+
end)
76
+
x
77
+
y;
78
+
[%expect {| |}];
79
+
let x : (foo_int, foo_string) v = "test" in
80
+
let sexp = [%sexp_of: ((foo_int[@phantom]), (foo_string[@phantom])) v] x in
81
+
print_s sexp;
82
+
[%expect {| test |}];
83
+
let y : (foo_bool, foo_float) v =
84
+
[%of_sexp: ((foo_bool[@phantom]), (foo_float[@phantom])) v] sexp
85
+
in
86
+
Expect_test_helpers_base.require_equal (module String) x y;
87
+
[%expect {| |}];
88
+
let x : (int, foo_string) w = Some 42 in
89
+
let sexp = [%sexp_of: (int, (foo_string[@phantom])) w] x in
90
+
print_s sexp;
91
+
[%expect {| (42) |}];
92
+
let y : (int, foo_bool) w = [%of_sexp: (int, (foo_bool[@phantom])) w] sexp in
93
+
Expect_test_helpers_base.require_equal
94
+
(module struct
95
+
type t = int option [@@deriving equal, sexp_of]
96
+
end)
97
+
x
98
+
y;
99
+
[%expect {| |}]
100
+
;;
+1
vendor/opam/ppx_sexp_conv/test/phantom.mli
+1
vendor/opam/ppx_sexp_conv/test/phantom.mli
···
1
+
(*_ This file is intentionally left blank. *)
+71
vendor/opam/ppx_sexp_conv/test/phantom.mlt
+71
vendor/opam/ppx_sexp_conv/test/phantom.mlt
···
1
+
open Ppx_sexp_conv_lib.Conv
2
+
3
+
type 'a[@phantom] t = int [@@deriving sexp]
4
+
type ('a[@phantom], 'b) u = 'b list [@@deriving sexp]
5
+
type ('a[@phantom], 'b[@phantom]) v = string [@@deriving sexp]
6
+
type ('a, 'b[@phantom]) w = 'a option [@@deriving sexp]
7
+
8
+
[%%expect {| |}];;
9
+
10
+
(* missing [[@phantom]]s *)
11
+
12
+
[%sexp_of: int t] 42
13
+
14
+
[%%expect
15
+
{|
16
+
Line _, characters _-_:
17
+
Error: The function sexp_of_t has type int -> Sexplib0.Sexp.t
18
+
It is applied to too many arguments
19
+
Line _, characters _-_:
20
+
This extra argument is not expected.
21
+
|}]
22
+
23
+
24
+
type my_int1 = int
25
+
26
+
let sexp_of_my_int1 x =
27
+
assert (Int.equal x 42);
28
+
sexp_of_int x
29
+
;;
30
+
31
+
type my_int2 = int
32
+
33
+
let sexp_of_my_int2 = sexp_of_int;;
34
+
35
+
print_endline
36
+
(Base.Sexp.to_string_hum ([%sexp_of: (my_int1, (my_int2[@phantom])) u] [ 42 ]))
37
+
38
+
[%%expect
39
+
{|
40
+
(42)
41
+
|}]
42
+
;;
43
+
44
+
[%sexp_of: (my_int1, (my_int2[@phantom])) u] [ 43 ]
45
+
46
+
[%%expect
47
+
{|
48
+
Exception: "Assert_failure phantom.mlt:30:2".
49
+
|}]
50
+
;;
51
+
52
+
(* extra [[@phantom]]s *)
53
+
54
+
[%sexp_of: ((int[@phantom]), (string[@phantom])) u] [ "hello"; "world" ]
55
+
56
+
[%%expect
57
+
{|
58
+
Line _, characters _-_:
59
+
Error: This expression should not be a list literal, the expected type is
60
+
'a -> Sexplib0.Sexp.t
61
+
|}]
62
+
;;
63
+
64
+
[%sexp_of: ((int[@phantom]), (string[@phantom])) w] (Some 42)
65
+
66
+
[%%expect
67
+
{|
68
+
Line _, characters _-_:
69
+
Error: This expression should not be a constructor, the expected type is
70
+
'a -> Sexplib0.Sexp.t
71
+
|}]
+87
vendor/opam/ppx_sexp_conv/test/portable_zapping.ml
+87
vendor/opam/ppx_sexp_conv/test/portable_zapping.ml
···
1
+
open! Base
2
+
3
+
[@@@disable_unused_warnings]
4
+
5
+
module Sexp_of_t = struct
6
+
type t = A [@@deriving sexp_of ~portable]
7
+
end
8
+
9
+
module Sexp_of_t_portable : sig
10
+
include module type of struct
11
+
include Sexp_of_t
12
+
end
13
+
end = struct
14
+
include Sexp_of_t
15
+
end
16
+
17
+
module Sexp_of_not_t = struct
18
+
type not_t = A [@@deriving sexp_of ~portable]
19
+
end
20
+
21
+
module Sexp_of_not_t_portable : sig
22
+
include module type of struct
23
+
include Sexp_of_not_t
24
+
end
25
+
end = struct
26
+
include Sexp_of_not_t
27
+
end
28
+
29
+
module Of_sexp_t = struct
30
+
type t = A [@@deriving of_sexp ~portable]
31
+
end
32
+
33
+
module Of_sexp_t_portable : sig
34
+
include module type of struct
35
+
include Of_sexp_t
36
+
end
37
+
end = struct
38
+
include Of_sexp_t
39
+
end
40
+
41
+
module Of_sexp_not_t = struct
42
+
type not_t = A [@@deriving of_sexp ~portable]
43
+
end
44
+
45
+
module Of_sexp_not_t_portable : sig
46
+
include module type of struct
47
+
include Of_sexp_not_t
48
+
end
49
+
end = struct
50
+
include Of_sexp_not_t
51
+
end
52
+
53
+
module Sexp_t = struct
54
+
type t = A [@@deriving sexp ~portable]
55
+
end
56
+
57
+
module Sexp_t_portable : sig
58
+
include module type of struct
59
+
include Sexp_t
60
+
end
61
+
end = struct
62
+
include Sexp_t
63
+
end
64
+
65
+
module Sexp_not_t = struct
66
+
type not_t = A [@@deriving sexp ~portable]
67
+
end
68
+
69
+
module Sexp_not_t_portable : sig
70
+
include module type of struct
71
+
include Sexp_not_t
72
+
end
73
+
end = struct
74
+
include Sexp_not_t
75
+
end
76
+
77
+
module Sexp_t1 = struct
78
+
type 'a t = A of 'a [@@deriving sexp ~portable]
79
+
end
80
+
81
+
module Sexp_t1_portable : sig
82
+
include module type of struct
83
+
include Sexp_t1
84
+
end
85
+
end = struct
86
+
include Sexp_t1
87
+
end
+1
vendor/opam/ppx_sexp_conv/test/portable_zapping.mli
+1
vendor/opam/ppx_sexp_conv/test/portable_zapping.mli
···
1
+
(*_ This file is intentionally left blank. *)
+3
vendor/opam/ppx_sexp_conv/test/ppx_sexp_conv_test.ml
+3
vendor/opam/ppx_sexp_conv/test/ppx_sexp_conv_test.ml
+1022
vendor/opam/ppx_sexp_conv/test/ppx_sexp_test.ml
+1022
vendor/opam/ppx_sexp_conv/test/ppx_sexp_test.ml
···
1
+
open Ppx_sexp_conv_lib
2
+
open Conv
3
+
4
+
(* Module names below are used in error messages being tested. *)
5
+
[@@@warning "-unused-module"]
6
+
7
+
module Sum_and_polymorphic_variants = struct
8
+
type poly =
9
+
[ `No_arg
10
+
| `One_arg of int
11
+
| `One_tuple of int * string
12
+
| `Two_args of int * string
13
+
]
14
+
[@@deriving sexp ~stackify, sexp_grammar]
15
+
16
+
let%test_unit _ =
17
+
List.iter
18
+
(fun (value, sexp) ->
19
+
assert (sexp_of_poly value = sexp);
20
+
assert (sexp_of_poly__stack value = sexp);
21
+
assert (poly_of_sexp sexp = value))
22
+
[ `No_arg, Sexp.Atom "No_arg"
23
+
; (`One_arg 1, Sexp.(List [ Atom "One_arg"; Atom "1" ]))
24
+
; ( `One_tuple (1, "a")
25
+
, Sexp.(List [ Atom "One_tuple"; List [ Atom "1"; Atom "a" ] ]) )
26
+
; (`Two_args (1, "a"), Sexp.(List [ Atom "Two_args"; List [ Atom "1"; Atom "a" ] ]))
27
+
]
28
+
;;
29
+
30
+
type nominal =
31
+
| No_arg
32
+
| One_arg of int
33
+
| One_tuple of (int * string)
34
+
| Two_args of int * string
35
+
[@@deriving sexp ~stackify, sexp_grammar]
36
+
37
+
let%test_unit _ =
38
+
List.iter
39
+
(fun (value, sexp) ->
40
+
assert (sexp_of_nominal value = sexp);
41
+
assert (sexp_of_nominal__stack value = sexp);
42
+
assert (nominal_of_sexp sexp = value))
43
+
[ No_arg, Sexp.Atom "No_arg"
44
+
; (One_arg 1, Sexp.(List [ Atom "One_arg"; Atom "1" ]))
45
+
; (One_tuple (1, "a"), Sexp.(List [ Atom "One_tuple"; List [ Atom "1"; Atom "a" ] ]))
46
+
; (Two_args (1, "a"), Sexp.(List [ Atom "Two_args"; Atom "1"; Atom "a" ]))
47
+
]
48
+
;;
49
+
50
+
let%expect_test _ =
51
+
let sexp = Sexplib.Sexp.of_string "(Three_args 1 1 1)" in
52
+
Expect_test_helpers_base.show_raise (fun () -> nominal_of_sexp sexp);
53
+
[%expect
54
+
{|
55
+
(raised (
56
+
Of_sexp_error
57
+
"ppx_sexp_test.ml.Sum_and_polymorphic_variants.nominal_of_sexp: unexpected variant constructor; expected one of No_arg One_arg One_tuple Two_args"
58
+
(invalid_sexp (Three_args 1 1 1))))
59
+
|}]
60
+
;;
61
+
end
62
+
63
+
module Records = struct
64
+
type t =
65
+
{ a : int
66
+
; b : (float * string) list option
67
+
}
68
+
[@@deriving sexp ~stackify, sexp_grammar]
69
+
70
+
let%test_unit _ =
71
+
let t = { a = 2; b = Some [ 1., "a"; 2.3, "b" ] } in
72
+
let sexp = Sexplib.Sexp.of_string "((a 2)(b (((1 a)(2.3 b)))))" in
73
+
assert (t_of_sexp sexp = t);
74
+
assert (sexp_of_t t = sexp);
75
+
assert (sexp_of_t__stack t = sexp)
76
+
;;
77
+
78
+
let%expect_test _ =
79
+
let sexp = Sexplib.Sexp.of_string "((a)(b ()))" in
80
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
81
+
[%expect
82
+
{|
83
+
(raised (
84
+
Of_sexp_error
85
+
"ppx_sexp_test.ml.Records.t_of_sexp: record conversion: only pairs expected, their first element must be an atom"
86
+
(invalid_sexp ((a) (b ())))))
87
+
|}]
88
+
;;
89
+
90
+
let%expect_test _ =
91
+
let sexp = Sexplib.Sexp.of_string "((a 1)(a))" in
92
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
93
+
[%expect
94
+
{|
95
+
(raised (
96
+
Of_sexp_error
97
+
"ppx_sexp_test.ml.Records.t_of_sexp: duplicate fields: a"
98
+
(invalid_sexp ((a 1) (a)))))
99
+
|}]
100
+
;;
101
+
102
+
let%expect_test _ =
103
+
let sexp = Sexplib.Sexp.of_string "((a 3 4))" in
104
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
105
+
[%expect
106
+
{|
107
+
(raised (
108
+
Of_sexp_error
109
+
"ppx_sexp_test.ml.Records.t_of_sexp: record conversion: only pairs expected, their first element must be an atom"
110
+
(invalid_sexp (a 3 4))))
111
+
|}]
112
+
;;
113
+
114
+
let%expect_test _ =
115
+
let sexp = Sexplib.Sexp.of_string "((c 3))" in
116
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
117
+
[%expect
118
+
{|
119
+
(raised (
120
+
Of_sexp_error
121
+
"ppx_sexp_test.ml.Records.t_of_sexp: extra fields found while some fields missing; extra fields: c; missing fields: a b"
122
+
(invalid_sexp ((c 3)))))
123
+
|}]
124
+
;;
125
+
126
+
let%expect_test _ =
127
+
let sexp = Sexplib.Sexp.of_string "((a 3))" in
128
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
129
+
[%expect
130
+
{|
131
+
(raised (
132
+
Of_sexp_error
133
+
"ppx_sexp_test.ml.Records.t_of_sexp: missing fields: b"
134
+
(invalid_sexp ((a 3)))))
135
+
|}]
136
+
;;
137
+
138
+
let%expect_test _ =
139
+
let sexp = Sexplib.Sexp.of_string "((a 3) (b ()) (c 1))" in
140
+
Expect_test_helpers_base.show_raise (fun () -> t_of_sexp sexp);
141
+
[%expect
142
+
{|
143
+
(raised (
144
+
Of_sexp_error
145
+
"ppx_sexp_test.ml.Records.t_of_sexp: extra fields: c"
146
+
(invalid_sexp ((a 3) (b ()) (c 1)))))
147
+
|}]
148
+
;;
149
+
end
150
+
151
+
module Inline_records = struct
152
+
type t =
153
+
| A of
154
+
{ a : int
155
+
; b : (float * string) list option
156
+
}
157
+
| B of int
158
+
[@@deriving sexp ~stackify, sexp_grammar]
159
+
160
+
let%test_unit _ =
161
+
let t = A { a = 2; b = Some [ 1., "a"; 2.3, "b" ] } in
162
+
let sexp = Sexplib.Sexp.of_string "(A (a 2)(b (((1 a)(2.3 b)))))" in
163
+
assert (t_of_sexp sexp = t);
164
+
assert (sexp_of_t t = sexp);
165
+
assert (sexp_of_t__stack t = sexp)
166
+
;;
167
+
end
168
+
169
+
module User_specified_conversion = struct
170
+
type my_float = float
171
+
172
+
let sexp_of_my_float n = Sexp.Atom (Printf.sprintf "%.4f" n)
173
+
let my_float_of_sexp = float_of_sexp
174
+
175
+
let%test_unit _ =
176
+
let my_float : my_float = 1.2 in
177
+
let sexp = Sexp.Atom "1.2000" in
178
+
assert (my_float_of_sexp sexp = my_float);
179
+
assert (sexp_of_my_float my_float = sexp)
180
+
;;
181
+
end
182
+
183
+
module Exceptions : sig
184
+
(* no sexp_grammars for exceptions, as they can't be parsed *)
185
+
exception E0 [@@deriving sexp]
186
+
exception E1 of string [@@deriving sexp]
187
+
exception E2 of string * int [@@deriving sexp]
188
+
exception E_tuple of (string * int) [@@deriving sexp]
189
+
190
+
exception
191
+
E_record of
192
+
{ a : string
193
+
; b : int
194
+
}
195
+
[@@deriving sexp]
196
+
end = struct
197
+
exception E0 [@@deriving sexp]
198
+
exception E1 of string [@@deriving sexp]
199
+
exception E2 of string * int [@@deriving sexp]
200
+
exception E_tuple of (string * int) [@@deriving sexp]
201
+
202
+
exception
203
+
E_record of
204
+
{ a : string
205
+
; b : int
206
+
}
207
+
[@@deriving sexp]
208
+
209
+
let%test_unit _ =
210
+
let cases =
211
+
[ E0, "ppx_sexp_test.ml.Exceptions.E0"
212
+
; E1 "a", "(ppx_sexp_test.ml.Exceptions.E1 a)"
213
+
; E2 ("b", 2), "(ppx_sexp_test.ml.Exceptions.E2 b 2)"
214
+
; E_tuple ("c", 3), "(ppx_sexp_test.ml.Exceptions.E_tuple(c 3))"
215
+
; E_record { a = "c"; b = 3 }, "(ppx_sexp_test.ml.Exceptions.E_record(a c)(b 3))"
216
+
]
217
+
in
218
+
List.iter
219
+
(fun (exn, sexp_as_str) ->
220
+
let sexp = Sexplib.Sexp.of_string sexp_as_str in
221
+
assert ([%sexp_of: exn] exn = sexp))
222
+
cases
223
+
;;
224
+
end
225
+
226
+
module Abstract_types_are_allowed_in_structures : sig
227
+
type t [@@deriving sexp ~stackify, sexp_grammar]
228
+
end = struct
229
+
type t [@@deriving sexp ~stackify, sexp_grammar]
230
+
end
231
+
232
+
module Manifest_types = struct
233
+
type a = { t : int }
234
+
type b = a = { t : int } [@@deriving sexp ~stackify, sexp_grammar]
235
+
end
236
+
237
+
module Uses_of_exn = struct
238
+
type t = int * exn [@@deriving sexp_of]
239
+
end
240
+
241
+
module Function_types : sig
242
+
type t1 = int -> unit [@@deriving sexp ~stackify, sexp_grammar]
243
+
244
+
type t2 = label:int -> ?optional:int -> unit -> unit
245
+
[@@deriving sexp ~stackify, sexp_grammar]
246
+
end = struct
247
+
type t1 = int -> unit [@@deriving sexp ~stackify, sexp_grammar]
248
+
249
+
type t2 = label:int -> ?optional:int -> unit -> unit
250
+
[@@deriving sexp ~stackify, sexp_grammar]
251
+
end
252
+
253
+
module No_unused_rec = struct
254
+
type r = { r : int } [@@deriving sexp ~stackify, sexp_grammar]
255
+
end
256
+
257
+
module Field_name_should_not_be_rewritten = struct
258
+
open No_unused_rec
259
+
260
+
type nonrec r = { r : r }
261
+
262
+
let _ = fun (r : r) -> r.r
263
+
end
264
+
265
+
module Polymorphic_variant_inclusion = struct
266
+
type sub1 =
267
+
[ `C1
268
+
| `C2
269
+
]
270
+
[@@deriving sexp ~stackify, sexp_grammar]
271
+
272
+
type 'b sub2 =
273
+
[ `C4
274
+
| `C5 of 'b
275
+
]
276
+
[@@deriving sexp ~stackify, sexp_grammar]
277
+
278
+
type ('a, 'b) t = [ sub1 | `C3 of [ `Nested of 'a ] | 'b sub2 | `C6 ] option
279
+
[@@deriving sexp ~stackify, sexp_grammar]
280
+
281
+
let%test_unit _ =
282
+
let cases : ((string * string, float) t * _) list =
283
+
[ None, "()"
284
+
; Some `C1, "(C1)"
285
+
; Some `C2, "(C2)"
286
+
; Some (`C3 (`Nested ("a", "b"))), "((C3 (Nested (a b))))"
287
+
; Some `C4, "(C4)"
288
+
; Some (`C5 1.5), "((C5 1.5))"
289
+
; Some `C6, "(C6)"
290
+
]
291
+
in
292
+
List.iter
293
+
(fun (t, sexp_as_str) ->
294
+
let sexp = Sexplib.Sexp.of_string sexp_as_str in
295
+
assert ([%of_sexp: (string * string, float) t] sexp = t);
296
+
assert ([%sexp_of: (string * string, float) t] t = sexp);
297
+
assert ([%sexp_of_stack: (string * string, float) t] t = sexp))
298
+
cases
299
+
;;
300
+
301
+
type sub1_alias = sub1 [@@deriving sexp_poly ~stackify, sexp_grammar]
302
+
303
+
type u =
304
+
[ `A
305
+
| sub1_alias
306
+
| `D
307
+
]
308
+
[@@deriving sexp ~stackify, sexp_grammar]
309
+
310
+
let%test_unit _ =
311
+
let cases : (u * _) list = [ `A, "A"; `C1, "C1"; `C2, "C2"; `D, "D" ] in
312
+
List.iter
313
+
(fun (u, sexp_as_str) ->
314
+
let sexp = Sexplib.Sexp.of_string sexp_as_str in
315
+
assert ([%of_sexp: u] sexp = u);
316
+
assert ([%sexp_of: u] u = sexp);
317
+
assert ([%sexp_of_stack: u] u = sexp))
318
+
cases
319
+
;;
320
+
end
321
+
322
+
module Polymorphic_record_field = struct
323
+
type 'x t =
324
+
{ poly : 'a 'b. 'a list
325
+
; maybe_x : 'x option
326
+
}
327
+
[@@deriving sexp ~stackify]
328
+
329
+
let%test_unit _ =
330
+
let t x = { poly = []; maybe_x = Some x } in
331
+
let sexp = Sexplib.Sexp.of_string "((poly ())(maybe_x (1)))" in
332
+
assert (t_of_sexp int_of_sexp sexp = t 1);
333
+
assert (sexp_of_t sexp_of_int (t 1) = sexp);
334
+
assert (sexp_of_t__stack sexp_of_int__stack (t 1) = sexp)
335
+
;;
336
+
end
337
+
338
+
module No_unused_value_warnings : sig end = struct
339
+
module No_warning : sig
340
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
341
+
end = struct
342
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
343
+
end
344
+
345
+
module Empty = struct end
346
+
347
+
module No_warning2 (X : sig
348
+
type t [@@deriving sexp ~stackify, sexp_grammar]
349
+
end) =
350
+
struct end
351
+
352
+
(* this one can't be handled (what if Empty was a functor, huh?) *)
353
+
(* module No_warning3(X : sig type t with sexp end) = Empty *)
354
+
module type S = sig
355
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
356
+
end
357
+
358
+
module No_warning4 : S = struct
359
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
360
+
end
361
+
362
+
module No_warning5 : S = (
363
+
(
364
+
struct
365
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
366
+
end :
367
+
S) :
368
+
S)
369
+
370
+
module Nested_functors
371
+
(M1 : sig
372
+
type t [@@deriving sexp ~stackify, sexp_grammar]
373
+
end)
374
+
(M2 : sig
375
+
type t [@@deriving sexp ~stackify, sexp_grammar]
376
+
end) =
377
+
struct end
378
+
379
+
let () =
380
+
let module M : sig
381
+
type t [@@deriving sexp ~stackify, sexp_grammar]
382
+
end = struct
383
+
type t [@@deriving sexp ~stackify, sexp_grammar]
384
+
end
385
+
in
386
+
()
387
+
;;
388
+
389
+
module Include = struct
390
+
include (
391
+
struct
392
+
type t = int [@@deriving sexp ~stackify, sexp_grammar]
393
+
end :
394
+
sig
395
+
type t [@@deriving sexp ~stackify, sexp_grammar]
396
+
end
397
+
with type t := int)
398
+
end
399
+
end
400
+
401
+
module Default = struct
402
+
type t = { a : int [@default 2] } [@@deriving sexp ~stackify, sexp_grammar]
403
+
404
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t { a = 1 }
405
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "2" ] ]) = sexp_of_t { a = 2 }
406
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t__stack { a = 1 }
407
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "2" ] ]) = sexp_of_t__stack { a = 2 }
408
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = { a = 1 }
409
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "2" ] ]) = { a = 2 }
410
+
let%test _ = t_of_sexp Sexp.(List []) = { a = 2 }
411
+
end
412
+
413
+
module Type_alias = struct
414
+
(* checking that the [as 'a] is supported and ignored in signatures, that it still
415
+
exports the sexp_of_t__ when needed *)
416
+
module B : sig
417
+
type a = [ `A ]
418
+
type t = [ `A ] as 'a constraint 'a = a [@@deriving sexp ~stackify, sexp_grammar]
419
+
end = struct
420
+
type a = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
421
+
type t = [ `A ] [@@deriving sexp ~stackify, sexp_grammar]
422
+
end
423
+
424
+
let%test _ = Sexp.to_string (B.sexp_of_t `A) = "A"
425
+
let%test _ = `A = B.t_of_sexp (Sexplib.Sexp.of_string "A")
426
+
427
+
module B2 = struct
428
+
type t =
429
+
[ B.t
430
+
| `B
431
+
]
432
+
[@@deriving sexp ~stackify, sexp_grammar]
433
+
end
434
+
435
+
module C : sig
436
+
type t = int as 'a [@@deriving sexp ~stackify, sexp_grammar]
437
+
end = struct
438
+
type t = int [@@deriving sexp ~stackify, sexp_grammar]
439
+
end
440
+
441
+
module D : sig
442
+
type t = 'a constraint 'a = int [@@deriving sexp ~stackify, sexp_grammar]
443
+
end = struct
444
+
type t = int [@@deriving sexp ~stackify, sexp_grammar]
445
+
end
446
+
end
447
+
448
+
module Tricky_variants = struct
449
+
(* Checking that the generated code compiles (there used to be a problem with subtyping
450
+
constraints preventing proper generalization). *)
451
+
type t = [ `a ] [@@deriving sexp ~stackify, sexp_grammar]
452
+
type 'a u = [ t | `b of 'a ] * int [@@deriving sexp ~stackify, sexp_grammar]
453
+
end
454
+
455
+
module Drop_default = struct
456
+
open! Base
457
+
open Expect_test_helpers_base
458
+
459
+
type t = { a : int } [@@deriving equal]
460
+
461
+
let test ?cr t_of_sexp sexp_of_t sexp_of_t__stack =
462
+
let ( = ) = Sexp.equal in
463
+
require ?cr (Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t { a = 1 });
464
+
require ?cr (Sexp.(List []) = sexp_of_t { a = 2 });
465
+
let ( = ) = Sexp.equal__local in
466
+
require ?cr (Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t__stack { a = 1 });
467
+
require ?cr (Sexp.(List []) = sexp_of_t__stack { a = 2 });
468
+
let ( = ) = equal in
469
+
require ?cr (t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = { a = 1 });
470
+
require ?cr (t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "2" ] ]) = { a = 2 });
471
+
require ?cr (t_of_sexp Sexp.(List []) = { a = 2 })
472
+
;;
473
+
474
+
type my_int = int [@@deriving sexp ~stackify, sexp_grammar]
475
+
476
+
module Poly = struct
477
+
type nonrec t = t = { a : my_int [@default 2] [@sexp_drop_default Poly.( = )] }
478
+
[@@deriving sexp ~stackify, sexp_grammar]
479
+
480
+
let%test_unit _ = test t_of_sexp sexp_of_t sexp_of_t__stack
481
+
end
482
+
483
+
module Equal = struct
484
+
let equal_my_int = equal_int
485
+
486
+
type nonrec t = t = { a : my_int [@default 2] [@sexp_drop_default.equal] }
487
+
[@@deriving sexp ~stackify, sexp_grammar]
488
+
489
+
let%test_unit _ = test t_of_sexp sexp_of_t sexp_of_t__stack
490
+
end
491
+
492
+
module Compare = struct
493
+
let compare_my_int = compare_int
494
+
495
+
type nonrec t = t = { a : my_int [@default 2] [@sexp_drop_default.compare] }
496
+
[@@deriving sexp ~stackify, sexp_grammar]
497
+
498
+
let%test_unit _ = test t_of_sexp sexp_of_t sexp_of_t__stack
499
+
end
500
+
501
+
module Sexp = struct
502
+
type nonrec t = t = { a : my_int [@default 2] [@sexp_drop_default.sexp] }
503
+
[@@deriving sexp ~stackify, sexp_grammar]
504
+
505
+
let%test_unit _ = test t_of_sexp sexp_of_t sexp_of_t__stack
506
+
end
507
+
end
508
+
509
+
module Drop_if = struct
510
+
type t = { a : int [@default 2] [@sexp_drop_if fun x -> x mod 2 = 0] }
511
+
[@@deriving sexp ~stackify, sexp_grammar]
512
+
513
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t { a = 1 }
514
+
let%test _ = Sexp.(List []) = sexp_of_t { a = 2 }
515
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "3" ] ]) = sexp_of_t { a = 3 }
516
+
let%test _ = Sexp.(List []) = sexp_of_t { a = 4 }
517
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = sexp_of_t__stack { a = 1 }
518
+
let%test _ = Sexp.(List []) = sexp_of_t__stack { a = 2 }
519
+
let%test _ = Sexp.(List [ List [ Atom "a"; Atom "3" ] ]) = sexp_of_t__stack { a = 3 }
520
+
let%test _ = Sexp.(List []) = sexp_of_t__stack { a = 4 }
521
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "1" ] ]) = { a = 1 }
522
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "2" ] ]) = { a = 2 }
523
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "3" ] ]) = { a = 3 }
524
+
let%test _ = t_of_sexp Sexp.(List [ List [ Atom "a"; Atom "4" ] ]) = { a = 4 }
525
+
let%test _ = t_of_sexp Sexp.(List []) = { a = 2 }
526
+
527
+
type u =
528
+
{ a : int
529
+
[@sexp_drop_if
530
+
fun x ->
531
+
(* pa_type_conv used to drop parens altogether, causing type errors in the
532
+
following code *)
533
+
let pair = x, 2 in
534
+
match Some pair with
535
+
| None -> true
536
+
| Some (x, y) -> x = y]
537
+
}
538
+
[@@deriving sexp ~stackify, sexp_grammar]
539
+
end
540
+
541
+
module Omit_nil = struct
542
+
type natural_option = int
543
+
544
+
let sexp_of_natural_option i = if i >= 0 then sexp_of_int i else sexp_of_unit ()
545
+
546
+
let sexp_of_natural_option__stack i =
547
+
if i >= 0 then sexp_of_int__stack i else sexp_of_unit__stack ()
548
+
;;
549
+
550
+
let natural_option_of_sexp = function
551
+
| Sexp.List [] -> -1
552
+
| sexp -> int_of_sexp sexp
553
+
;;
554
+
555
+
let natural_option_sexp_grammar : natural_option Sexplib0.Sexp_grammar.t =
556
+
{ untyped = Union [ List Empty; Integer ] }
557
+
;;
558
+
559
+
let check sexp_of_t sexp_of_t__stack t_of_sexp str t =
560
+
let sexp = Sexplib.Sexp.of_string str in
561
+
assert (sexp = sexp_of_t t);
562
+
assert (sexp = sexp_of_t__stack t);
563
+
assert (t_of_sexp sexp = t)
564
+
;;
565
+
566
+
type t = { a : natural_option [@sexp.omit_nil] }
567
+
[@@deriving sexp ~stackify, sexp_grammar]
568
+
569
+
let%test_unit _ = check sexp_of_t sexp_of_t__stack t_of_sexp "()" { a = -1 }
570
+
let%test_unit _ = check sexp_of_t sexp_of_t__stack t_of_sexp "((a 1))" { a = 1 }
571
+
572
+
type t2 = A of { a : int list [@sexp.omit_nil] }
573
+
[@@deriving sexp ~stackify, sexp_grammar]
574
+
575
+
let%test_unit _ = check sexp_of_t2 sexp_of_t2__stack t2_of_sexp "(A)" (A { a = [] })
576
+
577
+
let%test_unit _ =
578
+
check sexp_of_t2 sexp_of_t2__stack t2_of_sexp "(A (a (1)))" (A { a = [ 1 ] })
579
+
;;
580
+
end
581
+
582
+
module No_unused_rec_warning = struct
583
+
type r = { field : r -> unit } [@@deriving sexp_of ~stackify]
584
+
end
585
+
586
+
module True_and_false = struct
587
+
type t =
588
+
| True
589
+
| False
590
+
[@@deriving sexp ~stackify, sexp_grammar]
591
+
592
+
let%test _ = sexp_of_t True = Atom "True"
593
+
let%test _ = sexp_of_t False = Atom "False"
594
+
let%test _ = sexp_of_t__stack True = Atom "True"
595
+
let%test _ = sexp_of_t__stack False = Atom "False"
596
+
let%test _ = True = t_of_sexp (Sexplib.Sexp.of_string "True")
597
+
let%test _ = False = t_of_sexp (Sexplib.Sexp.of_string "False")
598
+
let%test _ = True = t_of_sexp (Sexplib.Sexp.of_string "true")
599
+
let%test _ = False = t_of_sexp (Sexplib.Sexp.of_string "false")
600
+
601
+
type u =
602
+
| True of int
603
+
| False of int
604
+
[@@deriving sexp ~stackify, sexp_grammar]
605
+
606
+
let%test _ = sexp_of_u (True 1) = List [ Atom "True"; Atom "1" ]
607
+
let%test _ = sexp_of_u (False 2) = List [ Atom "False"; Atom "2" ]
608
+
let%test _ = sexp_of_u__stack (True 1) = List [ Atom "True"; Atom "1" ]
609
+
let%test _ = sexp_of_u__stack (False 2) = List [ Atom "False"; Atom "2" ]
610
+
let%test _ = True 1 = u_of_sexp (Sexplib.Sexp.of_string "(True 1)")
611
+
let%test _ = False 2 = u_of_sexp (Sexplib.Sexp.of_string "(False 2)")
612
+
let%test _ = True 1 = u_of_sexp (Sexplib.Sexp.of_string "(true 1)")
613
+
let%test _ = False 2 = u_of_sexp (Sexplib.Sexp.of_string "(false 2)")
614
+
615
+
exception True [@@deriving sexp]
616
+
617
+
let%test _ = "ppx_sexp_test.ml.True_and_false.True" = Sexp.to_string (sexp_of_exn True)
618
+
619
+
exception False of int [@@deriving sexp]
620
+
621
+
let%test _ =
622
+
"(ppx_sexp_test.ml.True_and_false.False 1)" = Sexp.to_string (sexp_of_exn (False 1))
623
+
;;
624
+
625
+
type v =
626
+
[ `True
627
+
| `False of int
628
+
]
629
+
[@@deriving sexp ~stackify, sexp_grammar]
630
+
631
+
let%test _ = sexp_of_v `True = Atom "True"
632
+
let%test _ = sexp_of_v (`False 2) = List [ Atom "False"; Atom "2" ]
633
+
let%test _ = sexp_of_v__stack `True = Atom "True"
634
+
let%test _ = sexp_of_v__stack (`False 2) = List [ Atom "False"; Atom "2" ]
635
+
end
636
+
637
+
module Gadt = struct
638
+
let is_eq sexp str =
639
+
let sexp2 = Sexplib.Sexp.of_string str in
640
+
if sexp <> sexp2
641
+
then (
642
+
Printf.printf "%S vs %S\n%!" (Sexp.to_string sexp) str;
643
+
assert false)
644
+
;;
645
+
646
+
let is_eq_local sexp str = assert (sexp = Sexplib.Sexp.of_string str)
647
+
648
+
(* plain type without argument *)
649
+
type 'a s = Packed : 'a s [@@deriving sexp_of ~stackify]
650
+
651
+
let%test_unit _ = is_eq ([%sexp_of: int s] Packed) "Packed"
652
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: int s] Packed) "Packed"
653
+
654
+
(* two kind of existential variables *)
655
+
type 'a t = Packed : 'a * _ * ('b[@sexp.opaque]) -> 'a t [@warning "-3"]
656
+
[@@deriving sexp_of ~stackify]
657
+
658
+
let%test_unit _ =
659
+
is_eq ([%sexp_of: int t] (Packed (2, "asd", 1.))) "(Packed 2 _ <opaque>)"
660
+
;;
661
+
662
+
let%test_unit _ =
663
+
is_eq_local ([%sexp_of_stack: int t] (Packed (2, "asd", 1.))) "(Packed 2 _ <opaque>)"
664
+
;;
665
+
666
+
(* plain type with argument *)
667
+
type 'a u = A : 'a -> 'a u [@@deriving sexp_of ~stackify]
668
+
669
+
let%test_unit _ = is_eq ([%sexp_of: int u] (A 2)) "(A 2)"
670
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: int u] (A 2)) "(A 2)"
671
+
672
+
(* recursive *)
673
+
type v = A : v option -> v [@@deriving sexp_of ~stackify]
674
+
675
+
let%test_unit _ = is_eq ([%sexp_of: v] (A (Some (A None)))) "(A((A())))"
676
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: v] (A (Some (A None)))) "(A((A())))"
677
+
678
+
(* implicit existential variable *)
679
+
type w = A : 'a * int * ('a -> string) -> w [@@deriving sexp_of ~stackify]
680
+
681
+
let%test_unit _ = is_eq ([%sexp_of: w] (A (1., 2, string_of_float))) "(A _ 2 <fun>)"
682
+
683
+
let%test_unit _ =
684
+
is_eq_local ([%sexp_of_stack: w] (A (1., 2, string_of_float))) "(A _ 2 <fun>)"
685
+
;;
686
+
687
+
(* tricky variable naming *)
688
+
type 'a x = A : 'a -> 'b x [@@deriving sexp_of ~stackify]
689
+
690
+
let%test_unit _ = is_eq ([%sexp_of: int x] (A 1.)) "(A _)"
691
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: int x] (A 1.)) "(A _)"
692
+
693
+
(* interaction with inline record *)
694
+
type _ x2 = A : { x : 'c } -> 'c x2 [@@deriving sexp_of ~stackify]
695
+
696
+
let%test_unit _ = is_eq ([%sexp_of: int x2] (A { x = 1 })) "(A (x 1))"
697
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: int x2] (A { x = 1 })) "(A (x 1))"
698
+
699
+
(* unused but colliding variables *)
700
+
type (_, _) y = A : ('a, 'a) y [@@deriving sexp_of ~stackify]
701
+
702
+
let%test_unit _ = is_eq ([%sexp_of: (int, int) y] A) "A"
703
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: (int, int) y] A) "A"
704
+
705
+
(* making sure we're not reversing parameters *)
706
+
type (_, _) z = A : ('a * 'b) -> ('a, 'b) z [@@deriving sexp_of ~stackify]
707
+
708
+
let%test_unit _ = is_eq ([%sexp_of: (int, string) z] (A (1, "a"))) "(A (1 a))"
709
+
710
+
let%test_unit _ =
711
+
is_eq_local ([%sexp_of_stack: (int, string) z] (A (1, "a"))) "(A (1 a))"
712
+
;;
713
+
714
+
(* interaction with universal quantifiers *)
715
+
type _ z2 = A : { x : 'c. 'c option } -> 'c z2 [@@deriving sexp_of ~stackify]
716
+
717
+
let%test_unit _ = is_eq ([%sexp_of: unit z2] (A { x = None })) "(A (x ()))"
718
+
let%test_unit _ = is_eq_local ([%sexp_of_stack: unit z2] (A { x = None })) "(A (x ()))"
719
+
end
720
+
721
+
module Anonymous_variable = struct
722
+
type _ t = int [@@deriving sexp ~stackify, sexp_grammar]
723
+
724
+
let%test _ = [%sexp_of: _ t] 2 = Atom "2"
725
+
let%test _ = [%sexp_of_stack: _ t] 2 = Atom "2"
726
+
let%test _ = [%of_sexp: _ t] (Sexplib.Sexp.of_string "2") = 2
727
+
728
+
(* making sure we don't generate signatures like (_ -> Sexp.t) -> _ t -> Sexp.t which
729
+
are too general *)
730
+
module M : sig
731
+
type _ t [@@deriving sexp ~stackify, sexp_grammar]
732
+
end = struct
733
+
type 'a t = 'a [@@deriving sexp ~stackify, sexp_grammar]
734
+
end
735
+
end
736
+
737
+
module Record_field_disambiguation = struct
738
+
type a =
739
+
{ fl : float
740
+
; b : b
741
+
}
742
+
743
+
and b = { fl : int } [@@deriving sexp ~stackify, sexp_grammar]
744
+
end
745
+
746
+
module Private = struct
747
+
type t = private int [@@deriving sexp_of ~stackify]
748
+
type ('a, 'b) u = private t [@@deriving sexp_of ~stackify]
749
+
type ('a, 'b, 'c) v = private ('a, 'b) u [@@deriving sexp_of ~stackify]
750
+
end
751
+
752
+
module Nonregular_types = struct
753
+
type 'a nonregular =
754
+
| Leaf of 'a
755
+
| Branch of ('a * 'a) nonregular
756
+
[@@deriving sexp ~stackify, sexp_grammar]
757
+
758
+
type 'a variant = [ `A of 'a ] [@@deriving sexp ~stackify, sexp_grammar]
759
+
760
+
type ('a, 'b) nonregular_with_variant =
761
+
| Branch of ([ | 'a list variant ], 'b) nonregular_with_variant
762
+
[@@deriving sexp ~stackify, sexp_grammar]
763
+
end
764
+
765
+
module Opaque = struct
766
+
type t = (int[@sexp.opaque]) list [@@deriving sexp ~stackify, sexp_grammar]
767
+
768
+
let sexp = Sexplib.Sexp.of_string "(<opaque> <opaque>)"
769
+
let t = [ 1; 2 ]
770
+
let%test _ = sexp_of_t t = sexp
771
+
let%test _ = sexp_of_t__stack t = sexp
772
+
773
+
let%test _ =
774
+
match t_of_sexp sexp with
775
+
| _ -> false
776
+
| exception _ -> true
777
+
;;
778
+
779
+
type u = ([ `A of int ][@sexp.opaque]) [@@deriving sexp ~stackify, sexp_grammar]
780
+
781
+
let sexp = Sexplib.Sexp.of_string "<opaque>"
782
+
let u = `A 1
783
+
let%test _ = sexp_of_u u = sexp
784
+
let%test _ = sexp_of_u__stack u = sexp
785
+
786
+
let%test _ =
787
+
match u_of_sexp sexp with
788
+
| _ -> false
789
+
| exception _ -> true
790
+
;;
791
+
end
792
+
793
+
module Optional = struct
794
+
type t = { optional : int option [@sexp.option] }
795
+
[@@deriving sexp ~stackify, sexp_grammar]
796
+
797
+
let sexp = Sexplib.Sexp.of_string "()"
798
+
let t = { optional = None }
799
+
let%test _ = t_of_sexp sexp = t
800
+
let%test _ = sexp_of_t t = sexp
801
+
let%test _ = sexp_of_t__stack t = sexp
802
+
let sexp = Sexplib.Sexp.of_string "((optional 5))"
803
+
let t = { optional = Some 5 }
804
+
let%test _ = t_of_sexp sexp = t
805
+
let%test _ = sexp_of_t__stack t = sexp
806
+
end
807
+
808
+
module Nullable = struct
809
+
type t = { nullable : int or_null [@sexp.or_null] }
810
+
[@@deriving sexp ~stackify, sexp_grammar]
811
+
812
+
let sexp = Sexplib.Sexp.of_string "()"
813
+
let t = { nullable = Null }
814
+
let%test _ = t_of_sexp sexp = t
815
+
let%test _ = sexp_of_t t = sexp
816
+
let%test _ = sexp_of_t__stack t = sexp
817
+
let sexp = Sexplib.Sexp.of_string "((nullable 5))"
818
+
let t = { nullable = This 5 }
819
+
let%test _ = t_of_sexp sexp = t
820
+
let%test _ = sexp_of_t__stack t = sexp
821
+
end
822
+
823
+
module Nonempty = struct
824
+
type t =
825
+
{ list : int list [@sexp.list]
826
+
; array : int array [@sexp.array]
827
+
}
828
+
[@@deriving sexp ~stackify, sexp_grammar]
829
+
830
+
let sexp = Sexplib.Sexp.of_string "()"
831
+
let t = { list = []; array = [||] }
832
+
let%test _ = t_of_sexp sexp = t
833
+
let%test _ = sexp_of_t t = sexp
834
+
let%test _ = sexp_of_t__stack t = sexp
835
+
let sexp = Sexplib.Sexp.of_string "((list (1 2 3)) (array (3 2 1)))"
836
+
let t = { list = [ 1; 2; 3 ]; array = [| 3; 2; 1 |] }
837
+
let%test _ = t_of_sexp sexp = t
838
+
let%test _ = sexp_of_t t = sexp
839
+
let%test _ = sexp_of_t__stack t = sexp
840
+
end
841
+
842
+
module Boolean = struct
843
+
type t = { no_arg : bool [@sexp.bool] } [@@deriving sexp ~stackify, sexp_grammar]
844
+
845
+
let sexp = Sexplib.Sexp.of_string "()"
846
+
let t = { no_arg = false }
847
+
let%test _ = t_of_sexp sexp = t
848
+
let%test _ = sexp_of_t t = sexp
849
+
let%test _ = sexp_of_t__stack t = sexp
850
+
let sexp = Sexplib.Sexp.of_string "((no_arg))"
851
+
let t = { no_arg = true }
852
+
let%test _ = t_of_sexp sexp = t
853
+
let%test _ = sexp_of_t t = sexp
854
+
let%test _ = sexp_of_t__stack t = sexp
855
+
856
+
type t_allow_extra_fields = { no_arg : bool [@sexp.bool] }
857
+
[@@deriving sexp ~stackify, sexp_grammar] [@@sexp.allow_extra_fields]
858
+
859
+
let%expect_test _ =
860
+
Expect_test_helpers_base.require_does_raise ~cr:CR_soon (fun () ->
861
+
let r = t_allow_extra_fields_of_sexp (Sexplib.Sexp.of_string "((no_arg true))") in
862
+
print_endline (Bool.to_string r.no_arg));
863
+
[%expect
864
+
{|
865
+
(Of_sexp_error
866
+
"ppx_sexp_test.ml.Boolean.t_allow_extra_fields_of_sexp: record conversion: a [sexp.bool] field was given a payload"
867
+
(invalid_sexp ((no_arg true))))
868
+
|}]
869
+
;;
870
+
end
871
+
872
+
module Inline = struct
873
+
type t = A of int list [@sexp.list] [@@deriving sexp ~stackify, sexp_grammar]
874
+
875
+
let sexp = Sexplib.Sexp.of_string "(A 1 2 3)"
876
+
let t = A [ 1; 2; 3 ]
877
+
let%test _ = t_of_sexp sexp = t
878
+
let%test _ = sexp_of_t t = sexp
879
+
let%test _ = sexp_of_t__stack t = sexp
880
+
881
+
type u = [ `A of int list [@sexp.list] ] [@@deriving sexp ~stackify, sexp_grammar]
882
+
883
+
let sexp = Sexplib.Sexp.of_string "(A 1 2 3)"
884
+
let u = `A [ 1; 2; 3 ]
885
+
let%test _ = u_of_sexp sexp = u
886
+
let%test _ = sexp_of_u u = sexp
887
+
let%test _ = sexp_of_u__stack u = sexp
888
+
end
889
+
890
+
module Variance = struct
891
+
type (+'a, -'b, 'c, +_, -_, _) t [@@deriving sexp ~stackify, sexp_grammar]
892
+
end
893
+
894
+
module Clash = struct
895
+
(* Same name for type-var and type-name; must be careful when introducing rigid type names. *)
896
+
type 'hey hey = Hey of 'hey [@@deriving sexp ~stackify, sexp_grammar]
897
+
type 'hey rigid_hey = Hey of 'hey [@@deriving sexp ~stackify, sexp_grammar]
898
+
type ('foo, 'rigid_foo) foo = Foo of 'foo [@@deriving sexp ~stackify, sexp_grammar]
899
+
type 'rigid_bar rigid_rigid_bar = Bar [@@deriving sexp ~stackify, sexp_grammar]
900
+
end
901
+
902
+
module Applicative_functor_types = struct
903
+
module Bidirectional_map = struct
904
+
type ('k1, 'k2) t
905
+
906
+
module S
907
+
(K1 : sig
908
+
type t
909
+
end)
910
+
(K2 : sig
911
+
type t
912
+
end) =
913
+
struct
914
+
type nonrec t = (K1.t, K2.t) t
915
+
end
916
+
917
+
module type Of_sexpable = sig
918
+
type t [@@deriving of_sexp]
919
+
end
920
+
921
+
let s__t_of_sexp
922
+
(type k1 k2)
923
+
(module K1 : Of_sexpable with type t = k1)
924
+
(module K2 : Of_sexpable with type t = k2)
925
+
(_ : Sexp.t)
926
+
: (k1, k2) t
927
+
=
928
+
assert false
929
+
;;
930
+
931
+
module type Grammarable = sig
932
+
type t [@@deriving sexp_grammar]
933
+
end
934
+
935
+
(* You would actually have to write this manually for functors. *)
936
+
let s__t_sexp_grammar
937
+
(type k1 k2)
938
+
(module K1 : Grammarable with type t = k1)
939
+
(module K2 : Grammarable with type t = k2)
940
+
=
941
+
[%sexp_grammar: (K1.t * K2.t) list]
942
+
;;
943
+
end
944
+
945
+
module Int = struct
946
+
type t = int [@@deriving of_sexp, sexp_grammar]
947
+
end
948
+
949
+
module String = struct
950
+
type t = string [@@deriving of_sexp, sexp_grammar]
951
+
end
952
+
953
+
module M : sig
954
+
type t = Bidirectional_map.S(String)(Int).t [@@deriving of_sexp, sexp_grammar]
955
+
end = struct
956
+
type t = Bidirectional_map.S(String)(Int).t [@@deriving of_sexp, sexp_grammar]
957
+
end
958
+
end
959
+
960
+
module Type_extensions = struct
961
+
let _ = ([%sexp_of: int] : [%sexp_of: int])
962
+
let _ = ([%of_sexp: int] : [%of_sexp: int])
963
+
end
964
+
965
+
module Allow_extra_fields = struct
966
+
let should_raise f x =
967
+
try
968
+
ignore (f x);
969
+
false
970
+
with
971
+
| _ -> true
972
+
;;
973
+
974
+
module M1 = struct
975
+
type t1 = { a : int } [@@deriving sexp ~stackify]
976
+
977
+
type t2 = t1 = { a : int }
978
+
[@@deriving sexp ~stackify, sexp_grammar] [@@sexp.allow_extra_fields]
979
+
980
+
let sexp = Sexplib.Sexp.of_string "((a 1))"
981
+
let sexp_extra = Sexplib.Sexp.of_string "((a 1)(b 2))"
982
+
let%test _ = t2_of_sexp sexp = t2_of_sexp sexp_extra
983
+
let%test _ = t1_of_sexp sexp = t2_of_sexp sexp
984
+
let%test _ = should_raise t1_of_sexp sexp_extra
985
+
986
+
let%expect_test _ =
987
+
Expect_test_helpers_base.require_does_raise ~cr:CR_soon (fun () ->
988
+
t2_of_sexp (Sexplib.Sexp.of_string "((a 1)(a))"));
989
+
[%expect
990
+
{|
991
+
(Of_sexp_error
992
+
"ppx_sexp_test.ml.Allow_extra_fields.M1.t2_of_sexp: duplicate fields: a"
993
+
(invalid_sexp ((a 1) (a))))
994
+
|}]
995
+
;;
996
+
end
997
+
998
+
module M2 = struct
999
+
type t1 = A of { a : int list } [@@deriving sexp ~stackify]
1000
+
1001
+
type t2 = t1 = A of { a : int list } [@sexp.allow_extra_fields]
1002
+
[@@deriving sexp ~stackify, sexp_grammar]
1003
+
1004
+
let sexp = Sexplib.Sexp.of_string "(A (a (0)))"
1005
+
let sexp_extra = Sexplib.Sexp.of_string "(A (a (0))(b 2))"
1006
+
let%test _ = t2_of_sexp sexp = t2_of_sexp sexp_extra
1007
+
let%test _ = t1_of_sexp sexp = t2_of_sexp sexp
1008
+
let%test _ = should_raise t1_of_sexp sexp_extra
1009
+
end
1010
+
end
1011
+
1012
+
module Default_values_and_polymorphism = struct
1013
+
type t =
1014
+
{ a : int list [@sexp.list]
1015
+
; b : 'b. 'b -> int
1016
+
}
1017
+
[@@deriving of_sexp]
1018
+
end
1019
+
1020
+
module Type_parameter_with_constraint = struct
1021
+
type 'a t = Foo constraint 'a = [< `Foo ] [@@deriving sexp]
1022
+
end
vendor/opam/ppx_sexp_conv/test/ppx_sexp_test.mli
vendor/opam/ppx_sexp_conv/test/ppx_sexp_test.mli
This is a binary file and will not be displayed.
+5
vendor/opam/ppx_sexp_conv/test/pretty/dune
+5
vendor/opam/ppx_sexp_conv/test/pretty/dune
+47
vendor/opam/ppx_sexp_conv/test/pretty/phantom.ml
+47
vendor/opam/ppx_sexp_conv/test/pretty/phantom.ml
···
1
+
[@@@ocamlformat "disable"]
2
+
[@@@warning "-32-60"]
3
+
module M : sig
4
+
type ('a[@phantom] : any, 'b) t = 'b
5
+
[@@deriving_inline sexp]
6
+
val sexp_of_t :
7
+
('a : any) 'b .
8
+
('b -> Sexplib0.Sexp.t) -> (('a : any), 'b) t -> Sexplib0.Sexp.t
9
+
val t_of_sexp :
10
+
('a : any) 'b .
11
+
(Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> (('a : any), 'b) t
12
+
[@@@end]
13
+
14
+
type ('a [@phantom] : any, 'b) alias = ('a, 'b) t
15
+
[@@deriving_inline sexp]
16
+
val sexp_of_alias :
17
+
('a : any) 'b .
18
+
('b -> Sexplib0.Sexp.t) -> (('a : any), 'b) alias -> Sexplib0.Sexp.t
19
+
val alias_of_sexp :
20
+
('a : any) 'b .
21
+
(Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> (('a : any), 'b) alias
22
+
[@@@end]
23
+
end = struct
24
+
type ('a[@phantom] : any, 'b) t = 'b
25
+
[@@deriving_inline sexp]
26
+
let t_of_sexp :
27
+
'b ('a : any) .
28
+
(Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> (('a : any), 'b) t
29
+
= fun _of_b__002_ -> _of_b__002_
30
+
let sexp_of_t :
31
+
'b ('a : any) .
32
+
('b -> Sexplib0.Sexp.t) -> (('a : any), 'b) t -> Sexplib0.Sexp.t
33
+
= fun _of_b__005_ -> _of_b__005_
34
+
[@@@end]
35
+
36
+
type ('a [@phantom] : any, 'b) alias = ('a[@phantom], 'b) t
37
+
[@@deriving_inline sexp]
38
+
let alias_of_sexp :
39
+
'b ('a : any) .
40
+
(Sexplib0.Sexp.t -> 'b) -> Sexplib0.Sexp.t -> (('a : any), 'b) alias
41
+
= t_of_sexp
42
+
let sexp_of_alias :
43
+
'b ('a : any) .
44
+
('b -> Sexplib0.Sexp.t) -> (('a : any), 'b) alias -> Sexplib0.Sexp.t
45
+
= sexp_of_t
46
+
[@@@end]
47
+
end
+1
vendor/opam/ppx_sexp_conv/test/pretty/phantom.mli
+1
vendor/opam/ppx_sexp_conv/test/pretty/phantom.mli
···
1
+
(*_ This file is intentionally left blank. *)
+1
vendor/opam/ppx_sexp_conv/test/pretty/ppx_sexp_conv_test_pretty.ml
+1
vendor/opam/ppx_sexp_conv/test/pretty/ppx_sexp_conv_test_pretty.ml
···
1
+
(*_ This file is intentionally left blank. *)
+18
vendor/opam/ppx_sexp_conv/test/sexp_grammar/dune
+18
vendor/opam/ppx_sexp_conv/test/sexp_grammar/dune
···
1
+
(library
2
+
(name ppx_sexp_conv_test_sexp_grammar)
3
+
(libraries base expect_test_helpers_core.expect_test_helpers_base
4
+
sexp_grammar)
5
+
(preprocess
6
+
(pps ppx_sexp_conv ppx_expect ppx_here)))
7
+
8
+
(rule
9
+
(targets regular_vs_polymorphic_variants.diff)
10
+
(deps test_regular_variants.ml test_polymorphic_variants.ml)
11
+
(mode promote)
12
+
(action
13
+
(bash
14
+
"%{bin:patdiff-for-review} %{bin:patdiff} %{deps} > %{targets} || true")))
15
+
16
+
(alias
17
+
(name default)
18
+
(deps regular_vs_polymorphic_variants.diff))
+18
vendor/opam/ppx_sexp_conv/test/sexp_grammar/ppx_sexp_conv_test_sexp_grammar.ml
+18
vendor/opam/ppx_sexp_conv/test/sexp_grammar/ppx_sexp_conv_test_sexp_grammar.ml
···
1
+
module Test_allow_extra_fields = Test_allow_extra_fields
2
+
module Test_attributes = Test_attributes
3
+
module Test_base_map = Test_base_map
4
+
module Test_coverage_for_deriving = Test_coverage_for_deriving
5
+
module Test_extension = Test_extension
6
+
module Test_functors = Test_functors
7
+
module Test_gadt = Test_gadt
8
+
module Test_modalities = Test_modalities
9
+
module Test_nonrec = Test_nonrec
10
+
module Test_opaque = Test_opaque
11
+
module Test_polymorphic_variants = Test_polymorphic_variants
12
+
module Test_polymorphism = Test_polymorphism
13
+
module Test_recursive_groups = Test_recursive_groups
14
+
module Test_regular_variants = Test_regular_variants
15
+
module Test_tag_type_names = Test_tag_type_names
16
+
module Test_tags = Test_tags
17
+
module Test_test = Test_test
18
+
module Test_variants_more = Test_variants_more
+113
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_allow_extra_fields.ml
+113
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_allow_extra_fields.ml
···
1
+
open! Base
2
+
3
+
module _ = struct
4
+
type t = { a : int } [@@sexp.allow_extra_fields] [@@deriving_inline sexp_grammar]
5
+
6
+
let _ = fun (_ : t) -> ()
7
+
8
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
9
+
{ untyped =
10
+
List
11
+
(Fields
12
+
{ allow_extra_fields = true
13
+
; fields =
14
+
[ No_tag
15
+
{ name = "a"
16
+
; required = true
17
+
; args = Cons (int_sexp_grammar.untyped, Empty)
18
+
}
19
+
]
20
+
})
21
+
}
22
+
;;
23
+
24
+
let _ = t_sexp_grammar
25
+
26
+
[@@@end]
27
+
end
28
+
29
+
module _ = struct
30
+
type t = { a : int } [@@deriving_inline sexp_grammar]
31
+
32
+
let _ = fun (_ : t) -> ()
33
+
34
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
35
+
{ untyped =
36
+
List
37
+
(Fields
38
+
{ allow_extra_fields = false
39
+
; fields =
40
+
[ No_tag
41
+
{ name = "a"
42
+
; required = true
43
+
; args = Cons (int_sexp_grammar.untyped, Empty)
44
+
}
45
+
]
46
+
})
47
+
}
48
+
;;
49
+
50
+
let _ = t_sexp_grammar
51
+
52
+
[@@@end]
53
+
end
54
+
55
+
module _ = struct
56
+
type t =
57
+
| Allow_extra_fields of { foo : int } [@sexp.allow_extra_fields]
58
+
| Forbid_extra_fields of { bar : int }
59
+
[@@deriving_inline sexp_grammar]
60
+
61
+
let _ = fun (_ : t) -> ()
62
+
63
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
64
+
{ untyped =
65
+
Variant
66
+
{ case_sensitivity = Case_sensitive_except_first_character
67
+
; clauses =
68
+
[ No_tag
69
+
{ name = "Allow_extra_fields"
70
+
; clause_kind =
71
+
List_clause
72
+
{ args =
73
+
Fields
74
+
{ allow_extra_fields = true
75
+
; fields =
76
+
[ No_tag
77
+
{ name = "foo"
78
+
; required = true
79
+
; args = Cons (int_sexp_grammar.untyped, Empty)
80
+
}
81
+
]
82
+
}
83
+
}
84
+
}
85
+
; No_tag
86
+
{ name = "Forbid_extra_fields"
87
+
; clause_kind =
88
+
List_clause
89
+
{ args =
90
+
Fields
91
+
{ allow_extra_fields = false
92
+
; fields =
93
+
[ No_tag
94
+
{ name = "bar"
95
+
; required = true
96
+
; args = Cons (int_sexp_grammar.untyped, Empty)
97
+
}
98
+
]
99
+
}
100
+
}
101
+
}
102
+
]
103
+
}
104
+
}
105
+
;;
106
+
107
+
let _ = t_sexp_grammar
108
+
109
+
[@@@end]
110
+
111
+
let _ = Allow_extra_fields { foo = 1 }
112
+
let _ = Forbid_extra_fields { bar = 1 }
113
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_allow_extra_fields.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_allow_extra_fields.mli
···
1
+
(*_ This signature is deliberately empty. *)
+115
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_attributes.ml
+115
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_attributes.ml
···
1
+
open! Base
2
+
3
+
module type S = sig
4
+
type t [@@deriving sexp_grammar]
5
+
end
6
+
7
+
let show_grammar (module M : S) =
8
+
Expect_test_helpers_base.print_s ([%sexp_of: _ Sexp_grammar.t] [%sexp_grammar: M.t])
9
+
;;
10
+
11
+
module Grammarless = struct
12
+
type t =
13
+
[ `A
14
+
| `B of string
15
+
]
16
+
end
17
+
18
+
let the_grammar = [%sexp_grammar: [ `A | `B of string ]]
19
+
20
+
let%expect_test "[@sexp_grammar.custom] in [@@deriving]" =
21
+
show_grammar
22
+
(module struct
23
+
type t = (Grammarless.t[@sexp_grammar.custom the_grammar]) * int
24
+
[@@deriving_inline sexp_grammar]
25
+
26
+
let _ = fun (_ : t) -> ()
27
+
28
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
29
+
{ untyped =
30
+
List
31
+
(Cons
32
+
( (the_grammar : Grammarless.t Sexplib0.Sexp_grammar.t).untyped
33
+
, Cons (int_sexp_grammar.untyped, Empty) ))
34
+
}
35
+
;;
36
+
37
+
let _ = t_sexp_grammar
38
+
39
+
[@@@end]
40
+
end);
41
+
[%expect
42
+
{|
43
+
(List (
44
+
Cons
45
+
(Variant (
46
+
(case_sensitivity Case_sensitive)
47
+
(clauses (
48
+
(No_tag (
49
+
(name A)
50
+
(clause_kind Atom_clause)))
51
+
(No_tag (
52
+
(name B) (clause_kind (List_clause (args (Cons String Empty))))))))))
53
+
(Cons Integer Empty)))
54
+
|}]
55
+
;;
56
+
57
+
let%expect_test "[@sexp_grammar.custom] in [%sexp_grammar]" =
58
+
show_grammar
59
+
(module struct
60
+
type t = Grammarless.t * int
61
+
62
+
let t_sexp_grammar =
63
+
[%sexp_grammar: (Grammarless.t[@sexp_grammar.custom the_grammar]) * int]
64
+
;;
65
+
end);
66
+
[%expect
67
+
{|
68
+
(List (
69
+
Cons
70
+
(Variant (
71
+
(case_sensitivity Case_sensitive)
72
+
(clauses (
73
+
(No_tag (
74
+
(name A)
75
+
(clause_kind Atom_clause)))
76
+
(No_tag (
77
+
(name B) (clause_kind (List_clause (args (Cons String Empty))))))))))
78
+
(Cons Integer Empty)))
79
+
|}]
80
+
;;
81
+
82
+
let%expect_test "[@sexp_grammar.any] in [@@deriving]" =
83
+
show_grammar
84
+
(module struct
85
+
type t =
86
+
(Grammarless.t[@sexp_grammar.any "GRAMMARLESS"])
87
+
* (Grammarless.t[@sexp_grammar.any])
88
+
[@@deriving_inline sexp_grammar]
89
+
90
+
let _ = fun (_ : t) -> ()
91
+
92
+
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) =
93
+
{ untyped = List (Cons (Any "GRAMMARLESS", Cons (Any "ANY", Empty))) }
94
+
;;
95
+
96
+
let _ = t_sexp_grammar
97
+
98
+
[@@@end]
99
+
end);
100
+
[%expect {| (List (Cons (Any GRAMMARLESS) (Cons (Any ANY) Empty))) |}]
101
+
;;
102
+
103
+
let%expect_test "[@sexp_grammar.any] in [%sexp_grammar]" =
104
+
show_grammar
105
+
(module struct
106
+
type t = Grammarless.t * Grammarless.t
107
+
108
+
let t_sexp_grammar =
109
+
[%sexp_grammar:
110
+
(Grammarless.t[@sexp_grammar.any "GRAMMARLESS"])
111
+
* (Grammarless.t[@sexp_grammar.any])]
112
+
;;
113
+
end);
114
+
[%expect {| (List (Cons (Any GRAMMARLESS) (Cons (Any ANY) Empty))) |}]
115
+
;;
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_attributes.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_attributes.mli
···
1
+
(*_ This signature is deliberately empty. *)
+37
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_base_map.ml
+37
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_base_map.ml
···
1
+
open! Base
2
+
3
+
module type S = sig
4
+
type t [@@deriving sexp_grammar]
5
+
end
6
+
7
+
module Key = struct
8
+
type t = int [@@deriving sexp_grammar]
9
+
end
10
+
11
+
module Pair = struct
12
+
type ('a, 'b) t = 'a * 'b [@@deriving sexp_grammar]
13
+
14
+
module M (A : T) = struct
15
+
type 'b t = A.t * 'b
16
+
end
17
+
18
+
let m__t_sexp_grammar (type a) (module Key : S with type t = a) v_sexp_grammar =
19
+
t_sexp_grammar Key.t_sexp_grammar v_sexp_grammar
20
+
;;
21
+
end
22
+
23
+
type t = string Pair.M(Key).t [@@deriving_inline sexp_grammar]
24
+
25
+
let _ = fun (_ : t) -> ()
26
+
27
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
28
+
{ untyped =
29
+
Lazy
30
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
31
+
(Pair.m__t_sexp_grammar (module Key) string_sexp_grammar).untyped))
32
+
}
33
+
;;
34
+
35
+
let _ = t_sexp_grammar
36
+
37
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_base_map.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_base_map.mli
···
1
+
(*_ This signature is deliberately empty. *)
+702
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_coverage_for_deriving.ml
+702
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_coverage_for_deriving.ml
···
1
+
open Ppx_sexp_conv_lib.Conv
2
+
3
+
type 'a or_null = 'a Ppx_sexp_conv_lib.Or_null.t
4
+
5
+
[@@@warning "-37"] (* allow unused constructors *)
6
+
7
+
type abstract_a [@@deriving sexp] [@@deriving_inline sexp_grammar]
8
+
9
+
let _ = fun (_ : abstract_a) -> ()
10
+
11
+
let (abstract_a_sexp_grammar : abstract_a Sexplib0.Sexp_grammar.t) =
12
+
{ untyped = Any "Test_coverage_for_deriving.abstract_a" }
13
+
;;
14
+
15
+
let _ = abstract_a_sexp_grammar
16
+
17
+
[@@@end]
18
+
19
+
type abstract_b [@@deriving sexp] [@@deriving_inline sexp_grammar]
20
+
21
+
let _ = fun (_ : abstract_b) -> ()
22
+
23
+
let (abstract_b_sexp_grammar : abstract_b Sexplib0.Sexp_grammar.t) =
24
+
{ untyped = Any "Test_coverage_for_deriving.abstract_b" }
25
+
;;
26
+
27
+
let _ = abstract_b_sexp_grammar
28
+
29
+
[@@@end]
30
+
31
+
type integer = int [@@deriving sexp] [@@deriving_inline sexp_grammar]
32
+
33
+
let _ = fun (_ : integer) -> ()
34
+
let (integer_sexp_grammar : integer Sexplib0.Sexp_grammar.t) = int_sexp_grammar
35
+
let _ = integer_sexp_grammar
36
+
37
+
[@@@end]
38
+
39
+
type tuple = int * string [@@deriving sexp] [@@deriving_inline sexp_grammar]
40
+
41
+
let _ = fun (_ : tuple) -> ()
42
+
43
+
let tuple_sexp_grammar : tuple Sexplib0.Sexp_grammar.t =
44
+
{ untyped =
45
+
List (Cons (int_sexp_grammar.untyped, Cons (string_sexp_grammar.untyped, Empty)))
46
+
}
47
+
;;
48
+
49
+
let _ = tuple_sexp_grammar
50
+
51
+
[@@@end]
52
+
53
+
type pos =
54
+
{ x : float
55
+
; y : float
56
+
}
57
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
58
+
59
+
let _ = fun (_ : pos) -> ()
60
+
61
+
let pos_sexp_grammar : pos Sexplib0.Sexp_grammar.t =
62
+
{ untyped =
63
+
List
64
+
(Fields
65
+
{ allow_extra_fields = false
66
+
; fields =
67
+
[ No_tag
68
+
{ name = "x"
69
+
; required = true
70
+
; args = Cons (float_sexp_grammar.untyped, Empty)
71
+
}
72
+
; No_tag
73
+
{ name = "y"
74
+
; required = true
75
+
; args = Cons (float_sexp_grammar.untyped, Empty)
76
+
}
77
+
]
78
+
})
79
+
}
80
+
;;
81
+
82
+
let _ = pos_sexp_grammar
83
+
84
+
[@@@end]
85
+
86
+
type 'a unary = 'a list [@@deriving sexp] [@@deriving_inline sexp_grammar]
87
+
88
+
let _ = fun (_ : 'a unary) -> ()
89
+
90
+
let unary_sexp_grammar
91
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a unary Sexplib0.Sexp_grammar.t
92
+
=
93
+
fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar
94
+
;;
95
+
96
+
let _ = unary_sexp_grammar
97
+
98
+
[@@@end]
99
+
100
+
type enum =
101
+
| One
102
+
| Two
103
+
| Three
104
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
105
+
106
+
let _ = fun (_ : enum) -> ()
107
+
108
+
let (enum_sexp_grammar : enum Sexplib0.Sexp_grammar.t) =
109
+
{ untyped =
110
+
Variant
111
+
{ case_sensitivity = Case_sensitive_except_first_character
112
+
; clauses =
113
+
[ No_tag { name = "One"; clause_kind = Atom_clause }
114
+
; No_tag { name = "Two"; clause_kind = Atom_clause }
115
+
; No_tag { name = "Three"; clause_kind = Atom_clause }
116
+
]
117
+
}
118
+
}
119
+
;;
120
+
121
+
let _ = enum_sexp_grammar
122
+
123
+
[@@@end]
124
+
125
+
type ('a, 'b) which =
126
+
| This of 'a
127
+
| That of 'b
128
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
129
+
130
+
let _ = fun (_ : ('a, 'b) which) -> ()
131
+
132
+
let which_sexp_grammar
133
+
: 'a 'b.
134
+
'a Sexplib0.Sexp_grammar.t
135
+
-> 'b Sexplib0.Sexp_grammar.t
136
+
-> ('a, 'b) which Sexplib0.Sexp_grammar.t
137
+
=
138
+
fun _'a_sexp_grammar _'b_sexp_grammar ->
139
+
{ untyped =
140
+
Variant
141
+
{ case_sensitivity = Case_sensitive_except_first_character
142
+
; clauses =
143
+
[ No_tag
144
+
{ name = "This"
145
+
; clause_kind =
146
+
List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) }
147
+
}
148
+
; No_tag
149
+
{ name = "That"
150
+
; clause_kind =
151
+
List_clause { args = Cons (_'b_sexp_grammar.untyped, Empty) }
152
+
}
153
+
]
154
+
}
155
+
}
156
+
;;
157
+
158
+
let _ = which_sexp_grammar
159
+
160
+
[@@@end]
161
+
162
+
type 'a optional =
163
+
| No
164
+
| Yes of 'a
165
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
166
+
167
+
let _ = fun (_ : 'a optional) -> ()
168
+
169
+
let optional_sexp_grammar
170
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a optional Sexplib0.Sexp_grammar.t
171
+
=
172
+
fun _'a_sexp_grammar ->
173
+
{ untyped =
174
+
Variant
175
+
{ case_sensitivity = Case_sensitive_except_first_character
176
+
; clauses =
177
+
[ No_tag { name = "No"; clause_kind = Atom_clause }
178
+
; No_tag
179
+
{ name = "Yes"
180
+
; clause_kind =
181
+
List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) }
182
+
}
183
+
]
184
+
}
185
+
}
186
+
;;
187
+
188
+
let _ = optional_sexp_grammar
189
+
190
+
[@@@end]
191
+
192
+
type empty = | [@@deriving sexp] [@@deriving_inline sexp_grammar]
193
+
194
+
let _ = fun (_ : empty) -> ()
195
+
let (empty_sexp_grammar : empty Sexplib0.Sexp_grammar.t) = { untyped = Union [] }
196
+
let _ = empty_sexp_grammar
197
+
198
+
[@@@end]
199
+
200
+
type _ phantom = int [@@deriving sexp] [@@deriving_inline sexp_grammar]
201
+
202
+
let _ = fun (_ : _ phantom) -> ()
203
+
204
+
let phantom_sexp_grammar
205
+
: 'a__090_. 'a__090_ Sexplib0.Sexp_grammar.t -> 'a__090_ phantom Sexplib0.Sexp_grammar.t
206
+
=
207
+
fun _'a__090__sexp_grammar -> int_sexp_grammar
208
+
;;
209
+
210
+
let _ = phantom_sexp_grammar
211
+
212
+
[@@@end]
213
+
214
+
type color =
215
+
[ `Red
216
+
| `Blue
217
+
]
218
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
219
+
220
+
let _ = fun (_ : color) -> ()
221
+
222
+
let (color_sexp_grammar : color Sexplib0.Sexp_grammar.t) =
223
+
{ untyped =
224
+
Variant
225
+
{ case_sensitivity = Case_sensitive
226
+
; clauses =
227
+
[ No_tag { name = "Red"; clause_kind = Atom_clause }
228
+
; No_tag { name = "Blue"; clause_kind = Atom_clause }
229
+
]
230
+
}
231
+
}
232
+
;;
233
+
234
+
let _ = color_sexp_grammar
235
+
236
+
[@@@end]
237
+
238
+
type adjective =
239
+
[ color
240
+
| `Fast
241
+
| `Slow
242
+
| `Count of int
243
+
]
244
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
245
+
246
+
let _ = fun (_ : adjective) -> ()
247
+
248
+
let adjective_sexp_grammar : adjective Sexplib0.Sexp_grammar.t =
249
+
{ untyped =
250
+
Union
251
+
[ color_sexp_grammar.untyped
252
+
; Variant
253
+
{ case_sensitivity = Case_sensitive
254
+
; clauses =
255
+
[ No_tag { name = "Fast"; clause_kind = Atom_clause }
256
+
; No_tag { name = "Slow"; clause_kind = Atom_clause }
257
+
; No_tag
258
+
{ name = "Count"
259
+
; clause_kind =
260
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
261
+
}
262
+
]
263
+
}
264
+
]
265
+
}
266
+
;;
267
+
268
+
let _ = adjective_sexp_grammar
269
+
270
+
[@@@end]
271
+
272
+
type 'a tree =
273
+
{ data : 'a
274
+
; children : 'a tree list
275
+
}
276
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
277
+
278
+
let _ = fun (_ : 'a tree) -> ()
279
+
280
+
include struct
281
+
open struct
282
+
let grammars__126_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
283
+
=
284
+
Basement.Portable_lazy.from_fun
285
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
286
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
287
+
let tree_sexp_grammar
288
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t
289
+
=
290
+
fun _'a_sexp_grammar ->
291
+
{ untyped = Recursive ("tree", [ _'a_sexp_grammar.untyped ]) }
292
+
in
293
+
[ { tycon = "tree"
294
+
; tyvars = [ "a" ]
295
+
; grammar =
296
+
List
297
+
(Fields
298
+
{ allow_extra_fields = false
299
+
; fields =
300
+
[ No_tag
301
+
{ name = "data"
302
+
; required = true
303
+
; args = Cons (Tyvar "a", Empty)
304
+
}
305
+
; No_tag
306
+
{ name = "children"
307
+
; required = true
308
+
; args =
309
+
Cons
310
+
( (list_sexp_grammar
311
+
(tree_sexp_grammar { untyped = Tyvar "a" }))
312
+
.untyped
313
+
, Empty )
314
+
}
315
+
]
316
+
})
317
+
}
318
+
]))
319
+
;;
320
+
321
+
let _ = grammars__126_
322
+
end
323
+
324
+
let tree_sexp_grammar
325
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t
326
+
=
327
+
fun _'a_sexp_grammar ->
328
+
{ untyped =
329
+
Tycon
330
+
( "tree"
331
+
, [ _'a_sexp_grammar.untyped ]
332
+
, Basement.Portable_lazy.force grammars__126_ )
333
+
}
334
+
;;
335
+
336
+
let _ = tree_sexp_grammar
337
+
end
338
+
339
+
[@@@end]
340
+
341
+
type alpha = int
342
+
343
+
and beta =
344
+
{ alpha : alpha
345
+
; betas : beta list
346
+
}
347
+
348
+
and gamma = beta list [@@deriving sexp] [@@deriving_inline sexp_grammar]
349
+
350
+
let _ = fun (_ : alpha) -> ()
351
+
let _ = fun (_ : beta) -> ()
352
+
let _ = fun (_ : gamma) -> ()
353
+
354
+
include struct
355
+
open struct
356
+
let grammars__143_ : Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
357
+
=
358
+
Basement.Portable_lazy.from_fun
359
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
360
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
361
+
let alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t =
362
+
{ untyped = Recursive ("alpha", []) }
363
+
and beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t =
364
+
{ untyped = Recursive ("beta", []) }
365
+
in
366
+
[ { tycon = "alpha"; tyvars = []; grammar = int_sexp_grammar.untyped }
367
+
; { tycon = "beta"
368
+
; tyvars = []
369
+
; grammar =
370
+
List
371
+
(Fields
372
+
{ allow_extra_fields = false
373
+
; fields =
374
+
[ No_tag
375
+
{ name = "alpha"
376
+
; required = true
377
+
; args = Cons (alpha_sexp_grammar.untyped, Empty)
378
+
}
379
+
; No_tag
380
+
{ name = "betas"
381
+
; required = true
382
+
; args =
383
+
Cons
384
+
( (list_sexp_grammar beta_sexp_grammar).untyped
385
+
, Empty )
386
+
}
387
+
]
388
+
})
389
+
}
390
+
]))
391
+
;;
392
+
393
+
let _ = grammars__143_
394
+
end
395
+
396
+
let alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t =
397
+
{ untyped =
398
+
Lazy
399
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
400
+
Tycon ("alpha", [], Basement.Portable_lazy.force grammars__143_)))
401
+
}
402
+
403
+
and beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t =
404
+
{ untyped =
405
+
Lazy
406
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
407
+
Tycon ("beta", [], Basement.Portable_lazy.force grammars__143_)))
408
+
}
409
+
;;
410
+
411
+
let _ = alpha_sexp_grammar
412
+
and _ = beta_sexp_grammar
413
+
end
414
+
415
+
let gamma_sexp_grammar : gamma Sexplib0.Sexp_grammar.t =
416
+
{ untyped =
417
+
Lazy
418
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
419
+
(list_sexp_grammar beta_sexp_grammar).untyped))
420
+
}
421
+
;;
422
+
423
+
let _ = gamma_sexp_grammar
424
+
425
+
[@@@end]
426
+
427
+
type record_attributes =
428
+
{ a : int [@default 0]
429
+
; b : bool [@sexp.bool]
430
+
; c : float option [@sexp.option]
431
+
; d : string list [@sexp.list]
432
+
; e : bytes array [@sexp.array]
433
+
; f : Ppx_sexp_conv_lib.Sexp.t [@sexp.omit_nil]
434
+
; g : char or_null [@sexp.or_null]
435
+
}
436
+
[@@sexp.allow_extra_fields] [@@deriving sexp] [@@deriving_inline sexp_grammar]
437
+
438
+
let _ = fun (_ : record_attributes) -> ()
439
+
440
+
let record_attributes_sexp_grammar : record_attributes Sexplib0.Sexp_grammar.t =
441
+
{ untyped =
442
+
List
443
+
(Fields
444
+
{ allow_extra_fields = true
445
+
; fields =
446
+
[ No_tag
447
+
{ name = "a"
448
+
; required = false
449
+
; args = Cons (int_sexp_grammar.untyped, Empty)
450
+
}
451
+
; No_tag { name = "b"; required = false; args = Empty }
452
+
; No_tag
453
+
{ name = "c"
454
+
; required = false
455
+
; args = Cons (float_sexp_grammar.untyped, Empty)
456
+
}
457
+
; No_tag
458
+
{ name = "d"
459
+
; required = false
460
+
; args = Cons (List (Many string_sexp_grammar.untyped), Empty)
461
+
}
462
+
; No_tag
463
+
{ name = "e"
464
+
; required = false
465
+
; args = Cons (List (Many bytes_sexp_grammar.untyped), Empty)
466
+
}
467
+
; No_tag
468
+
{ name = "f"
469
+
; required = false
470
+
; args = Cons (Ppx_sexp_conv_lib.Sexp.t_sexp_grammar.untyped, Empty)
471
+
}
472
+
; No_tag
473
+
{ name = "g"
474
+
; required = false
475
+
; args = Cons (char_sexp_grammar.untyped, Empty)
476
+
}
477
+
]
478
+
})
479
+
}
480
+
;;
481
+
482
+
let _ = record_attributes_sexp_grammar
483
+
484
+
[@@@end]
485
+
486
+
type variant_attributes =
487
+
| A
488
+
| B of int list [@sexp.list]
489
+
| C of
490
+
{ a : int [@default 0]
491
+
; b : bool [@sexp.bool]
492
+
; c : float option [@sexp.option]
493
+
; d : string list [@sexp.list]
494
+
; e : bytes array [@sexp.array]
495
+
; f : Ppx_sexp_conv_lib.Sexp.t [@sexp.omit_nil]
496
+
; g : char or_null [@sexp.or_null]
497
+
} [@sexp.allow_extra_fields]
498
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
499
+
500
+
let _ = fun (_ : variant_attributes) -> ()
501
+
502
+
let variant_attributes_sexp_grammar : variant_attributes Sexplib0.Sexp_grammar.t =
503
+
{ untyped =
504
+
Variant
505
+
{ case_sensitivity = Case_sensitive_except_first_character
506
+
; clauses =
507
+
[ No_tag { name = "A"; clause_kind = Atom_clause }
508
+
; No_tag
509
+
{ name = "B"
510
+
; clause_kind = List_clause { args = Many int_sexp_grammar.untyped }
511
+
}
512
+
; No_tag
513
+
{ name = "C"
514
+
; clause_kind =
515
+
List_clause
516
+
{ args =
517
+
Fields
518
+
{ allow_extra_fields = true
519
+
; fields =
520
+
[ No_tag
521
+
{ name = "a"
522
+
; required = false
523
+
; args = Cons (int_sexp_grammar.untyped, Empty)
524
+
}
525
+
; No_tag { name = "b"; required = false; args = Empty }
526
+
; No_tag
527
+
{ name = "c"
528
+
; required = false
529
+
; args = Cons (float_sexp_grammar.untyped, Empty)
530
+
}
531
+
; No_tag
532
+
{ name = "d"
533
+
; required = false
534
+
; args =
535
+
Cons
536
+
(List (Many string_sexp_grammar.untyped), Empty)
537
+
}
538
+
; No_tag
539
+
{ name = "e"
540
+
; required = false
541
+
; args =
542
+
Cons
543
+
(List (Many bytes_sexp_grammar.untyped), Empty)
544
+
}
545
+
; No_tag
546
+
{ name = "f"
547
+
; required = false
548
+
; args =
549
+
Cons
550
+
( Ppx_sexp_conv_lib.Sexp.t_sexp_grammar.untyped
551
+
, Empty )
552
+
}
553
+
; No_tag
554
+
{ name = "g"
555
+
; required = false
556
+
; args = Cons (char_sexp_grammar.untyped, Empty)
557
+
}
558
+
]
559
+
}
560
+
}
561
+
}
562
+
]
563
+
}
564
+
}
565
+
;;
566
+
567
+
let _ = variant_attributes_sexp_grammar
568
+
569
+
[@@@end]
570
+
571
+
type polymorphic_variant_attributes =
572
+
[ `A
573
+
| `B of int list [@sexp.list]
574
+
]
575
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
576
+
577
+
let _ = fun (_ : polymorphic_variant_attributes) -> ()
578
+
579
+
let polymorphic_variant_attributes_sexp_grammar
580
+
: polymorphic_variant_attributes Sexplib0.Sexp_grammar.t
581
+
=
582
+
{ untyped =
583
+
Variant
584
+
{ case_sensitivity = Case_sensitive
585
+
; clauses =
586
+
[ No_tag { name = "A"; clause_kind = Atom_clause }
587
+
; No_tag
588
+
{ name = "B"
589
+
; clause_kind = List_clause { args = Many int_sexp_grammar.untyped }
590
+
}
591
+
]
592
+
}
593
+
}
594
+
;;
595
+
596
+
let _ = polymorphic_variant_attributes_sexp_grammar
597
+
598
+
[@@@end]
599
+
600
+
type opaque =
601
+
{ x : (string[@sexp.opaque])
602
+
; y : int -> int
603
+
}
604
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
605
+
606
+
let _ = fun (_ : opaque) -> ()
607
+
608
+
let opaque_sexp_grammar : opaque Sexplib0.Sexp_grammar.t =
609
+
{ untyped =
610
+
List
611
+
(Fields
612
+
{ allow_extra_fields = false
613
+
; fields =
614
+
[ No_tag
615
+
{ name = "x"
616
+
; required = true
617
+
; args = Cons (Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped, Empty)
618
+
}
619
+
; No_tag
620
+
{ name = "y"
621
+
; required = true
622
+
; args = Cons (Sexplib0.Sexp_conv.fun_sexp_grammar.untyped, Empty)
623
+
}
624
+
]
625
+
})
626
+
}
627
+
;;
628
+
629
+
let _ = opaque_sexp_grammar
630
+
631
+
[@@@end]
632
+
633
+
type nonportable =
634
+
{ x : string
635
+
; y : int -> int
636
+
}
637
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
638
+
639
+
let _ = fun (_ : nonportable) -> ()
640
+
641
+
let nonportable_sexp_grammar : nonportable Sexplib0.Sexp_grammar.t =
642
+
{ untyped =
643
+
List
644
+
(Fields
645
+
{ allow_extra_fields = false
646
+
; fields =
647
+
[ No_tag
648
+
{ name = "x"
649
+
; required = true
650
+
; args = Cons (string_sexp_grammar.untyped, Empty)
651
+
}
652
+
; No_tag
653
+
{ name = "y"
654
+
; required = true
655
+
; args = Cons (Sexplib0.Sexp_conv.fun_sexp_grammar.untyped, Empty)
656
+
}
657
+
]
658
+
})
659
+
}
660
+
;;
661
+
662
+
let _ = nonportable_sexp_grammar
663
+
664
+
[@@@end]
665
+
666
+
type 'a nonportable1 =
667
+
{ x : string
668
+
; y : 'a -> int
669
+
}
670
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
671
+
672
+
let _ = fun (_ : 'a nonportable1) -> ()
673
+
674
+
let nonportable1_sexp_grammar
675
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a nonportable1 Sexplib0.Sexp_grammar.t
676
+
=
677
+
fun _'a_sexp_grammar ->
678
+
{ untyped =
679
+
List
680
+
(Fields
681
+
{ allow_extra_fields = false
682
+
; fields =
683
+
[ No_tag
684
+
{ name = "x"
685
+
; required = true
686
+
; args = Cons (string_sexp_grammar.untyped, Empty)
687
+
}
688
+
; No_tag
689
+
{ name = "y"
690
+
; required = true
691
+
; args = Cons (Sexplib0.Sexp_conv.fun_sexp_grammar.untyped, Empty)
692
+
}
693
+
]
694
+
})
695
+
}
696
+
;;
697
+
698
+
let _ = nonportable1_sexp_grammar
699
+
700
+
[@@@end]
701
+
702
+
let nonportable1_sexp_grammar = nonportable1_sexp_grammar
+322
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_coverage_for_deriving.mli
+322
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_coverage_for_deriving.mli
···
1
+
(** This file covers a lot of cases for [@@deriving], for both interface and
2
+
implementation. They are also exported for validation. *)
3
+
4
+
type abstract_a [@@deriving sexp] [@@deriving_inline sexp_grammar]
5
+
6
+
include sig
7
+
[@@@ocaml.warning "-32"]
8
+
9
+
val abstract_a_sexp_grammar : abstract_a Sexplib0.Sexp_grammar.t
10
+
end
11
+
[@@ocaml.doc "@inline"]
12
+
13
+
[@@@end]
14
+
15
+
type abstract_b [@@deriving sexp] [@@deriving_inline sexp_grammar]
16
+
17
+
include sig
18
+
[@@@ocaml.warning "-32"]
19
+
20
+
val abstract_b_sexp_grammar : abstract_b Sexplib0.Sexp_grammar.t
21
+
end
22
+
[@@ocaml.doc "@inline"]
23
+
24
+
[@@@end]
25
+
26
+
type integer = int [@@deriving sexp] [@@deriving_inline sexp_grammar]
27
+
28
+
include sig
29
+
[@@@ocaml.warning "-32"]
30
+
31
+
val integer_sexp_grammar : integer Sexplib0.Sexp_grammar.t
32
+
end
33
+
[@@ocaml.doc "@inline"]
34
+
35
+
[@@@end]
36
+
37
+
type tuple = int * string [@@deriving sexp] [@@deriving_inline sexp_grammar]
38
+
39
+
include sig
40
+
[@@@ocaml.warning "-32"]
41
+
42
+
val tuple_sexp_grammar : tuple Sexplib0.Sexp_grammar.t
43
+
end
44
+
[@@ocaml.doc "@inline"]
45
+
46
+
[@@@end]
47
+
48
+
type pos =
49
+
{ x : float
50
+
; y : float
51
+
}
52
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
53
+
54
+
include sig
55
+
[@@@ocaml.warning "-32"]
56
+
57
+
val pos_sexp_grammar : pos Sexplib0.Sexp_grammar.t
58
+
end
59
+
[@@ocaml.doc "@inline"]
60
+
61
+
[@@@end]
62
+
63
+
type 'a unary = 'a list [@@deriving sexp] [@@deriving_inline sexp_grammar]
64
+
65
+
include sig
66
+
[@@@ocaml.warning "-32"]
67
+
68
+
val unary_sexp_grammar
69
+
: 'a.
70
+
'a Sexplib0.Sexp_grammar.t -> 'a unary Sexplib0.Sexp_grammar.t
71
+
end
72
+
[@@ocaml.doc "@inline"]
73
+
74
+
[@@@end]
75
+
76
+
type enum =
77
+
| One
78
+
| Two
79
+
| Three
80
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
81
+
82
+
include sig
83
+
[@@@ocaml.warning "-32"]
84
+
85
+
val enum_sexp_grammar : enum Sexplib0.Sexp_grammar.t
86
+
end
87
+
[@@ocaml.doc "@inline"]
88
+
89
+
[@@@end]
90
+
91
+
type ('a, 'b) which =
92
+
| This of 'a
93
+
| That of 'b
94
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
95
+
96
+
include sig
97
+
[@@@ocaml.warning "-32"]
98
+
99
+
val which_sexp_grammar
100
+
: 'a 'b.
101
+
'a Sexplib0.Sexp_grammar.t
102
+
-> 'b Sexplib0.Sexp_grammar.t
103
+
-> ('a, 'b) which Sexplib0.Sexp_grammar.t
104
+
end
105
+
[@@ocaml.doc "@inline"]
106
+
107
+
[@@@end]
108
+
109
+
type 'a optional =
110
+
| No
111
+
| Yes of 'a
112
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
113
+
114
+
include sig
115
+
[@@@ocaml.warning "-32"]
116
+
117
+
val optional_sexp_grammar
118
+
: 'a.
119
+
'a Sexplib0.Sexp_grammar.t -> 'a optional Sexplib0.Sexp_grammar.t
120
+
end
121
+
[@@ocaml.doc "@inline"]
122
+
123
+
[@@@end]
124
+
125
+
type empty = | [@@deriving sexp] [@@deriving_inline sexp_grammar]
126
+
127
+
include sig
128
+
[@@@ocaml.warning "-32"]
129
+
130
+
val empty_sexp_grammar : empty Sexplib0.Sexp_grammar.t
131
+
end
132
+
[@@ocaml.doc "@inline"]
133
+
134
+
[@@@end]
135
+
136
+
type _ phantom = int [@@deriving sexp] [@@deriving_inline sexp_grammar]
137
+
138
+
include sig
139
+
[@@@ocaml.warning "-32"]
140
+
141
+
val phantom_sexp_grammar
142
+
: 'a__003_.
143
+
'a__003_ Sexplib0.Sexp_grammar.t -> 'a__003_ phantom Sexplib0.Sexp_grammar.t
144
+
end
145
+
[@@ocaml.doc "@inline"]
146
+
147
+
[@@@end]
148
+
149
+
type color =
150
+
[ `Red
151
+
| `Blue
152
+
]
153
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
154
+
155
+
include sig
156
+
[@@@ocaml.warning "-32"]
157
+
158
+
val color_sexp_grammar : color Sexplib0.Sexp_grammar.t
159
+
end
160
+
[@@ocaml.doc "@inline"]
161
+
162
+
[@@@end]
163
+
164
+
type adjective =
165
+
[ color
166
+
| `Fast
167
+
| `Slow
168
+
| `Count of int
169
+
]
170
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
171
+
172
+
include sig
173
+
[@@@ocaml.warning "-32"]
174
+
175
+
val adjective_sexp_grammar : adjective Sexplib0.Sexp_grammar.t
176
+
end
177
+
[@@ocaml.doc "@inline"]
178
+
179
+
[@@@end]
180
+
181
+
type 'a tree =
182
+
{ data : 'a
183
+
; children : 'a tree list
184
+
}
185
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
186
+
187
+
include sig
188
+
[@@@ocaml.warning "-32"]
189
+
190
+
val tree_sexp_grammar
191
+
: 'a.
192
+
'a Sexplib0.Sexp_grammar.t -> 'a tree Sexplib0.Sexp_grammar.t
193
+
end
194
+
[@@ocaml.doc "@inline"]
195
+
196
+
[@@@end]
197
+
198
+
type alpha = int
199
+
200
+
and beta =
201
+
{ alpha : alpha
202
+
; betas : beta list
203
+
}
204
+
205
+
and gamma = beta list [@@deriving sexp] [@@deriving_inline sexp_grammar]
206
+
207
+
include sig
208
+
[@@@ocaml.warning "-32"]
209
+
210
+
val alpha_sexp_grammar : alpha Sexplib0.Sexp_grammar.t
211
+
val beta_sexp_grammar : beta Sexplib0.Sexp_grammar.t
212
+
val gamma_sexp_grammar : gamma Sexplib0.Sexp_grammar.t
213
+
end
214
+
[@@ocaml.doc "@inline"]
215
+
216
+
[@@@end]
217
+
218
+
type record_attributes =
219
+
{ a : int
220
+
; b : bool
221
+
; c : float option
222
+
; d : string list
223
+
; e : bytes array
224
+
; f : Ppx_sexp_conv_lib.Sexp.t
225
+
; g : char Ppx_sexp_conv_lib.Or_null.t
226
+
}
227
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
228
+
229
+
include sig
230
+
[@@@ocaml.warning "-32"]
231
+
232
+
val record_attributes_sexp_grammar : record_attributes Sexplib0.Sexp_grammar.t
233
+
end
234
+
[@@ocaml.doc "@inline"]
235
+
236
+
[@@@end]
237
+
238
+
type variant_attributes =
239
+
| A
240
+
| B of int list
241
+
| C of
242
+
{ a : int
243
+
; b : bool
244
+
; c : float option
245
+
; d : string list
246
+
; e : bytes array
247
+
; f : Ppx_sexp_conv_lib.Sexp.t
248
+
; g : char Ppx_sexp_conv_lib.Or_null.t
249
+
}
250
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
251
+
252
+
include sig
253
+
[@@@ocaml.warning "-32"]
254
+
255
+
val variant_attributes_sexp_grammar : variant_attributes Sexplib0.Sexp_grammar.t
256
+
end
257
+
[@@ocaml.doc "@inline"]
258
+
259
+
[@@@end]
260
+
261
+
type polymorphic_variant_attributes =
262
+
[ `A
263
+
| `B of int list
264
+
]
265
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
266
+
267
+
include sig
268
+
[@@@ocaml.warning "-32"]
269
+
270
+
val polymorphic_variant_attributes_sexp_grammar
271
+
: polymorphic_variant_attributes Sexplib0.Sexp_grammar.t
272
+
end
273
+
[@@ocaml.doc "@inline"]
274
+
275
+
[@@@end]
276
+
277
+
type opaque =
278
+
{ x : string
279
+
; y : int -> int
280
+
}
281
+
[@@deriving sexp] [@@deriving_inline sexp_grammar]
282
+
283
+
include sig
284
+
[@@@ocaml.warning "-32"]
285
+
286
+
val opaque_sexp_grammar : opaque Sexplib0.Sexp_grammar.t
287
+
end
288
+
[@@ocaml.doc "@inline"]
289
+
290
+
[@@@end]
291
+
292
+
type nonportable =
293
+
{ x : string
294
+
; y : int -> int
295
+
}
296
+
[@@deriving sexp] [@@deriving_inline sexp_grammar ~nonportable]
297
+
298
+
include sig
299
+
[@@@ocaml.warning "-32"]
300
+
301
+
val nonportable_sexp_grammar : nonportable Sexplib0.Sexp_grammar.t
302
+
end
303
+
[@@ocaml.doc "@inline"]
304
+
305
+
[@@@end]
306
+
307
+
type 'a nonportable1 =
308
+
{ x : string
309
+
; y : 'a -> int
310
+
}
311
+
[@@deriving sexp] [@@deriving_inline sexp_grammar ~nonportable]
312
+
313
+
include sig
314
+
[@@@ocaml.warning "-32"]
315
+
316
+
val nonportable1_sexp_grammar
317
+
: 'a.
318
+
'a Sexplib0.Sexp_grammar.t -> 'a nonportable1 Sexplib0.Sexp_grammar.t
319
+
end
320
+
[@@ocaml.doc "@inline"]
321
+
322
+
[@@@end]
+19
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_extension.ml
+19
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_extension.ml
···
1
+
open! Base
2
+
3
+
(* Not sure how much people will want to use this, considering that the input is more
4
+
complicated and specific than the output, but they have it. *)
5
+
module type S = sig
6
+
val t_sexp_grammar : [%sexp_grammar: int Map.M(String).t]
7
+
end
8
+
9
+
module _ (M : S) : sig
10
+
val t_sexp_grammar : int Map.M(String).t Sexplib0.Sexp_grammar.t [@@warning "-32"]
11
+
end =
12
+
M
13
+
14
+
(* The grammar is illegible, so just make sure it builds. *)
15
+
16
+
let (_ : _ Sexplib0.Sexp_grammar.t) = [%sexp_grammar: int Map.M(String).t]
17
+
18
+
(* This used to give a compilation error. *)
19
+
let (_ : _ Sexplib0.Sexp_grammar.t) = [%sexp_grammar: _ list]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_extension.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_extension.mli
···
1
+
(*_ This signature is deliberately empty. *)
+170
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_functors.ml
+170
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_functors.ml
···
1
+
open! Base
2
+
3
+
module Maybe = struct
4
+
type 'a t = 'a option [@@deriving_inline sexp_grammar]
5
+
6
+
let _ = fun (_ : 'a t) -> ()
7
+
8
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
9
+
fun _'a_sexp_grammar -> option_sexp_grammar _'a_sexp_grammar
10
+
;;
11
+
12
+
let _ = t_sexp_grammar
13
+
14
+
[@@@end]
15
+
end
16
+
17
+
module Make (T : sig
18
+
type 'a t [@@deriving sexp_grammar]
19
+
end) =
20
+
struct
21
+
[@@@warning "-37"]
22
+
23
+
type 'a t = T of 'a T.t u
24
+
and 'a u = U of 'a T.t t Maybe.t [@@deriving_inline sexp_grammar]
25
+
26
+
let _ = fun (_ : 'a t) -> ()
27
+
let _ = fun (_ : 'a u) -> ()
28
+
29
+
include struct
30
+
open struct
31
+
let grammars__001_
32
+
: Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
33
+
=
34
+
Basement.Portable_lazy.from_fun
35
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
36
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
37
+
let t_sexp_grammar
38
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t
39
+
=
40
+
fun _'a_sexp_grammar ->
41
+
{ untyped = Recursive ("t", [ _'a_sexp_grammar.untyped ]) }
42
+
and u_sexp_grammar
43
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t
44
+
=
45
+
fun _'a_sexp_grammar ->
46
+
{ untyped = Recursive ("u", [ _'a_sexp_grammar.untyped ]) }
47
+
in
48
+
[ { tycon = "t"
49
+
; tyvars = [ "a" ]
50
+
; grammar =
51
+
Variant
52
+
{ case_sensitivity = Case_sensitive_except_first_character
53
+
; clauses =
54
+
[ No_tag
55
+
{ name = "T"
56
+
; clause_kind =
57
+
List_clause
58
+
{ args =
59
+
Cons
60
+
( (u_sexp_grammar
61
+
(T.t_sexp_grammar
62
+
{ untyped = Tyvar "a" }))
63
+
.untyped
64
+
, Empty )
65
+
}
66
+
}
67
+
]
68
+
}
69
+
}
70
+
; { tycon = "u"
71
+
; tyvars = [ "a" ]
72
+
; grammar =
73
+
Variant
74
+
{ case_sensitivity = Case_sensitive_except_first_character
75
+
; clauses =
76
+
[ No_tag
77
+
{ name = "U"
78
+
; clause_kind =
79
+
List_clause
80
+
{ args =
81
+
Cons
82
+
( (Maybe.t_sexp_grammar
83
+
(t_sexp_grammar
84
+
(T.t_sexp_grammar
85
+
{ untyped = Tyvar "a" })))
86
+
.untyped
87
+
, Empty )
88
+
}
89
+
}
90
+
]
91
+
}
92
+
}
93
+
]))
94
+
;;
95
+
96
+
let _ = grammars__001_
97
+
end
98
+
99
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
100
+
fun _'a_sexp_grammar ->
101
+
{ untyped =
102
+
Tycon
103
+
( "t"
104
+
, [ _'a_sexp_grammar.untyped ]
105
+
, Basement.Portable_lazy.force grammars__001_ )
106
+
}
107
+
108
+
and u_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t =
109
+
fun _'a_sexp_grammar ->
110
+
{ untyped =
111
+
Tycon
112
+
( "u"
113
+
, [ _'a_sexp_grammar.untyped ]
114
+
, Basement.Portable_lazy.force grammars__001_ )
115
+
}
116
+
;;
117
+
118
+
let _ = t_sexp_grammar
119
+
and _ = u_sexp_grammar
120
+
end
121
+
122
+
[@@@end]
123
+
124
+
type 'a v = V of 'a t [@@deriving_inline sexp_grammar]
125
+
126
+
let _ = fun (_ : 'a v) -> ()
127
+
128
+
let v_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a v Sexplib0.Sexp_grammar.t =
129
+
fun _'a_sexp_grammar ->
130
+
{ untyped =
131
+
Variant
132
+
{ case_sensitivity = Case_sensitive_except_first_character
133
+
; clauses =
134
+
[ No_tag
135
+
{ name = "V"
136
+
; clause_kind =
137
+
List_clause
138
+
{ args = Cons ((t_sexp_grammar _'a_sexp_grammar).untyped, Empty) }
139
+
}
140
+
]
141
+
}
142
+
}
143
+
;;
144
+
145
+
let _ = v_sexp_grammar
146
+
147
+
[@@@end]
148
+
end
149
+
150
+
module T1 = Make (Maybe)
151
+
module T2 = Make (T1)
152
+
153
+
type t = int T2.t * int T1.t [@@deriving_inline sexp_grammar]
154
+
155
+
let _ = fun (_ : t) -> ()
156
+
157
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
158
+
{ untyped =
159
+
Lazy
160
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
161
+
List
162
+
(Cons
163
+
( (T2.t_sexp_grammar int_sexp_grammar).untyped
164
+
, Cons ((T1.t_sexp_grammar int_sexp_grammar).untyped, Empty) ))))
165
+
}
166
+
;;
167
+
168
+
let _ = t_sexp_grammar
169
+
170
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_functors.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_functors.mli
···
1
+
(*_ This signature is deliberately empty. *)
+72
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_gadt.ml
+72
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_gadt.ml
···
1
+
open! Base
2
+
3
+
type t = T : ('a[@sexp.opaque]) -> t [@@deriving sexp] [@@deriving_inline sexp_grammar]
4
+
5
+
let _ = fun (_ : t) -> ()
6
+
7
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
8
+
{ untyped =
9
+
Variant
10
+
{ case_sensitivity = Case_sensitive_except_first_character
11
+
; clauses =
12
+
[ No_tag
13
+
{ name = "T"
14
+
; clause_kind =
15
+
List_clause
16
+
{ args = Cons (Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped, Empty)
17
+
}
18
+
}
19
+
]
20
+
}
21
+
}
22
+
;;
23
+
24
+
let _ = t_sexp_grammar
25
+
26
+
[@@@end]
27
+
28
+
type nullary = Nullary : nullary [@@deriving sexp] [@@deriving_inline sexp_grammar]
29
+
30
+
let _ = fun (_ : nullary) -> ()
31
+
32
+
let (nullary_sexp_grammar : nullary Sexplib0.Sexp_grammar.t) =
33
+
{ untyped =
34
+
Variant
35
+
{ case_sensitivity = Case_sensitive_except_first_character
36
+
; clauses = [ No_tag { name = "Nullary"; clause_kind = Atom_clause } ]
37
+
}
38
+
}
39
+
;;
40
+
41
+
let _ = nullary_sexp_grammar
42
+
43
+
[@@@end]
44
+
45
+
(* We can't derive [of_sexp], but we can derive a sensible grammar for this type. *)
46
+
type _ grammar_only = Grammar_only : int -> string grammar_only
47
+
[@@warning "-37"] [@@deriving_inline sexp_grammar]
48
+
49
+
let _ = fun (_ : _ grammar_only) -> ()
50
+
51
+
let grammar_only_sexp_grammar
52
+
: 'a__016_.
53
+
'a__016_ Sexplib0.Sexp_grammar.t -> 'a__016_ grammar_only Sexplib0.Sexp_grammar.t
54
+
=
55
+
fun _'a__016__sexp_grammar ->
56
+
{ untyped =
57
+
Variant
58
+
{ case_sensitivity = Case_sensitive_except_first_character
59
+
; clauses =
60
+
[ No_tag
61
+
{ name = "Grammar_only"
62
+
; clause_kind =
63
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
64
+
}
65
+
]
66
+
}
67
+
}
68
+
;;
69
+
70
+
let _ = grammar_only_sexp_grammar
71
+
72
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_gadt.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_gadt.mli
···
1
+
(*_ This signature is deliberately empty. *)
+110
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_modalities.ml
+110
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_modalities.ml
···
1
+
module type Sexp_of = sig
2
+
type t [@@deriving_inline sexp_of ~portable]
3
+
4
+
include sig
5
+
[@@@ocaml.warning "-32"]
6
+
7
+
val sexp_of_t : t -> Sexplib0.Sexp.t
8
+
end
9
+
[@@ocaml.doc "@inline"]
10
+
11
+
[@@@end]
12
+
end
13
+
14
+
module type Sexp_of_local = sig
15
+
type t [@@deriving_inline sexp_of ~stackify ~portable]
16
+
17
+
include sig
18
+
[@@@ocaml.warning "-32"]
19
+
20
+
val sexp_of_t : t -> Sexplib0.Sexp.t
21
+
val sexp_of_t__stack : t -> Sexplib0.Sexp.t
22
+
end
23
+
[@@ocaml.doc "@inline"]
24
+
25
+
[@@@end]
26
+
end
27
+
28
+
module type Of_sexp = sig
29
+
type t [@@deriving_inline of_sexp ~portable]
30
+
31
+
include sig
32
+
[@@@ocaml.warning "-32"]
33
+
34
+
val t_of_sexp : Sexplib0.Sexp.t -> t
35
+
end
36
+
[@@ocaml.doc "@inline"]
37
+
38
+
[@@@end]
39
+
end
40
+
41
+
module type Of_sexp_poly = sig
42
+
type t [@@deriving_inline of_sexp_poly ~portable]
43
+
44
+
include sig
45
+
[@@@ocaml.warning "-32"]
46
+
47
+
val t_of_sexp : Sexplib0.Sexp.t -> t
48
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
49
+
end
50
+
[@@ocaml.doc "@inline"]
51
+
52
+
[@@@end]
53
+
end
54
+
55
+
module type Sexp = sig
56
+
type t [@@deriving_inline sexp ~portable]
57
+
58
+
include sig
59
+
[@@@ocaml.warning "-32"]
60
+
61
+
include Sexplib0.Sexpable.S with type t := t
62
+
end
63
+
[@@ocaml.doc "@inline"]
64
+
65
+
[@@@end]
66
+
end
67
+
68
+
module type Sexp_local = sig
69
+
type t [@@deriving_inline sexp ~stackify ~portable]
70
+
71
+
include sig
72
+
[@@@ocaml.warning "-32"]
73
+
74
+
include Sexplib0.Sexpable.S__stack with type t := t
75
+
end
76
+
[@@ocaml.doc "@inline"]
77
+
78
+
[@@@end]
79
+
end
80
+
81
+
module type Sexp_poly = sig
82
+
type t [@@deriving_inline sexp_poly ~portable]
83
+
84
+
include sig
85
+
[@@@ocaml.warning "-32"]
86
+
87
+
val t_of_sexp : Sexplib0.Sexp.t -> t
88
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
89
+
val sexp_of_t : t -> Sexplib0.Sexp.t
90
+
end
91
+
[@@ocaml.doc "@inline"]
92
+
93
+
[@@@end]
94
+
end
95
+
96
+
module type Sexp_poly_local = sig
97
+
type t [@@deriving_inline sexp_poly ~stackify ~portable]
98
+
99
+
include sig
100
+
[@@@ocaml.warning "-32"]
101
+
102
+
val t_of_sexp : Sexplib0.Sexp.t -> t
103
+
val __t_of_sexp__ : Sexplib0.Sexp.t -> t
104
+
val sexp_of_t : t -> Sexplib0.Sexp.t
105
+
val sexp_of_t__stack : t -> Sexplib0.Sexp.t
106
+
end
107
+
[@@ocaml.doc "@inline"]
108
+
109
+
[@@@end]
110
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_modalities.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_modalities.mli
···
1
+
(*_ This signature is deliberately empty. *)
+19
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_nonrec.ml
+19
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_nonrec.ml
···
1
+
open! Base
2
+
3
+
open struct
4
+
type t = int [@@deriving_inline sexp_grammar]
5
+
6
+
let _ = fun (_ : t) -> ()
7
+
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar
8
+
let _ = t_sexp_grammar
9
+
10
+
[@@@end]
11
+
end
12
+
13
+
type nonrec t = t [@@deriving_inline sexp_grammar]
14
+
15
+
let _ = fun (_ : t) -> ()
16
+
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = t_sexp_grammar
17
+
let _ = t_sexp_grammar
18
+
19
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_nonrec.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_nonrec.mli
···
1
+
(*_ This signature is deliberately empty. *)
+17
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_opaque.ml
+17
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_opaque.ml
···
1
+
open! Base
2
+
3
+
type t = (int[@sexp.opaque]) list [@@deriving_inline sexp_grammar]
4
+
5
+
let _ = fun (_ : t) -> ()
6
+
7
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
8
+
{ untyped =
9
+
Lazy
10
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
11
+
(list_sexp_grammar Sexplib0.Sexp_conv.opaque_sexp_grammar).untyped))
12
+
}
13
+
;;
14
+
15
+
let _ = t_sexp_grammar
16
+
17
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_opaque.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_opaque.mli
···
1
+
(*_ This signature is deliberately empty. *)
+169
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.ml
+169
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.ml
···
1
+
open Base
2
+
3
+
[@@@warning "-37"]
4
+
5
+
module _ = struct
6
+
type 'a t =
7
+
[ `A
8
+
| `B
9
+
]
10
+
[@@deriving_inline sexp_grammar]
11
+
12
+
let _ = fun (_ : 'a t) -> ()
13
+
14
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
15
+
fun _'a_sexp_grammar ->
16
+
{ untyped =
17
+
Variant
18
+
{ case_sensitivity = Case_sensitive
19
+
; clauses =
20
+
[ No_tag { name = "A"; clause_kind = Atom_clause }
21
+
; No_tag { name = "B"; clause_kind = Atom_clause }
22
+
]
23
+
}
24
+
}
25
+
;;
26
+
27
+
let _ = t_sexp_grammar
28
+
29
+
[@@@end]
30
+
end
31
+
32
+
module _ = struct
33
+
module With_sexp = struct
34
+
type t =
35
+
[ `A of int * int
36
+
| `B of string
37
+
]
38
+
[@@deriving sexp_of]
39
+
end
40
+
41
+
type t =
42
+
[ `A of int * int
43
+
| `B of string
44
+
]
45
+
[@@deriving_inline sexp_grammar]
46
+
47
+
let _ = fun (_ : t) -> ()
48
+
49
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
50
+
{ untyped =
51
+
Variant
52
+
{ case_sensitivity = Case_sensitive
53
+
; clauses =
54
+
[ No_tag
55
+
{ name = "A"
56
+
; clause_kind =
57
+
List_clause
58
+
{ args =
59
+
Cons
60
+
( List
61
+
(Cons
62
+
( int_sexp_grammar.untyped
63
+
, Cons (int_sexp_grammar.untyped, Empty) ))
64
+
, Empty )
65
+
}
66
+
}
67
+
; No_tag
68
+
{ name = "B"
69
+
; clause_kind =
70
+
List_clause { args = Cons (string_sexp_grammar.untyped, Empty) }
71
+
}
72
+
]
73
+
}
74
+
}
75
+
;;
76
+
77
+
let _ = t_sexp_grammar
78
+
79
+
[@@@end]
80
+
81
+
open Expect_test_helpers_base
82
+
83
+
let%expect_test _ =
84
+
print_s (With_sexp.sexp_of_t (`A (1, 2)));
85
+
print_s (With_sexp.sexp_of_t (`B "foo"));
86
+
[%expect
87
+
{|
88
+
(A (1 2))
89
+
(B foo)
90
+
|}]
91
+
;;
92
+
end
93
+
94
+
module _ = struct
95
+
module With_sexp = struct
96
+
type t =
97
+
[ `Int of int
98
+
| `List of int list
99
+
| `Sexp_dot_list of int list [@sexp.list]
100
+
]
101
+
[@@deriving sexp]
102
+
end
103
+
104
+
type t =
105
+
[ `Int of int
106
+
| `List of int list
107
+
| `Sexp_dot_list of int list [@sexp.list]
108
+
]
109
+
[@@deriving_inline sexp_grammar]
110
+
111
+
let _ = fun (_ : t) -> ()
112
+
113
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
114
+
{ untyped =
115
+
Lazy
116
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
117
+
Variant
118
+
{ case_sensitivity = Case_sensitive
119
+
; clauses =
120
+
[ No_tag
121
+
{ name = "Int"
122
+
; clause_kind =
123
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
124
+
}
125
+
; No_tag
126
+
{ name = "List"
127
+
; clause_kind =
128
+
List_clause
129
+
{ args =
130
+
Cons ((list_sexp_grammar int_sexp_grammar).untyped, Empty)
131
+
}
132
+
}
133
+
; No_tag
134
+
{ name = "Sexp_dot_list"
135
+
; clause_kind =
136
+
List_clause { args = Many int_sexp_grammar.untyped }
137
+
}
138
+
]
139
+
}))
140
+
}
141
+
;;
142
+
143
+
let _ = t_sexp_grammar
144
+
145
+
[@@@end]
146
+
147
+
let (T : (With_sexp.t, t) Type_equal.t) = T
148
+
149
+
open Expect_test_helpers_base
150
+
151
+
let%expect_test _ =
152
+
print_s (With_sexp.sexp_of_t (`Int 1));
153
+
List.iter
154
+
[ []; [ 1 ]; [ 1; 2 ] ]
155
+
~f:(fun l ->
156
+
print_s (With_sexp.sexp_of_t (`List l));
157
+
print_s (With_sexp.sexp_of_t (`Sexp_dot_list l)));
158
+
[%expect
159
+
{|
160
+
(Int 1)
161
+
(List ())
162
+
(Sexp_dot_list)
163
+
(List (1))
164
+
(Sexp_dot_list 1)
165
+
(List (1 2))
166
+
(Sexp_dot_list 1 2)
167
+
|}]
168
+
;;
169
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.mli
···
1
+
(*_ This signature is deliberately empty. *)
+115
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.mlt
+115
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphic_variants.mlt
···
1
+
(* This toplevel test exercises some polymorphic variants that sexp_grammar rejects. We
2
+
show that in each case, the compiler or sexp would have given an error anyway. *)
3
+
4
+
open Base
5
+
6
+
type t = [ `A of int & string ] [@@deriving sexp]
7
+
8
+
[%%expect
9
+
{|
10
+
Line _, characters _-_:
11
+
Error: unsupported: polymorphic variant intersection type
12
+
|}]
13
+
14
+
type t = [ `A of int & string ] [@@deriving sexp_grammar]
15
+
16
+
[%%expect
17
+
{|
18
+
Line _, characters _-_:
19
+
Error: sexp_grammar: intersection types are unsupported
20
+
|}]
21
+
22
+
type t = [> `A ] [@@deriving sexp]
23
+
24
+
[%%expect
25
+
{|
26
+
Line _, characters _-_:
27
+
Error: Type unsupported for ppx [of_sexp] conversion (open polymorphic variant type)
28
+
|}]
29
+
30
+
type t = [> `A ] [@@deriving sexp_grammar]
31
+
32
+
[%%expect
33
+
{|
34
+
Line _, characters _-_:
35
+
Error: sexp_grammar: open polymorphic variant types are unsupported
36
+
|}]
37
+
38
+
type t = [< `A ] [@@deriving sexp]
39
+
40
+
[%%expect
41
+
{|
42
+
Line _, characters _-_:
43
+
Error: A type variable is unbound in this type declaration.
44
+
In type [< `A ] as 'a the variable 'a is unbound
45
+
|}]
46
+
47
+
type t = [< `A ] [@@deriving sexp_grammar]
48
+
49
+
[%%expect
50
+
{|
51
+
Line _, characters _-_:
52
+
Error: A type variable is unbound in this type declaration.
53
+
In type [< `A ] as 'a the variable 'a is unbound
54
+
|}]
55
+
56
+
type 'a t = [< `A ] as 'a [@@deriving sexp]
57
+
58
+
[%%expect
59
+
{|
60
+
Line _, characters _-_:
61
+
Error: Type unsupported for ppx [of_sexp] conversion (type alias)
62
+
|}]
63
+
64
+
type 'a t = [< `A ] as 'a [@@deriving sexp_grammar]
65
+
66
+
[%%expect
67
+
{|
68
+
Line _, characters _-_:
69
+
Error: sexp_grammar: type aliases are unsupported
70
+
|}]
71
+
72
+
type a = A : [> ] -> a [@@deriving sexp]
73
+
74
+
[%%expect
75
+
{|
76
+
Line _, characters _-_:
77
+
Error: Type unsupported for ppx [of_sexp] conversion (open polymorphic variant type)
78
+
|}]
79
+
80
+
type a = A : [> ] -> a [@@deriving sexp_of]
81
+
82
+
[%%expect
83
+
{|
84
+
Line _, characters _-_:
85
+
Error: Type unsupported for ppx [sexp_of] conversion (open polymorphic variant type)
86
+
|}]
87
+
88
+
type a = [ `A ] [@@deriving sexp];;
89
+
90
+
#verbose true
91
+
92
+
let f = [%sexp_of: [< a ]]
93
+
94
+
[%%expect
95
+
{|
96
+
val f : [< a ] -> Sexp.t = <fun>
97
+
|}]
98
+
99
+
let f = [%of_sexp: [> a ]]
100
+
101
+
[%%expect
102
+
{|
103
+
Line _, characters _-_:
104
+
Error: Type unsupported for ppx [of_sexp] conversion (open polymorphic variant type)
105
+
|}]
106
+
107
+
let f = [%of_sexp: [ | a ]]
108
+
109
+
[%%expect
110
+
{|
111
+
val f : Sexp.t -> a = <fun>
112
+
|}]
113
+
;;
114
+
115
+
#verbose false
+35
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphism.ml
+35
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphism.ml
···
1
+
open! Base
2
+
3
+
type ('a, _, 'b) t = 'a * 'b
4
+
and u = (string, int, float) t [@@deriving_inline sexp_grammar]
5
+
6
+
let _ = fun (_ : ('a, _, 'b) t) -> ()
7
+
let _ = fun (_ : u) -> ()
8
+
9
+
let t_sexp_grammar
10
+
: 'a 'b__001_ 'b.
11
+
'a Sexplib0.Sexp_grammar.t
12
+
-> 'b__001_ Sexplib0.Sexp_grammar.t
13
+
-> 'b Sexplib0.Sexp_grammar.t
14
+
-> ('a, 'b__001_, 'b) t Sexplib0.Sexp_grammar.t
15
+
=
16
+
fun _'a_sexp_grammar _'b__001__sexp_grammar _'b_sexp_grammar ->
17
+
{ untyped =
18
+
List (Cons (_'a_sexp_grammar.untyped, Cons (_'b_sexp_grammar.untyped, Empty)))
19
+
}
20
+
;;
21
+
22
+
let _ = t_sexp_grammar
23
+
24
+
let u_sexp_grammar : u Sexplib0.Sexp_grammar.t =
25
+
{ untyped =
26
+
Lazy
27
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
28
+
(t_sexp_grammar string_sexp_grammar int_sexp_grammar float_sexp_grammar)
29
+
.untyped))
30
+
}
31
+
;;
32
+
33
+
let _ = u_sexp_grammar
34
+
35
+
[@@@end]
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphism.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_polymorphism.mli
···
1
+
(*_ This signature is deliberately empty. *)
+124
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_recursive_groups.ml
+124
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_recursive_groups.ml
···
1
+
open Base
2
+
3
+
[@@@warning "-37"]
4
+
5
+
module _ = struct
6
+
type t = T of int [@@deriving_inline sexp_grammar]
7
+
8
+
let _ = fun (_ : t) -> ()
9
+
10
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
11
+
{ untyped =
12
+
Variant
13
+
{ case_sensitivity = Case_sensitive_except_first_character
14
+
; clauses =
15
+
[ No_tag
16
+
{ name = "T"
17
+
; clause_kind =
18
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
19
+
}
20
+
]
21
+
}
22
+
}
23
+
;;
24
+
25
+
let _ = t_sexp_grammar
26
+
27
+
[@@@end]
28
+
end
29
+
30
+
module _ = struct
31
+
type t =
32
+
| T_int of int
33
+
| T_u of u
34
+
35
+
and u =
36
+
| U_int of int
37
+
| U_t of t
38
+
[@@deriving_inline sexp_grammar]
39
+
40
+
let _ = fun (_ : t) -> ()
41
+
let _ = fun (_ : u) -> ()
42
+
43
+
include struct
44
+
open struct
45
+
let grammars__001_
46
+
: Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
47
+
=
48
+
Basement.Portable_lazy.from_fun
49
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
50
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
51
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
52
+
{ untyped = Recursive ("t", []) }
53
+
and u_sexp_grammar : u Sexplib0.Sexp_grammar.t =
54
+
{ untyped = Recursive ("u", []) }
55
+
in
56
+
[ { tycon = "t"
57
+
; tyvars = []
58
+
; grammar =
59
+
Variant
60
+
{ case_sensitivity = Case_sensitive_except_first_character
61
+
; clauses =
62
+
[ No_tag
63
+
{ name = "T_int"
64
+
; clause_kind =
65
+
List_clause
66
+
{ args = Cons (int_sexp_grammar.untyped, Empty) }
67
+
}
68
+
; No_tag
69
+
{ name = "T_u"
70
+
; clause_kind =
71
+
List_clause
72
+
{ args = Cons (u_sexp_grammar.untyped, Empty) }
73
+
}
74
+
]
75
+
}
76
+
}
77
+
; { tycon = "u"
78
+
; tyvars = []
79
+
; grammar =
80
+
Variant
81
+
{ case_sensitivity = Case_sensitive_except_first_character
82
+
; clauses =
83
+
[ No_tag
84
+
{ name = "U_int"
85
+
; clause_kind =
86
+
List_clause
87
+
{ args = Cons (int_sexp_grammar.untyped, Empty) }
88
+
}
89
+
; No_tag
90
+
{ name = "U_t"
91
+
; clause_kind =
92
+
List_clause
93
+
{ args = Cons (t_sexp_grammar.untyped, Empty) }
94
+
}
95
+
]
96
+
}
97
+
}
98
+
]))
99
+
;;
100
+
101
+
let _ = grammars__001_
102
+
end
103
+
104
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
105
+
{ untyped =
106
+
Lazy
107
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
108
+
Tycon ("t", [], Basement.Portable_lazy.force grammars__001_)))
109
+
}
110
+
111
+
and u_sexp_grammar : u Sexplib0.Sexp_grammar.t =
112
+
{ untyped =
113
+
Lazy
114
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
115
+
Tycon ("u", [], Basement.Portable_lazy.force grammars__001_)))
116
+
}
117
+
;;
118
+
119
+
let _ = t_sexp_grammar
120
+
and _ = u_sexp_grammar
121
+
end
122
+
123
+
[@@@end]
124
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_recursive_groups.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_recursive_groups.mli
···
1
+
(*_ This signature is deliberately empty. *)
+161
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_regular_variants.ml
+161
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_regular_variants.ml
···
1
+
open Base
2
+
3
+
[@@@warning "-37"]
4
+
5
+
module _ = struct
6
+
type 'a t =
7
+
| A
8
+
| B
9
+
[@@deriving_inline sexp_grammar]
10
+
11
+
let _ = fun (_ : 'a t) -> ()
12
+
13
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
14
+
fun _'a_sexp_grammar ->
15
+
{ untyped =
16
+
Variant
17
+
{ case_sensitivity = Case_sensitive_except_first_character
18
+
; clauses =
19
+
[ No_tag { name = "A"; clause_kind = Atom_clause }
20
+
; No_tag { name = "B"; clause_kind = Atom_clause }
21
+
]
22
+
}
23
+
}
24
+
;;
25
+
26
+
let _ = t_sexp_grammar
27
+
28
+
[@@@end]
29
+
end
30
+
31
+
module _ = struct
32
+
module With_sexp = struct
33
+
type t =
34
+
| A of int * int
35
+
| B of string
36
+
[@@deriving sexp_of]
37
+
end
38
+
39
+
type t = With_sexp.t =
40
+
| A of int * int
41
+
| B of string
42
+
[@@deriving_inline sexp_grammar]
43
+
44
+
let _ = fun (_ : t) -> ()
45
+
46
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
47
+
{ untyped =
48
+
Variant
49
+
{ case_sensitivity = Case_sensitive_except_first_character
50
+
; clauses =
51
+
[ No_tag
52
+
{ name = "A"
53
+
; clause_kind =
54
+
List_clause
55
+
{ args =
56
+
Cons
57
+
( int_sexp_grammar.untyped
58
+
, Cons (int_sexp_grammar.untyped, Empty) )
59
+
}
60
+
}
61
+
; No_tag
62
+
{ name = "B"
63
+
; clause_kind =
64
+
List_clause { args = Cons (string_sexp_grammar.untyped, Empty) }
65
+
}
66
+
]
67
+
}
68
+
}
69
+
;;
70
+
71
+
let _ = t_sexp_grammar
72
+
73
+
[@@@end]
74
+
75
+
open Expect_test_helpers_base
76
+
77
+
let%expect_test _ =
78
+
print_s (With_sexp.sexp_of_t (A (1, 2)));
79
+
print_s (With_sexp.sexp_of_t (B "foo"));
80
+
[%expect
81
+
{|
82
+
(A 1 2)
83
+
(B foo)
84
+
|}]
85
+
;;
86
+
end
87
+
88
+
module _ = struct
89
+
module With_sexp = struct
90
+
type t =
91
+
| Int of int
92
+
| List of int list
93
+
| Sexp_dot_list of int list [@sexp.list]
94
+
[@@deriving sexp]
95
+
end
96
+
97
+
type t = With_sexp.t =
98
+
| Int of int
99
+
| List of int list
100
+
| Sexp_dot_list of int list [@sexp.list]
101
+
[@@deriving_inline sexp_grammar]
102
+
103
+
let _ = fun (_ : t) -> ()
104
+
105
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
106
+
{ untyped =
107
+
Lazy
108
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
109
+
Variant
110
+
{ case_sensitivity = Case_sensitive_except_first_character
111
+
; clauses =
112
+
[ No_tag
113
+
{ name = "Int"
114
+
; clause_kind =
115
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
116
+
}
117
+
; No_tag
118
+
{ name = "List"
119
+
; clause_kind =
120
+
List_clause
121
+
{ args =
122
+
Cons ((list_sexp_grammar int_sexp_grammar).untyped, Empty)
123
+
}
124
+
}
125
+
; No_tag
126
+
{ name = "Sexp_dot_list"
127
+
; clause_kind =
128
+
List_clause { args = Many int_sexp_grammar.untyped }
129
+
}
130
+
]
131
+
}))
132
+
}
133
+
;;
134
+
135
+
let _ = t_sexp_grammar
136
+
137
+
[@@@end]
138
+
139
+
let (T : (With_sexp.t, t) Type_equal.t) = T
140
+
141
+
open Expect_test_helpers_base
142
+
143
+
let%expect_test _ =
144
+
print_s (With_sexp.sexp_of_t (Int 1));
145
+
List.iter
146
+
[ []; [ 1 ]; [ 1; 2 ] ]
147
+
~f:(fun l ->
148
+
print_s (With_sexp.sexp_of_t (List l));
149
+
print_s (With_sexp.sexp_of_t (Sexp_dot_list l)));
150
+
[%expect
151
+
{|
152
+
(Int 1)
153
+
(List ())
154
+
(Sexp_dot_list)
155
+
(List (1))
156
+
(Sexp_dot_list 1)
157
+
(List (1 2))
158
+
(Sexp_dot_list 1 2)
159
+
|}]
160
+
;;
161
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_regular_variants.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_regular_variants.mli
···
1
+
(*_ This signature is deliberately empty. *)
+194
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_tag_type_names.ml
+194
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_tag_type_names.ml
···
1
+
open! Base
2
+
3
+
module _ = struct
4
+
(* Nonrecursive constant *)
5
+
type t = [ `T of int ] [@@deriving_inline sexp_grammar]
6
+
7
+
let _ = fun (_ : t) -> ()
8
+
9
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
10
+
{ untyped =
11
+
Variant
12
+
{ case_sensitivity = Case_sensitive
13
+
; clauses =
14
+
[ No_tag
15
+
{ name = "T"
16
+
; clause_kind =
17
+
List_clause { args = Cons (int_sexp_grammar.untyped, Empty) }
18
+
}
19
+
]
20
+
}
21
+
}
22
+
;;
23
+
24
+
let _ = t_sexp_grammar
25
+
26
+
[@@@end]
27
+
end
28
+
29
+
module _ = struct
30
+
(* Recursive constant *)
31
+
type t = [ `T of t ] [@@deriving_inline sexp_grammar]
32
+
33
+
let _ = fun (_ : t) -> ()
34
+
35
+
include struct
36
+
open struct
37
+
let grammars__001_
38
+
: Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
39
+
=
40
+
Basement.Portable_lazy.from_fun
41
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
42
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
43
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
44
+
{ untyped = Recursive ("t", []) }
45
+
in
46
+
[ { tycon = "t"
47
+
; tyvars = []
48
+
; grammar =
49
+
Variant
50
+
{ case_sensitivity = Case_sensitive
51
+
; clauses =
52
+
[ No_tag
53
+
{ name = "T"
54
+
; clause_kind =
55
+
List_clause
56
+
{ args = Cons (t_sexp_grammar.untyped, Empty) }
57
+
}
58
+
]
59
+
}
60
+
}
61
+
]))
62
+
;;
63
+
64
+
let _ = grammars__001_
65
+
end
66
+
67
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
68
+
{ untyped =
69
+
Lazy
70
+
(Basement.Portable_lazy.from_fun (fun () : Sexplib0.Sexp_grammar.grammar ->
71
+
Tycon ("t", [], Basement.Portable_lazy.force grammars__001_)))
72
+
}
73
+
;;
74
+
75
+
let _ = t_sexp_grammar
76
+
end
77
+
78
+
[@@@end]
79
+
end
80
+
81
+
module _ = struct
82
+
(* Nonrecursive parameterized *)
83
+
type 'a t = [ `T of 'a ] [@@deriving_inline sexp_grammar]
84
+
85
+
let _ = fun (_ : 'a t) -> ()
86
+
87
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
88
+
fun _'a_sexp_grammar ->
89
+
{ untyped =
90
+
Variant
91
+
{ case_sensitivity = Case_sensitive
92
+
; clauses =
93
+
[ No_tag
94
+
{ name = "T"
95
+
; clause_kind =
96
+
List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) }
97
+
}
98
+
]
99
+
}
100
+
}
101
+
;;
102
+
103
+
let _ = t_sexp_grammar
104
+
105
+
[@@@end]
106
+
end
107
+
108
+
module _ = struct
109
+
(* Recursive parameterized *)
110
+
type 'a t = [ `T of 'a t ] [@@deriving_inline sexp_grammar]
111
+
112
+
let _ = fun (_ : 'a t) -> ()
113
+
114
+
include struct
115
+
open struct
116
+
let grammars__002_
117
+
: Sexplib0.Sexp_grammar.defn Stdlib.List.t Basement.Portable_lazy.t
118
+
=
119
+
Basement.Portable_lazy.from_fun
120
+
(Basement.Portability_hacks.magic_portable__needs_base_and_core
121
+
(fun () : Sexplib0.Sexp_grammar.defn list ->
122
+
let t_sexp_grammar
123
+
: 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t
124
+
=
125
+
fun _'a_sexp_grammar ->
126
+
{ untyped = Recursive ("t", [ _'a_sexp_grammar.untyped ]) }
127
+
in
128
+
[ { tycon = "t"
129
+
; tyvars = [ "a" ]
130
+
; grammar =
131
+
Variant
132
+
{ case_sensitivity = Case_sensitive
133
+
; clauses =
134
+
[ No_tag
135
+
{ name = "T"
136
+
; clause_kind =
137
+
List_clause
138
+
{ args =
139
+
Cons
140
+
( (t_sexp_grammar { untyped = Tyvar "a" })
141
+
.untyped
142
+
, Empty )
143
+
}
144
+
}
145
+
]
146
+
}
147
+
}
148
+
]))
149
+
;;
150
+
151
+
let _ = grammars__002_
152
+
end
153
+
154
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
155
+
fun _'a_sexp_grammar ->
156
+
{ untyped =
157
+
Tycon
158
+
( "t"
159
+
, [ _'a_sexp_grammar.untyped ]
160
+
, Basement.Portable_lazy.force grammars__002_ )
161
+
}
162
+
;;
163
+
164
+
let _ = t_sexp_grammar
165
+
end
166
+
167
+
[@@@end]
168
+
end
169
+
170
+
module _ = struct
171
+
(* Aliasing of non-parameterized type *)
172
+
type t = int [@@deriving_inline sexp_grammar]
173
+
174
+
let _ = fun (_ : t) -> ()
175
+
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar
176
+
let _ = t_sexp_grammar
177
+
178
+
[@@@end]
179
+
end
180
+
181
+
module _ = struct
182
+
(* Aliasing of parameterized type *)
183
+
type 'a t = 'a list [@@deriving_inline sexp_grammar]
184
+
185
+
let _ = fun (_ : 'a t) -> ()
186
+
187
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
188
+
fun _'a_sexp_grammar -> list_sexp_grammar _'a_sexp_grammar
189
+
;;
190
+
191
+
let _ = t_sexp_grammar
192
+
193
+
[@@@end]
194
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_tag_type_names.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_tag_type_names.mli
···
1
+
(*_ This signature is deliberately empty. *)
+86
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_test.ml
+86
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_test.ml
···
1
+
open! Base
2
+
3
+
module _ = struct
4
+
type t = int [@@deriving_inline sexp_grammar]
5
+
6
+
let _ = fun (_ : t) -> ()
7
+
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int_sexp_grammar
8
+
let _ = t_sexp_grammar
9
+
10
+
[@@@end]
11
+
end
12
+
13
+
module _ = struct
14
+
type 'a t = T of 'a
15
+
and 'a u = U of 'a t option [@@deriving_inline sexp_grammar]
16
+
17
+
let _ = fun (_ : 'a t) -> ()
18
+
let _ = fun (_ : 'a u) -> ()
19
+
20
+
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
21
+
fun _'a_sexp_grammar ->
22
+
{ untyped =
23
+
Variant
24
+
{ case_sensitivity = Case_sensitive_except_first_character
25
+
; clauses =
26
+
[ No_tag
27
+
{ name = "T"
28
+
; clause_kind =
29
+
List_clause { args = Cons (_'a_sexp_grammar.untyped, Empty) }
30
+
}
31
+
]
32
+
}
33
+
}
34
+
;;
35
+
36
+
let _ = t_sexp_grammar
37
+
38
+
let u_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a u Sexplib0.Sexp_grammar.t =
39
+
fun _'a_sexp_grammar ->
40
+
{ untyped =
41
+
Variant
42
+
{ case_sensitivity = Case_sensitive_except_first_character
43
+
; clauses =
44
+
[ No_tag
45
+
{ name = "U"
46
+
; clause_kind =
47
+
List_clause
48
+
{ args =
49
+
Cons
50
+
( (option_sexp_grammar (t_sexp_grammar _'a_sexp_grammar))
51
+
.untyped
52
+
, Empty )
53
+
}
54
+
}
55
+
]
56
+
}
57
+
}
58
+
;;
59
+
60
+
let _ = u_sexp_grammar
61
+
62
+
[@@@end]
63
+
64
+
(* Avoid unused constructor warnings. *)
65
+
let _ = T ()
66
+
let _ = U None
67
+
end
68
+
69
+
module _ = struct
70
+
type ('a, 'b) t = 'a -> 'b [@@deriving_inline sexp_grammar]
71
+
72
+
let _ = fun (_ : ('a, 'b) t) -> ()
73
+
74
+
let t_sexp_grammar
75
+
: 'a 'b.
76
+
'a Sexplib0.Sexp_grammar.t
77
+
-> 'b Sexplib0.Sexp_grammar.t
78
+
-> ('a, 'b) t Sexplib0.Sexp_grammar.t
79
+
=
80
+
fun _'a_sexp_grammar _'b_sexp_grammar -> Sexplib0.Sexp_conv.fun_sexp_grammar
81
+
;;
82
+
83
+
let _ = t_sexp_grammar
84
+
85
+
[@@@end]
86
+
end
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_test.mli
+1
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_test.mli
···
1
+
(*_ This signature is deliberately empty. *)
+86
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_variants_more.ml
+86
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_variants_more.ml
···
1
+
open Base
2
+
3
+
[@@@warning "-37"]
4
+
5
+
module _ = struct
6
+
type t = A of [ `A of int ] [@@deriving_inline sexp_grammar]
7
+
8
+
let _ = fun (_ : t) -> ()
9
+
10
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
11
+
{ untyped =
12
+
Variant
13
+
{ case_sensitivity = Case_sensitive_except_first_character
14
+
; clauses =
15
+
[ No_tag
16
+
{ name = "A"
17
+
; clause_kind =
18
+
List_clause
19
+
{ args =
20
+
Cons
21
+
( Variant
22
+
{ case_sensitivity = Case_sensitive
23
+
; clauses =
24
+
[ No_tag
25
+
{ name = "A"
26
+
; clause_kind =
27
+
List_clause
28
+
{ args =
29
+
Cons (int_sexp_grammar.untyped, Empty)
30
+
}
31
+
}
32
+
]
33
+
}
34
+
, Empty )
35
+
}
36
+
}
37
+
]
38
+
}
39
+
}
40
+
;;
41
+
42
+
let _ = t_sexp_grammar
43
+
44
+
[@@@end]
45
+
end
46
+
47
+
module _ = struct
48
+
type t = { a : [ `A of int ] } [@@deriving_inline sexp_grammar]
49
+
50
+
let _ = fun (_ : t) -> ()
51
+
52
+
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t =
53
+
{ untyped =
54
+
List
55
+
(Fields
56
+
{ allow_extra_fields = false
57
+
; fields =
58
+
[ No_tag
59
+
{ name = "a"
60
+
; required = true
61
+
; args =
62
+
Cons
63
+
( Variant
64
+
{ case_sensitivity = Case_sensitive
65
+
; clauses =
66
+
[ No_tag
67
+
{ name = "A"
68
+
; clause_kind =
69
+
List_clause
70
+
{ args =
71
+
Cons (int_sexp_grammar.untyped, Empty)
72
+
}
73
+
}
74
+
]
75
+
}
76
+
, Empty )
77
+
}
78
+
]
79
+
})
80
+
}
81
+
;;
82
+
83
+
let _ = t_sexp_grammar
84
+
85
+
[@@@end]
86
+
end
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_variants_more.mli
vendor/opam/ppx_sexp_conv/test/sexp_grammar/test_variants_more.mli
This is a binary file and will not be displayed.
+34
vendor/opam/ppx_sexp_conv/test/test.sexp
+34
vendor/opam/ppx_sexp_conv/test/test.sexp
···
1
+
(this is a list)
2
+
3
+
(this is another list and (this is a nested list))
4
+
5
+
(
6
+
"\
7
+
This is a multi-line \
8
+
string with embedded
9
+
10
+
newlines."
11
+
12
+
"This string contains decimal \255, hex \xff codes, \
13
+
and other \\ \n escapes."
14
+
15
+
A# # ## #x|
16
+
)
17
+
18
+
; Line comment
19
+
20
+
#; (
21
+
S-expression comment
22
+
)
23
+
24
+
#| #| Nested |# block comment "|#" |#
25
+
26
+
#| "" |#
27
+
#| ""|#
28
+
#|"" |#
29
+
#|""|#
30
+
31
+
#| "asdf" "asdf" |#
32
+
33
+
(something #| ; |# () "something else")
34
+