My working unpac space for OCaml projects in development
Merge opam/patches/sexplib0
+4789
+1
vendor/opam/sexplib0/.ocamlformat
+1
vendor/opam/sexplib0/.ocamlformat
···
1
+
profile=janestreet
+18
vendor/opam/sexplib0/CHANGES.md
+18
vendor/opam/sexplib0/CHANGES.md
···
1
+
## Release v0.17.0
2
+
3
+
* Add a test that `Sexp.to_string` works on large input.
4
+
5
+
* Improve error messages produced by `Sexp_conv`
6
+
7
+
* Use `[@tail_mod_cons]` in `sexp_of_list`.
8
+
9
+
* Add support for labeled tuples, a compiler extension available at:
10
+
https://github.com/ocaml-flambda/flambda-backend
11
+
12
+
## Release v0.16.0
13
+
14
+
* Added `Sexp_conv_record`. Supports improvements to `ppx_sexp_conv` for deriving
15
+
`of_sexp` on record types. Provides a GADT-based generic interface to parsing record
16
+
sexps. This avoids having to generate the same field-parsing code over and over.
17
+
18
+
* Added `sexp_grammar_with_tags` and `sexp_grammar_with_tag_list` to `Sexp_conv_grammar`.
+67
vendor/opam/sexplib0/CONTRIBUTING.md
+67
vendor/opam/sexplib0/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/sexplib0/LICENSE.md
+21
vendor/opam/sexplib0/LICENSE.md
···
1
+
The MIT License
2
+
3
+
Copyright (c) 2005--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/sexplib0/Makefile
+17
vendor/opam/sexplib0/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
+9
vendor/opam/sexplib0/README.md
+9
vendor/opam/sexplib0/README.md
···
1
+
"Sexplib0 - a low-dep version of Sexplib"
2
+
=========================================
3
+
4
+
`sexplib0` is a lightweight portion of `sexplib`, for situations where a
5
+
dependency on `sexplib` is problematic.
6
+
7
+
It has the type definition and the printing functions, but not parsing.
8
+
9
+
See [sexplib](https://github.com/janestreet/sexplib) for documentation.
+135
vendor/opam/sexplib0/bench/bench_record.ml
+135
vendor/opam/sexplib0/bench/bench_record.ml
···
1
+
open Sexplib0.Sexp_conv
2
+
3
+
type 'a or_null = 'a Basement.Or_null_shim.t
4
+
5
+
let bench_t_of_sexp ~t_of_sexp string =
6
+
let sexp = Sys.opaque_identity (Parsexp.Single.parse_string_exn string) in
7
+
fun () -> t_of_sexp sexp
8
+
;;
9
+
10
+
type t =
11
+
{ a : int
12
+
; b : int option
13
+
; c : bool
14
+
; d : int array
15
+
; e : int list
16
+
; f : int option
17
+
; g : int
18
+
; h : 'a. 'a list
19
+
; i : int or_null
20
+
}
21
+
22
+
let t_of_sexp =
23
+
let open struct
24
+
type poly = { h : 'a. 'a list } [@@unboxed]
25
+
end in
26
+
Sexplib0.Sexp_conv_record.record_of_sexp
27
+
~caller:"Record.t"
28
+
~fields:
29
+
(Field
30
+
{ name = "a"
31
+
; kind = Required
32
+
; conv =
33
+
(fun sexp ->
34
+
let value = int_of_sexp sexp in
35
+
fun () -> value)
36
+
; rest =
37
+
Field
38
+
{ name = "b"
39
+
; kind = Omit_nil
40
+
; conv =
41
+
(fun sexp ->
42
+
let value = option_of_sexp int_of_sexp sexp in
43
+
fun () -> value)
44
+
; rest =
45
+
Field
46
+
{ name = "c"
47
+
; kind = Sexp_bool
48
+
; conv = ()
49
+
; rest =
50
+
Field
51
+
{ name = "d"
52
+
; kind = Sexp_array
53
+
; conv = int_of_sexp
54
+
; rest =
55
+
Field
56
+
{ name = "e"
57
+
; kind = Sexp_list
58
+
; conv = int_of_sexp
59
+
; rest =
60
+
Field
61
+
{ name = "f"
62
+
; kind = Sexp_option
63
+
; conv = int_of_sexp
64
+
; rest =
65
+
Field
66
+
{ name = "g"
67
+
; kind = Default (fun () -> 0)
68
+
; conv =
69
+
(fun sexp ->
70
+
let value = int_of_sexp sexp in
71
+
fun () -> value)
72
+
; rest =
73
+
Field
74
+
{ name = "h"
75
+
; kind = Required
76
+
; conv =
77
+
(fun sexp ->
78
+
let value =
79
+
{ h =
80
+
list_of_sexp
81
+
(Sexplib0.Sexp_conv_error
82
+
.record_poly_field_value
83
+
"Record.t")
84
+
sexp
85
+
}
86
+
in
87
+
fun () -> value)
88
+
; rest =
89
+
Field
90
+
{ name = "i"
91
+
; kind = Sexp_or_null
92
+
; conv = int_of_sexp
93
+
; rest = Empty
94
+
}
95
+
}
96
+
}
97
+
}
98
+
}
99
+
}
100
+
}
101
+
}
102
+
})
103
+
~index_of_field:(function
104
+
| "a" -> 0
105
+
| "b" -> 1
106
+
| "c" -> 2
107
+
| "d" -> 3
108
+
| "e" -> 4
109
+
| "f" -> 5
110
+
| "g" -> 6
111
+
| "h" -> 7
112
+
| "i" -> 8
113
+
| _ -> -1)
114
+
~allow_extra_fields:false
115
+
~create:(fun (a, (b, (c, (d, (e, (f, (g, (h, (i, ()))))))))) ->
116
+
let a = a () in
117
+
let b = b () in
118
+
let g = g () in
119
+
let { h } = h () in
120
+
{ a; b; c; d; e; f; g; h; i })
121
+
;;
122
+
123
+
let%bench_fun "t_of_sexp, full, in order" =
124
+
bench_t_of_sexp
125
+
~t_of_sexp
126
+
"((a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h ()) (i 9))"
127
+
;;
128
+
129
+
let%bench_fun "t_of_sexp, full, reverse order" =
130
+
bench_t_of_sexp
131
+
~t_of_sexp
132
+
"((i 9) (h ()) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) (a 1))"
133
+
;;
134
+
135
+
let%bench_fun "t_of_sexp, empty" = bench_t_of_sexp ~t_of_sexp "((a 0) (h ()))"
+1
vendor/opam/sexplib0/bench/bench_record.mli
+1
vendor/opam/sexplib0/bench/bench_record.mli
···
1
+
(*_ This signature is deliberately empty. *)
+5
vendor/opam/sexplib0/bench/dune
+5
vendor/opam/sexplib0/bench/dune
+1
vendor/opam/sexplib0/bench/sexplib0_bench.ml
+1
vendor/opam/sexplib0/bench/sexplib0_bench.ml
···
1
+
(*_ Deliberately empty. *)
+1
vendor/opam/sexplib0/dune-project
+1
vendor/opam/sexplib0/dune-project
···
1
+
(lang dune 3.17)
+24
vendor/opam/sexplib0/sexplib0.opam
+24
vendor/opam/sexplib0/sexplib0.opam
···
1
+
opam-version: "2.0"
2
+
maintainer: "Jane Street developers"
3
+
authors: ["Jane Street Group, LLC"]
4
+
homepage: "https://github.com/janestreet/sexplib0"
5
+
bug-reports: "https://github.com/janestreet/sexplib0/issues"
6
+
dev-repo: "git+https://github.com/janestreet/sexplib0.git"
7
+
doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/sexplib0/index.html"
8
+
license: "MIT"
9
+
build: [
10
+
["dune" "build" "-p" name "-j" jobs]
11
+
]
12
+
depends: [
13
+
"ocaml" {>= "4.14.0"}
14
+
"basement"
15
+
"dune" {>= "3.17.0"}
16
+
]
17
+
available: arch != "arm32" & arch != "x86_32"
18
+
synopsis: "Library containing the definition of S-expressions and some base converters"
19
+
description: "
20
+
Part of Jane Street's Core library
21
+
The Core suite of libraries is an industrial strength alternative to
22
+
OCaml's standard library that was developed by Jane Street, the
23
+
largest industrial user of OCaml.
24
+
"
+6
vendor/opam/sexplib0/src/dune
+6
vendor/opam/sexplib0/src/dune
+546
vendor/opam/sexplib0/src/sexp.ml
+546
vendor/opam/sexplib0/src/sexp.ml
···
1
+
open Basement
2
+
open StdLabels
3
+
open Format
4
+
open Stdlib_stubs
5
+
include Sexp_intf.Definitions
6
+
7
+
let sexp_of_t t = t
8
+
let sexp_of_t__stack t = t
9
+
let t_of_sexp t = t
10
+
11
+
let rec compare_list a b =
12
+
match a, b with
13
+
| [], [] -> 0
14
+
| [], _ -> -1
15
+
| _, [] -> 1
16
+
| x :: xs, y :: ys ->
17
+
let res = compare x y in
18
+
if res <> 0 then res else compare_list xs ys
19
+
20
+
and compare a b =
21
+
if a == b
22
+
then 0
23
+
else (
24
+
match a, b with
25
+
| Atom a, Atom b -> String.compare a b
26
+
| Atom _, _ -> -1
27
+
| _, Atom _ -> 1
28
+
| List a, List b -> compare_list a b)
29
+
;;
30
+
31
+
let rec equal a b =
32
+
a == b
33
+
||
34
+
match a, b with
35
+
| Atom a, Atom b -> String.equal a b
36
+
| Atom _, _ | _, Atom _ -> false
37
+
| List a, List b -> List.equal ~eq:equal a b
38
+
;;
39
+
40
+
exception Not_found_s of t
41
+
exception Of_sexp_error of exn * t
42
+
43
+
module Printing = struct
44
+
(** Default indentation level for human-readable conversions *)
45
+
let default_indent = Dynamic.make 1
46
+
47
+
let index_of_newline str start = String.index_from_opt str start '\n'
48
+
49
+
(* The maximum size of a thing on the minor heap is 256 words.
50
+
Previously, this size of the returned buffer here was 4096 bytes, which
51
+
caused the Buffer to be allocated on the *major* heap every time.
52
+
53
+
According to a simple benchmark by Ron, we can improve performance for
54
+
small s-expressions by a factor of ~4 if we only allocate 1024 bytes
55
+
(128 words + some small overhead) worth of buffer initially. And one
56
+
can argue that if it's free to allocate strings smaller than 256 words,
57
+
large s-expressions requiring larger expensive buffers won't notice
58
+
the extra two doublings from 1024 bytes to 2048 and 4096. And especially
59
+
performance-sensitive applications to always pass in a larger buffer to
60
+
use. *)
61
+
let buffer () = Buffer.create 1024
62
+
63
+
[@@@expand_inline
64
+
[%%template
65
+
[@@@alloc.default a @ m = (stack_local, heap_global)]
66
+
67
+
let to_buffer_mach_internal ~buf sexp ~mach_maybe_esc_str =
68
+
let rec loop may_need_space = function
69
+
| Atom str ->
70
+
let str' = mach_maybe_esc_str str in
71
+
let new_may_need_space = str' == str in
72
+
if may_need_space && new_may_need_space then Buffer.add_char buf ' ';
73
+
Buffer.add_string buf str';
74
+
new_may_need_space
75
+
| List (h :: t) ->
76
+
Buffer.add_char buf '(';
77
+
let may_need_space = loop false h in
78
+
loop_rest may_need_space t;
79
+
false
80
+
| List [] ->
81
+
Buffer.add_string buf "()";
82
+
false
83
+
and loop_rest may_need_space = function
84
+
| h :: t ->
85
+
let may_need_space = loop may_need_space h in
86
+
loop_rest may_need_space t
87
+
| [] -> Buffer.add_char buf ')'
88
+
in
89
+
ignore (loop false sexp)
90
+
;;
91
+
92
+
let to_string_mach_internal t ~mach_maybe_esc_str =
93
+
match t with
94
+
| Atom str -> mach_maybe_esc_str str [@exclave_if_stack a]
95
+
| sexp ->
96
+
(let buf = buffer () in
97
+
(to_buffer_mach_internal [@alloc a]) ~buf sexp ~mach_maybe_esc_str;
98
+
let len = Buffer.length buf in
99
+
let bytes = (Bytes.create [@alloc a]) len in
100
+
Buffer.blit buf 0 bytes 0 len;
101
+
Bytes.unsafe_to_string bytes)
102
+
[@exclave_if_stack a]
103
+
;;]]
104
+
105
+
include struct
106
+
let to_buffer_mach_internal__stack ~buf sexp ~mach_maybe_esc_str =
107
+
let rec loop may_need_space = function
108
+
| Atom str ->
109
+
let str' = mach_maybe_esc_str str in
110
+
let new_may_need_space = str' == str in
111
+
if may_need_space && new_may_need_space then Buffer.add_char buf ' ';
112
+
Buffer.add_string buf str';
113
+
new_may_need_space
114
+
| List (h :: t) ->
115
+
Buffer.add_char buf '(';
116
+
let may_need_space = loop false h in
117
+
loop_rest may_need_space t;
118
+
false
119
+
| List [] ->
120
+
Buffer.add_string buf "()";
121
+
false
122
+
and loop_rest may_need_space = function
123
+
| h :: t ->
124
+
let may_need_space = loop may_need_space h in
125
+
loop_rest may_need_space t
126
+
| [] -> Buffer.add_char buf ')'
127
+
in
128
+
ignore (loop false sexp)
129
+
;;
130
+
131
+
let to_string_mach_internal__stack t ~mach_maybe_esc_str =
132
+
match t with
133
+
| Atom str -> mach_maybe_esc_str str
134
+
| sexp ->
135
+
let buf = buffer () in
136
+
to_buffer_mach_internal__stack ~buf sexp ~mach_maybe_esc_str;
137
+
let len = Buffer.length buf in
138
+
let bytes = Bytes.create__stack len in
139
+
Buffer.blit buf 0 bytes 0 len;
140
+
Bytes.unsafe_to_string bytes
141
+
;;
142
+
end [@@ocaml.doc " @inline "]
143
+
144
+
include struct
145
+
let to_buffer_mach_internal ~buf sexp ~mach_maybe_esc_str =
146
+
let rec loop may_need_space = function
147
+
| Atom str ->
148
+
let str' = mach_maybe_esc_str str in
149
+
let new_may_need_space = str' == str in
150
+
if may_need_space && new_may_need_space then Buffer.add_char buf ' ';
151
+
Buffer.add_string buf str';
152
+
new_may_need_space
153
+
| List (h :: t) ->
154
+
Buffer.add_char buf '(';
155
+
let may_need_space = loop false h in
156
+
loop_rest may_need_space t;
157
+
false
158
+
| List [] ->
159
+
Buffer.add_string buf "()";
160
+
false
161
+
and loop_rest may_need_space = function
162
+
| h :: t ->
163
+
let may_need_space = loop may_need_space h in
164
+
loop_rest may_need_space t
165
+
| [] -> Buffer.add_char buf ')'
166
+
in
167
+
ignore (loop false sexp)
168
+
;;
169
+
170
+
let to_string_mach_internal t ~mach_maybe_esc_str =
171
+
match t with
172
+
| Atom str -> mach_maybe_esc_str str
173
+
| sexp ->
174
+
let buf = buffer () in
175
+
to_buffer_mach_internal ~buf sexp ~mach_maybe_esc_str;
176
+
let len = Buffer.length buf in
177
+
let bytes = Bytes.create len in
178
+
Buffer.blit buf 0 bytes 0 len;
179
+
Bytes.unsafe_to_string bytes
180
+
;;
181
+
end [@@ocaml.doc " @inline "]
182
+
183
+
[@@@end]
184
+
185
+
module Make_pretty_printing (Helpers : Pretty_printing_helpers) :
186
+
Pretty_printing with type output := string = struct
187
+
include Helpers
188
+
189
+
let to_buffer_hum ~buf ?(indent = Dynamic.get default_indent) ?max_width sexp =
190
+
let ppf = Format.formatter_of_buffer buf in
191
+
let () =
192
+
match max_width with
193
+
| Some width -> Format.pp_set_margin ppf width
194
+
| None -> ()
195
+
in
196
+
Format.fprintf ppf "%a@?" (pp_hum_indent indent) sexp
197
+
;;
198
+
199
+
let to_buffer_mach ~buf sexp = to_buffer_mach_internal ~buf sexp ~mach_maybe_esc_str
200
+
let to_buffer = to_buffer_mach
201
+
202
+
let to_buffer_gen ~buf ~add_char ~add_string sexp =
203
+
let rec loop may_need_space = function
204
+
| Atom str ->
205
+
let str' = mach_maybe_esc_str str in
206
+
let new_may_need_space = str' == str in
207
+
if may_need_space && new_may_need_space then add_char buf ' ';
208
+
add_string buf str';
209
+
new_may_need_space
210
+
| List (h :: t) ->
211
+
add_char buf '(';
212
+
let may_need_space = loop false h in
213
+
loop_rest may_need_space t;
214
+
false
215
+
| List [] ->
216
+
add_string buf "()";
217
+
false
218
+
and loop_rest may_need_space = function
219
+
| h :: t ->
220
+
let may_need_space = loop may_need_space h in
221
+
loop_rest may_need_space t
222
+
| [] -> add_char buf ')'
223
+
in
224
+
ignore (loop false sexp)
225
+
;;
226
+
227
+
(* String conversions *)
228
+
229
+
let to_string_hum ?indent ?max_width = function
230
+
| Atom str
231
+
when match index_of_newline str 0 with
232
+
| None -> true
233
+
| Some _ -> false -> mach_maybe_esc_str str
234
+
| sexp ->
235
+
let buf = buffer () in
236
+
to_buffer_hum ~buf ?indent ?max_width sexp;
237
+
Buffer.contents buf
238
+
;;
239
+
240
+
let to_string_mach sexp = to_string_mach_internal sexp ~mach_maybe_esc_str
241
+
let to_string = to_string_mach
242
+
243
+
module Pretty_printing_helpers_private = Helpers
244
+
end
245
+
246
+
(* Escaping of strings used as atoms in S-expressions *)
247
+
248
+
module Printing_helpers = struct
249
+
let must_escape str =
250
+
let len = String.length str in
251
+
len = 0
252
+
||
253
+
let rec loop str ix =
254
+
match str.[ix] with
255
+
| '"' | '(' | ')' | ';' | '\\' -> true
256
+
| '|' ->
257
+
ix > 0
258
+
&&
259
+
let next = ix - 1 in
260
+
Char.equal str.[next] '#' || loop str next
261
+
| '#' ->
262
+
ix > 0
263
+
&&
264
+
let next = ix - 1 in
265
+
Char.equal str.[next] '|' || loop str next
266
+
| '\000' .. '\032' | '\127' .. '\255' -> true
267
+
| _ -> ix > 0 && loop str (ix - 1)
268
+
in
269
+
loop str (len - 1)
270
+
;;
271
+
272
+
let length_of_escaped_string s =
273
+
let n = ref 0 in
274
+
for i = 0 to String.length s - 1 do
275
+
n
276
+
:= !n
277
+
+
278
+
match String.unsafe_get s i with
279
+
| '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
280
+
| ' ' .. '~' -> 1
281
+
| _ -> 4
282
+
done;
283
+
!n
284
+
;;
285
+
286
+
let escaped_bytes s bytes =
287
+
let n = ref 0 in
288
+
n := 0;
289
+
for i = 0 to String.length s - 1 do
290
+
(match String.unsafe_get s i with
291
+
| ('\"' | '\\') as c ->
292
+
Bytes.unsafe_set bytes !n '\\';
293
+
incr n;
294
+
Bytes.unsafe_set bytes !n c
295
+
| '\n' ->
296
+
Bytes.unsafe_set bytes !n '\\';
297
+
incr n;
298
+
Bytes.unsafe_set bytes !n 'n'
299
+
| '\t' ->
300
+
Bytes.unsafe_set bytes !n '\\';
301
+
incr n;
302
+
Bytes.unsafe_set bytes !n 't'
303
+
| '\r' ->
304
+
Bytes.unsafe_set bytes !n '\\';
305
+
incr n;
306
+
Bytes.unsafe_set bytes !n 'r'
307
+
| '\b' ->
308
+
Bytes.unsafe_set bytes !n '\\';
309
+
incr n;
310
+
Bytes.unsafe_set bytes !n 'b'
311
+
| ' ' .. '~' as c -> Bytes.unsafe_set bytes !n c
312
+
| c ->
313
+
let a = Char.code c in
314
+
Bytes.unsafe_set bytes !n '\\';
315
+
incr n;
316
+
Bytes.unsafe_set bytes !n (Char.chr (48 + (a / 100)));
317
+
incr n;
318
+
Bytes.unsafe_set bytes !n (Char.chr (48 + (a / 10 mod 10)));
319
+
incr n;
320
+
Bytes.unsafe_set bytes !n (Char.chr (48 + (a mod 10))));
321
+
incr n
322
+
done
323
+
;;
324
+
325
+
[@@@expand_inline
326
+
[%%template
327
+
[@@@alloc.default a @ m = (heap_global, stack_local)]
328
+
329
+
let escaped s =
330
+
(let length_of_escaped_string = length_of_escaped_string s in
331
+
if length_of_escaped_string = String.length s
332
+
then s
333
+
else (
334
+
let bytes = (Bytes.create [@alloc a]) length_of_escaped_string in
335
+
escaped_bytes s bytes;
336
+
Bytes.unsafe_to_string bytes))
337
+
[@exclave_if_stack a]
338
+
;;
339
+
340
+
let esc_str str =
341
+
(let estr = (escaped [@alloc a]) str in
342
+
let elen = String.length estr in
343
+
let res = (Bytes.create [@alloc a]) (elen + 2) in
344
+
Bytes.unsafe_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen;
345
+
Bytes.unsafe_set res 0 '"';
346
+
Bytes.unsafe_set res (elen + 1) '"';
347
+
Bytes.unsafe_to_string res)
348
+
[@exclave_if_stack a]
349
+
;;
350
+
351
+
let mach_maybe_esc_str str =
352
+
(if must_escape str then (esc_str [@alloc a]) str else str) [@exclave_if_stack a]
353
+
;;
354
+
355
+
let to_string_mach sexp =
356
+
(to_string_mach_internal [@alloc a])
357
+
sexp
358
+
~mach_maybe_esc_str:(mach_maybe_esc_str [@alloc a]) [@exclave_if_stack a]
359
+
;;
360
+
361
+
let to_string = (to_string_mach [@alloc a])]]
362
+
363
+
include struct
364
+
let escaped s =
365
+
let length_of_escaped_string = length_of_escaped_string s in
366
+
if length_of_escaped_string = String.length s
367
+
then s
368
+
else (
369
+
let bytes = Bytes.create length_of_escaped_string in
370
+
escaped_bytes s bytes;
371
+
Bytes.unsafe_to_string bytes)
372
+
;;
373
+
374
+
let esc_str str =
375
+
let estr = escaped str in
376
+
let elen = String.length estr in
377
+
let res = Bytes.create (elen + 2) in
378
+
Bytes.unsafe_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen;
379
+
Bytes.unsafe_set res 0 '"';
380
+
Bytes.unsafe_set res (elen + 1) '"';
381
+
Bytes.unsafe_to_string res
382
+
;;
383
+
384
+
let mach_maybe_esc_str str = if must_escape str then esc_str str else str
385
+
let to_string_mach sexp = to_string_mach_internal sexp ~mach_maybe_esc_str
386
+
let to_string = to_string_mach
387
+
end [@@ocaml.doc " @inline "]
388
+
389
+
include struct
390
+
let escaped__stack s =
391
+
let length_of_escaped_string = length_of_escaped_string s in
392
+
if length_of_escaped_string = String.length s
393
+
then s
394
+
else (
395
+
let bytes = Bytes.create__stack length_of_escaped_string in
396
+
escaped_bytes s bytes;
397
+
Bytes.unsafe_to_string bytes)
398
+
;;
399
+
400
+
let esc_str__stack str =
401
+
let estr = escaped__stack str in
402
+
let elen = String.length estr in
403
+
let res = Bytes.create__stack (elen + 2) in
404
+
Bytes.unsafe_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen;
405
+
Bytes.unsafe_set res 0 '"';
406
+
Bytes.unsafe_set res (elen + 1) '"';
407
+
Bytes.unsafe_to_string res
408
+
;;
409
+
410
+
let mach_maybe_esc_str__stack str =
411
+
if must_escape str then esc_str__stack str else str
412
+
;;
413
+
414
+
let to_string_mach__stack sexp =
415
+
to_string_mach_internal__stack sexp ~mach_maybe_esc_str:mach_maybe_esc_str__stack
416
+
;;
417
+
418
+
let to_string__stack = to_string_mach__stack
419
+
end [@@ocaml.doc " @inline "]
420
+
421
+
[@@@end]
422
+
423
+
let get_substring str index end_pos_opt =
424
+
let end_pos =
425
+
match end_pos_opt with
426
+
| None -> String.length str
427
+
| Some end_pos -> end_pos
428
+
in
429
+
String.sub str ~pos:index ~len:(end_pos - index)
430
+
;;
431
+
432
+
let is_one_line str =
433
+
match index_of_newline str 0 with
434
+
| None -> true
435
+
| Some index -> index + 1 = String.length str
436
+
;;
437
+
438
+
let pp_hum_maybe_esc_str ppf str =
439
+
if not (must_escape str)
440
+
then pp_print_string ppf str
441
+
else if is_one_line str
442
+
then pp_print_string ppf (esc_str str)
443
+
else (
444
+
let rec loop index =
445
+
let next_newline = index_of_newline str index in
446
+
let next_line = get_substring str index next_newline in
447
+
pp_print_string ppf (escaped next_line);
448
+
match next_newline with
449
+
| None -> ()
450
+
| Some newline_index ->
451
+
pp_print_string ppf "\\";
452
+
pp_force_newline ppf ();
453
+
pp_print_string ppf "\\n";
454
+
loop (newline_index + 1)
455
+
in
456
+
pp_open_box ppf 0;
457
+
(* the leading space is to line up the lines *)
458
+
pp_print_string ppf " \"";
459
+
loop 0;
460
+
pp_print_string ppf "\"";
461
+
pp_close_box ppf ())
462
+
;;
463
+
464
+
(* Output of S-expressions to formatters *)
465
+
466
+
let rec pp_hum_indent indent ppf = function
467
+
| Atom str -> pp_hum_maybe_esc_str ppf str
468
+
| List (h :: t) ->
469
+
pp_open_box ppf indent;
470
+
pp_print_string ppf "(";
471
+
pp_hum_indent indent ppf h;
472
+
pp_hum_rest indent ppf t
473
+
| List [] -> pp_print_string ppf "()"
474
+
475
+
and pp_hum_rest indent ppf = function
476
+
| h :: t ->
477
+
pp_print_space ppf ();
478
+
pp_hum_indent indent ppf h;
479
+
pp_hum_rest indent ppf t
480
+
| [] ->
481
+
pp_print_string ppf ")";
482
+
pp_close_box ppf ()
483
+
;;
484
+
485
+
let rec pp_mach_internal may_need_space ppf = function
486
+
| Atom str ->
487
+
let str' = mach_maybe_esc_str str in
488
+
let new_may_need_space = str' == str in
489
+
if may_need_space && new_may_need_space then pp_print_string ppf " ";
490
+
pp_print_string ppf str';
491
+
new_may_need_space
492
+
| List (h :: t) ->
493
+
pp_print_string ppf "(";
494
+
let may_need_space = pp_mach_internal false ppf h in
495
+
pp_mach_rest may_need_space ppf t;
496
+
false
497
+
| List [] ->
498
+
pp_print_string ppf "()";
499
+
false
500
+
501
+
and pp_mach_rest may_need_space ppf = function
502
+
| h :: t ->
503
+
let may_need_space = pp_mach_internal may_need_space ppf h in
504
+
pp_mach_rest may_need_space ppf t
505
+
| [] -> pp_print_string ppf ")"
506
+
;;
507
+
508
+
let pp_hum ppf sexp = pp_hum_indent (Dynamic.get default_indent) ppf sexp
509
+
let pp_mach ppf sexp = ignore (pp_mach_internal false ppf sexp)
510
+
let pp = pp_mach
511
+
end
512
+
513
+
(* Sexp size *)
514
+
515
+
let rec size_loop ((v, c) as acc) = function
516
+
| Atom str -> v + 1, c + String.length str
517
+
| List lst -> List.fold_left lst ~init:acc ~f:size_loop
518
+
;;
519
+
520
+
let size sexp = size_loop (0, 0) sexp
521
+
522
+
(* Buffer conversions *)
523
+
524
+
include Make_pretty_printing (Printing_helpers)
525
+
include Printing_helpers
526
+
end
527
+
528
+
include Printing
529
+
530
+
let of_float_style = Dynamic.make (`No_underscores : [ `Underscores | `No_underscores ])
531
+
let of_int_style = Dynamic.make (`No_underscores : [ `Underscores | `No_underscores ])
532
+
533
+
module Private = struct
534
+
include Printing
535
+
end
536
+
537
+
let message name fields =
538
+
let rec conv_fields = function
539
+
| [] -> []
540
+
| (fname, fsexp) :: rest ->
541
+
(match fname with
542
+
| "" -> fsexp :: conv_fields rest
543
+
| _ -> List [ Atom fname; fsexp ] :: conv_fields rest)
544
+
in
545
+
List (Atom name :: conv_fields fields)
546
+
;;
+1
vendor/opam/sexplib0/src/sexp.mli
+1
vendor/opam/sexplib0/src/sexp.mli
···
1
+
include Sexp_intf.Sexp (** @inline *)
+935
vendor/opam/sexplib0/src/sexp_conv.ml
+935
vendor/opam/sexplib0/src/sexp_conv.ml
···
1
+
(* Utility Module for S-expression Conversions *)
2
+
3
+
open StdLabels
4
+
open MoreLabels
5
+
open Basement
6
+
7
+
open Blocking_sync [@@alert
8
+
"-deprecated"
9
+
(* Used here since sexplib0 can't depend on Await_sync *)]
10
+
11
+
open Printf
12
+
open Sexp
13
+
14
+
(* Conversion of OCaml-values to S-expressions *)
15
+
16
+
external globalize_float : float -> float = "caml_obj_dup"
17
+
external bytes_length : bytes -> int = "%bytes_length"
18
+
external create_local_bytes : int -> bytes = "caml_create_bytes"
19
+
20
+
external unsafe_blit_bytes
21
+
: src:bytes
22
+
-> src_pos:int
23
+
-> dst:bytes
24
+
-> dst_pos:int
25
+
-> len:int
26
+
-> unit
27
+
= "caml_blit_bytes"
28
+
[@@noalloc]
29
+
30
+
external unsafe_bytes_to_string : bytes -> string = "%bytes_to_string"
31
+
32
+
let bytes_to_string_local b =
33
+
let len = bytes_length b in
34
+
let s = create_local_bytes len in
35
+
unsafe_blit_bytes ~src:b ~src_pos:0 ~dst:s ~dst_pos:0 ~len;
36
+
unsafe_bytes_to_string s
37
+
;;
38
+
39
+
external unsafe_fill_bytes
40
+
: bytes
41
+
-> pos:int
42
+
-> len:int
43
+
-> char
44
+
-> unit
45
+
= "caml_fill_bytes"
46
+
[@@noalloc]
47
+
48
+
let string_make_local n c =
49
+
let s = create_local_bytes n in
50
+
unsafe_fill_bytes s ~pos:0 ~len:n c;
51
+
unsafe_bytes_to_string s
52
+
;;
53
+
54
+
external format_float : string -> float -> string = "caml_format_float"
55
+
external format_int32 : string -> int32 -> string = "caml_int32_format"
56
+
external format_int64 : string -> int64 -> string = "caml_int64_format"
57
+
external format_nativeint : string -> nativeint -> string = "caml_nativeint_format"
58
+
external lazy_force : ('a lazy_t[@local_opt]) -> ('a[@local_opt]) = "%lazy_force"
59
+
external array_length : _ array -> int = "%array_length"
60
+
61
+
external array_safe_get
62
+
: ('a array[@local_opt])
63
+
-> int
64
+
-> ('a[@local_opt])
65
+
= "%array_safe_get"
66
+
67
+
let string_of_int32 n = format_int32 "%d" n
68
+
let string_of_int64 n = format_int64 "%d" n
69
+
let string_of_nativeint n = format_nativeint "%d" n
70
+
71
+
(* '%.17g' is guaranteed to be round-trippable.
72
+
73
+
'%.15g' will be round-trippable and not have noise at the last digit or two for a float
74
+
which was converted from a decimal (string) with <= 15 significant digits. So it's
75
+
worth trying first to avoid things like "3.1400000000000001".
76
+
77
+
See comment above [to_string_round_trippable] in {!Core.Float} for
78
+
detailed explanation and examples. *)
79
+
let default_string_of_float =
80
+
Dynamic.make (fun x ->
81
+
let y = format_float "%.15G" x in
82
+
if float_of_string y = x then y else format_float "%.17G" x)
83
+
;;
84
+
85
+
let read_old_option_format = Dynamic.make true
86
+
let write_old_option_format = Dynamic.make true
87
+
let list_map f l = List.map l ~f
88
+
89
+
let list_map__stack f lst =
90
+
let rec rev lst acc =
91
+
match lst with
92
+
| [] -> acc
93
+
| hd :: tl -> rev tl (hd :: acc)
94
+
in
95
+
let rec rev_map lst acc =
96
+
match lst with
97
+
| [] -> acc
98
+
| hd :: tl -> rev_map tl (f hd :: acc)
99
+
in
100
+
rev (rev_map lst []) []
101
+
;;
102
+
103
+
let sexp_of_unit () = List []
104
+
let sexp_of_unit__stack () = List []
105
+
106
+
let[@zero_alloc] sexp_of_bool = function
107
+
| false -> Atom "false"
108
+
| true -> Atom "true"
109
+
;;
110
+
111
+
let sexp_of_bool__stack = sexp_of_bool
112
+
let sexp_of_string str = Atom str
113
+
let sexp_of_string__stack str = Atom str
114
+
let sexp_of_bytes bytes = Atom (Bytes.to_string bytes)
115
+
let sexp_of_bytes__stack bytes = Atom (bytes_to_string_local bytes)
116
+
let sexp_of_int n = Atom (string_of_int n)
117
+
let sexp_of_int__stack n = Atom (string_of_int n)
118
+
let sexp_of_float n = Atom ((Dynamic.get default_string_of_float) n)
119
+
120
+
let sexp_of_float__stack n =
121
+
Atom ((Dynamic.get default_string_of_float) (globalize_float n))
122
+
;;
123
+
124
+
let sexp_of_int32 n = Atom (Int32.to_string n)
125
+
let sexp_of_int32__stack n = Atom (string_of_int32 n)
126
+
let sexp_of_int64 n = Atom (Int64.to_string n)
127
+
let sexp_of_int64__stack n = Atom (string_of_int64 n)
128
+
let sexp_of_nativeint n = Atom (Nativeint.to_string n)
129
+
let sexp_of_nativeint__stack n = Atom (string_of_nativeint n)
130
+
let sexp_of_ref sexp_of__a rf = sexp_of__a !rf
131
+
let sexp_of_ref__stack sexp_of__a rf = sexp_of__a !rf
132
+
let sexp_of_lazy_t sexp_of__a lv = sexp_of__a (Lazy.force lv)
133
+
let sexp_of_lazy_t__stack sexp_of__a lv = sexp_of__a (lazy_force lv)
134
+
135
+
let sexp_of_option sexp_of__a option =
136
+
let write_old_option_format = Dynamic.get write_old_option_format in
137
+
match option with
138
+
| Some x when write_old_option_format -> List [ sexp_of__a x ]
139
+
| Some x -> List [ Atom "some"; sexp_of__a x ]
140
+
| None when write_old_option_format -> List []
141
+
| None -> Atom "none"
142
+
;;
143
+
144
+
let sexp_of_option__stack sexp_of__a option =
145
+
let write_old_option_format = Dynamic.get write_old_option_format in
146
+
match option with
147
+
| Some x when write_old_option_format -> List [ sexp_of__a x ]
148
+
| Some x -> List [ Atom "some"; sexp_of__a x ]
149
+
| None when write_old_option_format -> List []
150
+
| None -> Atom "none"
151
+
;;
152
+
153
+
let sexp_of_or_null sexp_of__a or_null =
154
+
let write_old_option_format = Dynamic.get write_old_option_format in
155
+
match or_null with
156
+
| Or_null_shim.This x when write_old_option_format -> List [ sexp_of__a x ]
157
+
| Or_null_shim.This x -> List [ Atom "this"; sexp_of__a x ]
158
+
| Null when write_old_option_format -> List []
159
+
| Null -> Atom "null"
160
+
;;
161
+
162
+
let sexp_of_or_null__stack sexp_of__a or_null =
163
+
let write_old_option_format = Dynamic.get write_old_option_format in
164
+
match or_null with
165
+
| Or_null_shim.This x when write_old_option_format -> List [ sexp_of__a x ]
166
+
| Or_null_shim.This x -> List [ Atom "this"; sexp_of__a x ]
167
+
| Null when write_old_option_format -> List []
168
+
| Null -> Atom "null"
169
+
;;
170
+
171
+
let sexp_of_pair sexp_of__a sexp_of__b (a, b) = List [ sexp_of__a a; sexp_of__b b ]
172
+
173
+
let sexp_of_triple sexp_of__a sexp_of__b sexp_of__c (a, b, c) =
174
+
List [ sexp_of__a a; sexp_of__b b; sexp_of__c c ]
175
+
;;
176
+
177
+
let sexp_of_list sexp_of__a lst = List (List.map lst ~f:sexp_of__a)
178
+
let sexp_of_list__stack sexp_of__a lst = List (list_map__stack sexp_of__a lst)
179
+
180
+
let sexp_of_array sexp_of__a ar =
181
+
let lst_ref = ref [] in
182
+
for i = Array.length ar - 1 downto 0 do
183
+
lst_ref := sexp_of__a ar.(i) :: !lst_ref
184
+
done;
185
+
List !lst_ref
186
+
;;
187
+
188
+
let sexp_of_array__stack sexp_of__a ar =
189
+
let rec loop i acc =
190
+
if i < 0 then List acc else loop (i - 1) (sexp_of__a (array_safe_get ar i) :: acc)
191
+
in
192
+
loop (array_length ar - 1) []
193
+
;;
194
+
195
+
let sexp_of_hashtbl sexp_of_key sexp_of_val htbl =
196
+
let coll ~key:k ~data:v acc = List [ sexp_of_key k; sexp_of_val v ] :: acc in
197
+
List (Hashtbl.fold htbl ~init:[] ~f:coll)
198
+
;;
199
+
200
+
let sexp_of_opaque _ = Atom "<opaque>"
201
+
let sexp_of_fun _ = Atom "<fun>"
202
+
203
+
(* Exception converter registration and lookup *)
204
+
205
+
module Exn_converter = struct
206
+
(* Fast and automatic exception registration *)
207
+
208
+
module Registration = struct
209
+
type t =
210
+
{ sexp_of_exn : exn -> Sexp.t
211
+
; (* If [printexc = true] then this sexp converter is used for Printexc.to_string *)
212
+
printexc : bool
213
+
}
214
+
[@@unsafe_allow_any_mode_crossing]
215
+
end
216
+
217
+
module Exn_table = Basement.Stdlib_shim.Ephemeron.K1.MakePortable (struct
218
+
type t = extension_constructor
219
+
220
+
let equal = ( == )
221
+
let hash = Obj.Extension_constructor.id
222
+
end)
223
+
224
+
module type The_exn_table = sig
225
+
type key
226
+
227
+
val lock : key Mutex.t
228
+
end
229
+
230
+
module The_exn_table : The_exn_table =
231
+
(val let (Capsule.Key.P (type key) (key : key Capsule.Key.t)) = Capsule.create () in
232
+
let lock = Mutex.create key in
233
+
(module struct
234
+
type nonrec key = key
235
+
236
+
let lock = lock
237
+
end : The_exn_table))
238
+
239
+
let the_exn_table : (Registration.t Exn_table.t, The_exn_table.key) Capsule.Data.t =
240
+
Capsule.Data.create (fun () -> Exn_table.create 17)
241
+
;;
242
+
243
+
(* Ephemerons are used so that [sexp_of_exn] closure don't keep the
244
+
extension_constructor live. *)
245
+
let add ?(printexc = true) ?finalise:_ extension_constructor sexp_of_exn =
246
+
let sexp_of_exn = Portability_hacks.magic_portable__needs_base_and_core sexp_of_exn in
247
+
let extension_constructor =
248
+
Portability_hacks.Cross.Portable.(cross extension_constructor) extension_constructor
249
+
in
250
+
Mutex.with_lock The_exn_table.lock ~f:(fun password ->
251
+
Capsule.Data.iter the_exn_table ~password ~f:(fun the_exn_table ->
252
+
let extension_constructor =
253
+
Portability_hacks.Cross.Contended.(cross extension_constructor)
254
+
extension_constructor
255
+
in
256
+
Exn_table.add
257
+
the_exn_table
258
+
extension_constructor
259
+
({ sexp_of_exn; printexc } : Registration.t)))
260
+
;;
261
+
262
+
let find_auto ~for_printexc exn =
263
+
let extension_constructor = Obj.Extension_constructor.of_val exn in
264
+
let extension_constructor =
265
+
Portability_hacks.Cross.Portable.(cross extension_constructor) extension_constructor
266
+
in
267
+
match
268
+
Mutex.with_lock The_exn_table.lock ~f:(fun password ->
269
+
Capsule.Data.extract the_exn_table ~password ~f:(fun the_exn_table ->
270
+
let extension_constructor =
271
+
Portability_hacks.Cross.Contended.(cross extension_constructor)
272
+
extension_constructor
273
+
in
274
+
{ Stdlib_shim.Modes.Aliased.aliased =
275
+
(Exn_table.find_opt the_exn_table extension_constructor
276
+
: Registration.t option)
277
+
})
278
+
[@nontail])
279
+
with
280
+
| { aliased = None } -> None
281
+
| { aliased = Some { sexp_of_exn; printexc } } ->
282
+
(match for_printexc, printexc with
283
+
| false, _ | _, true -> Some (sexp_of_exn exn)
284
+
| true, false -> None)
285
+
;;
286
+
287
+
module For_unit_tests_only = struct
288
+
let size () =
289
+
Mutex.with_lock The_exn_table.lock ~f:(fun password ->
290
+
Capsule.Data.extract the_exn_table ~password ~f:(fun the_exn_table ->
291
+
(Exn_table.stats_alive the_exn_table).num_bindings))
292
+
;;
293
+
end
294
+
end
295
+
296
+
let sexp_of_exn_opt_for_printexc exn = Exn_converter.find_auto ~for_printexc:true exn
297
+
let sexp_of_exn_opt exn = Exn_converter.find_auto ~for_printexc:false exn
298
+
299
+
let sexp_of_exn exn =
300
+
match sexp_of_exn_opt exn with
301
+
| None -> List [ Atom (Printexc.to_string exn) ]
302
+
| Some sexp -> sexp
303
+
;;
304
+
305
+
let exn_to_string e = Sexp.to_string_hum (sexp_of_exn e)
306
+
307
+
(* {[exception Blah [@@deriving sexp]]} generates a call to the function
308
+
[Exn_converter.add] defined in this file. So we are guaranted that as soon as we
309
+
mark an exception as sexpable, this module will be linked in and this printer will be
310
+
registered, which is what we want. *)
311
+
let () =
312
+
(Printexc.register_printer [@alert "-unsafe_multidomain"]) (fun exn ->
313
+
match sexp_of_exn_opt_for_printexc exn with
314
+
| None -> None
315
+
| Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp))
316
+
;;
317
+
318
+
let printexc_prefer_sexp exn =
319
+
match sexp_of_exn_opt exn with
320
+
| None -> Printexc.to_string exn
321
+
| Some sexp -> Sexp.to_string_hum ~indent:2 sexp
322
+
;;
323
+
324
+
(* Conversion of S-expressions to OCaml-values *)
325
+
326
+
exception Of_sexp_error = Sexp.Of_sexp_error
327
+
328
+
let record_check_extra_fields = Dynamic.make true
329
+
let of_sexp_error_exn exc sexp = raise (Of_sexp_error (exc, sexp))
330
+
let of_sexp_error what sexp = raise (Of_sexp_error (Failure what, sexp))
331
+
332
+
let unit_of_sexp sexp =
333
+
match sexp with
334
+
| List [] -> ()
335
+
| Atom _ | List _ -> of_sexp_error "unit_of_sexp: empty list needed" sexp
336
+
;;
337
+
338
+
let bool_of_sexp sexp =
339
+
match sexp with
340
+
| Atom ("true" | "True") -> true
341
+
| Atom ("false" | "False") -> false
342
+
| Atom _ -> of_sexp_error "bool_of_sexp: unknown string" sexp
343
+
| List _ -> of_sexp_error "bool_of_sexp: atom needed" sexp
344
+
;;
345
+
346
+
let string_of_sexp sexp =
347
+
match sexp with
348
+
| Atom str -> str
349
+
| List _ -> of_sexp_error "string_of_sexp: atom needed" sexp
350
+
;;
351
+
352
+
let bytes_of_sexp sexp =
353
+
match sexp with
354
+
| Atom str -> Bytes.of_string str
355
+
| List _ -> of_sexp_error "bytes_of_sexp: atom needed" sexp
356
+
;;
357
+
358
+
let char_of_sexp sexp =
359
+
match sexp with
360
+
| Atom str ->
361
+
if String.length str <> 1
362
+
then of_sexp_error "char_of_sexp: atom string must contain one character only" sexp;
363
+
str.[0]
364
+
| List _ -> of_sexp_error "char_of_sexp: atom needed" sexp
365
+
;;
366
+
367
+
let int_of_sexp sexp =
368
+
match sexp with
369
+
| Atom str ->
370
+
(try int_of_string str with
371
+
| exc -> of_sexp_error ("int_of_sexp: " ^ exn_to_string exc) sexp)
372
+
| List _ -> of_sexp_error "int_of_sexp: atom needed" sexp
373
+
;;
374
+
375
+
let float_of_sexp sexp =
376
+
match sexp with
377
+
| Atom str ->
378
+
(try float_of_string str with
379
+
| exc -> of_sexp_error ("float_of_sexp: " ^ exn_to_string exc) sexp)
380
+
| List _ -> of_sexp_error "float_of_sexp: atom needed" sexp
381
+
;;
382
+
383
+
let int32_of_sexp sexp =
384
+
match sexp with
385
+
| Atom str ->
386
+
(try Int32.of_string str with
387
+
| exc -> of_sexp_error ("int32_of_sexp: " ^ exn_to_string exc) sexp)
388
+
| List _ -> of_sexp_error "int32_of_sexp: atom needed" sexp
389
+
;;
390
+
391
+
let int64_of_sexp sexp =
392
+
match sexp with
393
+
| Atom str ->
394
+
(try Int64.of_string str with
395
+
| exc -> of_sexp_error ("int64_of_sexp: " ^ exn_to_string exc) sexp)
396
+
| List _ -> of_sexp_error "int64_of_sexp: atom needed" sexp
397
+
;;
398
+
399
+
let nativeint_of_sexp sexp =
400
+
match sexp with
401
+
| Atom str ->
402
+
(try Nativeint.of_string str with
403
+
| exc -> of_sexp_error ("nativeint_of_sexp: " ^ exn_to_string exc) sexp)
404
+
| List _ -> of_sexp_error "nativeint_of_sexp: atom needed" sexp
405
+
;;
406
+
407
+
let ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp)
408
+
let lazy_t_of_sexp a__of_sexp sexp = Lazy.from_val (a__of_sexp sexp)
409
+
410
+
let option_of_sexp a__of_sexp sexp =
411
+
if Dynamic.get read_old_option_format
412
+
then (
413
+
match sexp with
414
+
| List [] | Atom ("none" | "None") -> None
415
+
| List [ el ] | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el)
416
+
| List _ -> of_sexp_error "option_of_sexp: list must represent optional value" sexp
417
+
| Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp)
418
+
else (
419
+
match sexp with
420
+
| Atom ("none" | "None") -> None
421
+
| List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el)
422
+
| Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp
423
+
| List _ -> of_sexp_error "option_of_sexp: list must be (some el)" sexp)
424
+
;;
425
+
426
+
let or_null_of_sexp a__of_sexp sexp =
427
+
if Dynamic.get read_old_option_format
428
+
then (
429
+
match sexp with
430
+
| List [] | Atom ("null" | "Null") -> Or_null_shim.Null
431
+
| List [ el ] | List [ Atom ("this" | "This"); el ] -> This (a__of_sexp el)
432
+
| List _ -> of_sexp_error "or_null_of_sexp: list must represent or_null value" sexp
433
+
| Atom _ -> of_sexp_error "or_null_of_sexp: only null can be atom" sexp)
434
+
else (
435
+
match sexp with
436
+
| Atom ("null" | "Null") -> Or_null_shim.Null
437
+
| List [ Atom ("this" | "This"); el ] -> This (a__of_sexp el)
438
+
| Atom _ -> of_sexp_error "or_null_of_sexp: only null can be atom" sexp
439
+
| List _ -> of_sexp_error "or_null_of_sexp: list must be (this el)" sexp)
440
+
;;
441
+
442
+
let pair_of_sexp a__of_sexp b__of_sexp sexp =
443
+
match sexp with
444
+
| List [ a_sexp; b_sexp ] ->
445
+
let a = a__of_sexp a_sexp in
446
+
let b = b__of_sexp b_sexp in
447
+
a, b
448
+
| List _ ->
449
+
of_sexp_error "pair_of_sexp: list must contain exactly two elements only" sexp
450
+
| Atom _ -> of_sexp_error "pair_of_sexp: list needed" sexp
451
+
;;
452
+
453
+
let triple_of_sexp a__of_sexp b__of_sexp c__of_sexp sexp =
454
+
match sexp with
455
+
| List [ a_sexp; b_sexp; c_sexp ] ->
456
+
let a = a__of_sexp a_sexp in
457
+
let b = b__of_sexp b_sexp in
458
+
let c = c__of_sexp c_sexp in
459
+
a, b, c
460
+
| List _ ->
461
+
of_sexp_error "triple_of_sexp: list must contain exactly three elements only" sexp
462
+
| Atom _ -> of_sexp_error "triple_of_sexp: list needed" sexp
463
+
;;
464
+
465
+
let list_of_sexp a__of_sexp sexp =
466
+
match sexp with
467
+
| List lst -> List.map lst ~f:a__of_sexp
468
+
| Atom _ -> of_sexp_error "list_of_sexp: list needed" sexp
469
+
;;
470
+
471
+
let array_of_sexp a__of_sexp sexp =
472
+
match sexp with
473
+
| List [] -> [||]
474
+
| List (h :: t) ->
475
+
let len = List.length t + 1 in
476
+
let res = Array.make len (a__of_sexp h) in
477
+
let rec loop i = function
478
+
| [] -> res
479
+
| h :: t ->
480
+
res.(i) <- a__of_sexp h;
481
+
loop (i + 1) t
482
+
in
483
+
loop 1 t
484
+
| Atom _ -> of_sexp_error "array_of_sexp: list needed" sexp
485
+
;;
486
+
487
+
let hashtbl_of_sexp key_of_sexp val_of_sexp sexp =
488
+
match sexp with
489
+
| List lst ->
490
+
let htbl = Hashtbl.create 0 in
491
+
let act = function
492
+
| List [ k_sexp; v_sexp ] ->
493
+
Hashtbl.add htbl ~key:(key_of_sexp k_sexp) ~data:(val_of_sexp v_sexp)
494
+
| List _ | Atom _ -> of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp
495
+
in
496
+
List.iter lst ~f:act;
497
+
htbl
498
+
| Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp
499
+
;;
500
+
501
+
let opaque_of_sexp sexp =
502
+
of_sexp_error "opaque_of_sexp: cannot convert opaque values" sexp
503
+
;;
504
+
505
+
let fun_of_sexp sexp = of_sexp_error "fun_of_sexp: cannot convert function values" sexp
506
+
507
+
(* Sexp Grammars *)
508
+
509
+
include Sexp_conv_grammar
510
+
511
+
(* Registering default exception printers *)
512
+
513
+
let get_flc_error name (file, line, chr) = Atom (sprintf "%s %s:%d:%d" name file line chr)
514
+
515
+
type handler = { h : exn -> Sexp.t } [@@unboxed] [@@unsafe_allow_any_mode_crossing]
516
+
517
+
let () =
518
+
List.iter
519
+
~f:(fun (extension_constructor, handler) ->
520
+
Exn_converter.add ~printexc:false ~finalise:false extension_constructor handler.h)
521
+
[ ( [%extension_constructor Assert_failure]
522
+
, { h =
523
+
(function
524
+
| Assert_failure arg -> get_flc_error "Assert_failure" arg
525
+
| _ -> assert false)
526
+
} )
527
+
; ( [%extension_constructor Exit]
528
+
, { h =
529
+
(function
530
+
| Exit -> Atom "Exit"
531
+
| _ -> assert false)
532
+
} )
533
+
; ( [%extension_constructor End_of_file]
534
+
, { h =
535
+
(function
536
+
| End_of_file -> Atom "End_of_file"
537
+
| _ -> assert false)
538
+
} )
539
+
; ( [%extension_constructor Failure]
540
+
, { h =
541
+
(function
542
+
| Failure arg -> List [ Atom "Failure"; Atom arg ]
543
+
| _ -> assert false)
544
+
} )
545
+
; ( [%extension_constructor Not_found]
546
+
, { h =
547
+
(function
548
+
| Not_found -> Atom "Not_found"
549
+
| _ -> assert false)
550
+
} )
551
+
; ( [%extension_constructor Invalid_argument]
552
+
, { h =
553
+
(function
554
+
| Invalid_argument arg -> List [ Atom "Invalid_argument"; Atom arg ]
555
+
| _ -> assert false)
556
+
} )
557
+
; ( [%extension_constructor Match_failure]
558
+
, { h =
559
+
(function
560
+
| Match_failure arg -> get_flc_error "Match_failure" arg
561
+
| _ -> assert false)
562
+
} )
563
+
; ( [%extension_constructor Not_found_s]
564
+
, { h =
565
+
(function
566
+
| Not_found_s arg -> List [ Atom "Not_found_s"; arg ]
567
+
| _ -> assert false)
568
+
} )
569
+
; ( [%extension_constructor Sys_error]
570
+
, { h =
571
+
(function
572
+
| Sys_error arg -> List [ Atom "Sys_error"; Atom arg ]
573
+
| _ -> assert false)
574
+
} )
575
+
; ( [%extension_constructor Arg.Help]
576
+
, { h =
577
+
(function
578
+
| Arg.Help arg -> List [ Atom "Arg.Help"; Atom arg ]
579
+
| _ -> assert false)
580
+
} )
581
+
; ( [%extension_constructor Arg.Bad]
582
+
, { h =
583
+
(function
584
+
| Arg.Bad arg -> List [ Atom "Arg.Bad"; Atom arg ]
585
+
| _ -> assert false)
586
+
} )
587
+
; ( [%extension_constructor Lazy.Undefined]
588
+
, { h =
589
+
(function
590
+
| Lazy.Undefined -> Atom "Lazy.Undefined"
591
+
| _ -> assert false)
592
+
} )
593
+
; ( [%extension_constructor Parsing.Parse_error]
594
+
, { h =
595
+
(function
596
+
| Parsing.Parse_error -> Atom "Parsing.Parse_error"
597
+
| _ -> assert false)
598
+
} )
599
+
; ( [%extension_constructor Queue.Empty]
600
+
, { h =
601
+
(function
602
+
| Queue.Empty -> Atom "Queue.Empty"
603
+
| _ -> assert false)
604
+
} )
605
+
; ( [%extension_constructor Scanf.Scan_failure]
606
+
, { h =
607
+
(function
608
+
| Scanf.Scan_failure arg -> List [ Atom "Scanf.Scan_failure"; Atom arg ]
609
+
| _ -> assert false)
610
+
} )
611
+
; ( [%extension_constructor Stack.Empty]
612
+
, { h =
613
+
(function
614
+
| Stack.Empty -> Atom "Stack.Empty"
615
+
| _ -> assert false)
616
+
} )
617
+
; ( [%extension_constructor Sys.Break]
618
+
, { h =
619
+
(function
620
+
| Sys.Break -> Atom "Sys.Break"
621
+
| _ -> assert false)
622
+
} )
623
+
]
624
+
;;
625
+
626
+
let () =
627
+
List.iter
628
+
~f:(fun (extension_constructor, handler) ->
629
+
Exn_converter.add ~printexc:true ~finalise:false extension_constructor handler.h)
630
+
[ ( [%extension_constructor Of_sexp_error]
631
+
, { h =
632
+
(function
633
+
| Of_sexp_error (exc, sexp) ->
634
+
List [ Atom "Sexplib.Conv.Of_sexp_error"; sexp_of_exn exc; sexp ]
635
+
| _ -> assert false)
636
+
} )
637
+
]
638
+
;;
639
+
640
+
external ignore : 'a. ('a[@local_opt]) -> unit = "%ignore"
641
+
external ( = ) : 'a. ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal"
642
+
643
+
(* The compiler generates *catastrophically* bad code if you let it inline this function.
644
+
But with that prevented, the compiler reliably optimizes this to a load from a
645
+
statically allocated array. *)
646
+
let[@zero_alloc] [@inline never] [@local never] [@specialise never] sexp_of_char_statically_allocated
647
+
= function
648
+
(*$
649
+
for i = 0 to 255 do
650
+
Printf.printf "| '\\x%02x' -> Atom \"\\x%02x\"\n" i i
651
+
done
652
+
*)
653
+
| '\x00' -> Atom "\x00"
654
+
| '\x01' -> Atom "\x01"
655
+
| '\x02' -> Atom "\x02"
656
+
| '\x03' -> Atom "\x03"
657
+
| '\x04' -> Atom "\x04"
658
+
| '\x05' -> Atom "\x05"
659
+
| '\x06' -> Atom "\x06"
660
+
| '\x07' -> Atom "\x07"
661
+
| '\x08' -> Atom "\x08"
662
+
| '\x09' -> Atom "\x09"
663
+
| '\x0a' -> Atom "\x0a"
664
+
| '\x0b' -> Atom "\x0b"
665
+
| '\x0c' -> Atom "\x0c"
666
+
| '\x0d' -> Atom "\x0d"
667
+
| '\x0e' -> Atom "\x0e"
668
+
| '\x0f' -> Atom "\x0f"
669
+
| '\x10' -> Atom "\x10"
670
+
| '\x11' -> Atom "\x11"
671
+
| '\x12' -> Atom "\x12"
672
+
| '\x13' -> Atom "\x13"
673
+
| '\x14' -> Atom "\x14"
674
+
| '\x15' -> Atom "\x15"
675
+
| '\x16' -> Atom "\x16"
676
+
| '\x17' -> Atom "\x17"
677
+
| '\x18' -> Atom "\x18"
678
+
| '\x19' -> Atom "\x19"
679
+
| '\x1a' -> Atom "\x1a"
680
+
| '\x1b' -> Atom "\x1b"
681
+
| '\x1c' -> Atom "\x1c"
682
+
| '\x1d' -> Atom "\x1d"
683
+
| '\x1e' -> Atom "\x1e"
684
+
| '\x1f' -> Atom "\x1f"
685
+
| '\x20' -> Atom "\x20"
686
+
| '\x21' -> Atom "\x21"
687
+
| '\x22' -> Atom "\x22"
688
+
| '\x23' -> Atom "\x23"
689
+
| '\x24' -> Atom "\x24"
690
+
| '\x25' -> Atom "\x25"
691
+
| '\x26' -> Atom "\x26"
692
+
| '\x27' -> Atom "\x27"
693
+
| '\x28' -> Atom "\x28"
694
+
| '\x29' -> Atom "\x29"
695
+
| '\x2a' -> Atom "\x2a"
696
+
| '\x2b' -> Atom "\x2b"
697
+
| '\x2c' -> Atom "\x2c"
698
+
| '\x2d' -> Atom "\x2d"
699
+
| '\x2e' -> Atom "\x2e"
700
+
| '\x2f' -> Atom "\x2f"
701
+
| '\x30' -> Atom "\x30"
702
+
| '\x31' -> Atom "\x31"
703
+
| '\x32' -> Atom "\x32"
704
+
| '\x33' -> Atom "\x33"
705
+
| '\x34' -> Atom "\x34"
706
+
| '\x35' -> Atom "\x35"
707
+
| '\x36' -> Atom "\x36"
708
+
| '\x37' -> Atom "\x37"
709
+
| '\x38' -> Atom "\x38"
710
+
| '\x39' -> Atom "\x39"
711
+
| '\x3a' -> Atom "\x3a"
712
+
| '\x3b' -> Atom "\x3b"
713
+
| '\x3c' -> Atom "\x3c"
714
+
| '\x3d' -> Atom "\x3d"
715
+
| '\x3e' -> Atom "\x3e"
716
+
| '\x3f' -> Atom "\x3f"
717
+
| '\x40' -> Atom "\x40"
718
+
| '\x41' -> Atom "\x41"
719
+
| '\x42' -> Atom "\x42"
720
+
| '\x43' -> Atom "\x43"
721
+
| '\x44' -> Atom "\x44"
722
+
| '\x45' -> Atom "\x45"
723
+
| '\x46' -> Atom "\x46"
724
+
| '\x47' -> Atom "\x47"
725
+
| '\x48' -> Atom "\x48"
726
+
| '\x49' -> Atom "\x49"
727
+
| '\x4a' -> Atom "\x4a"
728
+
| '\x4b' -> Atom "\x4b"
729
+
| '\x4c' -> Atom "\x4c"
730
+
| '\x4d' -> Atom "\x4d"
731
+
| '\x4e' -> Atom "\x4e"
732
+
| '\x4f' -> Atom "\x4f"
733
+
| '\x50' -> Atom "\x50"
734
+
| '\x51' -> Atom "\x51"
735
+
| '\x52' -> Atom "\x52"
736
+
| '\x53' -> Atom "\x53"
737
+
| '\x54' -> Atom "\x54"
738
+
| '\x55' -> Atom "\x55"
739
+
| '\x56' -> Atom "\x56"
740
+
| '\x57' -> Atom "\x57"
741
+
| '\x58' -> Atom "\x58"
742
+
| '\x59' -> Atom "\x59"
743
+
| '\x5a' -> Atom "\x5a"
744
+
| '\x5b' -> Atom "\x5b"
745
+
| '\x5c' -> Atom "\x5c"
746
+
| '\x5d' -> Atom "\x5d"
747
+
| '\x5e' -> Atom "\x5e"
748
+
| '\x5f' -> Atom "\x5f"
749
+
| '\x60' -> Atom "\x60"
750
+
| '\x61' -> Atom "\x61"
751
+
| '\x62' -> Atom "\x62"
752
+
| '\x63' -> Atom "\x63"
753
+
| '\x64' -> Atom "\x64"
754
+
| '\x65' -> Atom "\x65"
755
+
| '\x66' -> Atom "\x66"
756
+
| '\x67' -> Atom "\x67"
757
+
| '\x68' -> Atom "\x68"
758
+
| '\x69' -> Atom "\x69"
759
+
| '\x6a' -> Atom "\x6a"
760
+
| '\x6b' -> Atom "\x6b"
761
+
| '\x6c' -> Atom "\x6c"
762
+
| '\x6d' -> Atom "\x6d"
763
+
| '\x6e' -> Atom "\x6e"
764
+
| '\x6f' -> Atom "\x6f"
765
+
| '\x70' -> Atom "\x70"
766
+
| '\x71' -> Atom "\x71"
767
+
| '\x72' -> Atom "\x72"
768
+
| '\x73' -> Atom "\x73"
769
+
| '\x74' -> Atom "\x74"
770
+
| '\x75' -> Atom "\x75"
771
+
| '\x76' -> Atom "\x76"
772
+
| '\x77' -> Atom "\x77"
773
+
| '\x78' -> Atom "\x78"
774
+
| '\x79' -> Atom "\x79"
775
+
| '\x7a' -> Atom "\x7a"
776
+
| '\x7b' -> Atom "\x7b"
777
+
| '\x7c' -> Atom "\x7c"
778
+
| '\x7d' -> Atom "\x7d"
779
+
| '\x7e' -> Atom "\x7e"
780
+
| '\x7f' -> Atom "\x7f"
781
+
| '\x80' -> Atom "\x80"
782
+
| '\x81' -> Atom "\x81"
783
+
| '\x82' -> Atom "\x82"
784
+
| '\x83' -> Atom "\x83"
785
+
| '\x84' -> Atom "\x84"
786
+
| '\x85' -> Atom "\x85"
787
+
| '\x86' -> Atom "\x86"
788
+
| '\x87' -> Atom "\x87"
789
+
| '\x88' -> Atom "\x88"
790
+
| '\x89' -> Atom "\x89"
791
+
| '\x8a' -> Atom "\x8a"
792
+
| '\x8b' -> Atom "\x8b"
793
+
| '\x8c' -> Atom "\x8c"
794
+
| '\x8d' -> Atom "\x8d"
795
+
| '\x8e' -> Atom "\x8e"
796
+
| '\x8f' -> Atom "\x8f"
797
+
| '\x90' -> Atom "\x90"
798
+
| '\x91' -> Atom "\x91"
799
+
| '\x92' -> Atom "\x92"
800
+
| '\x93' -> Atom "\x93"
801
+
| '\x94' -> Atom "\x94"
802
+
| '\x95' -> Atom "\x95"
803
+
| '\x96' -> Atom "\x96"
804
+
| '\x97' -> Atom "\x97"
805
+
| '\x98' -> Atom "\x98"
806
+
| '\x99' -> Atom "\x99"
807
+
| '\x9a' -> Atom "\x9a"
808
+
| '\x9b' -> Atom "\x9b"
809
+
| '\x9c' -> Atom "\x9c"
810
+
| '\x9d' -> Atom "\x9d"
811
+
| '\x9e' -> Atom "\x9e"
812
+
| '\x9f' -> Atom "\x9f"
813
+
| '\xa0' -> Atom "\xa0"
814
+
| '\xa1' -> Atom "\xa1"
815
+
| '\xa2' -> Atom "\xa2"
816
+
| '\xa3' -> Atom "\xa3"
817
+
| '\xa4' -> Atom "\xa4"
818
+
| '\xa5' -> Atom "\xa5"
819
+
| '\xa6' -> Atom "\xa6"
820
+
| '\xa7' -> Atom "\xa7"
821
+
| '\xa8' -> Atom "\xa8"
822
+
| '\xa9' -> Atom "\xa9"
823
+
| '\xaa' -> Atom "\xaa"
824
+
| '\xab' -> Atom "\xab"
825
+
| '\xac' -> Atom "\xac"
826
+
| '\xad' -> Atom "\xad"
827
+
| '\xae' -> Atom "\xae"
828
+
| '\xaf' -> Atom "\xaf"
829
+
| '\xb0' -> Atom "\xb0"
830
+
| '\xb1' -> Atom "\xb1"
831
+
| '\xb2' -> Atom "\xb2"
832
+
| '\xb3' -> Atom "\xb3"
833
+
| '\xb4' -> Atom "\xb4"
834
+
| '\xb5' -> Atom "\xb5"
835
+
| '\xb6' -> Atom "\xb6"
836
+
| '\xb7' -> Atom "\xb7"
837
+
| '\xb8' -> Atom "\xb8"
838
+
| '\xb9' -> Atom "\xb9"
839
+
| '\xba' -> Atom "\xba"
840
+
| '\xbb' -> Atom "\xbb"
841
+
| '\xbc' -> Atom "\xbc"
842
+
| '\xbd' -> Atom "\xbd"
843
+
| '\xbe' -> Atom "\xbe"
844
+
| '\xbf' -> Atom "\xbf"
845
+
| '\xc0' -> Atom "\xc0"
846
+
| '\xc1' -> Atom "\xc1"
847
+
| '\xc2' -> Atom "\xc2"
848
+
| '\xc3' -> Atom "\xc3"
849
+
| '\xc4' -> Atom "\xc4"
850
+
| '\xc5' -> Atom "\xc5"
851
+
| '\xc6' -> Atom "\xc6"
852
+
| '\xc7' -> Atom "\xc7"
853
+
| '\xc8' -> Atom "\xc8"
854
+
| '\xc9' -> Atom "\xc9"
855
+
| '\xca' -> Atom "\xca"
856
+
| '\xcb' -> Atom "\xcb"
857
+
| '\xcc' -> Atom "\xcc"
858
+
| '\xcd' -> Atom "\xcd"
859
+
| '\xce' -> Atom "\xce"
860
+
| '\xcf' -> Atom "\xcf"
861
+
| '\xd0' -> Atom "\xd0"
862
+
| '\xd1' -> Atom "\xd1"
863
+
| '\xd2' -> Atom "\xd2"
864
+
| '\xd3' -> Atom "\xd3"
865
+
| '\xd4' -> Atom "\xd4"
866
+
| '\xd5' -> Atom "\xd5"
867
+
| '\xd6' -> Atom "\xd6"
868
+
| '\xd7' -> Atom "\xd7"
869
+
| '\xd8' -> Atom "\xd8"
870
+
| '\xd9' -> Atom "\xd9"
871
+
| '\xda' -> Atom "\xda"
872
+
| '\xdb' -> Atom "\xdb"
873
+
| '\xdc' -> Atom "\xdc"
874
+
| '\xdd' -> Atom "\xdd"
875
+
| '\xde' -> Atom "\xde"
876
+
| '\xdf' -> Atom "\xdf"
877
+
| '\xe0' -> Atom "\xe0"
878
+
| '\xe1' -> Atom "\xe1"
879
+
| '\xe2' -> Atom "\xe2"
880
+
| '\xe3' -> Atom "\xe3"
881
+
| '\xe4' -> Atom "\xe4"
882
+
| '\xe5' -> Atom "\xe5"
883
+
| '\xe6' -> Atom "\xe6"
884
+
| '\xe7' -> Atom "\xe7"
885
+
| '\xe8' -> Atom "\xe8"
886
+
| '\xe9' -> Atom "\xe9"
887
+
| '\xea' -> Atom "\xea"
888
+
| '\xeb' -> Atom "\xeb"
889
+
| '\xec' -> Atom "\xec"
890
+
| '\xed' -> Atom "\xed"
891
+
| '\xee' -> Atom "\xee"
892
+
| '\xef' -> Atom "\xef"
893
+
| '\xf0' -> Atom "\xf0"
894
+
| '\xf1' -> Atom "\xf1"
895
+
| '\xf2' -> Atom "\xf2"
896
+
| '\xf3' -> Atom "\xf3"
897
+
| '\xf4' -> Atom "\xf4"
898
+
| '\xf5' -> Atom "\xf5"
899
+
| '\xf6' -> Atom "\xf6"
900
+
| '\xf7' -> Atom "\xf7"
901
+
| '\xf8' -> Atom "\xf8"
902
+
| '\xf9' -> Atom "\xf9"
903
+
| '\xfa' -> Atom "\xfa"
904
+
| '\xfb' -> Atom "\xfb"
905
+
| '\xfc' -> Atom "\xfc"
906
+
| '\xfd' -> Atom "\xfd"
907
+
| '\xfe' -> Atom "\xfe"
908
+
| '\xff' -> Atom "\xff"
909
+
;;
910
+
911
+
(*$*)
912
+
913
+
let[@inline always] is_valid_char (char : char) : bool = Char.code char land lnot 0xff = 0
914
+
915
+
let[@inline never] [@local never] [@specialise never] fallback_sexp_of_char (char : char) =
916
+
Atom ((String.make [@inlined never]) 1 char)
917
+
;;
918
+
919
+
let[@inline always] sexp_of_char (char : char) =
920
+
if is_valid_char char
921
+
then sexp_of_char_statically_allocated char [@tail]
922
+
else fallback_sexp_of_char char [@tail]
923
+
;;
924
+
925
+
let[@inline never] [@local never] [@specialise never] fallback_sexp_of_char__stack
926
+
(char : char)
927
+
=
928
+
Atom ((string_make_local [@inlined never]) 1 char)
929
+
;;
930
+
931
+
let[@inline always] sexp_of_char__stack (char : char) =
932
+
if is_valid_char char
933
+
then sexp_of_char_statically_allocated char
934
+
else fallback_sexp_of_char__stack char
935
+
;;
+325
vendor/opam/sexplib0/src/sexp_conv.mli
+325
vendor/opam/sexplib0/src/sexp_conv.mli
···
1
+
(** Utility Module for S-expression Conversions *)
2
+
3
+
open Basement
4
+
5
+
(** {6 Conversion of OCaml-values to S-expressions} *)
6
+
7
+
(** [default_string_of_float] reference to the default function used to convert floats to
8
+
strings.
9
+
10
+
Initially set to [fun n -> sprintf "%.20G" n]. *)
11
+
val default_string_of_float : (float -> string) Dynamic.t
12
+
13
+
(** [write_old_option_format] reference for the default option format used to write option
14
+
values. If set to [true], the old-style option format will be used, the new-style one
15
+
otherwise.
16
+
17
+
Initially set to [true]. *)
18
+
val write_old_option_format : bool Dynamic.t
19
+
20
+
(** [read_old_option_format] reference for the default option format used to read option
21
+
values. [Of_sexp_error] will be raised with old-style option values if this reference
22
+
is set to [false]. Reading new-style option values is always supported. Using a global
23
+
reference instead of changing the converter calling conventions is the only way to
24
+
avoid breaking old code with the standard macros.
25
+
26
+
Initially set to [true]. *)
27
+
val read_old_option_format : bool Dynamic.t
28
+
29
+
(** We re-export a tail recursive map function, because some modules override the standard
30
+
library functions (e.g. [StdLabels]) which wrecks havoc with the camlp4 extension. *)
31
+
val list_map : ('a -> 'b) -> 'a list -> 'b list
32
+
33
+
(** As [list_map], but operating over locally-allocated values. *)
34
+
val list_map__stack : ('a -> 'b) -> 'a list -> 'b list
35
+
36
+
(** [sexp_of_unit ()] converts a value of type [unit] to an S-expression. *)
37
+
val sexp_of_unit : unit -> Sexp.t
38
+
39
+
(** As [sexp_of_unit], but returning a locally-allocated sexp. *)
40
+
val sexp_of_unit__stack : unit -> Sexp.t
41
+
42
+
(** [sexp_of_bool b] converts the value [x] of type [bool] to an S-expression. *)
43
+
val sexp_of_bool : bool -> Sexp.t
44
+
45
+
(** As [sexp_of_bool], but returning a locally-allocated sexp. *)
46
+
val sexp_of_bool__stack : bool -> Sexp.t
47
+
48
+
(** [sexp_of_string str] converts the value [str] of type [string] to an S-expression. *)
49
+
val sexp_of_string : string -> Sexp.t
50
+
51
+
(** As [sexp_of_string], but returning a locally-allocated sexp. *)
52
+
val sexp_of_string__stack : string -> Sexp.t
53
+
54
+
(** [sexp_of_bytes str] converts the value [str] of type [bytes] to an S-expression. *)
55
+
val sexp_of_bytes : bytes -> Sexp.t
56
+
57
+
(** As [sexp_of_bytes], but returning a locally-allocated sexp. *)
58
+
val sexp_of_bytes__stack : bytes -> Sexp.t
59
+
60
+
(** [sexp_of_char c] converts the value [c] of type [char] to an S-expression. *)
61
+
val sexp_of_char : char -> Sexp.t
62
+
63
+
(** As [sexp_of_char], but returning a locally-allocated sexp. Currently, the sexp will
64
+
contain a one-character string which is heap-allocated. *)
65
+
val sexp_of_char__stack : char -> Sexp.t
66
+
67
+
(** [sexp_of_int n] converts the value [n] of type [int] to an S-expression. *)
68
+
val sexp_of_int : int -> Sexp.t
69
+
70
+
(** As [sexp_of_int], but returning a locally-allocated sexp. Currently, the sexp will
71
+
contain a formatted string which is heap-allocated. *)
72
+
val sexp_of_int__stack : int -> Sexp.t
73
+
74
+
(** [sexp_of_float n] converts the value [n] of type [float] to an S-expression. *)
75
+
val sexp_of_float : float -> Sexp.t
76
+
77
+
(** As [sexp_of_float], but returning a locally-allocated sexp. Currently, the float will
78
+
be copied to the heap, and the sexp will contain a formatted string which is
79
+
heap-allocated. *)
80
+
val sexp_of_float__stack : float -> Sexp.t
81
+
82
+
(** [sexp_of_int32 n] converts the value [n] of type [int32] to an S-expression. *)
83
+
val sexp_of_int32 : int32 -> Sexp.t
84
+
85
+
(** As [sexp_of_int32], but returning a locally-allocated sexp. Currently, the sexp will
86
+
contain a formatted string which is heap-allocated. *)
87
+
val sexp_of_int32__stack : int32 -> Sexp.t
88
+
89
+
(** [sexp_of_int64 n] converts the value [n] of type [int64] to an S-expression. *)
90
+
val sexp_of_int64 : int64 -> Sexp.t
91
+
92
+
(** As [sexp_of_int64], but returning a locally-allocated sexp. Currently, the sexp will
93
+
contain a formatted string which is heap-allocated. *)
94
+
val sexp_of_int64__stack : int64 -> Sexp.t
95
+
96
+
(** [sexp_of_nativeint n] converts the value [n] of type [nativeint] to an S-expression. *)
97
+
val sexp_of_nativeint : nativeint -> Sexp.t
98
+
99
+
(** As [sexp_of_nativeint], but returning a locally-allocated sexp. Currently, the sexp
100
+
will contain a formatted string which is heap-allocated. *)
101
+
val sexp_of_nativeint__stack : nativeint -> Sexp.t
102
+
103
+
(** [sexp_of_ref conv r] converts the value [r] of type ['a ref] to an S-expression. Uses
104
+
[conv] to convert values of type ['a] to an S-expression. *)
105
+
val sexp_of_ref : 'a. ('a -> Sexp.t) -> 'a ref -> Sexp.t
106
+
107
+
(** As [sexp_of_ref], but returning a locally-allocated sexp. *)
108
+
val sexp_of_ref__stack : 'a. ('a -> Sexp.t) -> 'a ref -> Sexp.t
109
+
110
+
(** [sexp_of_lazy_t conv l] converts the value [l] of type ['a lazy_t] to an S-expression.
111
+
Uses [conv] to convert values of type ['a] to an S-expression. *)
112
+
val sexp_of_lazy_t : 'a. ('a -> Sexp.t) -> 'a lazy_t -> Sexp.t
113
+
114
+
(** As [sexp_of_lazy_t], but returning a locally-allocated sexp. *)
115
+
val sexp_of_lazy_t__stack : 'a. ('a -> Sexp.t) -> 'a lazy_t -> Sexp.t
116
+
117
+
(** [sexp_of_option conv opt] converts the value [opt] of type ['a option] to an
118
+
S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *)
119
+
val sexp_of_option : 'a. ('a -> Sexp.t) -> 'a option -> Sexp.t
120
+
121
+
(** As [sexp_of_option], but returning a locally-allocated sexp. *)
122
+
val sexp_of_option__stack : 'a. ('a -> Sexp.t) -> 'a option -> Sexp.t
123
+
124
+
(** [sexp_of_or_null conv orn] converts the value [orn] of type ['a or_null] to an
125
+
S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *)
126
+
val sexp_of_or_null : 'a. ('a -> Sexp.t) -> 'a Or_null_shim.t -> Sexp.t
127
+
128
+
(** As [sexp_of_or_null], but returning a locally-allocated sexp. *)
129
+
val sexp_of_or_null__stack : 'a. ('a -> Sexp.t) -> 'a Or_null_shim.t -> Sexp.t
130
+
131
+
(** [sexp_of_pair conv1 conv2 pair] converts a pair to an S-expression. It uses its first
132
+
argument to convert the first element of the pair, and its second argument to convert
133
+
the second element of the pair. *)
134
+
val sexp_of_pair : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> 'a * 'b -> Sexp.t
135
+
136
+
(** [sexp_of_triple conv1 conv2 conv3 triple] converts a triple to an S-expression using
137
+
[conv1], [conv2], and [conv3] to convert its elements. *)
138
+
val sexp_of_triple
139
+
: 'a 'b 'c.
140
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> 'a * 'b * 'c -> Sexp.t
141
+
142
+
(** [sexp_of_list conv lst] converts the value [lst] of type ['a list] to an S-expression.
143
+
Uses [conv] to convert values of type ['a] to an S-expression. *)
144
+
val sexp_of_list : 'a. ('a -> Sexp.t) -> 'a list -> Sexp.t
145
+
146
+
(** As [sexp_of_list], but returning a locally-allocated sexp. *)
147
+
val sexp_of_list__stack : 'a. ('a -> Sexp.t) -> 'a list -> Sexp.t
148
+
149
+
(** [sexp_of_array conv ar] converts the value [ar] of type ['a array] to an S-expression.
150
+
Uses [conv] to convert values of type ['a] to an S-expression. *)
151
+
val sexp_of_array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t
152
+
153
+
(** As [sexp_of_array], but returning a locally-allocated sexp. *)
154
+
val sexp_of_array__stack : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t
155
+
156
+
(** [sexp_of_hashtbl conv_key conv_value htbl] converts the value [htbl] of type
157
+
[('a, 'b) Hashtbl.t] to an S-expression. Uses [conv_key] to convert the hashtable keys
158
+
of type ['a], and [conv_value] to convert hashtable values of type ['b] to
159
+
S-expressions. *)
160
+
val sexp_of_hashtbl
161
+
: 'a 'b.
162
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) Hashtbl.t -> Sexp.t
163
+
164
+
(** [sexp_of_opaque x] converts the value [x] of opaque type to an S-expression. This
165
+
means the user need not provide converters, but the result cannot be interpreted. *)
166
+
val sexp_of_opaque : 'a. 'a -> Sexp.t
167
+
168
+
(** [sexp_of_fun f] converts the value [f] of function type to a dummy S-expression.
169
+
Functions cannot be serialized as S-expressions, but at least a placeholder can be
170
+
generated for pretty-printing. *)
171
+
val sexp_of_fun : ('a -> 'b) -> Sexp.t
172
+
173
+
(** {6 Conversion of S-expressions to OCaml-values} *)
174
+
175
+
(** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be
176
+
successfully converted to an OCaml-value. *)
177
+
exception Of_sexp_error of exn * Sexp.t
178
+
179
+
(** [record_check_extra_fields] checks for extra (= unknown) fields in record
180
+
S-expressions. *)
181
+
val record_check_extra_fields : bool Dynamic.t
182
+
183
+
(** [of_sexp_error reason sexp]
184
+
@raise Of_sexp_error (Failure reason, sexp). *)
185
+
val of_sexp_error : string -> Sexp.t -> 'a
186
+
187
+
(** [of_sexp_error exc sexp]
188
+
@raise Of_sexp_error (exc, sexp). *)
189
+
val of_sexp_error_exn : exn -> Sexp.t -> 'a
190
+
191
+
(** [unit_of_sexp sexp] converts S-expression [sexp] to a value of type [unit]. *)
192
+
val unit_of_sexp : Sexp.t -> unit
193
+
194
+
(** [bool_of_sexp sexp] converts S-expression [sexp] to a value of type [bool]. *)
195
+
val bool_of_sexp : Sexp.t -> bool
196
+
197
+
(** [string_of_sexp sexp] converts S-expression [sexp] to a value of type [string]. *)
198
+
val string_of_sexp : Sexp.t -> string
199
+
200
+
(** [bytes_of_sexp sexp] converts S-expression [sexp] to a value of type [bytes]. *)
201
+
val bytes_of_sexp : Sexp.t -> bytes
202
+
203
+
(** [char_of_sexp sexp] converts S-expression [sexp] to a value of type [char]. *)
204
+
val char_of_sexp : Sexp.t -> char
205
+
206
+
(** [int_of_sexp sexp] converts S-expression [sexp] to a value of type [int]. *)
207
+
val int_of_sexp : Sexp.t -> int
208
+
209
+
(** [float_of_sexp sexp] converts S-expression [sexp] to a value of type [float]. *)
210
+
val float_of_sexp : Sexp.t -> float
211
+
212
+
(** [int32_of_sexp sexp] converts S-expression [sexp] to a value of type [int32]. *)
213
+
val int32_of_sexp : Sexp.t -> int32
214
+
215
+
(** [int64_of_sexp sexp] converts S-expression [sexp] to a value of type [int64]. *)
216
+
val int64_of_sexp : Sexp.t -> int64
217
+
218
+
(** [nativeint_of_sexp sexp] converts S-expression [sexp] to a value of type [nativeint]. *)
219
+
val nativeint_of_sexp : Sexp.t -> nativeint
220
+
221
+
(** [ref_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a ref] using
222
+
conversion function [conv], which converts an S-expression to a value of type ['a]. *)
223
+
val ref_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a ref
224
+
225
+
(** [lazy_t_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a lazy_t]
226
+
using conversion function [conv], which converts an S-expression to a value of type
227
+
['a]. *)
228
+
val lazy_t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a lazy_t
229
+
230
+
(** [option_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a option]
231
+
using conversion function [conv], which converts an S-expression to a value of type
232
+
['a]. *)
233
+
val option_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a option
234
+
235
+
(** [option_of_sexp conv sexp] converts S-expression [sexp] to a value of type
236
+
['a or_null] using conversion function [conv], which converts an S-expression to a
237
+
value of type ['a]. *)
238
+
val or_null_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a Or_null_shim.t
239
+
240
+
(** [pair_of_sexp conv1 conv2 sexp] converts S-expression [sexp] to a pair of type
241
+
['a * 'b] using conversion functions [conv1] and [conv2], which convert S-expressions
242
+
to values of type ['a] and ['b] respectively. *)
243
+
val pair_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> 'a * 'b
244
+
245
+
(** [triple_of_sexp conv1 conv2 conv3 sexp] converts S-expression [sexp] to a triple of
246
+
type ['a * 'b * 'c] using conversion functions [conv1], [conv2], and [conv3], which
247
+
convert S-expressions to values of type ['a], ['b], and ['c] respectively. *)
248
+
val triple_of_sexp
249
+
: 'a 'b 'c.
250
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> 'a * 'b * 'c
251
+
252
+
(** [list_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a list]
253
+
using conversion function [conv], which converts an S-expression to a value of type
254
+
['a]. *)
255
+
val list_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a list
256
+
257
+
(** [array_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a array]
258
+
using conversion function [conv], which converts an S-expression to a value of type
259
+
['a]. *)
260
+
val array_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a array
261
+
262
+
(** [hashtbl_of_sexp conv_key conv_value sexp] converts S-expression [sexp] to a value of
263
+
type [('a, 'b) Hashtbl.t] using conversion function [conv_key], which converts an
264
+
S-expression to hashtable key of type ['a], and function [conv_value], which converts
265
+
an S-expression to hashtable value of type ['b]. *)
266
+
val hashtbl_of_sexp
267
+
: 'a 'b.
268
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) Hashtbl.t
269
+
270
+
(** [opaque_of_sexp sexp]
271
+
@raise Of_sexp_error when attempting to convert an S-expression to an opaque value. *)
272
+
val opaque_of_sexp : Sexp.t -> 'a
273
+
274
+
(** [fun_of_sexp sexp]
275
+
@raise Of_sexp_error when attempting to convert an S-expression to a function. *)
276
+
val fun_of_sexp : Sexp.t -> 'a
277
+
278
+
(** Sexp Grammars *)
279
+
280
+
include module type of struct
281
+
include Sexp_conv_grammar
282
+
end
283
+
284
+
(** Exception converters *)
285
+
286
+
(** [sexp_of_exn exc] converts exception [exc] to an S-expression. If no suitable
287
+
converter is found, the standard converter in [Printexc] will be used to generate an
288
+
atomic S-expression. *)
289
+
val sexp_of_exn : exn -> Sexp.t
290
+
291
+
(** Converts an exception to a string via sexp, falling back to [Printexc.to_string] if no
292
+
sexp conversion is registered for this exception.
293
+
294
+
This is different from [Printexc.to_string] in that it additionally uses the sexp
295
+
converters registered with [~printexc:false]. Another difference is that the behavior
296
+
of [Printexc] can be overridden with [Printexc.register], but here we always try sexp
297
+
conversion first. *)
298
+
val printexc_prefer_sexp : exn -> string
299
+
300
+
(** [sexp_of_exn_opt exc] converts exception [exc] to [Some sexp]. If no suitable
301
+
converter is found, [None] is returned instead. *)
302
+
val sexp_of_exn_opt : exn -> Sexp.t option
303
+
304
+
module Exn_converter : sig
305
+
(** [add constructor sexp_of_exn] registers exception S-expression converter
306
+
[sexp_of_exn] for exceptions with the given [constructor].
307
+
308
+
NOTE: [finalise] is ignored, and provided only for backward compatibility. *)
309
+
val add
310
+
: ?printexc:bool
311
+
-> ?finalise:bool
312
+
-> extension_constructor
313
+
-> (exn -> Sexp.t)
314
+
-> unit
315
+
316
+
module For_unit_tests_only : sig
317
+
val size : unit -> int
318
+
end
319
+
end
320
+
321
+
(**/**)
322
+
323
+
(*_ For the syntax extension *)
324
+
external ignore : 'a. ('a[@local_opt]) -> unit = "%ignore"
325
+
external ( = ) : 'a. ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal"
+128
vendor/opam/sexplib0/src/sexp_conv_error.ml
+128
vendor/opam/sexplib0/src/sexp_conv_error.ml
···
1
+
(* Conv_error: Module for Handling Errors during Automated S-expression
2
+
Conversions *)
3
+
4
+
open StdLabels
5
+
open Printf
6
+
open Sexp_conv
7
+
8
+
exception Of_sexp_error = Of_sexp_error
9
+
10
+
let error ~loc ~sexp msg = of_sexp_error (sprintf "%s_of_sexp: %s" loc msg) sexp
11
+
let simple_error msg loc sexp = error ~loc ~sexp msg
12
+
13
+
(* Errors concerning tuples *)
14
+
15
+
let tuple_of_size_n_expected loc n sexp =
16
+
error ~loc ~sexp (sprintf "tuple of size %d expected" n)
17
+
;;
18
+
19
+
let tuple_pair_expected loc name sexp =
20
+
let msg = sprintf "%s_of_sexp: expected a pair beginning with label %s" loc name in
21
+
of_sexp_error msg sexp
22
+
;;
23
+
24
+
let tuple_incorrect_label loc name pos sexp =
25
+
let msg =
26
+
sprintf "%s_of_sexp: incorrect label for element %s at position %i" loc name pos
27
+
in
28
+
of_sexp_error msg sexp
29
+
;;
30
+
31
+
(* Errors concerning sum types *)
32
+
33
+
let stag_no_args = simple_error "this constructor does not take arguments"
34
+
35
+
let stag_incorrect_n_args loc tag sexp =
36
+
error ~loc ~sexp (sprintf "sum tag %S has incorrect number of arguments" tag)
37
+
;;
38
+
39
+
let stag_takes_args = simple_error "this constructor requires arguments"
40
+
let nested_list_invalid_sum = simple_error "expected a variant type, saw a nested list"
41
+
let empty_list_invalid_sum = simple_error "expected a variant type, saw an empty list"
42
+
43
+
let unexpected_stag loc expected_cnstrs sexp =
44
+
let max_cnstrs = 10 in
45
+
let expected_cnstrs =
46
+
if List.length expected_cnstrs <= max_cnstrs
47
+
then expected_cnstrs
48
+
else List.filteri expected_cnstrs ~f:(fun i _ -> i < max_cnstrs) @ [ "..." ]
49
+
in
50
+
let expected_cnstrs_string = String.concat expected_cnstrs ~sep:" " in
51
+
error
52
+
~loc
53
+
~sexp
54
+
(sprintf "unexpected variant constructor; expected one of %s" expected_cnstrs_string)
55
+
;;
56
+
57
+
(* Errors concerning records *)
58
+
59
+
let record_sexp_bool_with_payload =
60
+
simple_error "record conversion: a [sexp.bool] field was given a payload"
61
+
;;
62
+
63
+
let record_only_pairs_expected =
64
+
simple_error
65
+
"record conversion: only pairs expected, their first element must be an atom"
66
+
;;
67
+
68
+
let record_invalid_fields ~what ~loc fld_names sexp =
69
+
let fld_names_str = String.concat fld_names ~sep:" " in
70
+
error ~loc ~sexp (sprintf "%s: %s" what fld_names_str)
71
+
;;
72
+
73
+
let record_duplicate_fields loc fld_names sexp =
74
+
record_invalid_fields ~what:"duplicate fields" ~loc fld_names sexp
75
+
;;
76
+
77
+
let record_missing_and_extra_fields loc sexp ~missing ~extras =
78
+
match missing, extras with
79
+
| [], [] -> assert false
80
+
| _ :: _, [] -> record_invalid_fields ~what:"missing fields" ~loc missing sexp
81
+
| [], _ :: _ -> record_invalid_fields ~what:"extra fields" ~loc extras sexp
82
+
| _ :: _, _ :: _ ->
83
+
let missing_fields = String.concat ~sep:" " missing in
84
+
let extra_fields = String.concat ~sep:" " extras in
85
+
error
86
+
~loc
87
+
~sexp
88
+
(sprintf
89
+
"extra fields found while some fields missing; extra fields: %s; missing \
90
+
fields: %s"
91
+
extra_fields
92
+
missing_fields)
93
+
;;
94
+
95
+
let record_list_instead_atom = simple_error "list expected for record, found atom instead"
96
+
97
+
let record_poly_field_value =
98
+
simple_error "cannot convert values of types resulting from polymorphic record fields"
99
+
;;
100
+
101
+
(* Errors concerning polymorphic variants *)
102
+
103
+
exception No_variant_match
104
+
105
+
let no_variant_match () = raise No_variant_match
106
+
let no_matching_variant_found = simple_error "no matching variant found"
107
+
let ptag_no_args = simple_error "polymorphic variant does not take arguments"
108
+
109
+
let ptag_incorrect_n_args loc cnstr sexp =
110
+
error
111
+
~loc
112
+
~sexp
113
+
(sprintf "polymorphic variant tag %S has incorrect number of arguments" cnstr)
114
+
;;
115
+
116
+
let ptag_takes_args = simple_error "polymorphic variant tag takes an argument"
117
+
118
+
let nested_list_invalid_poly_var =
119
+
simple_error "a nested list is an invalid polymorphic variant"
120
+
;;
121
+
122
+
let empty_list_invalid_poly_var =
123
+
simple_error "the empty list is an invalid polymorphic variant"
124
+
;;
125
+
126
+
let empty_type = simple_error "trying to convert an empty type"
127
+
128
+
type nothing = |
+41
vendor/opam/sexplib0/src/sexp_conv_error.mli
+41
vendor/opam/sexplib0/src/sexp_conv_error.mli
···
1
+
val error : loc:string -> sexp:Sexp.t -> string -> _
2
+
val simple_error : string -> string -> Sexp.t -> _
3
+
4
+
exception Of_sexp_error of exn * Sexp.t
5
+
6
+
val tuple_of_size_n_expected : string -> int -> Sexp.t -> _
7
+
val tuple_pair_expected : string -> string -> Sexp.t -> _
8
+
val stag_no_args : string -> Sexp.t -> _
9
+
val stag_incorrect_n_args : string -> string -> Sexp.t -> _
10
+
val stag_takes_args : string -> Sexp.t -> _
11
+
val nested_list_invalid_sum : string -> Sexp.t -> _
12
+
val empty_list_invalid_sum : string -> Sexp.t -> _
13
+
val unexpected_stag : string -> string list -> Sexp.t -> _
14
+
val record_sexp_bool_with_payload : string -> Sexp.t -> _
15
+
val tuple_incorrect_label : string -> string -> int -> Sexp.t -> _
16
+
val record_only_pairs_expected : string -> Sexp.t -> _
17
+
val record_invalid_fields : what:string -> loc:string -> string list -> Sexp.t -> _
18
+
val record_duplicate_fields : string -> string list -> Sexp.t -> _
19
+
20
+
val record_missing_and_extra_fields
21
+
: string
22
+
-> Sexp.t
23
+
-> missing:string list
24
+
-> extras:string list
25
+
-> _
26
+
27
+
val record_list_instead_atom : string -> Sexp.t -> _
28
+
val record_poly_field_value : string -> Sexp.t -> _
29
+
30
+
exception No_variant_match
31
+
32
+
val no_variant_match : unit -> _
33
+
val no_matching_variant_found : string -> Sexp.t -> _
34
+
val ptag_no_args : string -> Sexp.t -> _
35
+
val ptag_incorrect_n_args : string -> string -> Sexp.t -> _
36
+
val ptag_takes_args : string -> Sexp.t -> _
37
+
val nested_list_invalid_poly_var : string -> Sexp.t -> _
38
+
val empty_list_invalid_poly_var : string -> Sexp.t -> _
39
+
val empty_type : string -> Sexp.t -> _
40
+
41
+
type nothing = |
+41
vendor/opam/sexplib0/src/sexp_conv_grammar.ml
+41
vendor/opam/sexplib0/src/sexp_conv_grammar.ml
···
1
+
open StdLabels
2
+
3
+
let sexp_grammar_with_tags grammar ~tags =
4
+
List.fold_right tags ~init:grammar ~f:(fun (key, value) grammar ->
5
+
Sexp_grammar.Tagged { key; value; grammar })
6
+
;;
7
+
8
+
let sexp_grammar_with_tag_list x ~tags =
9
+
List.fold_right tags ~init:x ~f:(fun (key, value) grammar ->
10
+
Sexp_grammar.Tag { key; value; grammar })
11
+
;;
12
+
13
+
let unit_sexp_grammar : unit Sexp_grammar.t = { untyped = List Empty }
14
+
let bool_sexp_grammar : bool Sexp_grammar.t = { untyped = Bool }
15
+
let string_sexp_grammar : string Sexp_grammar.t = { untyped = String }
16
+
let bytes_sexp_grammar : bytes Sexp_grammar.t = { untyped = String }
17
+
let char_sexp_grammar : char Sexp_grammar.t = { untyped = Char }
18
+
let int_sexp_grammar : int Sexp_grammar.t = { untyped = Integer }
19
+
let float_sexp_grammar : float Sexp_grammar.t = { untyped = Float }
20
+
let int32_sexp_grammar : int32 Sexp_grammar.t = { untyped = Integer }
21
+
let int64_sexp_grammar : int64 Sexp_grammar.t = { untyped = Integer }
22
+
let nativeint_sexp_grammar : nativeint Sexp_grammar.t = { untyped = Integer }
23
+
let sexp_t_sexp_grammar : Sexp.t Sexp_grammar.t = { untyped = Any "Sexp.t" }
24
+
let ref_sexp_grammar grammar = Sexp_grammar.coerce grammar
25
+
let lazy_t_sexp_grammar grammar = Sexp_grammar.coerce grammar
26
+
27
+
let option_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ option Sexp_grammar.t =
28
+
{ untyped = Option untyped }
29
+
;;
30
+
31
+
let list_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ list Sexp_grammar.t =
32
+
{ untyped = List (Many untyped) }
33
+
;;
34
+
35
+
let array_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ array Sexp_grammar.t =
36
+
{ untyped = List (Many untyped) }
37
+
;;
38
+
39
+
let empty_sexp_grammar : _ Sexp_grammar.t = { untyped = Union [] }
40
+
let opaque_sexp_grammar = empty_sexp_grammar
41
+
let fun_sexp_grammar = empty_sexp_grammar
+32
vendor/opam/sexplib0/src/sexp_conv_grammar.mli
+32
vendor/opam/sexplib0/src/sexp_conv_grammar.mli
···
1
+
(** Grammar constructors. *)
2
+
3
+
val sexp_grammar_with_tags
4
+
: Sexp_grammar.grammar
5
+
-> tags:(string * Sexp.t) list
6
+
-> Sexp_grammar.grammar
7
+
8
+
val sexp_grammar_with_tag_list
9
+
: 'a Sexp_grammar.with_tag_list
10
+
-> tags:(string * Sexp.t) list
11
+
-> 'a Sexp_grammar.with_tag_list
12
+
13
+
(** Sexp grammar definitions. *)
14
+
15
+
val unit_sexp_grammar : unit Sexp_grammar.t
16
+
val bool_sexp_grammar : bool Sexp_grammar.t
17
+
val string_sexp_grammar : string Sexp_grammar.t
18
+
val bytes_sexp_grammar : bytes Sexp_grammar.t
19
+
val char_sexp_grammar : char Sexp_grammar.t
20
+
val int_sexp_grammar : int Sexp_grammar.t
21
+
val float_sexp_grammar : float Sexp_grammar.t
22
+
val int32_sexp_grammar : int32 Sexp_grammar.t
23
+
val int64_sexp_grammar : int64 Sexp_grammar.t
24
+
val nativeint_sexp_grammar : nativeint Sexp_grammar.t
25
+
val sexp_t_sexp_grammar : Sexp.t Sexp_grammar.t
26
+
val ref_sexp_grammar : 'a. 'a Sexp_grammar.t -> 'a ref Sexp_grammar.t
27
+
val lazy_t_sexp_grammar : 'a Sexp_grammar.t -> 'a lazy_t Sexp_grammar.t
28
+
val option_sexp_grammar : 'a. 'a Sexp_grammar.t -> 'a option Sexp_grammar.t
29
+
val list_sexp_grammar : 'a. 'a Sexp_grammar.t -> 'a list Sexp_grammar.t
30
+
val array_sexp_grammar : 'a. 'a Sexp_grammar.t -> 'a array Sexp_grammar.t
31
+
val opaque_sexp_grammar : 'a. 'a Sexp_grammar.t
32
+
val fun_sexp_grammar : 'a Sexp_grammar.t
+57
vendor/opam/sexplib0/src/sexp_conv_labeled_tuple.ml
+57
vendor/opam/sexplib0/src/sexp_conv_labeled_tuple.ml
···
1
+
module Fields = struct
2
+
type _ t =
3
+
| Field :
4
+
'a 'b.
5
+
{ name : string
6
+
; conv : Sexp.t -> unit -> 'a
7
+
; rest : 'b t
8
+
}
9
+
-> ((unit -> 'a) * 'b) t
10
+
| Empty : unit t
11
+
12
+
let rec length_loop : type a. a t -> int -> int =
13
+
fun t acc ->
14
+
match t with
15
+
| Empty -> acc
16
+
| Field field -> length_loop field.rest (acc + 1)
17
+
;;
18
+
19
+
let length t = length_loop t 0
20
+
end
21
+
22
+
let[@tail_mod_cons] rec of_list
23
+
: type a.
24
+
caller:string
25
+
-> fields:a Fields.t
26
+
-> len:int
27
+
-> original_sexp:Sexp.t
28
+
-> pos:int
29
+
-> Sexp.t list
30
+
-> a
31
+
=
32
+
fun ~caller ~fields ~len ~original_sexp ~pos list ->
33
+
match fields with
34
+
| Empty ->
35
+
(match list with
36
+
| [] -> ()
37
+
| _ :: _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp)
38
+
| Field { name; conv; rest } ->
39
+
(match list with
40
+
| [] -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp
41
+
| sexp :: list ->
42
+
(match sexp with
43
+
| List [ Atom atom; sexp ] ->
44
+
if String.equal atom name
45
+
then
46
+
( conv sexp
47
+
, of_list ~caller ~fields:rest ~len ~original_sexp ~pos:(pos + 1) list )
48
+
else Sexp_conv_error.tuple_incorrect_label caller name pos original_sexp
49
+
| _ -> Sexp_conv_error.tuple_pair_expected caller name sexp))
50
+
;;
51
+
52
+
let labeled_tuple_of_sexp ~caller ~fields ~create original_sexp =
53
+
let len = Fields.length fields in
54
+
match (original_sexp : Sexp.t) with
55
+
| Atom _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp
56
+
| List list -> create (of_list ~caller ~fields ~len ~original_sexp ~pos:0 list)
57
+
;;
+22
vendor/opam/sexplib0/src/sexp_conv_labeled_tuple.mli
+22
vendor/opam/sexplib0/src/sexp_conv_labeled_tuple.mli
···
1
+
(* Parses sexps 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
+
module Fields : sig
6
+
type _ t =
7
+
| Field :
8
+
'a 'b.
9
+
{ name : string
10
+
; conv : Sexp.t -> unit -> 'a
11
+
; rest : 'b t
12
+
}
13
+
-> ((unit -> 'a) * 'b) t
14
+
| Empty : unit t
15
+
end
16
+
17
+
val labeled_tuple_of_sexp
18
+
: caller:string
19
+
-> fields:'a Fields.t
20
+
-> create:('a -> 'b)
21
+
-> Sexp.t
22
+
-> 'b
+344
vendor/opam/sexplib0/src/sexp_conv_record.ml
+344
vendor/opam/sexplib0/src/sexp_conv_record.ml
···
1
+
open! StdLabels
2
+
open Basement
3
+
open Sexp_conv
4
+
open Sexp_conv_error
5
+
6
+
module Kind = struct
7
+
type (_, _) t =
8
+
| Default : 'a. (unit -> 'a) -> (unit -> 'a, Sexp.t -> unit -> 'a) t
9
+
| Omit_nil : 'a. (unit -> 'a, Sexp.t -> unit -> 'a) t
10
+
| Required : 'a. (unit -> 'a, Sexp.t -> unit -> 'a) t
11
+
| Sexp_array : ('a array, Sexp.t -> 'a) t
12
+
| Sexp_bool : (bool, unit) t
13
+
| Sexp_list : ('a list, Sexp.t -> 'a) t
14
+
| Sexp_option : ('a option, Sexp.t -> 'a) t
15
+
| Sexp_or_null : ('a Or_null_shim.t, Sexp.t -> 'a) t
16
+
end
17
+
18
+
module Fields = struct
19
+
type _ t =
20
+
| Empty : unit t
21
+
| Field :
22
+
'a 'b 'conv.
23
+
{ name : string
24
+
; kind : ('a, 'conv) Kind.t
25
+
; conv : 'conv
26
+
; rest : 'b t
27
+
}
28
+
-> ('a * 'b) t
29
+
30
+
let length =
31
+
let rec length_loop : type a. a t -> int -> int =
32
+
fun t acc ->
33
+
match t with
34
+
| Field { rest; _ } -> length_loop rest (acc + 1)
35
+
| Empty -> acc
36
+
in
37
+
fun t -> length_loop t 0
38
+
;;
39
+
end
40
+
41
+
module Malformed = struct
42
+
(* Represents errors that can occur due to malformed record sexps. Accumulated as a
43
+
value so we can report multiple names at once for extra fields, duplicate fields, or
44
+
missing fields. *)
45
+
type t =
46
+
| Bool_payload
47
+
| Missing_and_extras of
48
+
{ missing : string list
49
+
; extras : string list
50
+
}
51
+
| Dups of string list
52
+
| Non_pair of Sexp.t option
53
+
54
+
let missing missing = Missing_and_extras { missing; extras = [] }
55
+
let extras extras = Missing_and_extras { missing = []; extras }
56
+
57
+
let combine a b =
58
+
match a, b with
59
+
(* choose the first bool-payload or non-pair error that occurs *)
60
+
| ((Bool_payload | Non_pair _) as t), _ -> t
61
+
| _, ((Bool_payload | Non_pair _) as t) -> t
62
+
(* combine lists of similar errors *)
63
+
| ( Missing_and_extras { missing = missing_a; extras = extras_a }
64
+
, Missing_and_extras { missing = missing_b; extras = extras_b } ) ->
65
+
Missing_and_extras { missing = missing_a @ missing_b; extras = extras_a @ extras_b }
66
+
| Dups a, Dups b -> Dups (a @ b)
67
+
(* otherwise, dups > extras > missing *)
68
+
| (Dups _ as t), _ | _, (Dups _ as t) -> t
69
+
;;
70
+
71
+
let raise t ~caller ~context =
72
+
match t with
73
+
| Bool_payload -> record_sexp_bool_with_payload caller context
74
+
| Missing_and_extras { missing; extras } ->
75
+
record_missing_and_extra_fields caller ~missing ~extras context
76
+
| Dups names -> record_duplicate_fields caller names context
77
+
| Non_pair maybe_context ->
78
+
let context = Option.value maybe_context ~default:context in
79
+
record_only_pairs_expected caller context
80
+
;;
81
+
end
82
+
83
+
exception Malformed of Malformed.t
84
+
85
+
module State = struct
86
+
(* Stores sexps corresponding to record fields, in the order the fields were declared.
87
+
Excludes fields already parsed in the fast path.
88
+
89
+
List sexps represent a field that is present, such as (x 1) for a field named "x".
90
+
Atom sexps represent a field that is absent, or at least not yet seen. *)
91
+
type t = { state : Sexp.t array } [@@unboxed]
92
+
93
+
let unsafe_get t pos = Array.unsafe_get t.state pos
94
+
let unsafe_set t pos sexp = Array.unsafe_set t.state pos sexp
95
+
let create len = { state = Array.make len (Sexp.Atom "") }
96
+
end
97
+
98
+
(* Parsing field values from state. *)
99
+
100
+
let rec parse_value_malformed
101
+
: type a b. Malformed.t -> fields:(a * b) Fields.t -> state:State.t -> pos:int -> a
102
+
=
103
+
fun malformed ~fields ~state ~pos ->
104
+
let (Field field) = fields in
105
+
let malformed =
106
+
match parse_values ~fields:field.rest ~state ~pos:(pos + 1) with
107
+
| (_ : b) -> malformed
108
+
| exception Malformed other -> Malformed.combine malformed other
109
+
in
110
+
raise (Malformed malformed)
111
+
112
+
and[@tail_mod_cons] parse_value
113
+
: type a b. fields:(a * b) Fields.t -> state:State.t -> pos:int -> a * b
114
+
=
115
+
fun ~fields ~state ~pos ->
116
+
let (Field { name; kind; conv; rest }) = fields in
117
+
let value : a =
118
+
match kind, State.unsafe_get state pos with
119
+
(* well-formed *)
120
+
| Required, List [ _; sexp ] -> conv sexp
121
+
| Default _, List [ _; sexp ] -> conv sexp
122
+
| Omit_nil, List [ _; sexp ] -> conv sexp
123
+
| Sexp_option, List [ _; sexp ] -> Some (conv sexp)
124
+
| Sexp_or_null, List [ _; sexp ] -> This (conv sexp)
125
+
| Sexp_list, List [ _; sexp ] -> list_of_sexp conv sexp
126
+
| Sexp_array, List [ _; sexp ] -> array_of_sexp conv sexp
127
+
| Sexp_bool, List [ _ ] -> true
128
+
(* ill-formed *)
129
+
| ( ( Required
130
+
| Default _
131
+
| Omit_nil
132
+
| Sexp_option
133
+
| Sexp_or_null
134
+
| Sexp_list
135
+
| Sexp_array )
136
+
, (List (_ :: _ :: _ :: _) as sexp) ) ->
137
+
parse_value_malformed (Non_pair (Some sexp)) ~fields ~state ~pos
138
+
| ( ( Required
139
+
| Default _
140
+
| Omit_nil
141
+
| Sexp_option
142
+
| Sexp_or_null
143
+
| Sexp_list
144
+
| Sexp_array )
145
+
, List ([] | [ _ ]) ) -> parse_value_malformed (Non_pair None) ~fields ~state ~pos
146
+
| Sexp_bool, List ([] | _ :: _ :: _) ->
147
+
parse_value_malformed Bool_payload ~fields ~state ~pos
148
+
(* absent *)
149
+
| Required, Atom _ ->
150
+
parse_value_malformed (Malformed.missing [ name ]) ~fields ~state ~pos
151
+
| Default default, Atom _ -> default
152
+
| Omit_nil, Atom _ -> conv (List [])
153
+
| Sexp_option, Atom _ -> None
154
+
| Sexp_or_null, Atom _ -> Null
155
+
| Sexp_list, Atom _ -> []
156
+
| Sexp_array, Atom _ -> [||]
157
+
| Sexp_bool, Atom _ -> false
158
+
in
159
+
value, parse_values ~fields:rest ~state ~pos:(pos + 1)
160
+
161
+
and[@tail_mod_cons] parse_values
162
+
: type a. fields:a Fields.t -> state:State.t -> pos:int -> a
163
+
=
164
+
fun ~fields ~state ~pos ->
165
+
match fields with
166
+
| Field _ -> parse_value ~fields ~state ~pos
167
+
| Empty -> ()
168
+
;;
169
+
170
+
(* Populating state. Handles slow path cases where there may be reordered, duplicated,
171
+
missing, or extra fields. *)
172
+
173
+
let rec parse_spine_malformed malformed ~index ~extra ~seen ~state ~len sexps =
174
+
let malformed =
175
+
match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with
176
+
| () -> malformed
177
+
| exception Malformed other -> Malformed.combine malformed other
178
+
in
179
+
raise (Malformed malformed)
180
+
181
+
and parse_spine_slow ~index ~extra ~seen ~state ~len sexps =
182
+
match (sexps : Sexp.t list) with
183
+
| [] -> ()
184
+
| (List (Atom name :: _) as field) :: sexps ->
185
+
let i = index name in
186
+
(match seen <= i && i < len with
187
+
| true ->
188
+
(* valid field for slow-path parsing *)
189
+
let pos = i - seen in
190
+
(match State.unsafe_get state pos with
191
+
| Atom _ ->
192
+
(* field not seen yet *)
193
+
State.unsafe_set state pos field;
194
+
parse_spine_slow ~index ~extra ~seen ~state ~len sexps
195
+
| List _ ->
196
+
(* field already seen *)
197
+
parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps)
198
+
| false ->
199
+
(match 0 <= i && i < seen with
200
+
| true ->
201
+
(* field seen in fast path *)
202
+
parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps
203
+
| false ->
204
+
(* extra field *)
205
+
(match extra with
206
+
| true -> parse_spine_slow ~index ~extra ~seen ~state ~len sexps
207
+
| false ->
208
+
parse_spine_malformed
209
+
(Malformed.extras [ name ])
210
+
~index
211
+
~extra
212
+
~seen
213
+
~state
214
+
~len
215
+
sexps)))
216
+
| sexp :: sexps ->
217
+
parse_spine_malformed (Non_pair (Some sexp)) ~index ~extra ~seen ~state ~len sexps
218
+
;;
219
+
220
+
(* Slow path for record parsing. Uses state to store fields as they are discovered. *)
221
+
222
+
let parse_record_slow ~fields ~index ~extra ~seen sexps =
223
+
let unseen = Fields.length fields in
224
+
let state = State.create unseen in
225
+
let len = seen + unseen in
226
+
(* populate state *)
227
+
let maybe_malformed =
228
+
match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with
229
+
| exception Malformed malformed -> Some malformed
230
+
| () -> None
231
+
in
232
+
(* parse values from state *)
233
+
let parsed_or_malformed =
234
+
match parse_values ~fields ~state ~pos:0 with
235
+
| values -> Ok values
236
+
| exception Malformed malformed -> Error malformed
237
+
in
238
+
match maybe_malformed, parsed_or_malformed with
239
+
| None, Ok values -> values
240
+
| Some malformed, Ok _ | None, Error malformed -> raise (Malformed malformed)
241
+
| Some malformed1, Error malformed2 ->
242
+
raise (Malformed (Malformed.combine malformed1 malformed2))
243
+
;;
244
+
245
+
(* Fast path for record parsing. Directly parses and returns fields in the order they are
246
+
declared. Falls back on slow path if any fields are absent, reordered, or malformed. *)
247
+
248
+
let[@tail_mod_cons] rec parse_field_fast
249
+
: type a b.
250
+
fields:(a * b) Fields.t
251
+
-> index:(string -> int)
252
+
-> extra:bool
253
+
-> seen:int
254
+
-> Sexp.t list
255
+
-> a * b
256
+
=
257
+
fun ~fields ~index ~extra ~seen sexps ->
258
+
let (Field { name; kind; conv; rest }) = fields in
259
+
match sexps with
260
+
| List (Atom atom :: args) :: others when String.equal atom name ->
261
+
(match kind, args with
262
+
| Required, [ sexp ] ->
263
+
conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others
264
+
| Default _, [ sexp ] ->
265
+
conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others
266
+
| Omit_nil, [ sexp ] ->
267
+
conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others
268
+
| Sexp_option, [ sexp ] ->
269
+
( Some (conv sexp)
270
+
, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others )
271
+
| Sexp_or_null, [ sexp ] ->
272
+
( This (conv sexp)
273
+
, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others )
274
+
| Sexp_list, [ sexp ] ->
275
+
( list_of_sexp conv sexp
276
+
, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others )
277
+
| Sexp_array, [ sexp ] ->
278
+
( array_of_sexp conv sexp
279
+
, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others )
280
+
| Sexp_bool, [] ->
281
+
true, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others
282
+
(* malformed field of some kind, dispatch to slow path *)
283
+
| _, _ -> (parse_record_slow [@tailcall false]) ~fields ~index ~extra ~seen sexps)
284
+
(* malformed or out-of-order field, dispatch to slow path *)
285
+
| _ -> (parse_record_slow [@tailcall false]) ~fields ~index ~extra ~seen sexps
286
+
287
+
and[@tail_mod_cons] parse_spine_fast
288
+
: type a.
289
+
fields:a Fields.t
290
+
-> index:(string -> int)
291
+
-> extra:bool
292
+
-> seen:int
293
+
-> Sexp.t list
294
+
-> a
295
+
=
296
+
fun ~fields ~index ~extra ~seen sexps ->
297
+
match fields with
298
+
| Field _ -> parse_field_fast ~fields ~index ~extra ~seen sexps
299
+
| Empty ->
300
+
(match sexps with
301
+
| [] -> ()
302
+
| _ :: _ ->
303
+
(* extra sexps, dispatch to slow path *)
304
+
(parse_record_slow [@tailcall false]) ~fields ~index ~extra ~seen sexps)
305
+
;;
306
+
307
+
let parse_record_fast ~fields ~index ~extra sexps =
308
+
parse_spine_fast ~fields ~index ~extra ~seen:0 sexps
309
+
;;
310
+
311
+
(* Entry points. *)
312
+
313
+
let record_of_sexps
314
+
~caller
315
+
~context
316
+
~fields
317
+
~index_of_field
318
+
~allow_extra_fields
319
+
~create
320
+
sexps
321
+
=
322
+
let allow_extra_fields =
323
+
allow_extra_fields || not (Dynamic.get Sexp_conv.record_check_extra_fields)
324
+
in
325
+
match
326
+
parse_record_fast ~fields ~index:index_of_field ~extra:allow_extra_fields sexps
327
+
with
328
+
| value -> create value
329
+
| exception Malformed malformed -> Malformed.raise malformed ~caller ~context
330
+
;;
331
+
332
+
let record_of_sexp ~caller ~fields ~index_of_field ~allow_extra_fields ~create sexp =
333
+
match (sexp : Sexp.t) with
334
+
| Atom _ as context -> record_list_instead_atom caller context
335
+
| List sexps as context ->
336
+
record_of_sexps
337
+
~caller
338
+
~context
339
+
~fields
340
+
~index_of_field
341
+
~allow_extra_fields
342
+
~create
343
+
sexps
344
+
;;
+56
vendor/opam/sexplib0/src/sexp_conv_record.mli
+56
vendor/opam/sexplib0/src/sexp_conv_record.mli
···
1
+
module Kind : sig
2
+
(** A GADT specifying how to parse a record field. See documentation for
3
+
[ppx_sexp_conv]. *)
4
+
type (_, _) t =
5
+
| Default : 'a. (unit -> 'a) -> (unit -> 'a, Sexp.t -> unit -> 'a) t
6
+
| Omit_nil : 'a. (unit -> 'a, Sexp.t -> unit -> 'a) t
7
+
| Required : 'a. (unit -> 'a, Sexp.t -> unit -> 'a) t
8
+
| Sexp_array : ('a array, Sexp.t -> 'a) t
9
+
| Sexp_bool : (bool, unit) t
10
+
| Sexp_list : ('a list, Sexp.t -> 'a) t
11
+
| Sexp_option : ('a option, Sexp.t -> 'a) t
12
+
| Sexp_or_null : ('a Basement.Or_null_shim.t, Sexp.t -> 'a) t
13
+
end
14
+
15
+
module Fields : sig
16
+
(** A GADT specifying record fields. *)
17
+
18
+
type _ t =
19
+
| Empty : unit t
20
+
| Field :
21
+
'a 'b 'conv.
22
+
{ name : string
23
+
; kind : ('a, 'conv) Kind.t
24
+
; conv : 'conv
25
+
; rest : 'b t
26
+
}
27
+
-> ('a * 'b) t
28
+
end
29
+
30
+
(** Parses a record from a sexp that must be a list of fields.
31
+
32
+
Uses [caller] as the source for error messages. Parses using the given [field]s. Uses
33
+
[index_of_field] to look up field names found in sexps. If [allow_extra_fields] is
34
+
true, extra fields are allowed and discarded without error. [create] is used to
35
+
construct the final returned value. *)
36
+
val record_of_sexp
37
+
: caller:string
38
+
-> fields:'a Fields.t
39
+
-> index_of_field:(string -> int)
40
+
-> allow_extra_fields:bool
41
+
-> create:('a -> 'b)
42
+
-> Sexp.t
43
+
-> 'b
44
+
45
+
(** Like [record_of_sexp], but for a list of sexps with no [List] wrapper. Used, for
46
+
example, to parse arguments to a variant constructor with an inlined record argument.
47
+
Reports [context] for parse errors when no more specific sexp is applicable. *)
48
+
val record_of_sexps
49
+
: caller:string
50
+
-> context:Sexp.t
51
+
-> fields:'a Fields.t
52
+
-> index_of_field:(string -> int)
53
+
-> allow_extra_fields:bool
54
+
-> create:('a -> 'b)
55
+
-> Sexp.t list
56
+
-> 'b
+14
vendor/opam/sexplib0/src/sexp_grammar.ml
+14
vendor/opam/sexplib0/src/sexp_grammar.ml
···
1
+
include Sexp_grammar_intf.Definitions
2
+
3
+
let coerce (type a b) ({ untyped = _ } as t : a t) : b t = t
4
+
5
+
let tag (type a) ({ untyped = grammar } : a t) ~key ~value : a t =
6
+
{ untyped = Tagged { key; value; grammar } }
7
+
;;
8
+
9
+
let doc_comment_tag = "sexp_grammar.doc_comment"
10
+
let type_name_tag = "sexp_grammar.type_name"
11
+
let assoc_tag = "sexp_grammar.assoc"
12
+
let assoc_key_tag = "sexp_grammar.assoc.key"
13
+
let assoc_value_tag = "sexp_grammar.assoc.value"
14
+
let completion_suggested = "sexp_grammar.completion-suggested"
+1
vendor/opam/sexplib0/src/sexp_grammar.mli
+1
vendor/opam/sexplib0/src/sexp_grammar.mli
···
1
+
include Sexp_grammar_intf.Sexp_grammar
+215
vendor/opam/sexplib0/src/sexp_grammar_intf.ml
+215
vendor/opam/sexplib0/src/sexp_grammar_intf.ml
···
1
+
(** Representation of S-expression grammars *)
2
+
3
+
(** This module defines a representation for s-expression grammars. Using ppx_sexp_conv
4
+
and [[@@deriving sexp_grammar]] produces a grammar that is compatible with the derived
5
+
[of_sexp] for a given type.
6
+
7
+
As with other derived definitions, polymorphic types derive a function that takes a
8
+
grammar for each type argument and produces a grammar for the monomorphized type.
9
+
10
+
Monomorphic types derive a grammar directly. To avoid top-level side effects,
11
+
[[@@deriving sexp_grammar]] wraps grammars in the [Lazy] constructor as needed.
12
+
13
+
This type may change over time as our needs for expressive grammars change. We will
14
+
attempt to make changes backward-compatible, or at least provide a reasonable upgrade
15
+
path. *)
16
+
17
+
[@@@warning "-30"] (* allow duplicate field names *)
18
+
19
+
module Definitions = struct
20
+
(** Grammar of a sexp. *)
21
+
type grammar =
22
+
| Any of string (** accepts any sexp; string is a type name for human readability *)
23
+
| Bool (** accepts the atoms "true" or "false", modulo capitalization *)
24
+
| Char (** accepts any single-character atom *)
25
+
| Integer
26
+
(** accepts any atom matching ocaml integer syntax, regardless of bit width *)
27
+
| Float (** accepts any atom matching ocaml float syntax *)
28
+
| String (** accepts any atom *)
29
+
| Option of grammar
30
+
(** accepts an option, both [None] vs [Some _] and [()] vs [(_)]. *)
31
+
| List of list_grammar (** accepts a list *)
32
+
| Variant of variant (** accepts clauses keyed by a leading or sole atom *)
33
+
| Union of grammar list (** accepts a sexp if any of the listed grammars accepts it *)
34
+
| Tagged of grammar with_tag
35
+
(** annotates a grammar with a client-specific key/value pair *)
36
+
| Tyvar of string
37
+
(** Name of a type variable, e.g. [Tyvar "a"] for ['a]. Only meaningful when the body
38
+
of the innermost enclosing [defn] defines a corresponding type variable. *)
39
+
| Tycon of string * grammar list * defn list
40
+
(** Type constructor applied to arguments, and its definition.
41
+
42
+
For example, writing [Tycon ("tree", [ Integer ], defns)] represents [int tree],
43
+
for whatever [tree] is defined as in [defns]. The following defines [tree] as a
44
+
binary tree with the parameter type stored at the leaves.
45
+
46
+
{[
47
+
let defns =
48
+
[ { tycon = "tree"
49
+
; tyvars = [ "a" ]
50
+
; grammar =
51
+
Variant
52
+
{ name_kind = Capitalized
53
+
; clauses =
54
+
[ { name = "Node"
55
+
; args = Cons (Recursive ("node", [ Tyvar "a" ]), Empty)
56
+
}
57
+
; { name = "Leaf"
58
+
; args = Cons (Recursive ("leaf", [ Tyvar "a" ]), Empty)
59
+
}
60
+
]
61
+
}
62
+
}
63
+
; { tycon = "node"
64
+
; tyvars = [ "a" ]
65
+
; grammar = List (Many (Recursive "tree", [ Tyvar "a" ]))
66
+
}
67
+
; { tycon = "leaf"; tyvars = [ "a" ]; grammar = [ Tyvar "a" ] }
68
+
]
69
+
;;
70
+
]}
71
+
72
+
To illustrate the meaning of [Tycon] with respect to [defns], and to demonstrate
73
+
one way to access them, it is equivalent to expand the definition of "tree" one
74
+
level and move the [defns] to enclosed recursive references:
75
+
76
+
{[
77
+
Tycon ("tree", [ Integer ], defns)
78
+
--> Variant
79
+
{ name_kind = Capitalized
80
+
; clauses =
81
+
[ { name = "Node"
82
+
; args = Cons (Tycon ("node", [ Tyvar "a" ], defns), Empty)
83
+
}
84
+
; { name = "Leaf"
85
+
; args = Cons (Tycon ("leaf", [ Tyvar "a" ], defns), Empty)
86
+
}
87
+
]
88
+
}
89
+
]}
90
+
91
+
This transformation exposes the structure of a grammar with recursive references,
92
+
while preserving the meaning of recursively-defined elements. *)
93
+
| Recursive of string * grammar list
94
+
(** Type constructor applied to arguments. Used to denote recursive type references.
95
+
Only meaningful when used inside the [defn]s of a [Tycon] grammar, to refer to a
96
+
type constructor in the nearest enclosing [defn] list. *)
97
+
| Lazy of grammar Basement.Portable_lazy.t
98
+
(** Lazily computed grammar. Use [Lazy] to avoid top-level side effects. To define
99
+
recursive grammars, use [Recursive] instead. *)
100
+
[@@unsafe_allow_any_mode_crossing]
101
+
102
+
(** Grammar of a list of sexps. *)
103
+
and list_grammar =
104
+
| Empty (** accepts an empty list of sexps *)
105
+
| Cons of grammar * list_grammar
106
+
(** accepts a non-empty list with head and tail matching the given grammars *)
107
+
| Many of grammar (** accepts zero or more sexps, each matching the given grammar *)
108
+
| Fields of record (** accepts sexps representing fields of a record *)
109
+
110
+
(** Case sensitivity options for names of variant constructors. *)
111
+
and case_sensitivity =
112
+
| Case_insensitive (** Comparison is case insensitive. Used for custom parsers. *)
113
+
| Case_sensitive (** Comparison is case sensitive. Used for polymorphic variants. *)
114
+
| Case_sensitive_except_first_character
115
+
(** Comparison is case insensitive for the first character and case sensitive
116
+
afterward. Used for regular variants. *)
117
+
118
+
(** Grammar of variants. Accepts any sexp matching one of the clauses. *)
119
+
and variant =
120
+
{ case_sensitivity : case_sensitivity
121
+
; clauses : clause with_tag_list list
122
+
}
123
+
[@@unsafe_allow_any_mode_crossing]
124
+
125
+
(** Grammar of a single variant clause. Accepts sexps based on the [clause_kind]. *)
126
+
and clause =
127
+
{ name : string
128
+
; clause_kind : clause_kind
129
+
}
130
+
131
+
(** Grammar of a single variant clause's contents. [Atom_clause] accepts an atom
132
+
matching the clause's name. [List_clause] accepts a list whose head is an atom
133
+
matching the clause's name and whose tail matches [args]. The clause's name is
134
+
matched modulo the variant's [name_kind]. *)
135
+
and clause_kind =
136
+
| Atom_clause
137
+
| List_clause of { args : list_grammar }
138
+
139
+
(** Grammar of a record. Accepts any list of sexps specifying each of the fields,
140
+
regardless of order. If [allow_extra_fields] is specified, ignores sexps with names
141
+
not found in [fields]. *)
142
+
and record =
143
+
{ allow_extra_fields : bool
144
+
; fields : field with_tag_list list
145
+
}
146
+
147
+
(** Grammar of a record field. A field must show up exactly once in a record if
148
+
[required], or at most once otherwise. Accepts a list headed by [name] as an atom,
149
+
followed by sexps matching [args]. *)
150
+
and field =
151
+
{ name : string
152
+
; required : bool
153
+
; args : list_grammar
154
+
}
155
+
156
+
(** Grammar tagged with client-specific key/value pair. *)
157
+
and 'a with_tag =
158
+
{ key : string
159
+
; value : Sexp.t
160
+
; grammar : 'a
161
+
}
162
+
163
+
and 'a with_tag_list =
164
+
| Tag of 'a with_tag_list with_tag
165
+
| No_tag of 'a
166
+
167
+
(** Grammar of a recursive type definition. Names the [tycon] being defined, and the
168
+
[tyvars] it takes as parameters. Specifies the [grammar] of the [tycon]. The grammar
169
+
may refer to any of the [tyvars], and to any of the [tycon]s from the same set of
170
+
[Recursive] definitions. *)
171
+
and defn =
172
+
{ tycon : string
173
+
; tyvars : string list
174
+
; grammar : grammar
175
+
}
176
+
177
+
(** Top-level grammar type. Has a phantom type parameter to associate each grammar with
178
+
the type its sexps represent. This makes it harder to apply grammars to the wrong
179
+
type, while grammars can still be easily coerced to a new type if needed. *)
180
+
type _ t = { untyped : grammar } [@@unboxed]
181
+
end
182
+
183
+
module type Sexp_grammar = sig
184
+
include module type of struct
185
+
include Definitions
186
+
end
187
+
188
+
(** Convert a sexp grammar for one type to another. *)
189
+
val coerce : 'a 'b. 'a t -> 'b t
190
+
191
+
(** Add a key/value tag to a grammar. *)
192
+
val tag : 'a. 'a t -> key:string -> value:Sexp.t -> 'a t
193
+
194
+
(** This reserved key is used for all tags generated from doc comments. *)
195
+
val doc_comment_tag : string
196
+
197
+
(** This reserved key can be used to associate a type name with a grammar. *)
198
+
val type_name_tag : string
199
+
200
+
(** This reserved key indicates that a sexp represents a key/value association. The
201
+
tag's value is ignored. *)
202
+
val assoc_tag : string
203
+
204
+
(** This reserved key indicates that a sexp is a key in a key/value association. The
205
+
tag's value is ignored. *)
206
+
val assoc_key_tag : string
207
+
208
+
(** This reserved key indicates that a sexp is a value in a key/value association. The
209
+
tag's value is ignored. *)
210
+
val assoc_value_tag : string
211
+
212
+
(** When the key is set to [Atom "false"] for a variant clause, that clause should not
213
+
be suggested in auto-completion based on the sexp grammar. *)
214
+
val completion_suggested : string
215
+
end
+186
vendor/opam/sexplib0/src/sexp_intf.ml
+186
vendor/opam/sexplib0/src/sexp_intf.ml
···
1
+
open Basement
2
+
3
+
module Definitions = struct
4
+
type t =
5
+
| Atom of string
6
+
| List of t list
7
+
8
+
module type Pretty_print_to_formatter = sig
9
+
(** [pp_hum ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human readable
10
+
form. *)
11
+
val pp_hum : Format.formatter -> t -> unit
12
+
13
+
(** [pp_hum_indent n ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human
14
+
readable form and indentation level [n]. *)
15
+
val pp_hum_indent : int -> Format.formatter -> t -> unit
16
+
17
+
(** [pp_mach ppf sexp] outputs S-expression [sexp] to formatter [ppf] in machine
18
+
readable (i.e. most compact) form. *)
19
+
val pp_mach : Format.formatter -> t -> unit
20
+
21
+
(** Same as [pp_mach]. *)
22
+
val pp : Format.formatter -> t -> unit
23
+
end
24
+
25
+
module type Pretty_printing_helpers_private = sig
26
+
(** Functions used by [Make_pretty_printing] *)
27
+
28
+
val mach_maybe_esc_str : string -> string
29
+
val must_escape : string -> bool
30
+
val esc_str : string -> string
31
+
end
32
+
33
+
module type Pretty_printing_helpers = sig
34
+
include Pretty_print_to_formatter (** @inline *)
35
+
36
+
include Pretty_printing_helpers_private (** @inline *)
37
+
end
38
+
39
+
module type Pretty_printing = sig
40
+
(*_ In [Base], this is replaced with [String.Utf8.t] *)
41
+
type output
42
+
43
+
(** {1 Printing to formatters} *)
44
+
45
+
include Pretty_print_to_formatter (** @inline *)
46
+
47
+
(** {1 Conversion to strings} *)
48
+
49
+
(** [to_string_hum ?indent ?max_width sexp] converts S-expression [sexp] to a string
50
+
in human readable form with indentation level [indent] and target maximum width
51
+
[max_width]. Note long atoms may overflow [max_width].
52
+
53
+
@param indent default = [Dynamic.get default_indent]
54
+
@param max_width default = [78] *)
55
+
val to_string_hum : ?indent:int -> ?max_width:int -> t -> output
56
+
57
+
(** [to_string_mach sexp] converts S-expression [sexp] to a string in machine readable
58
+
(i.e. most compact) form. *)
59
+
val to_string_mach : t -> output
60
+
61
+
(** Same as [to_string_mach]. *)
62
+
val to_string : t -> output
63
+
64
+
(** {1 Conversion to buffers} *)
65
+
66
+
(** [to_buffer_hum ~buf ?indent ?max_width sexp] outputs the S-expression [sexp]
67
+
converted to a string in human readable form to buffer [buf] with indentation
68
+
level [indent] and target maximum width [max_width]. Note long atoms may overflow
69
+
[max_width].
70
+
71
+
@param indent default = [Dynamic.get default_indent]
72
+
@param max_width default = [78] *)
73
+
val to_buffer_hum : buf:Buffer.t -> ?indent:int -> ?max_width:int -> t -> unit
74
+
75
+
(** [to_buffer_mach ~buf sexp] outputs the S-expression [sexp] converted to a string
76
+
in machine readable (i.e. most compact) form to buffer [buf]. *)
77
+
val to_buffer_mach : buf:Buffer.t -> t -> unit
78
+
79
+
(** [to_buffer ~buf sexp] same as {!to_buffer_mach}. *)
80
+
val to_buffer : buf:Buffer.t -> t -> unit
81
+
82
+
(** [to_buffer_gen ~buf ~add_char ~add_string sexp] outputs the S-expression [sexp]
83
+
converted to a string to buffer [buf] using the output functions [add_char] and
84
+
[add_string]. *)
85
+
val to_buffer_gen
86
+
: buf:'buffer
87
+
-> add_char:('buffer -> char -> unit)
88
+
-> add_string:('buffer -> string -> unit)
89
+
-> t
90
+
-> unit
91
+
92
+
(*_ See the Jane Street Style Guide for an explanation of [Private] submodules:
93
+
94
+
https://opensource.janestreet.com/standards/#private-submodules *)
95
+
module Pretty_printing_helpers_private : Pretty_printing_helpers_private
96
+
end
97
+
end
98
+
99
+
module type Sexp = sig
100
+
(*_ NOTE: We do not use the [include module type of struct] pattern here as it messes
101
+
with the compiler's short-names heuristics. This should be okay since [Definitions]
102
+
isn't exported from this library.*)
103
+
include module type of Definitions
104
+
105
+
(*_ We don't use [@@deriving sexp] as this would generated references to [Sexplib],
106
+
creating a circular dependency *)
107
+
val t_of_sexp : t -> t
108
+
val sexp_of_t : t -> t
109
+
val sexp_of_t__stack : t -> t
110
+
val equal : t -> t -> bool
111
+
val compare : t -> t -> int
112
+
113
+
(** [Not_found_s] is used by functions that historically raised [Not_found], to allow
114
+
them to raise an exception that contains an informative error message (as a sexp),
115
+
while still having an exception that can be distinguished from other exceptions. *)
116
+
exception Not_found_s of t
117
+
118
+
(** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be
119
+
successfully converted to an OCaml-value. *)
120
+
exception Of_sexp_error of exn * t
121
+
122
+
(** {1 Helpers} *)
123
+
124
+
(** {v
125
+
Helper to build nice s-expressions for error messages. It imitates the behavior of
126
+
[[%message ...]] from the ppx_sexp_message rewriter.
127
+
128
+
[message name key_values] produces a s-expression list starting with atom [name] and
129
+
followed by list of size 2 of the form [(key value)]. When the key is the empty
130
+
string, [value] is used directly instead as for [[%message]].
131
+
132
+
For instance the following code:
133
+
134
+
{[
135
+
Sexp.message "error"
136
+
[ "x", sexp_of_int 42
137
+
; "" , sexp_of_exn Exit
138
+
]
139
+
]}
140
+
141
+
produces the s-expression:
142
+
143
+
{[
144
+
(error (x 42) Exit)
145
+
]}
146
+
v} *)
147
+
val message : string -> (string * t) list -> t
148
+
149
+
(** {1 Defaults} *)
150
+
151
+
(** [default_indent] reference to default indentation level for human-readable
152
+
conversions.
153
+
154
+
Initialisation value: 1. *)
155
+
val default_indent : int Dynamic.t
156
+
157
+
(** {1 Pretty printing of S-expressions} *)
158
+
159
+
module Make_pretty_printing (Helpers : Pretty_printing_helpers) :
160
+
Pretty_printing with type output := string
161
+
162
+
include Pretty_printing with type output := string
163
+
164
+
(** See [Pretty_printing.to_string_mach] and [to_string], respectively. *)
165
+
166
+
val to_string_mach__stack : t -> string
167
+
val to_string__stack : t -> string
168
+
169
+
(** {1 Styles} *)
170
+
171
+
val of_float_style : [ `Underscores | `No_underscores ] Dynamic.t
172
+
val of_int_style : [ `Underscores | `No_underscores ] Dynamic.t
173
+
174
+
(*_ See the Jane Street Style Guide for an explanation of [Private] submodules:
175
+
176
+
https://opensource.janestreet.com/standards/#private-submodules *)
177
+
module Private : sig
178
+
(*_ Exported for sexplib *)
179
+
180
+
val size : t -> int * int
181
+
val buffer : unit -> Buffer.t
182
+
183
+
include Definitions.Pretty_printing_helpers_private
184
+
include Pretty_printing with type output := string
185
+
end
186
+
end
+787
vendor/opam/sexplib0/src/sexpable.ml
+787
vendor/opam/sexplib0/src/sexpable.ml
···
1
+
[@@@expand_inline
2
+
[%%template
3
+
module type Of_sexp = sig
4
+
type t
5
+
6
+
val t_of_sexp : Sexp.t -> t
7
+
end
8
+
9
+
[@@@alloc.default a @ m = (heap @ global, stack @ local)]
10
+
11
+
module type Sexp_of = sig
12
+
type t
13
+
14
+
val sexp_of_t : t -> Sexp.t [@@alloc a @ m = (a @ m, heap @ global)]
15
+
end
16
+
17
+
module type S_any = sig
18
+
type t
19
+
20
+
include Of_sexp with type t := t
21
+
include Sexp_of [@alloc a] with type t := t
22
+
end
23
+
24
+
module type S = sig
25
+
type t
26
+
27
+
include S_any [@alloc a] with type t := t
28
+
end
29
+
30
+
[@@@kind.default ka = (value, any)]
31
+
32
+
module type S_any1 = sig
33
+
type 'a t
34
+
35
+
val t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a t
36
+
37
+
val sexp_of_t : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
38
+
[@@alloc a @ m = (a @ m, heap @ global)]
39
+
end
40
+
41
+
module type S1 = sig
42
+
type 'a t
43
+
44
+
include S_any1 [@kind ka] [@alloc a] with type 'a t := 'a t
45
+
end
46
+
47
+
[@@@kind.default kb = (value, any)]
48
+
49
+
module type S_any2 = sig
50
+
type ('a, 'b) t
51
+
52
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
53
+
54
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
55
+
[@@alloc a @ m = (a @ m, heap @ global)]
56
+
end
57
+
58
+
module type S2 = sig
59
+
type ('a, 'b) t
60
+
61
+
include S_any2 [@kind ka kb] [@alloc a] with type ('a, 'b) t := ('a, 'b) t
62
+
end
63
+
64
+
[@@@kind.default kc = (value, any)]
65
+
66
+
module type S_any3 = sig
67
+
type ('a, 'b, 'c) t
68
+
69
+
val t_of_sexp
70
+
: 'a 'b 'c.
71
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
72
+
73
+
val sexp_of_t
74
+
: 'a 'b 'c.
75
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
76
+
[@@alloc a @ m = (a @ m, heap @ global)]
77
+
end
78
+
79
+
module type S3 = sig
80
+
type ('a, 'b, 'c) t
81
+
82
+
include S_any3 [@kind ka kb kc] [@alloc a] with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
83
+
end]]
84
+
85
+
module type Of_sexp = sig
86
+
type t
87
+
88
+
val t_of_sexp : Sexp.t -> t
89
+
end
90
+
91
+
include struct
92
+
module type Sexp_of = sig
93
+
type t
94
+
95
+
val sexp_of_t : t -> Sexp.t
96
+
end
97
+
98
+
module type S_any = sig
99
+
type t
100
+
101
+
include Of_sexp with type t := t
102
+
include Sexp_of with type t := t
103
+
end
104
+
105
+
module type S = sig
106
+
type t
107
+
108
+
include S_any with type t := t
109
+
end
110
+
111
+
include struct
112
+
module type S_any1 = sig
113
+
type 'a t
114
+
115
+
val t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a t
116
+
val sexp_of_t : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
117
+
end
118
+
119
+
module type S1 = sig
120
+
type 'a t
121
+
122
+
include S_any1 with type 'a t := 'a t
123
+
end
124
+
125
+
include struct
126
+
module type S_any2 = sig
127
+
type ('a, 'b) t
128
+
129
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
130
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
131
+
end
132
+
133
+
module type S2 = sig
134
+
type ('a, 'b) t
135
+
136
+
include S_any2 with type ('a, 'b) t := ('a, 'b) t
137
+
end
138
+
139
+
include struct
140
+
module type S_any3 = sig
141
+
type ('a, 'b, 'c) t
142
+
143
+
val t_of_sexp
144
+
: 'a 'b 'c.
145
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
146
+
147
+
val sexp_of_t
148
+
: 'a 'b 'c.
149
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
150
+
end
151
+
152
+
module type S3 = sig
153
+
type ('a, 'b, 'c) t
154
+
155
+
include S_any3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
156
+
end
157
+
end [@@ocaml.doc " @inline "]
158
+
159
+
include struct
160
+
module type S_any3__value__value__any = sig
161
+
type ('a, 'b, 'c) t
162
+
163
+
val t_of_sexp
164
+
: 'a 'b 'c.
165
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
166
+
167
+
val sexp_of_t
168
+
: 'a 'b 'c.
169
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
170
+
end
171
+
172
+
module type S3__value__value__any = sig
173
+
type ('a, 'b, 'c) t
174
+
175
+
include S_any3__value__value__any with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
176
+
end
177
+
end [@@ocaml.doc " @inline "]
178
+
end [@@ocaml.doc " @inline "]
179
+
180
+
include struct
181
+
module type S_any2__value__any = sig
182
+
type ('a, 'b) t
183
+
184
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
185
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
186
+
end
187
+
188
+
module type S2__value__any = sig
189
+
type ('a, 'b) t
190
+
191
+
include S_any2__value__any with type ('a, 'b) t := ('a, 'b) t
192
+
end
193
+
194
+
include struct
195
+
module type S_any3__value__any__value = sig
196
+
type ('a, 'b, 'c) t
197
+
198
+
val t_of_sexp
199
+
: 'a 'b 'c.
200
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
201
+
202
+
val sexp_of_t
203
+
: 'a 'b 'c.
204
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
205
+
end
206
+
207
+
module type S3__value__any__value = sig
208
+
type ('a, 'b, 'c) t
209
+
210
+
include S_any3__value__any__value with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
211
+
end
212
+
end [@@ocaml.doc " @inline "]
213
+
214
+
include struct
215
+
module type S_any3__value__any__any = sig
216
+
type ('a, 'b, 'c) t
217
+
218
+
val t_of_sexp
219
+
: 'a 'b 'c.
220
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
221
+
222
+
val sexp_of_t
223
+
: 'a 'b 'c.
224
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
225
+
end
226
+
227
+
module type S3__value__any__any = sig
228
+
type ('a, 'b, 'c) t
229
+
230
+
include S_any3__value__any__any with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
231
+
end
232
+
end [@@ocaml.doc " @inline "]
233
+
end [@@ocaml.doc " @inline "]
234
+
end [@@ocaml.doc " @inline "]
235
+
236
+
include struct
237
+
module type S_any1__any = sig
238
+
type 'a t
239
+
240
+
val t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a t
241
+
val sexp_of_t : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
242
+
end
243
+
244
+
module type S1__any = sig
245
+
type 'a t
246
+
247
+
include S_any1__any with type 'a t := 'a t
248
+
end
249
+
250
+
include struct
251
+
module type S_any2__any__value = sig
252
+
type ('a, 'b) t
253
+
254
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
255
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
256
+
end
257
+
258
+
module type S2__any__value = sig
259
+
type ('a, 'b) t
260
+
261
+
include S_any2__any__value with type ('a, 'b) t := ('a, 'b) t
262
+
end
263
+
264
+
include struct
265
+
module type S_any3__any__value__value = sig
266
+
type ('a, 'b, 'c) t
267
+
268
+
val t_of_sexp
269
+
: 'a 'b 'c.
270
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
271
+
272
+
val sexp_of_t
273
+
: 'a 'b 'c.
274
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
275
+
end
276
+
277
+
module type S3__any__value__value = sig
278
+
type ('a, 'b, 'c) t
279
+
280
+
include S_any3__any__value__value with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
281
+
end
282
+
end [@@ocaml.doc " @inline "]
283
+
284
+
include struct
285
+
module type S_any3__any__value__any = sig
286
+
type ('a, 'b, 'c) t
287
+
288
+
val t_of_sexp
289
+
: 'a 'b 'c.
290
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
291
+
292
+
val sexp_of_t
293
+
: 'a 'b 'c.
294
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
295
+
end
296
+
297
+
module type S3__any__value__any = sig
298
+
type ('a, 'b, 'c) t
299
+
300
+
include S_any3__any__value__any with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
301
+
end
302
+
end [@@ocaml.doc " @inline "]
303
+
end [@@ocaml.doc " @inline "]
304
+
305
+
include struct
306
+
module type S_any2__any__any = sig
307
+
type ('a, 'b) t
308
+
309
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
310
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
311
+
end
312
+
313
+
module type S2__any__any = sig
314
+
type ('a, 'b) t
315
+
316
+
include S_any2__any__any with type ('a, 'b) t := ('a, 'b) t
317
+
end
318
+
319
+
include struct
320
+
module type S_any3__any__any__value = sig
321
+
type ('a, 'b, 'c) t
322
+
323
+
val t_of_sexp
324
+
: 'a 'b 'c.
325
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
326
+
327
+
val sexp_of_t
328
+
: 'a 'b 'c.
329
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
330
+
end
331
+
332
+
module type S3__any__any__value = sig
333
+
type ('a, 'b, 'c) t
334
+
335
+
include S_any3__any__any__value with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
336
+
end
337
+
end [@@ocaml.doc " @inline "]
338
+
339
+
include struct
340
+
module type S_any3__any__any__any = sig
341
+
type ('a, 'b, 'c) t
342
+
343
+
val t_of_sexp
344
+
: 'a 'b 'c.
345
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
346
+
347
+
val sexp_of_t
348
+
: 'a 'b 'c.
349
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
350
+
end
351
+
352
+
module type S3__any__any__any = sig
353
+
type ('a, 'b, 'c) t
354
+
355
+
include S_any3__any__any__any with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
356
+
end
357
+
end [@@ocaml.doc " @inline "]
358
+
end [@@ocaml.doc " @inline "]
359
+
end [@@ocaml.doc " @inline "]
360
+
end [@@ocaml.doc " @inline "]
361
+
362
+
include struct
363
+
module type Sexp_of__stack = sig
364
+
type t
365
+
366
+
[@@@ocaml.text "/*"]
367
+
368
+
val sexp_of_t__stack : t -> Sexp.t
369
+
370
+
[@@@ocaml.text "/*"]
371
+
372
+
val sexp_of_t : t -> Sexp.t
373
+
end
374
+
375
+
module type S_any__stack = sig
376
+
type t
377
+
378
+
include Of_sexp with type t := t
379
+
include Sexp_of__stack with type t := t
380
+
end
381
+
382
+
module type S__stack = sig
383
+
type t
384
+
385
+
include S_any__stack with type t := t
386
+
end
387
+
388
+
include struct
389
+
module type S_any1__stack = sig
390
+
type 'a t
391
+
392
+
val t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a t
393
+
394
+
[@@@ocaml.text "/*"]
395
+
396
+
val sexp_of_t__stack : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
397
+
398
+
[@@@ocaml.text "/*"]
399
+
400
+
val sexp_of_t : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
401
+
end
402
+
403
+
module type S1__stack = sig
404
+
type 'a t
405
+
406
+
include S_any1__stack with type 'a t := 'a t
407
+
end
408
+
409
+
include struct
410
+
module type S_any2__stack = sig
411
+
type ('a, 'b) t
412
+
413
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
414
+
415
+
[@@@ocaml.text "/*"]
416
+
417
+
val sexp_of_t__stack
418
+
: 'a 'b.
419
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
420
+
421
+
[@@@ocaml.text "/*"]
422
+
423
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
424
+
end
425
+
426
+
module type S2__stack = sig
427
+
type ('a, 'b) t
428
+
429
+
include S_any2__stack with type ('a, 'b) t := ('a, 'b) t
430
+
end
431
+
432
+
include struct
433
+
module type S_any3__stack = sig
434
+
type ('a, 'b, 'c) t
435
+
436
+
val t_of_sexp
437
+
: 'a 'b 'c.
438
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
439
+
440
+
[@@@ocaml.text "/*"]
441
+
442
+
val sexp_of_t__stack
443
+
: 'a 'b 'c.
444
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
445
+
446
+
[@@@ocaml.text "/*"]
447
+
448
+
val sexp_of_t
449
+
: 'a 'b 'c.
450
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
451
+
end
452
+
453
+
module type S3__stack = sig
454
+
type ('a, 'b, 'c) t
455
+
456
+
include S_any3__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
457
+
end
458
+
end [@@ocaml.doc " @inline "]
459
+
460
+
include struct
461
+
module type S_any3__value__value__any__stack = sig
462
+
type ('a, 'b, 'c) t
463
+
464
+
val t_of_sexp
465
+
: 'a 'b 'c.
466
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
467
+
468
+
[@@@ocaml.text "/*"]
469
+
470
+
val sexp_of_t__stack
471
+
: 'a 'b 'c.
472
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
473
+
474
+
[@@@ocaml.text "/*"]
475
+
476
+
val sexp_of_t
477
+
: 'a 'b 'c.
478
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
479
+
end
480
+
481
+
module type S3__value__value__any__stack = sig
482
+
type ('a, 'b, 'c) t
483
+
484
+
include
485
+
S_any3__value__value__any__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
486
+
end
487
+
end [@@ocaml.doc " @inline "]
488
+
end [@@ocaml.doc " @inline "]
489
+
490
+
include struct
491
+
module type S_any2__value__any__stack = sig
492
+
type ('a, 'b) t
493
+
494
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
495
+
496
+
[@@@ocaml.text "/*"]
497
+
498
+
val sexp_of_t__stack
499
+
: 'a 'b.
500
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
501
+
502
+
[@@@ocaml.text "/*"]
503
+
504
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
505
+
end
506
+
507
+
module type S2__value__any__stack = sig
508
+
type ('a, 'b) t
509
+
510
+
include S_any2__value__any__stack with type ('a, 'b) t := ('a, 'b) t
511
+
end
512
+
513
+
include struct
514
+
module type S_any3__value__any__value__stack = sig
515
+
type ('a, 'b, 'c) t
516
+
517
+
val t_of_sexp
518
+
: 'a 'b 'c.
519
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
520
+
521
+
[@@@ocaml.text "/*"]
522
+
523
+
val sexp_of_t__stack
524
+
: 'a 'b 'c.
525
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
526
+
527
+
[@@@ocaml.text "/*"]
528
+
529
+
val sexp_of_t
530
+
: 'a 'b 'c.
531
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
532
+
end
533
+
534
+
module type S3__value__any__value__stack = sig
535
+
type ('a, 'b, 'c) t
536
+
537
+
include
538
+
S_any3__value__any__value__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
539
+
end
540
+
end [@@ocaml.doc " @inline "]
541
+
542
+
include struct
543
+
module type S_any3__value__any__any__stack = sig
544
+
type ('a, 'b, 'c) t
545
+
546
+
val t_of_sexp
547
+
: 'a 'b 'c.
548
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
549
+
550
+
[@@@ocaml.text "/*"]
551
+
552
+
val sexp_of_t__stack
553
+
: 'a 'b 'c.
554
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
555
+
556
+
[@@@ocaml.text "/*"]
557
+
558
+
val sexp_of_t
559
+
: 'a 'b 'c.
560
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
561
+
end
562
+
563
+
module type S3__value__any__any__stack = sig
564
+
type ('a, 'b, 'c) t
565
+
566
+
include
567
+
S_any3__value__any__any__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
568
+
end
569
+
end [@@ocaml.doc " @inline "]
570
+
end [@@ocaml.doc " @inline "]
571
+
end [@@ocaml.doc " @inline "]
572
+
573
+
include struct
574
+
module type S_any1__any__stack = sig
575
+
type 'a t
576
+
577
+
val t_of_sexp : 'a. (Sexp.t -> 'a) -> Sexp.t -> 'a t
578
+
579
+
[@@@ocaml.text "/*"]
580
+
581
+
val sexp_of_t__stack : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
582
+
583
+
[@@@ocaml.text "/*"]
584
+
585
+
val sexp_of_t : 'a. ('a -> Sexp.t) -> 'a t -> Sexp.t
586
+
end
587
+
588
+
module type S1__any__stack = sig
589
+
type 'a t
590
+
591
+
include S_any1__any__stack with type 'a t := 'a t
592
+
end
593
+
594
+
include struct
595
+
module type S_any2__any__value__stack = sig
596
+
type ('a, 'b) t
597
+
598
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
599
+
600
+
[@@@ocaml.text "/*"]
601
+
602
+
val sexp_of_t__stack
603
+
: 'a 'b.
604
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
605
+
606
+
[@@@ocaml.text "/*"]
607
+
608
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
609
+
end
610
+
611
+
module type S2__any__value__stack = sig
612
+
type ('a, 'b) t
613
+
614
+
include S_any2__any__value__stack with type ('a, 'b) t := ('a, 'b) t
615
+
end
616
+
617
+
include struct
618
+
module type S_any3__any__value__value__stack = sig
619
+
type ('a, 'b, 'c) t
620
+
621
+
val t_of_sexp
622
+
: 'a 'b 'c.
623
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
624
+
625
+
[@@@ocaml.text "/*"]
626
+
627
+
val sexp_of_t__stack
628
+
: 'a 'b 'c.
629
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
630
+
631
+
[@@@ocaml.text "/*"]
632
+
633
+
val sexp_of_t
634
+
: 'a 'b 'c.
635
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
636
+
end
637
+
638
+
module type S3__any__value__value__stack = sig
639
+
type ('a, 'b, 'c) t
640
+
641
+
include
642
+
S_any3__any__value__value__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
643
+
end
644
+
end [@@ocaml.doc " @inline "]
645
+
646
+
include struct
647
+
module type S_any3__any__value__any__stack = sig
648
+
type ('a, 'b, 'c) t
649
+
650
+
val t_of_sexp
651
+
: 'a 'b 'c.
652
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
653
+
654
+
[@@@ocaml.text "/*"]
655
+
656
+
val sexp_of_t__stack
657
+
: 'a 'b 'c.
658
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
659
+
660
+
[@@@ocaml.text "/*"]
661
+
662
+
val sexp_of_t
663
+
: 'a 'b 'c.
664
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
665
+
end
666
+
667
+
module type S3__any__value__any__stack = sig
668
+
type ('a, 'b, 'c) t
669
+
670
+
include
671
+
S_any3__any__value__any__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
672
+
end
673
+
end [@@ocaml.doc " @inline "]
674
+
end [@@ocaml.doc " @inline "]
675
+
676
+
include struct
677
+
module type S_any2__any__any__stack = sig
678
+
type ('a, 'b) t
679
+
680
+
val t_of_sexp : 'a 'b. (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t
681
+
682
+
[@@@ocaml.text "/*"]
683
+
684
+
val sexp_of_t__stack
685
+
: 'a 'b.
686
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
687
+
688
+
[@@@ocaml.text "/*"]
689
+
690
+
val sexp_of_t : 'a 'b. ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t
691
+
end
692
+
693
+
module type S2__any__any__stack = sig
694
+
type ('a, 'b) t
695
+
696
+
include S_any2__any__any__stack with type ('a, 'b) t := ('a, 'b) t
697
+
end
698
+
699
+
include struct
700
+
module type S_any3__any__any__value__stack = sig
701
+
type ('a, 'b, 'c) t
702
+
703
+
val t_of_sexp
704
+
: 'a 'b 'c.
705
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
706
+
707
+
[@@@ocaml.text "/*"]
708
+
709
+
val sexp_of_t__stack
710
+
: 'a 'b 'c.
711
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
712
+
713
+
[@@@ocaml.text "/*"]
714
+
715
+
val sexp_of_t
716
+
: 'a 'b 'c.
717
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
718
+
end
719
+
720
+
module type S3__any__any__value__stack = sig
721
+
type ('a, 'b, 'c) t
722
+
723
+
include
724
+
S_any3__any__any__value__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
725
+
end
726
+
end [@@ocaml.doc " @inline "]
727
+
728
+
include struct
729
+
module type S_any3__any__any__any__stack = sig
730
+
type ('a, 'b, 'c) t
731
+
732
+
val t_of_sexp
733
+
: 'a 'b 'c.
734
+
(Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> ('a, 'b, 'c) t
735
+
736
+
[@@@ocaml.text "/*"]
737
+
738
+
val sexp_of_t__stack
739
+
: 'a 'b 'c.
740
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
741
+
742
+
[@@@ocaml.text "/*"]
743
+
744
+
val sexp_of_t
745
+
: 'a 'b 'c.
746
+
('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('a, 'b, 'c) t -> Sexp.t
747
+
end
748
+
749
+
module type S3__any__any__any__stack = sig
750
+
type ('a, 'b, 'c) t
751
+
752
+
include S_any3__any__any__any__stack with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
753
+
end
754
+
end [@@ocaml.doc " @inline "]
755
+
end [@@ocaml.doc " @inline "]
756
+
end [@@ocaml.doc " @inline "]
757
+
end [@@ocaml.doc " @inline "]
758
+
759
+
[@@@end]
760
+
761
+
module type S_with_grammar = sig
762
+
include S
763
+
764
+
val t_sexp_grammar : t Sexp_grammar.t
765
+
end
766
+
767
+
module type S1_with_grammar = sig
768
+
include S1
769
+
770
+
val t_sexp_grammar : 'a Sexp_grammar.t -> 'a t Sexp_grammar.t
771
+
end
772
+
773
+
module type S2_with_grammar = sig
774
+
include S2
775
+
776
+
val t_sexp_grammar : 'a Sexp_grammar.t -> 'b Sexp_grammar.t -> ('a, 'b) t Sexp_grammar.t
777
+
end
778
+
779
+
module type S3_with_grammar = sig
780
+
include S3
781
+
782
+
val t_sexp_grammar
783
+
: 'a Sexp_grammar.t
784
+
-> 'b Sexp_grammar.t
785
+
-> 'c Sexp_grammar.t
786
+
-> ('a, 'b, 'c) t Sexp_grammar.t
787
+
end
+7
vendor/opam/sexplib0/src/sexplib0.ml
+7
vendor/opam/sexplib0/src/sexplib0.ml
+43
vendor/opam/sexplib0/src/stdlib_stubs.ml
+43
vendor/opam/sexplib0/src/stdlib_stubs.ml
···
1
+
open! StdLabels
2
+
3
+
module Buffer = struct
4
+
include Buffer
5
+
6
+
external magic_global : 'a -> 'b = "%identity"
7
+
8
+
let add_string t str = Buffer.add_string (magic_global t) (magic_global str)
9
+
10
+
let blit src srcoff dst dstoff len =
11
+
Buffer.blit (magic_global src) srcoff (magic_global dst) dstoff len
12
+
;;
13
+
end
14
+
15
+
module Bytes = struct
16
+
include Bytes
17
+
18
+
external create__stack : int -> bytes = "caml_create_bytes"
19
+
external unsafe_set : (bytes[@local_opt]) -> int -> char -> unit = "%bytes_unsafe_set"
20
+
21
+
external unsafe_to_string
22
+
: (bytes[@local_opt])
23
+
-> (string[@local_opt])
24
+
= "%bytes_to_string"
25
+
26
+
external unsafe_blit_string
27
+
: src:(string[@local_opt])
28
+
-> src_pos:int
29
+
-> dst:(bytes[@local_opt])
30
+
-> dst_pos:int
31
+
-> len:int
32
+
-> unit
33
+
= "caml_blit_string"
34
+
[@@noalloc]
35
+
end
36
+
37
+
module String = struct
38
+
include String
39
+
40
+
external length : (string[@local_opt]) -> int = "%string_length"
41
+
external get : (string[@local_opt]) -> int -> char = "%string_safe_get"
42
+
external unsafe_get : (string[@local_opt]) -> int -> char = "%string_unsafe_get"
43
+
end
+44
vendor/opam/sexplib0/src/stdlib_stubs.mli
+44
vendor/opam/sexplib0/src/stdlib_stubs.mli
···
1
+
open! StdLabels
2
+
3
+
module Buffer : sig
4
+
include module type of struct
5
+
include Buffer
6
+
end
7
+
8
+
val add_string : t -> string -> unit
9
+
val blit : t -> int -> bytes -> int -> int -> unit
10
+
end
11
+
12
+
module Bytes : sig
13
+
include module type of struct
14
+
include Bytes
15
+
end
16
+
17
+
external create__stack : int -> bytes = "caml_create_bytes"
18
+
external unsafe_set : (bytes[@local_opt]) -> int -> char -> unit = "%bytes_unsafe_set"
19
+
20
+
external unsafe_to_string
21
+
: (bytes[@local_opt])
22
+
-> (string[@local_opt])
23
+
= "%bytes_to_string"
24
+
25
+
external unsafe_blit_string
26
+
: src:(string[@local_opt])
27
+
-> src_pos:int
28
+
-> dst:(bytes[@local_opt])
29
+
-> dst_pos:int
30
+
-> len:int
31
+
-> unit
32
+
= "caml_blit_string"
33
+
[@@noalloc]
34
+
end
35
+
36
+
module String : sig
37
+
include module type of struct
38
+
include String
39
+
end
40
+
41
+
external length : (string[@local_opt]) -> int = "%string_length"
42
+
external get : (string[@local_opt]) -> int -> char = "%string_safe_get"
43
+
external unsafe_get : (string[@local_opt]) -> int -> char = "%string_unsafe_get"
44
+
end
+7
vendor/opam/sexplib0/test/dune
+7
vendor/opam/sexplib0/test/dune
+645
vendor/opam/sexplib0/test/sexplib0_test.ml
+645
vendor/opam/sexplib0/test/sexplib0_test.ml
···
1
+
open! Base
2
+
open Expect_test_helpers_base
3
+
open Sexplib0
4
+
5
+
let () = Dynamic.set_root sexp_style Sexp_style.simple_pretty
6
+
7
+
module type S = sig
8
+
type t [@@deriving equal, sexp]
9
+
end
10
+
11
+
let test (type a) (module M : S with type t = a) string =
12
+
let sexp = Parsexp.Single.parse_string_exn string in
13
+
let result = Or_error.try_with (fun () -> M.t_of_sexp sexp) in
14
+
print_s [%sexp (result : M.t Or_error.t)]
15
+
;;
16
+
17
+
let const x () = x
18
+
let thunk f x = const (f x)
19
+
20
+
let%expect_test "simple record" =
21
+
let module M = struct
22
+
type t =
23
+
{ x : int
24
+
; y : int
25
+
}
26
+
[@@deriving equal, sexp_of]
27
+
28
+
let t_of_sexp sexp =
29
+
Sexp_conv_record.record_of_sexp
30
+
sexp
31
+
~caller:"M.t"
32
+
~fields:
33
+
(Field
34
+
{ name = "x"
35
+
; kind = Required
36
+
; conv = thunk int_of_sexp
37
+
; rest =
38
+
Field
39
+
{ name = "y"; kind = Required; conv = thunk int_of_sexp; rest = Empty }
40
+
})
41
+
~index_of_field:(function
42
+
| "x" -> 0
43
+
| "y" -> 1
44
+
| _ -> -1)
45
+
~allow_extra_fields:false
46
+
~create:(fun (x, (y, ())) -> { x = x (); y = y () })
47
+
;;
48
+
end
49
+
in
50
+
let test = test (module M) in
51
+
(* in order *)
52
+
test "((x 1) (y 2))";
53
+
[%expect {| (Ok ((x 1) (y 2))) |}];
54
+
(* reverse order *)
55
+
test "((y 2) (x 1))";
56
+
[%expect {| (Ok ((x 1) (y 2))) |}];
57
+
(* duplicate fields *)
58
+
test "((x 1) (x 2) (y 3) (y 4))";
59
+
[%expect
60
+
{|
61
+
(Error
62
+
(Of_sexp_error
63
+
"M.t_of_sexp: duplicate fields: x y"
64
+
(invalid_sexp ((x 1) (x 2) (y 3) (y 4)))))
65
+
|}];
66
+
(* extra fields *)
67
+
test "((a 1) (b 2) (c 3))";
68
+
[%expect
69
+
{|
70
+
(Error
71
+
(Of_sexp_error
72
+
"M.t_of_sexp: extra fields found while some fields missing; extra fields: a b c; missing fields: x y"
73
+
(invalid_sexp ((a 1) (b 2) (c 3)))))
74
+
|}];
75
+
(* missing field *)
76
+
test "((x 1))";
77
+
[%expect
78
+
{|
79
+
(Error
80
+
(Of_sexp_error "M.t_of_sexp: missing fields: y" (invalid_sexp ((x 1)))))
81
+
|}];
82
+
(* other missing field *)
83
+
test "((y 2))";
84
+
[%expect
85
+
{|
86
+
(Error
87
+
(Of_sexp_error "M.t_of_sexp: missing fields: x" (invalid_sexp ((y 2)))))
88
+
|}];
89
+
(* multiple missing fields *)
90
+
test "()";
91
+
[%expect
92
+
{| (Error (Of_sexp_error "M.t_of_sexp: missing fields: x y" (invalid_sexp ()))) |}];
93
+
()
94
+
;;
95
+
96
+
let%expect_test "record with extra fields" =
97
+
let module M = struct
98
+
type t =
99
+
{ x : int
100
+
; y : int
101
+
}
102
+
[@@deriving equal, sexp_of]
103
+
104
+
let t_of_sexp =
105
+
Sexp_conv_record.record_of_sexp
106
+
~caller:"M.t"
107
+
~fields:
108
+
(Field
109
+
{ name = "x"
110
+
; kind = Required
111
+
; conv = thunk int_of_sexp
112
+
; rest =
113
+
Field
114
+
{ name = "y"; kind = Required; conv = thunk int_of_sexp; rest = Empty }
115
+
})
116
+
~index_of_field:(function
117
+
| "x" -> 0
118
+
| "y" -> 1
119
+
| _ -> -1)
120
+
~allow_extra_fields:true
121
+
~create:(fun (x, (y, ())) -> { x = x (); y = y () })
122
+
;;
123
+
end
124
+
in
125
+
let test = test (module M) in
126
+
(* in order *)
127
+
test "((x 1) (y 2))";
128
+
[%expect {| (Ok ((x 1) (y 2))) |}];
129
+
(* reversed order *)
130
+
test "((y 2) (x 1))";
131
+
[%expect {| (Ok ((x 1) (y 2))) |}];
132
+
(* extra field *)
133
+
test "((x 1) (y 2) (z 3))";
134
+
[%expect {| (Ok ((x 1) (y 2))) |}];
135
+
(* missing field *)
136
+
test "((x 1))";
137
+
[%expect
138
+
{|
139
+
(Error
140
+
(Of_sexp_error "M.t_of_sexp: missing fields: y" (invalid_sexp ((x 1)))))
141
+
|}];
142
+
(* other missing field *)
143
+
test "((y 2))";
144
+
[%expect
145
+
{|
146
+
(Error
147
+
(Of_sexp_error "M.t_of_sexp: missing fields: x" (invalid_sexp ((y 2)))))
148
+
|}];
149
+
(* multiple missing fields *)
150
+
test "()";
151
+
[%expect
152
+
{| (Error (Of_sexp_error "M.t_of_sexp: missing fields: x y" (invalid_sexp ()))) |}];
153
+
()
154
+
;;
155
+
156
+
let%expect_test "record with defaults" =
157
+
let module M = struct
158
+
type t =
159
+
{ x : int
160
+
; y : int
161
+
}
162
+
[@@deriving equal, sexp_of]
163
+
164
+
let t_of_sexp =
165
+
Sexp_conv_record.record_of_sexp
166
+
~caller:"M.t"
167
+
~fields:
168
+
(Field
169
+
{ name = "x"
170
+
; kind = Default (fun () -> 0)
171
+
; conv = thunk int_of_sexp
172
+
; rest =
173
+
Field
174
+
{ name = "y"
175
+
; kind = Default (fun () -> 0)
176
+
; conv = thunk int_of_sexp
177
+
; rest = Empty
178
+
}
179
+
})
180
+
~index_of_field:(function
181
+
| "x" -> 0
182
+
| "y" -> 1
183
+
| _ -> -1)
184
+
~allow_extra_fields:false
185
+
~create:(fun (x, (y, ())) -> { x = x (); y = y () })
186
+
;;
187
+
end
188
+
in
189
+
let test = test (module M) in
190
+
(* in order *)
191
+
test "((x 1) (y 2))";
192
+
[%expect {| (Ok ((x 1) (y 2))) |}];
193
+
(* reverse order *)
194
+
test "((y 2) (x 1))";
195
+
[%expect {| (Ok ((x 1) (y 2))) |}];
196
+
(* extra field *)
197
+
test "((x 1) (y 2) (z 3))";
198
+
[%expect
199
+
{|
200
+
(Error
201
+
(Of_sexp_error
202
+
"M.t_of_sexp: extra fields: z"
203
+
(invalid_sexp ((x 1) (y 2) (z 3)))))
204
+
|}];
205
+
(* missing field *)
206
+
test "((x 1))";
207
+
[%expect {| (Ok ((x 1) (y 0))) |}];
208
+
(* other missing field *)
209
+
test "((y 2))";
210
+
[%expect {| (Ok ((x 0) (y 2))) |}];
211
+
(* multiple missing fields *)
212
+
test "()";
213
+
[%expect {| (Ok ((x 0) (y 0))) |}];
214
+
()
215
+
;;
216
+
217
+
let%expect_test "record with omit nil" =
218
+
let module M = struct
219
+
type t =
220
+
{ a : int option
221
+
; b : int list
222
+
}
223
+
[@@deriving equal, sexp_of]
224
+
225
+
let t_of_sexp =
226
+
Sexp_conv_record.record_of_sexp
227
+
~caller:"M.t"
228
+
~fields:
229
+
(Field
230
+
{ name = "a"
231
+
; kind = Omit_nil
232
+
; conv = thunk (option_of_sexp int_of_sexp)
233
+
; rest =
234
+
Field
235
+
{ name = "b"
236
+
; kind = Omit_nil
237
+
; conv = thunk (list_of_sexp int_of_sexp)
238
+
; rest = Empty
239
+
}
240
+
})
241
+
~index_of_field:(function
242
+
| "a" -> 0
243
+
| "b" -> 1
244
+
| _ -> -1)
245
+
~allow_extra_fields:false
246
+
~create:(fun (a, (b, ())) -> { a = a (); b = b () })
247
+
;;
248
+
end
249
+
in
250
+
let test = test (module M) in
251
+
(* in order *)
252
+
test "((a (1)) (b (2 3)))";
253
+
[%expect {| (Ok ((a (1)) (b (2 3)))) |}];
254
+
(* reverse order *)
255
+
test "((b ()) (a ()))";
256
+
[%expect {| (Ok ((a ()) (b ()))) |}];
257
+
(* extra field *)
258
+
test "((a (1)) (b (2 3)) (z ()))";
259
+
[%expect
260
+
{|
261
+
(Error
262
+
(Of_sexp_error
263
+
"M.t_of_sexp: extra fields: z"
264
+
(invalid_sexp ((a (1)) (b (2 3)) (z ())))))
265
+
|}];
266
+
(* missing field *)
267
+
test "((a (1)))";
268
+
[%expect {| (Ok ((a (1)) (b ()))) |}];
269
+
(* other missing field *)
270
+
test "((b (2 3)))";
271
+
[%expect {| (Ok ((a ()) (b (2 3)))) |}];
272
+
(* multiple missing fields *)
273
+
test "()";
274
+
[%expect {| (Ok ((a ()) (b ()))) |}];
275
+
()
276
+
;;
277
+
278
+
let%expect_test "record with sexp types" =
279
+
let module M = struct
280
+
type t =
281
+
{ a : int option
282
+
; b : int list
283
+
; c : int array
284
+
; d : bool
285
+
; e : int Or_null.t
286
+
}
287
+
[@@deriving equal, sexp_of]
288
+
289
+
let t_of_sexp =
290
+
Sexp_conv_record.record_of_sexp
291
+
~caller:"M.t"
292
+
~fields:
293
+
(Field
294
+
{ name = "a"
295
+
; kind = Sexp_option
296
+
; conv = int_of_sexp
297
+
; rest =
298
+
Field
299
+
{ name = "b"
300
+
; kind = Sexp_list
301
+
; conv = int_of_sexp
302
+
; rest =
303
+
Field
304
+
{ name = "c"
305
+
; kind = Sexp_array
306
+
; conv = int_of_sexp
307
+
; rest =
308
+
Field
309
+
{ name = "d"
310
+
; kind = Sexp_bool
311
+
; conv = ()
312
+
; rest =
313
+
Field
314
+
{ name = "e"
315
+
; kind = Sexp_or_null
316
+
; conv = int_of_sexp
317
+
; rest = Empty
318
+
}
319
+
}
320
+
}
321
+
}
322
+
})
323
+
~index_of_field:(function
324
+
| "a" -> 0
325
+
| "b" -> 1
326
+
| "c" -> 2
327
+
| "d" -> 3
328
+
| "e" -> 4
329
+
| _ -> -1)
330
+
~allow_extra_fields:false
331
+
~create:(fun (a, (b, (c, (d, (e, ()))))) -> { a; b; c; d; e })
332
+
;;
333
+
end
334
+
in
335
+
let test = test (module M) in
336
+
(* in order *)
337
+
test "((a 1) (b (2 3)) (c (4 5)) (d))";
338
+
[%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d true) (e ()))) |}];
339
+
(* reverse order *)
340
+
test "((d) (c ()) (b ()) (a 1))";
341
+
[%expect {| (Ok ((a (1)) (b ()) (c ()) (d true) (e ()))) |}];
342
+
(* missing field d *)
343
+
test "((a 1) (b (2 3)) (c (4 5)))";
344
+
[%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d false) (e ()))) |}];
345
+
(* missing field c *)
346
+
test "((a 1) (b (2 3)) (d))";
347
+
[%expect {| (Ok ((a (1)) (b (2 3)) (c ()) (d true) (e ()))) |}];
348
+
(* missing field b *)
349
+
test "((a 1) (c (2 3)) (d))";
350
+
[%expect {| (Ok ((a (1)) (b ()) (c (2 3)) (d true) (e ()))) |}];
351
+
(* missing field a *)
352
+
test "((b (1 2)) (c (3 4)) (d))";
353
+
[%expect {| (Ok ((a ()) (b (1 2)) (c (3 4)) (d true) (e ()))) |}];
354
+
(* extra field *)
355
+
test "((a 1) (b (2 3)) (c (4 5)) (d) (e 6) (f (7 8)))";
356
+
[%expect
357
+
{|
358
+
(Error
359
+
(Of_sexp_error
360
+
"M.t_of_sexp: extra fields: f"
361
+
(invalid_sexp ((a 1) (b (2 3)) (c (4 5)) (d) (e 6) (f (7 8))))))
362
+
|}];
363
+
(* all fields missing *)
364
+
test "()";
365
+
[%expect {| (Ok ((a ()) (b ()) (c ()) (d false) (e ()))) |}];
366
+
()
367
+
;;
368
+
369
+
let%expect_test "record with polymorphic fields" =
370
+
let module M = struct
371
+
type t =
372
+
{ a : 'a. 'a list
373
+
; b : 'a 'b. ('a, 'b) Result.t option
374
+
}
375
+
[@@deriving sexp_of]
376
+
377
+
let equal = Poly.equal
378
+
379
+
type a = { a : 'a. 'a list } [@@unboxed]
380
+
type b = { b : 'a 'b. ('a, 'b) Result.t option } [@@unboxed]
381
+
382
+
let t_of_sexp =
383
+
let caller = "M.t" in
384
+
Sexp_conv_record.record_of_sexp
385
+
~caller
386
+
~fields:
387
+
(Field
388
+
{ name = "a"
389
+
; kind = Required
390
+
; conv =
391
+
thunk (fun sexp ->
392
+
{ a =
393
+
list_of_sexp
394
+
(Sexplib.Conv_error.record_poly_field_value caller)
395
+
sexp
396
+
})
397
+
; rest =
398
+
Field
399
+
{ name = "b"
400
+
; kind = Required
401
+
; conv =
402
+
thunk (fun sexp ->
403
+
{ b =
404
+
Option.t_of_sexp
405
+
(Result.t_of_sexp
406
+
(Sexplib.Conv_error.record_poly_field_value caller)
407
+
(Sexplib.Conv_error.record_poly_field_value caller))
408
+
sexp
409
+
})
410
+
; rest = Empty
411
+
}
412
+
})
413
+
~index_of_field:(function
414
+
| "a" -> 0
415
+
| "b" -> 1
416
+
| _ -> -1)
417
+
~allow_extra_fields:false
418
+
~create:(fun (a, (b, ())) ->
419
+
let { a } = a ()
420
+
and { b } = b () in
421
+
{ a; b })
422
+
;;
423
+
end
424
+
in
425
+
let test = test (module M) in
426
+
(* in order *)
427
+
test "((a ()) (b ()))";
428
+
[%expect {| (Ok ((a ()) (b ()))) |}];
429
+
(* reverse order *)
430
+
test "((b ()) (a ()))";
431
+
[%expect {| (Ok ((a ()) (b ()))) |}];
432
+
(* attempt to deserialize paramter to [a] *)
433
+
test "((a (_)) (b ()))";
434
+
[%expect
435
+
{|
436
+
(Error
437
+
(Of_sexp_error
438
+
"M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields"
439
+
(invalid_sexp _)))
440
+
|}];
441
+
(* attempt to deserialize first parameter to [b] *)
442
+
test "((a ()) (b ((Ok _))))";
443
+
[%expect
444
+
{|
445
+
(Error
446
+
(Of_sexp_error
447
+
"M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields"
448
+
(invalid_sexp _)))
449
+
|}];
450
+
(* attempt to deserialize second parameter to [b] *)
451
+
test "((a ()) (b ((Error _))))";
452
+
[%expect
453
+
{|
454
+
(Error
455
+
(Of_sexp_error
456
+
"M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields"
457
+
(invalid_sexp _)))
458
+
|}];
459
+
(* multiple missing fields *)
460
+
test "()";
461
+
[%expect
462
+
{| (Error (Of_sexp_error "M.t_of_sexp: missing fields: a b" (invalid_sexp ()))) |}];
463
+
()
464
+
;;
465
+
466
+
let%expect_test "Show effect of setting indent/max width for to_string_hum" =
467
+
let sexp : Sexp.t =
468
+
List
469
+
[ List (List.init 40 ~f:(fun n -> Sexp.Atom ("atom-" ^ Int.to_string n)))
470
+
; Atom "a-very-very-very-very-very-very-very-very-very-long-atom"
471
+
]
472
+
in
473
+
let case ~indent ~max_width =
474
+
print_endline (String.make max_width '-');
475
+
print_endline (Sexp.to_string_hum ~indent ~max_width sexp)
476
+
in
477
+
case ~indent:1 ~max_width:78;
478
+
[%expect
479
+
{|
480
+
------------------------------------------------------------------------------
481
+
((atom-0 atom-1 atom-2 atom-3 atom-4 atom-5 atom-6 atom-7 atom-8 atom-9
482
+
atom-10 atom-11 atom-12 atom-13 atom-14 atom-15 atom-16 atom-17 atom-18
483
+
atom-19 atom-20 atom-21 atom-22 atom-23 atom-24 atom-25 atom-26 atom-27
484
+
atom-28 atom-29 atom-30 atom-31 atom-32 atom-33 atom-34 atom-35 atom-36
485
+
atom-37 atom-38 atom-39)
486
+
a-very-very-very-very-very-very-very-very-very-long-atom)
487
+
|}];
488
+
case ~indent:4 ~max_width:50;
489
+
[%expect
490
+
{|
491
+
--------------------------------------------------
492
+
((atom-0 atom-1 atom-2 atom-3 atom-4 atom-5
493
+
atom-6 atom-7 atom-8 atom-9 atom-10 atom-11
494
+
atom-12 atom-13 atom-14 atom-15 atom-16
495
+
atom-17 atom-18 atom-19 atom-20 atom-21
496
+
atom-22 atom-23 atom-24 atom-25 atom-26
497
+
atom-27 atom-28 atom-29 atom-30 atom-31
498
+
atom-32 atom-33 atom-34 atom-35 atom-36
499
+
atom-37 atom-38 atom-39)
500
+
a-very-very-very-very-very-very-very-very-very-long-atom)
501
+
|}];
502
+
case ~indent:1 ~max_width:20;
503
+
[%expect
504
+
{|
505
+
--------------------
506
+
((atom-0 atom-1
507
+
atom-2 atom-3
508
+
atom-4 atom-5
509
+
atom-6 atom-7
510
+
atom-8 atom-9
511
+
atom-10 atom-11
512
+
atom-12 atom-13
513
+
atom-14 atom-15
514
+
atom-16 atom-17
515
+
atom-18 atom-19
516
+
atom-20 atom-21
517
+
atom-22 atom-23
518
+
atom-24 atom-25
519
+
atom-26 atom-27
520
+
atom-28 atom-29
521
+
atom-30 atom-31
522
+
atom-32 atom-33
523
+
atom-34 atom-35
524
+
atom-36 atom-37
525
+
atom-38 atom-39)
526
+
a-very-very-very-very-very-very-very-very-very-long-atom)
527
+
|}]
528
+
;;
529
+
530
+
[%%template
531
+
[@@@alloc.default a = (stack, heap)]
532
+
533
+
let%expect_test _ =
534
+
let big_string = String.init 5_000_000 ~f:(fun i -> String.get (Int.to_string i) 0) in
535
+
let sexp = [%sexp (big_string : string)] [@alloc a] in
536
+
let sexp_string =
537
+
(* In an experimental compiler version, this would overflow the stack. *)
538
+
(Sexp.to_string [@alloc a]) sexp
539
+
in
540
+
print_endline (Int.to_string_hum (String.length sexp_string));
541
+
[%expect {| 5_000_000 |}]
542
+
;;]
543
+
544
+
let%expect_test "simple [to_string__stack] test" =
545
+
let sexp : Sexp.t =
546
+
List [ Atom "atom-at-0"; List [ Atom "atom-at-1-a"; Atom "atom-at-1-b" ] ]
547
+
in
548
+
let print_local s = s |> String.globalize |> print_endline in
549
+
(Sexp.to_string [@alloc stack]) sexp |> print_local;
550
+
[%expect {| (atom-at-0(atom-at-1-a atom-at-1-b)) |}];
551
+
(Sexp.to_string_mach [@alloc stack]) sexp |> print_local;
552
+
[%expect {| (atom-at-0(atom-at-1-a atom-at-1-b)) |}]
553
+
;;
554
+
555
+
let%expect_test _ =
556
+
Base_quickcheck.Test.run_exn
557
+
(module struct
558
+
include Sexp
559
+
560
+
let quickcheck_generator = Base_quickcheck.Generator.sexp
561
+
let quickcheck_shrinker = Base_quickcheck.Shrinker.sexp
562
+
end)
563
+
~f:(fun sexp ->
564
+
let str = Sexp.to_string sexp in
565
+
let stack_allocated_str =
566
+
(Sexp.to_string [@alloc stack]) sexp |> String.globalize
567
+
in
568
+
require_equal (module String) str stack_allocated_str;
569
+
let str_mach = Sexp.to_string_mach sexp in
570
+
let stack_allocated_str_mach =
571
+
(Sexp.to_string_mach [@alloc stack]) sexp |> String.globalize
572
+
in
573
+
require_equal (module String) str_mach stack_allocated_str_mach)
574
+
;;
575
+
576
+
(* Assert that the module types defined by sexplib0 are equivalent to those derived by
577
+
ppx_sexp_conv. *)
578
+
module _ = struct
579
+
module type S = sig
580
+
type t [@@deriving sexp]
581
+
end
582
+
583
+
module type S1 = sig
584
+
type 'a t [@@deriving sexp]
585
+
end
586
+
587
+
module type S2 = sig
588
+
type ('a, 'b) t [@@deriving sexp]
589
+
end
590
+
591
+
module type S3 = sig
592
+
type ('a, 'b, 'c) t [@@deriving sexp]
593
+
end
594
+
595
+
module type S_with_grammar = sig
596
+
type t [@@deriving sexp, sexp_grammar]
597
+
end
598
+
599
+
module type S1_with_grammar = sig
600
+
type 'a t [@@deriving sexp, sexp_grammar]
601
+
end
602
+
603
+
module type S2_with_grammar = sig
604
+
type ('a, 'b) t [@@deriving sexp, sexp_grammar]
605
+
end
606
+
607
+
module type S3_with_grammar = sig
608
+
type ('a, 'b, 'c) t [@@deriving sexp, sexp_grammar]
609
+
end
610
+
611
+
let (T : ((module Sexpable.S), (module S)) Type_equal.t) = T
612
+
let (T : ((module Sexpable.S1), (module S1)) Type_equal.t) = T
613
+
let (T : ((module Sexpable.S2), (module S2)) Type_equal.t) = T
614
+
let (T : ((module Sexpable.S3), (module S3)) Type_equal.t) = T
615
+
let (T : ((module Sexpable.S_with_grammar), (module S_with_grammar)) Type_equal.t) = T
616
+
let (T : ((module Sexpable.S1_with_grammar), (module S1_with_grammar)) Type_equal.t) = T
617
+
let (T : ((module Sexpable.S2_with_grammar), (module S2_with_grammar)) Type_equal.t) = T
618
+
let (T : ((module Sexpable.S3_with_grammar), (module S3_with_grammar)) Type_equal.t) = T
619
+
end
620
+
621
+
module%test Illegal_chars = struct
622
+
(* Test [sexp_of_char] against the naive implementation that dynamically creates the
623
+
length-1 string. The focus of this test is on illegal representations: immediates
624
+
that lie outside the range representable by [char] *)
625
+
626
+
let[@inline never] sexp_of_char' (char : char) : Sexp.t =
627
+
Atom ((String.make [@inlined never]) 1 char)
628
+
;;
629
+
630
+
let test_at ~start ~num_tests =
631
+
List.init num_tests ~f:(( + ) start)
632
+
|> List.iter ~f:(fun (c : int) ->
633
+
let c : char = Stdlib.Obj.magic c in
634
+
Expect_test_helpers_base.require_equal
635
+
(module Sexp)
636
+
(sexp_of_char c)
637
+
(sexp_of_char' c))
638
+
;;
639
+
640
+
let%expect_test _ =
641
+
test_at ~start:Int.min_value ~num_tests:0x10000;
642
+
test_at ~start:(-0x10000) ~num_tests:0x20000;
643
+
test_at ~start:(Int.max_value - 0xFFFF) ~num_tests:0x10000
644
+
;;
645
+
end
+1
vendor/opam/sexplib0/test/sexplib0_test.mli
+1
vendor/opam/sexplib0/test/sexplib0_test.mli
···
1
+
(*_ This signature is deliberately empty. *)