├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── bench ├── bench_record.ml ├── bench_record.mli ├── dune └── sexplib0_bench.ml ├── dune-project ├── sexplib0.opam ├── src ├── dune ├── sexp.ml ├── sexp.mli ├── sexp_conv.ml ├── sexp_conv.mli ├── sexp_conv_error.ml ├── sexp_conv_error.mli ├── sexp_conv_grammar.ml ├── sexp_conv_grammar.mli ├── sexp_conv_labeled_tuple.ml ├── sexp_conv_labeled_tuple.mli ├── sexp_conv_record.ml ├── sexp_conv_record.mli ├── sexp_grammar.ml ├── sexp_grammar.mli ├── sexp_grammar_intf.ml ├── sexpable.ml └── sexplib0.ml └── test ├── dune ├── sexplib0_test.ml └── sexplib0_test.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /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`. 19 | -------------------------------------------------------------------------------- /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 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/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2005--2025 Jane Street Group, LLC 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. 22 | -------------------------------------------------------------------------------- /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 18 | -------------------------------------------------------------------------------- /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. 10 | -------------------------------------------------------------------------------- /bench/bench_record.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0.Sexp_conv 2 | 3 | let bench_t_of_sexp ~t_of_sexp string = 4 | let sexp = Sys.opaque_identity (Parsexp.Single.parse_string_exn string) in 5 | fun () -> t_of_sexp sexp 6 | ;; 7 | 8 | type t = 9 | { a : int 10 | ; b : int option 11 | ; c : bool 12 | ; d : int array 13 | ; e : int list 14 | ; f : int option 15 | ; g : int 16 | ; h : 'a. 'a list 17 | } 18 | 19 | let t_of_sexp = 20 | let open struct 21 | type poly = { h : 'a. 'a list } [@@unboxed] 22 | end in 23 | Sexplib0.Sexp_conv_record.record_of_sexp 24 | ~caller:"Record.t" 25 | ~fields: 26 | (Field 27 | { name = "a" 28 | ; kind = Required 29 | ; conv = int_of_sexp 30 | ; layout = Value 31 | ; rest = 32 | Field 33 | { name = "b" 34 | ; kind = Omit_nil 35 | ; conv = option_of_sexp int_of_sexp 36 | ; layout = Value 37 | ; rest = 38 | Field 39 | { name = "c" 40 | ; kind = Sexp_bool 41 | ; conv = () 42 | ; layout = Value 43 | ; rest = 44 | Field 45 | { name = "d" 46 | ; kind = Sexp_array 47 | ; conv = int_of_sexp 48 | ; layout = Value 49 | ; rest = 50 | Field 51 | { name = "e" 52 | ; kind = Sexp_list 53 | ; conv = int_of_sexp 54 | ; layout = Value 55 | ; rest = 56 | Field 57 | { name = "f" 58 | ; kind = Sexp_option 59 | ; conv = int_of_sexp 60 | ; layout = Value 61 | ; rest = 62 | Field 63 | { name = "g" 64 | ; kind = Default (fun () -> 0) 65 | ; conv = int_of_sexp 66 | ; layout = Value 67 | ; rest = 68 | Field 69 | { name = "h" 70 | ; kind = Required 71 | ; layout = Value 72 | ; conv = 73 | (fun sexp -> 74 | { h = 75 | list_of_sexp 76 | (Sexplib0.Sexp_conv_error 77 | .record_poly_field_value 78 | "Record.t") 79 | sexp 80 | }) 81 | ; rest = Empty 82 | } 83 | } 84 | } 85 | } 86 | } 87 | } 88 | } 89 | }) 90 | ~index_of_field:(function 91 | | "a" -> 0 92 | | "b" -> 1 93 | | "c" -> 2 94 | | "d" -> 3 95 | | "e" -> 4 96 | | "f" -> 5 97 | | "g" -> 6 98 | | "h" -> 7 99 | | _ -> -1) 100 | ~allow_extra_fields:false 101 | ~create:(fun (a, (b, (c, (d, (e, (f, (g, ({ h }, ())))))))) -> 102 | { a; b; c; d; e; f; g; h }) 103 | ;; 104 | 105 | let%bench_fun "t_of_sexp, full, in order" = 106 | bench_t_of_sexp ~t_of_sexp "((a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h ()))" 107 | ;; 108 | 109 | let%bench_fun "t_of_sexp, full, reverse order" = 110 | bench_t_of_sexp ~t_of_sexp "((h ()) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) (a 1))" 111 | ;; 112 | 113 | let%bench_fun "t_of_sexp, empty" = bench_t_of_sexp ~t_of_sexp "((a 0) (h ()))" 114 | -------------------------------------------------------------------------------- /bench/bench_record.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sexplib0_bench) 3 | (libraries parsexp sexplib0) 4 | (preprocess 5 | (pps ppx_bench))) 6 | -------------------------------------------------------------------------------- /bench/sexplib0_bench.ml: -------------------------------------------------------------------------------- 1 | (*_ Deliberately empty. *) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /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 | " 25 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sexplib0) 3 | (public_name sexplib0) 4 | (libraries basement) 5 | (preprocess no_preprocessing) 6 | (ocamlopt_flags :standard -O3)) 7 | -------------------------------------------------------------------------------- /src/sexp.ml: -------------------------------------------------------------------------------- 1 | (* blit_string doesn't exist in [StdLabels.Bytes]... *) 2 | let bytes_blit_string ~src ~src_pos ~dst ~dst_pos ~len = 3 | Bytes.blit_string src src_pos dst dst_pos len 4 | ;; 5 | 6 | open Basement 7 | open StdLabels 8 | open Format 9 | 10 | (** Type of S-expressions *) 11 | type t = 12 | | Atom of string 13 | | List of t list 14 | 15 | let sexp_of_t t = t 16 | let sexp_of_t__local t = t 17 | let t_of_sexp t = t 18 | 19 | let rec compare_list a b = 20 | match a, b with 21 | | [], [] -> 0 22 | | [], _ -> -1 23 | | _, [] -> 1 24 | | x :: xs, y :: ys -> 25 | let res = compare x y in 26 | if res <> 0 then res else compare_list xs ys 27 | 28 | and compare a b = 29 | if a == b 30 | then 0 31 | else ( 32 | match a, b with 33 | | Atom a, Atom b -> String.compare a b 34 | | Atom _, _ -> -1 35 | | _, Atom _ -> 1 36 | | List a, List b -> compare_list a b) 37 | ;; 38 | 39 | let rec equal a b = 40 | a == b 41 | || 42 | match a, b with 43 | | Atom a, Atom b -> String.equal a b 44 | | Atom _, _ | _, Atom _ -> false 45 | | List a, List b -> List.equal ~eq:equal a b 46 | ;; 47 | 48 | exception Not_found_s of t 49 | exception Of_sexp_error of exn * t 50 | 51 | module Printing = struct 52 | (* Default indentation level for human-readable conversions *) 53 | 54 | let default_indent = Dynamic.make 1 55 | 56 | (* Escaping of strings used as atoms in S-expressions *) 57 | 58 | let must_escape str = 59 | let len = String.length str in 60 | len = 0 61 | || 62 | let rec loop str ix = 63 | match str.[ix] with 64 | | '"' | '(' | ')' | ';' | '\\' -> true 65 | | '|' -> 66 | ix > 0 67 | && 68 | let next = ix - 1 in 69 | Char.equal str.[next] '#' || loop str next 70 | | '#' -> 71 | ix > 0 72 | && 73 | let next = ix - 1 in 74 | Char.equal str.[next] '|' || loop str next 75 | | '\000' .. '\032' | '\127' .. '\255' -> true 76 | | _ -> ix > 0 && loop str (ix - 1) 77 | in 78 | loop str (len - 1) 79 | ;; 80 | 81 | let escaped s = 82 | let n = ref 0 in 83 | for i = 0 to String.length s - 1 do 84 | n 85 | := !n 86 | + 87 | match String.unsafe_get s i with 88 | | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 89 | | ' ' .. '~' -> 1 90 | | _ -> 4 91 | done; 92 | if !n = String.length s 93 | then s 94 | else ( 95 | let s' = Bytes.create !n in 96 | n := 0; 97 | for i = 0 to String.length s - 1 do 98 | (match String.unsafe_get s i with 99 | | ('\"' | '\\') as c -> 100 | Bytes.unsafe_set s' !n '\\'; 101 | incr n; 102 | Bytes.unsafe_set s' !n c 103 | | '\n' -> 104 | Bytes.unsafe_set s' !n '\\'; 105 | incr n; 106 | Bytes.unsafe_set s' !n 'n' 107 | | '\t' -> 108 | Bytes.unsafe_set s' !n '\\'; 109 | incr n; 110 | Bytes.unsafe_set s' !n 't' 111 | | '\r' -> 112 | Bytes.unsafe_set s' !n '\\'; 113 | incr n; 114 | Bytes.unsafe_set s' !n 'r' 115 | | '\b' -> 116 | Bytes.unsafe_set s' !n '\\'; 117 | incr n; 118 | Bytes.unsafe_set s' !n 'b' 119 | | ' ' .. '~' as c -> Bytes.unsafe_set s' !n c 120 | | c -> 121 | let a = Char.code c in 122 | Bytes.unsafe_set s' !n '\\'; 123 | incr n; 124 | Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); 125 | incr n; 126 | Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); 127 | incr n; 128 | Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10)))); 129 | incr n 130 | done; 131 | Bytes.unsafe_to_string s') 132 | ;; 133 | 134 | let esc_str str = 135 | let estr = escaped str in 136 | let elen = String.length estr in 137 | let res = Bytes.create (elen + 2) in 138 | bytes_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen; 139 | Bytes.unsafe_set res 0 '"'; 140 | Bytes.unsafe_set res (elen + 1) '"'; 141 | Bytes.unsafe_to_string res 142 | ;; 143 | 144 | let index_of_newline str start = String.index_from_opt str start '\n' 145 | 146 | let get_substring str index end_pos_opt = 147 | let end_pos = 148 | match end_pos_opt with 149 | | None -> String.length str 150 | | Some end_pos -> end_pos 151 | in 152 | String.sub str ~pos:index ~len:(end_pos - index) 153 | ;; 154 | 155 | let is_one_line str = 156 | match index_of_newline str 0 with 157 | | None -> true 158 | | Some index -> index + 1 = String.length str 159 | ;; 160 | 161 | let pp_hum_maybe_esc_str ppf str = 162 | if not (must_escape str) 163 | then pp_print_string ppf str 164 | else if is_one_line str 165 | then pp_print_string ppf (esc_str str) 166 | else ( 167 | let rec loop index = 168 | let next_newline = index_of_newline str index in 169 | let next_line = get_substring str index next_newline in 170 | pp_print_string ppf (escaped next_line); 171 | match next_newline with 172 | | None -> () 173 | | Some newline_index -> 174 | pp_print_string ppf "\\"; 175 | pp_force_newline ppf (); 176 | pp_print_string ppf "\\n"; 177 | loop (newline_index + 1) 178 | in 179 | pp_open_box ppf 0; 180 | (* the leading space is to line up the lines *) 181 | pp_print_string ppf " \""; 182 | loop 0; 183 | pp_print_string ppf "\""; 184 | pp_close_box ppf ()) 185 | ;; 186 | 187 | let mach_maybe_esc_str str = if must_escape str then esc_str str else str 188 | 189 | (* Output of S-expressions to formatters *) 190 | 191 | let rec pp_hum_indent indent ppf = function 192 | | Atom str -> pp_hum_maybe_esc_str ppf str 193 | | List (h :: t) -> 194 | pp_open_box ppf indent; 195 | pp_print_string ppf "("; 196 | pp_hum_indent indent ppf h; 197 | pp_hum_rest indent ppf t 198 | | List [] -> pp_print_string ppf "()" 199 | 200 | and pp_hum_rest indent ppf = function 201 | | h :: t -> 202 | pp_print_space ppf (); 203 | pp_hum_indent indent ppf h; 204 | pp_hum_rest indent ppf t 205 | | [] -> 206 | pp_print_string ppf ")"; 207 | pp_close_box ppf () 208 | ;; 209 | 210 | let rec pp_mach_internal may_need_space ppf = function 211 | | Atom str -> 212 | let str' = mach_maybe_esc_str str in 213 | let new_may_need_space = str' == str in 214 | if may_need_space && new_may_need_space then pp_print_string ppf " "; 215 | pp_print_string ppf str'; 216 | new_may_need_space 217 | | List (h :: t) -> 218 | pp_print_string ppf "("; 219 | let may_need_space = pp_mach_internal false ppf h in 220 | pp_mach_rest may_need_space ppf t; 221 | false 222 | | List [] -> 223 | pp_print_string ppf "()"; 224 | false 225 | 226 | and pp_mach_rest may_need_space ppf = function 227 | | h :: t -> 228 | let may_need_space = pp_mach_internal may_need_space ppf h in 229 | pp_mach_rest may_need_space ppf t 230 | | [] -> pp_print_string ppf ")" 231 | ;; 232 | 233 | let pp_hum ppf sexp = pp_hum_indent (Dynamic.get default_indent) ppf sexp 234 | let pp_mach ppf sexp = ignore (pp_mach_internal false ppf sexp) 235 | let pp = pp_mach 236 | 237 | (* Sexp size *) 238 | 239 | let rec size_loop ((v, c) as acc) = function 240 | | Atom str -> v + 1, c + String.length str 241 | | List lst -> List.fold_left lst ~init:acc ~f:size_loop 242 | ;; 243 | 244 | let size sexp = size_loop (0, 0) sexp 245 | 246 | (* Buffer conversions *) 247 | 248 | let to_buffer_hum ~buf ?(indent = Dynamic.get default_indent) sexp = 249 | let ppf = Format.formatter_of_buffer buf in 250 | Format.fprintf ppf "%a@?" (pp_hum_indent indent) sexp 251 | ;; 252 | 253 | let to_buffer_mach ~buf sexp = 254 | let rec loop may_need_space = function 255 | | Atom str -> 256 | let str' = mach_maybe_esc_str str in 257 | let new_may_need_space = str' == str in 258 | if may_need_space && new_may_need_space then Buffer.add_char buf ' '; 259 | Buffer.add_string buf str'; 260 | new_may_need_space 261 | | List (h :: t) -> 262 | Buffer.add_char buf '('; 263 | let may_need_space = loop false h in 264 | loop_rest may_need_space t; 265 | false 266 | | List [] -> 267 | Buffer.add_string buf "()"; 268 | false 269 | and loop_rest may_need_space = function 270 | | h :: t -> 271 | let may_need_space = loop may_need_space h in 272 | loop_rest may_need_space t 273 | | [] -> Buffer.add_char buf ')' 274 | in 275 | ignore (loop false sexp) 276 | ;; 277 | 278 | let to_buffer = to_buffer_mach 279 | 280 | let to_buffer_gen ~buf ~add_char ~add_string sexp = 281 | let rec loop may_need_space = function 282 | | Atom str -> 283 | let str' = mach_maybe_esc_str str in 284 | let new_may_need_space = str' == str in 285 | if may_need_space && new_may_need_space then add_char buf ' '; 286 | add_string buf str'; 287 | new_may_need_space 288 | | List (h :: t) -> 289 | add_char buf '('; 290 | let may_need_space = loop false h in 291 | loop_rest may_need_space t; 292 | false 293 | | List [] -> 294 | add_string buf "()"; 295 | false 296 | and loop_rest may_need_space = function 297 | | h :: t -> 298 | let may_need_space = loop may_need_space h in 299 | loop_rest may_need_space t 300 | | [] -> add_char buf ')' 301 | in 302 | ignore (loop false sexp) 303 | ;; 304 | 305 | (* The maximum size of a thing on the minor heap is 256 words. 306 | Previously, this size of the returned buffer here was 4096 bytes, which 307 | caused the Buffer to be allocated on the *major* heap every time. 308 | 309 | According to a simple benchmark by Ron, we can improve performance for 310 | small s-expressions by a factor of ~4 if we only allocate 1024 bytes 311 | (128 words + some small overhead) worth of buffer initially. And one 312 | can argue that if it's free to allocate strings smaller than 256 words, 313 | large s-expressions requiring larger expensive buffers won't notice 314 | the extra two doublings from 1024 bytes to 2048 and 4096. And especially 315 | performance-sensitive applications to always pass in a larger buffer to 316 | use. *) 317 | let buffer () = Buffer.create 1024 318 | 319 | (* String conversions *) 320 | 321 | let to_string_hum ?indent = function 322 | | Atom str 323 | when match index_of_newline str 0 with 324 | | None -> true 325 | | Some _ -> false -> mach_maybe_esc_str str 326 | | sexp -> 327 | let buf = buffer () in 328 | to_buffer_hum ?indent sexp ~buf; 329 | Buffer.contents buf 330 | ;; 331 | 332 | let to_string_mach = function 333 | | Atom str -> mach_maybe_esc_str str 334 | | sexp -> 335 | let buf = buffer () in 336 | to_buffer_mach sexp ~buf; 337 | Buffer.contents buf 338 | ;; 339 | 340 | let to_string = to_string_mach 341 | end 342 | 343 | include Printing 344 | 345 | let of_float_style = Dynamic.make (`No_underscores : [ `Underscores | `No_underscores ]) 346 | let of_int_style = Dynamic.make (`No_underscores : [ `Underscores | `No_underscores ]) 347 | 348 | module Private = struct 349 | include Printing 350 | end 351 | 352 | let message name fields = 353 | let rec conv_fields = function 354 | | [] -> [] 355 | | (fname, fsexp) :: rest -> 356 | (match fname with 357 | | "" -> fsexp :: conv_fields rest 358 | | _ -> List [ Atom fname; fsexp ] :: conv_fields rest) 359 | in 360 | List (Atom name :: conv_fields fields) 361 | ;; 362 | -------------------------------------------------------------------------------- /src/sexp.mli: -------------------------------------------------------------------------------- 1 | open Basement 2 | 3 | (** Type of S-expressions *) 4 | 5 | type t = 6 | | Atom of string 7 | | List of t list 8 | 9 | (*_ We don't use [@@deriving sexp] as this would generated references to [Sexplib], 10 | creating a circular dependency *) 11 | val t_of_sexp : t -> t 12 | val sexp_of_t : t -> t 13 | val sexp_of_t__local : t -> t 14 | val equal : t -> t -> bool 15 | val compare : t -> t -> int 16 | 17 | (** [Not_found_s] is used by functions that historically raised [Not_found], to allow them 18 | to raise an exception that contains an informative error message (as a sexp), while 19 | still having an exception that can be distinguished from other exceptions. *) 20 | exception Not_found_s of t 21 | 22 | (** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be 23 | successfully converted to an OCaml-value. *) 24 | exception Of_sexp_error of exn * t 25 | 26 | (** {1 Helpers} *) 27 | 28 | (** {v 29 | Helper to build nice s-expressions for error messages. It imitates the behavior of 30 | [[%message ...]] from the ppx_sexp_message rewriter. 31 | 32 | [message name key_values] produces a s-expression list starting with atom [name] and 33 | followed by list of size 2 of the form [(key value)]. When the key is the empty 34 | string, [value] is used directly instead as for [[%message]]. 35 | 36 | For instance the following code: 37 | 38 | {[ 39 | Sexp.message "error" 40 | [ "x", sexp_of_int 42 41 | ; "" , sexp_of_exn Exit 42 | ] 43 | ]} 44 | 45 | produces the s-expression: 46 | 47 | {[ 48 | (error (x 42) Exit) 49 | ]} 50 | v} *) 51 | val message : string -> (string * t) list -> t 52 | 53 | (** {1 Defaults} *) 54 | 55 | (** [default_indent] reference to default indentation level for human-readable 56 | conversions. 57 | 58 | Initialisation value: 2. *) 59 | val default_indent : int Dynamic.t 60 | 61 | (** {1 Pretty printing of S-expressions} *) 62 | 63 | (** [pp_hum ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human readable 64 | form. *) 65 | val pp_hum : Format.formatter -> t -> unit 66 | 67 | (** [pp_hum_indent n ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human 68 | readable form and indentation level [n]. *) 69 | val pp_hum_indent : int -> Format.formatter -> t -> unit 70 | 71 | (** [pp_mach ppf sexp] outputs S-expression [sexp] to formatter [ppf] in machine readable 72 | (i.e. most compact) form. *) 73 | val pp_mach : Format.formatter -> t -> unit 74 | 75 | (** Same as [pp_mach]. *) 76 | val pp : Format.formatter -> t -> unit 77 | 78 | (** {1 Conversion to strings} *) 79 | 80 | (** [to_string_hum ?indent sexp] converts S-expression [sexp] to a string in human 81 | readable form with indentation level [indent]. 82 | 83 | @param indent default = [!default_indent] *) 84 | val to_string_hum : ?indent:int -> t -> string 85 | 86 | (** [to_string_mach sexp] converts S-expression [sexp] to a string in machine readable 87 | (i.e. most compact) form. *) 88 | val to_string_mach : t -> string 89 | 90 | (** Same as [to_string_mach]. *) 91 | val to_string : t -> string 92 | 93 | (** {1 Styles} *) 94 | 95 | val of_float_style : [ `Underscores | `No_underscores ] Dynamic.t 96 | val of_int_style : [ `Underscores | `No_underscores ] Dynamic.t 97 | 98 | (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: 99 | 100 | https://opensource.janestreet.com/standards/#private-submodules *) 101 | module Private : sig 102 | (*_ Exported for sexplib *) 103 | 104 | val size : t -> int * int 105 | val buffer : unit -> Buffer.t 106 | val to_buffer : buf:Buffer.t -> t -> unit 107 | val to_buffer_hum : buf:Buffer.t -> ?indent:int -> t -> unit 108 | val to_buffer_mach : buf:Buffer.t -> t -> unit 109 | 110 | val to_buffer_gen 111 | : buf:'buffer 112 | -> add_char:('buffer -> char -> unit) 113 | -> add_string:('buffer -> string -> unit) 114 | -> t 115 | -> unit 116 | 117 | val mach_maybe_esc_str : string -> string 118 | val must_escape : string -> bool 119 | val esc_str : string -> string 120 | end 121 | -------------------------------------------------------------------------------- /src/sexp_conv.ml: -------------------------------------------------------------------------------- 1 | (* Utility Module for S-expression Conversions *) 2 | 3 | open StdLabels 4 | open MoreLabels 5 | open Basement 6 | open Printf 7 | open Sexp 8 | 9 | (* Conversion of OCaml-values to S-expressions *) 10 | 11 | external globalize_float : float -> float = "caml_obj_dup" 12 | external bytes_length : bytes -> int = "%bytes_length" 13 | external create_local_bytes : int -> bytes = "caml_create_bytes" 14 | 15 | external unsafe_blit_bytes 16 | : src:bytes 17 | -> src_pos:int 18 | -> dst:bytes 19 | -> dst_pos:int 20 | -> len:int 21 | -> unit 22 | = "caml_blit_bytes" 23 | [@@noalloc] 24 | 25 | external unsafe_bytes_to_string : bytes -> string = "%bytes_to_string" 26 | 27 | let bytes_to_string_local b = 28 | let len = bytes_length b in 29 | let s = create_local_bytes len in 30 | unsafe_blit_bytes ~src:b ~src_pos:0 ~dst:s ~dst_pos:0 ~len; 31 | unsafe_bytes_to_string s 32 | ;; 33 | 34 | external unsafe_fill_bytes 35 | : bytes 36 | -> pos:int 37 | -> len:int 38 | -> char 39 | -> unit 40 | = "caml_fill_bytes" 41 | [@@noalloc] 42 | 43 | let string_make_local n c = 44 | let s = create_local_bytes n in 45 | unsafe_fill_bytes s ~pos:0 ~len:n c; 46 | unsafe_bytes_to_string s 47 | ;; 48 | 49 | external format_float : string -> float -> string = "caml_format_float" 50 | external format_int32 : string -> int32 -> string = "caml_int32_format" 51 | external format_int64 : string -> int64 -> string = "caml_int64_format" 52 | external format_nativeint : string -> nativeint -> string = "caml_nativeint_format" 53 | external lazy_force : ('a lazy_t[@local_opt]) -> ('a[@local_opt]) = "%lazy_force" 54 | external array_length : _ array -> int = "%array_length" 55 | 56 | external array_safe_get 57 | : ('a array[@local_opt]) 58 | -> int 59 | -> ('a[@local_opt]) 60 | = "%array_safe_get" 61 | 62 | let string_of_int32 n = format_int32 "%d" n 63 | let string_of_int64 n = format_int64 "%d" n 64 | let string_of_nativeint n = format_nativeint "%d" n 65 | 66 | (* '%.17g' is guaranteed to be round-trippable. 67 | 68 | '%.15g' will be round-trippable and not have noise at the last digit or two for a float 69 | which was converted from a decimal (string) with <= 15 significant digits. So it's 70 | worth trying first to avoid things like "3.1400000000000001". 71 | 72 | See comment above [to_string_round_trippable] in {!Core.Float} for 73 | detailed explanation and examples. *) 74 | let default_string_of_float = 75 | Dynamic.make (fun x -> 76 | let y = format_float "%.15G" x in 77 | if float_of_string y = x then y else format_float "%.17G" x) 78 | ;; 79 | 80 | let read_old_option_format = Dynamic.make true 81 | let write_old_option_format = Dynamic.make true 82 | let list_map f l = List.map l ~f 83 | 84 | let list_map__local f lst = 85 | let rec rev lst acc = 86 | match lst with 87 | | [] -> acc 88 | | hd :: tl -> rev tl (hd :: acc) 89 | in 90 | let rec rev_map lst acc = 91 | match lst with 92 | | [] -> acc 93 | | hd :: tl -> rev_map tl (f hd :: acc) 94 | in 95 | rev (rev_map lst []) [] 96 | ;; 97 | 98 | let sexp_of_unit () = List [] 99 | let sexp_of_unit__local () = List [] 100 | 101 | let[@zero_alloc] sexp_of_bool = function 102 | | false -> Atom "false" 103 | | true -> Atom "true" 104 | ;; 105 | 106 | let sexp_of_bool__local = sexp_of_bool 107 | let sexp_of_string str = Atom str 108 | let sexp_of_string__local str = Atom str 109 | let sexp_of_bytes bytes = Atom (Bytes.to_string bytes) 110 | let sexp_of_bytes__local bytes = Atom (bytes_to_string_local bytes) 111 | let sexp_of_int n = Atom (string_of_int n) 112 | let sexp_of_int__local n = Atom (string_of_int n) 113 | let sexp_of_float n = Atom ((Dynamic.get default_string_of_float) n) 114 | 115 | let sexp_of_float__local n = 116 | Atom ((Dynamic.get default_string_of_float) (globalize_float n)) 117 | ;; 118 | 119 | let sexp_of_int32 n = Atom (Int32.to_string n) 120 | let sexp_of_int32__local n = Atom (string_of_int32 n) 121 | let sexp_of_int64 n = Atom (Int64.to_string n) 122 | let sexp_of_int64__local n = Atom (string_of_int64 n) 123 | let sexp_of_nativeint n = Atom (Nativeint.to_string n) 124 | let sexp_of_nativeint__local n = Atom (string_of_nativeint n) 125 | let sexp_of_ref sexp_of__a rf = sexp_of__a !rf 126 | let sexp_of_ref__local sexp_of__a rf = sexp_of__a !rf 127 | let sexp_of_lazy_t sexp_of__a lv = sexp_of__a (Lazy.force lv) 128 | let sexp_of_lazy_t__local sexp_of__a lv = sexp_of__a (lazy_force lv) 129 | 130 | let sexp_of_option sexp_of__a option = 131 | let write_old_option_format = Dynamic.get write_old_option_format in 132 | match option with 133 | | Some x when write_old_option_format -> List [ sexp_of__a x ] 134 | | Some x -> List [ Atom "some"; sexp_of__a x ] 135 | | None when write_old_option_format -> List [] 136 | | None -> Atom "none" 137 | ;; 138 | 139 | let sexp_of_option__local sexp_of__a option = 140 | let write_old_option_format = Dynamic.get write_old_option_format in 141 | match option with 142 | | Some x when write_old_option_format -> List [ sexp_of__a x ] 143 | | Some x -> List [ Atom "some"; sexp_of__a x ] 144 | | None when write_old_option_format -> List [] 145 | | None -> Atom "none" 146 | ;; 147 | 148 | let sexp_of_or_null sexp_of__a or_null = 149 | let write_old_option_format = Dynamic.get write_old_option_format in 150 | match or_null with 151 | | Or_null_shim.This x when write_old_option_format -> List [ sexp_of__a x ] 152 | | Or_null_shim.This x -> List [ Atom "this"; sexp_of__a x ] 153 | | Null when write_old_option_format -> List [] 154 | | Null -> Atom "null" 155 | ;; 156 | 157 | let sexp_of_or_null__local sexp_of__a or_null = 158 | let write_old_option_format = Dynamic.get write_old_option_format in 159 | match or_null with 160 | | Or_null_shim.This x when write_old_option_format -> List [ sexp_of__a x ] 161 | | Or_null_shim.This x -> List [ Atom "this"; sexp_of__a x ] 162 | | Null when write_old_option_format -> List [] 163 | | Null -> Atom "null" 164 | ;; 165 | 166 | let sexp_of_pair sexp_of__a sexp_of__b (a, b) = List [ sexp_of__a a; sexp_of__b b ] 167 | 168 | let sexp_of_triple sexp_of__a sexp_of__b sexp_of__c (a, b, c) = 169 | List [ sexp_of__a a; sexp_of__b b; sexp_of__c c ] 170 | ;; 171 | 172 | let sexp_of_list sexp_of__a lst = List (List.map lst ~f:sexp_of__a) 173 | let sexp_of_list__local sexp_of__a lst = List (list_map__local sexp_of__a lst) 174 | 175 | let sexp_of_array sexp_of__a ar = 176 | let lst_ref = ref [] in 177 | for i = Array.length ar - 1 downto 0 do 178 | lst_ref := sexp_of__a ar.(i) :: !lst_ref 179 | done; 180 | List !lst_ref 181 | ;; 182 | 183 | let sexp_of_array__local sexp_of__a ar = 184 | let rec loop i acc = 185 | if i < 0 then List acc else loop (i - 1) (sexp_of__a (array_safe_get ar i) :: acc) 186 | in 187 | loop (array_length ar - 1) [] 188 | ;; 189 | 190 | let sexp_of_hashtbl sexp_of_key sexp_of_val htbl = 191 | let coll ~key:k ~data:v acc = List [ sexp_of_key k; sexp_of_val v ] :: acc in 192 | List (Hashtbl.fold htbl ~init:[] ~f:coll) 193 | ;; 194 | 195 | let sexp_of_opaque _ = Atom "" 196 | let sexp_of_fun _ = Atom "" 197 | 198 | (* Exception converter registration and lookup *) 199 | 200 | module Exn_converter = struct 201 | (* Fast and automatic exception registration *) 202 | 203 | module Registration = struct 204 | type t = 205 | { sexp_of_exn : exn -> Sexp.t 206 | ; (* If [printexc = true] then this sexp converter is used for Printexc.to_string *) 207 | printexc : bool 208 | } 209 | [@@unsafe_allow_any_mode_crossing] 210 | end 211 | 212 | module Exn_table = Basement.Stdlib_shim.Ephemeron.K1.MakePortable (struct 213 | type t = extension_constructor 214 | 215 | let equal = ( == ) 216 | let hash = Obj.Extension_constructor.id 217 | end) 218 | 219 | module type The_exn_table = sig 220 | type key 221 | 222 | val lock : key Capsule.Mutex.t 223 | end 224 | 225 | module The_exn_table : The_exn_table = 226 | (val let (Capsule.Key.P (type key) (key : key Capsule.Key.t)) = Capsule.create () in 227 | let lock = Capsule.Mutex.create key in 228 | (module struct 229 | type nonrec key = key 230 | 231 | let lock = lock 232 | end : The_exn_table)) 233 | 234 | let the_exn_table : (Registration.t Exn_table.t, The_exn_table.key) Capsule.Data.t = 235 | Capsule.Data.create (fun () -> Exn_table.create 17) 236 | ;; 237 | 238 | (* Ephemerons are used so that [sexp_of_exn] closure don't keep the 239 | extension_constructor live. *) 240 | let add ?(printexc = true) ?finalise:_ extension_constructor sexp_of_exn = 241 | let sexp_of_exn = Portability_hacks.magic_portable__needs_base_and_core sexp_of_exn in 242 | let extension_constructor = 243 | Portability_hacks.Cross.Portable.(cross extension_constructor) extension_constructor 244 | in 245 | Capsule.Mutex.with_lock The_exn_table.lock ~f:(fun password -> 246 | Capsule.Data.iter the_exn_table ~password ~f:(fun the_exn_table -> 247 | let extension_constructor = 248 | Portability_hacks.Cross.Contended.(cross extension_constructor) 249 | extension_constructor 250 | in 251 | Exn_table.add 252 | the_exn_table 253 | extension_constructor 254 | ({ sexp_of_exn; printexc } : Registration.t))) 255 | ;; 256 | 257 | let find_auto ~for_printexc exn = 258 | let extension_constructor = Obj.Extension_constructor.of_val exn in 259 | let extension_constructor = 260 | Portability_hacks.Cross.Portable.(cross extension_constructor) extension_constructor 261 | in 262 | match 263 | Capsule.Mutex.with_lock The_exn_table.lock ~f:(fun password -> 264 | Capsule.Data.extract the_exn_table ~password ~f:(fun the_exn_table -> 265 | let extension_constructor = 266 | Portability_hacks.Cross.Contended.(cross extension_constructor) 267 | extension_constructor 268 | in 269 | { Stdlib_shim.Modes.Aliased.aliased = 270 | (Exn_table.find_opt the_exn_table extension_constructor 271 | : Registration.t option) 272 | }) 273 | [@nontail]) 274 | with 275 | | { aliased = None } -> None 276 | | { aliased = Some { sexp_of_exn; printexc } } -> 277 | (match for_printexc, printexc with 278 | | false, _ | _, true -> Some (sexp_of_exn exn) 279 | | true, false -> None) 280 | ;; 281 | 282 | module For_unit_tests_only = struct 283 | let size () = 284 | Capsule.Mutex.with_lock The_exn_table.lock ~f:(fun password -> 285 | Capsule.Data.extract the_exn_table ~password ~f:(fun the_exn_table -> 286 | (Exn_table.stats_alive the_exn_table).num_bindings)) 287 | ;; 288 | end 289 | end 290 | 291 | let sexp_of_exn_opt_for_printexc exn = Exn_converter.find_auto ~for_printexc:true exn 292 | let sexp_of_exn_opt exn = Exn_converter.find_auto ~for_printexc:false exn 293 | 294 | let sexp_of_exn exn = 295 | match sexp_of_exn_opt exn with 296 | | None -> List [ Atom (Printexc.to_string exn) ] 297 | | Some sexp -> sexp 298 | ;; 299 | 300 | let exn_to_string e = Sexp.to_string_hum (sexp_of_exn e) 301 | 302 | (* {[exception Blah [@@deriving sexp]]} generates a call to the function 303 | [Exn_converter.add] defined in this file. So we are guaranted that as soon as we 304 | mark an exception as sexpable, this module will be linked in and this printer will be 305 | registered, which is what we want. *) 306 | let () = 307 | (Printexc.register_printer [@alert "-unsafe_multidomain"]) (fun exn -> 308 | match sexp_of_exn_opt_for_printexc exn with 309 | | None -> None 310 | | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) 311 | ;; 312 | 313 | let printexc_prefer_sexp exn = 314 | match sexp_of_exn_opt exn with 315 | | None -> Printexc.to_string exn 316 | | Some sexp -> Sexp.to_string_hum ~indent:2 sexp 317 | ;; 318 | 319 | (* Conversion of S-expressions to OCaml-values *) 320 | 321 | exception Of_sexp_error = Sexp.Of_sexp_error 322 | 323 | let record_check_extra_fields = Dynamic.make true 324 | let of_sexp_error_exn exc sexp = raise (Of_sexp_error (exc, sexp)) 325 | let of_sexp_error what sexp = raise (Of_sexp_error (Failure what, sexp)) 326 | 327 | let unit_of_sexp sexp = 328 | match sexp with 329 | | List [] -> () 330 | | Atom _ | List _ -> of_sexp_error "unit_of_sexp: empty list needed" sexp 331 | ;; 332 | 333 | let bool_of_sexp sexp = 334 | match sexp with 335 | | Atom ("true" | "True") -> true 336 | | Atom ("false" | "False") -> false 337 | | Atom _ -> of_sexp_error "bool_of_sexp: unknown string" sexp 338 | | List _ -> of_sexp_error "bool_of_sexp: atom needed" sexp 339 | ;; 340 | 341 | let string_of_sexp sexp = 342 | match sexp with 343 | | Atom str -> str 344 | | List _ -> of_sexp_error "string_of_sexp: atom needed" sexp 345 | ;; 346 | 347 | let bytes_of_sexp sexp = 348 | match sexp with 349 | | Atom str -> Bytes.of_string str 350 | | List _ -> of_sexp_error "bytes_of_sexp: atom needed" sexp 351 | ;; 352 | 353 | let char_of_sexp sexp = 354 | match sexp with 355 | | Atom str -> 356 | if String.length str <> 1 357 | then of_sexp_error "char_of_sexp: atom string must contain one character only" sexp; 358 | str.[0] 359 | | List _ -> of_sexp_error "char_of_sexp: atom needed" sexp 360 | ;; 361 | 362 | let int_of_sexp sexp = 363 | match sexp with 364 | | Atom str -> 365 | (try int_of_string str with 366 | | exc -> of_sexp_error ("int_of_sexp: " ^ exn_to_string exc) sexp) 367 | | List _ -> of_sexp_error "int_of_sexp: atom needed" sexp 368 | ;; 369 | 370 | let float_of_sexp sexp = 371 | match sexp with 372 | | Atom str -> 373 | (try float_of_string str with 374 | | exc -> of_sexp_error ("float_of_sexp: " ^ exn_to_string exc) sexp) 375 | | List _ -> of_sexp_error "float_of_sexp: atom needed" sexp 376 | ;; 377 | 378 | let int32_of_sexp sexp = 379 | match sexp with 380 | | Atom str -> 381 | (try Int32.of_string str with 382 | | exc -> of_sexp_error ("int32_of_sexp: " ^ exn_to_string exc) sexp) 383 | | List _ -> of_sexp_error "int32_of_sexp: atom needed" sexp 384 | ;; 385 | 386 | let int64_of_sexp sexp = 387 | match sexp with 388 | | Atom str -> 389 | (try Int64.of_string str with 390 | | exc -> of_sexp_error ("int64_of_sexp: " ^ exn_to_string exc) sexp) 391 | | List _ -> of_sexp_error "int64_of_sexp: atom needed" sexp 392 | ;; 393 | 394 | let nativeint_of_sexp sexp = 395 | match sexp with 396 | | Atom str -> 397 | (try Nativeint.of_string str with 398 | | exc -> of_sexp_error ("nativeint_of_sexp: " ^ exn_to_string exc) sexp) 399 | | List _ -> of_sexp_error "nativeint_of_sexp: atom needed" sexp 400 | ;; 401 | 402 | let ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp) 403 | let lazy_t_of_sexp a__of_sexp sexp = Lazy.from_val (a__of_sexp sexp) 404 | 405 | let option_of_sexp a__of_sexp sexp = 406 | if Dynamic.get read_old_option_format 407 | then ( 408 | match sexp with 409 | | List [] | Atom ("none" | "None") -> None 410 | | List [ el ] | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) 411 | | List _ -> of_sexp_error "option_of_sexp: list must represent optional value" sexp 412 | | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp) 413 | else ( 414 | match sexp with 415 | | Atom ("none" | "None") -> None 416 | | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) 417 | | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp 418 | | List _ -> of_sexp_error "option_of_sexp: list must be (some el)" sexp) 419 | ;; 420 | 421 | let or_null_of_sexp a__of_sexp sexp = 422 | if Dynamic.get read_old_option_format 423 | then ( 424 | match sexp with 425 | | List [] | Atom ("null" | "Null") -> Or_null_shim.Null 426 | | List [ el ] | List [ Atom ("this" | "This"); el ] -> This (a__of_sexp el) 427 | | List _ -> of_sexp_error "or_null_of_sexp: list must represent or_null value" sexp 428 | | Atom _ -> of_sexp_error "or_null_of_sexp: only null can be atom" sexp) 429 | else ( 430 | match sexp with 431 | | Atom ("null" | "Null") -> Or_null_shim.Null 432 | | List [ Atom ("this" | "This"); el ] -> This (a__of_sexp el) 433 | | Atom _ -> of_sexp_error "or_null_of_sexp: only null can be atom" sexp 434 | | List _ -> of_sexp_error "or_null_of_sexp: list must be (this el)" sexp) 435 | ;; 436 | 437 | let pair_of_sexp a__of_sexp b__of_sexp sexp = 438 | match sexp with 439 | | List [ a_sexp; b_sexp ] -> 440 | let a = a__of_sexp a_sexp in 441 | let b = b__of_sexp b_sexp in 442 | a, b 443 | | List _ -> 444 | of_sexp_error "pair_of_sexp: list must contain exactly two elements only" sexp 445 | | Atom _ -> of_sexp_error "pair_of_sexp: list needed" sexp 446 | ;; 447 | 448 | let triple_of_sexp a__of_sexp b__of_sexp c__of_sexp sexp = 449 | match sexp with 450 | | List [ a_sexp; b_sexp; c_sexp ] -> 451 | let a = a__of_sexp a_sexp in 452 | let b = b__of_sexp b_sexp in 453 | let c = c__of_sexp c_sexp in 454 | a, b, c 455 | | List _ -> 456 | of_sexp_error "triple_of_sexp: list must contain exactly three elements only" sexp 457 | | Atom _ -> of_sexp_error "triple_of_sexp: list needed" sexp 458 | ;; 459 | 460 | let list_of_sexp a__of_sexp sexp = 461 | match sexp with 462 | | List lst -> List.map lst ~f:a__of_sexp 463 | | Atom _ -> of_sexp_error "list_of_sexp: list needed" sexp 464 | ;; 465 | 466 | let array_of_sexp a__of_sexp sexp = 467 | match sexp with 468 | | List [] -> [||] 469 | | List (h :: t) -> 470 | let len = List.length t + 1 in 471 | let res = Array.make len (a__of_sexp h) in 472 | let rec loop i = function 473 | | [] -> res 474 | | h :: t -> 475 | res.(i) <- a__of_sexp h; 476 | loop (i + 1) t 477 | in 478 | loop 1 t 479 | | Atom _ -> of_sexp_error "array_of_sexp: list needed" sexp 480 | ;; 481 | 482 | let hashtbl_of_sexp key_of_sexp val_of_sexp sexp = 483 | match sexp with 484 | | List lst -> 485 | let htbl = Hashtbl.create 0 in 486 | let act = function 487 | | List [ k_sexp; v_sexp ] -> 488 | Hashtbl.add htbl ~key:(key_of_sexp k_sexp) ~data:(val_of_sexp v_sexp) 489 | | List _ | Atom _ -> of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp 490 | in 491 | List.iter lst ~f:act; 492 | htbl 493 | | Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp 494 | ;; 495 | 496 | let opaque_of_sexp sexp = 497 | of_sexp_error "opaque_of_sexp: cannot convert opaque values" sexp 498 | ;; 499 | 500 | let fun_of_sexp sexp = of_sexp_error "fun_of_sexp: cannot convert function values" sexp 501 | 502 | (* Sexp Grammars *) 503 | 504 | include Sexp_conv_grammar 505 | 506 | (* Registering default exception printers *) 507 | 508 | let get_flc_error name (file, line, chr) = Atom (sprintf "%s %s:%d:%d" name file line chr) 509 | 510 | type handler = { h : exn -> Sexp.t } [@@unboxed] [@@unsafe_allow_any_mode_crossing] 511 | 512 | let () = 513 | List.iter 514 | ~f:(fun (extension_constructor, handler) -> 515 | Exn_converter.add ~printexc:false ~finalise:false extension_constructor handler.h) 516 | [ ( [%extension_constructor Assert_failure] 517 | , { h = 518 | (function 519 | | Assert_failure arg -> get_flc_error "Assert_failure" arg 520 | | _ -> assert false) 521 | } ) 522 | ; ( [%extension_constructor Exit] 523 | , { h = 524 | (function 525 | | Exit -> Atom "Exit" 526 | | _ -> assert false) 527 | } ) 528 | ; ( [%extension_constructor End_of_file] 529 | , { h = 530 | (function 531 | | End_of_file -> Atom "End_of_file" 532 | | _ -> assert false) 533 | } ) 534 | ; ( [%extension_constructor Failure] 535 | , { h = 536 | (function 537 | | Failure arg -> List [ Atom "Failure"; Atom arg ] 538 | | _ -> assert false) 539 | } ) 540 | ; ( [%extension_constructor Not_found] 541 | , { h = 542 | (function 543 | | Not_found -> Atom "Not_found" 544 | | _ -> assert false) 545 | } ) 546 | ; ( [%extension_constructor Invalid_argument] 547 | , { h = 548 | (function 549 | | Invalid_argument arg -> List [ Atom "Invalid_argument"; Atom arg ] 550 | | _ -> assert false) 551 | } ) 552 | ; ( [%extension_constructor Match_failure] 553 | , { h = 554 | (function 555 | | Match_failure arg -> get_flc_error "Match_failure" arg 556 | | _ -> assert false) 557 | } ) 558 | ; ( [%extension_constructor Not_found_s] 559 | , { h = 560 | (function 561 | | Not_found_s arg -> List [ Atom "Not_found_s"; arg ] 562 | | _ -> assert false) 563 | } ) 564 | ; ( [%extension_constructor Sys_error] 565 | , { h = 566 | (function 567 | | Sys_error arg -> List [ Atom "Sys_error"; Atom arg ] 568 | | _ -> assert false) 569 | } ) 570 | ; ( [%extension_constructor Arg.Help] 571 | , { h = 572 | (function 573 | | Arg.Help arg -> List [ Atom "Arg.Help"; Atom arg ] 574 | | _ -> assert false) 575 | } ) 576 | ; ( [%extension_constructor Arg.Bad] 577 | , { h = 578 | (function 579 | | Arg.Bad arg -> List [ Atom "Arg.Bad"; Atom arg ] 580 | | _ -> assert false) 581 | } ) 582 | ; ( [%extension_constructor Lazy.Undefined] 583 | , { h = 584 | (function 585 | | Lazy.Undefined -> Atom "Lazy.Undefined" 586 | | _ -> assert false) 587 | } ) 588 | ; ( [%extension_constructor Parsing.Parse_error] 589 | , { h = 590 | (function 591 | | Parsing.Parse_error -> Atom "Parsing.Parse_error" 592 | | _ -> assert false) 593 | } ) 594 | ; ( [%extension_constructor Queue.Empty] 595 | , { h = 596 | (function 597 | | Queue.Empty -> Atom "Queue.Empty" 598 | | _ -> assert false) 599 | } ) 600 | ; ( [%extension_constructor Scanf.Scan_failure] 601 | , { h = 602 | (function 603 | | Scanf.Scan_failure arg -> List [ Atom "Scanf.Scan_failure"; Atom arg ] 604 | | _ -> assert false) 605 | } ) 606 | ; ( [%extension_constructor Stack.Empty] 607 | , { h = 608 | (function 609 | | Stack.Empty -> Atom "Stack.Empty" 610 | | _ -> assert false) 611 | } ) 612 | ; ( [%extension_constructor Sys.Break] 613 | , { h = 614 | (function 615 | | Sys.Break -> Atom "Sys.Break" 616 | | _ -> assert false) 617 | } ) 618 | ] 619 | ;; 620 | 621 | let () = 622 | List.iter 623 | ~f:(fun (extension_constructor, handler) -> 624 | Exn_converter.add ~printexc:true ~finalise:false extension_constructor handler.h) 625 | [ ( [%extension_constructor Of_sexp_error] 626 | , { h = 627 | (function 628 | | Of_sexp_error (exc, sexp) -> 629 | List [ Atom "Sexplib.Conv.Of_sexp_error"; sexp_of_exn exc; sexp ] 630 | | _ -> assert false) 631 | } ) 632 | ] 633 | ;; 634 | 635 | external ignore : (_[@local_opt]) -> unit = "%ignore" 636 | external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" 637 | 638 | (* The compiler generates *catastrophically* bad code if you let it inline this function. 639 | But with that prevented, the compiler reliably optimizes this to a load from a 640 | statically allocated array. *) 641 | let[@zero_alloc] [@inline never] [@local never] [@specialise never] sexp_of_char_statically_allocated 642 | = function 643 | (*$ 644 | for i = 0 to 255 do 645 | Printf.printf "| '\\x%02x' -> Atom \"\\x%02x\"\n" i i 646 | done 647 | *) 648 | | '\x00' -> Atom "\x00" 649 | | '\x01' -> Atom "\x01" 650 | | '\x02' -> Atom "\x02" 651 | | '\x03' -> Atom "\x03" 652 | | '\x04' -> Atom "\x04" 653 | | '\x05' -> Atom "\x05" 654 | | '\x06' -> Atom "\x06" 655 | | '\x07' -> Atom "\x07" 656 | | '\x08' -> Atom "\x08" 657 | | '\x09' -> Atom "\x09" 658 | | '\x0a' -> Atom "\x0a" 659 | | '\x0b' -> Atom "\x0b" 660 | | '\x0c' -> Atom "\x0c" 661 | | '\x0d' -> Atom "\x0d" 662 | | '\x0e' -> Atom "\x0e" 663 | | '\x0f' -> Atom "\x0f" 664 | | '\x10' -> Atom "\x10" 665 | | '\x11' -> Atom "\x11" 666 | | '\x12' -> Atom "\x12" 667 | | '\x13' -> Atom "\x13" 668 | | '\x14' -> Atom "\x14" 669 | | '\x15' -> Atom "\x15" 670 | | '\x16' -> Atom "\x16" 671 | | '\x17' -> Atom "\x17" 672 | | '\x18' -> Atom "\x18" 673 | | '\x19' -> Atom "\x19" 674 | | '\x1a' -> Atom "\x1a" 675 | | '\x1b' -> Atom "\x1b" 676 | | '\x1c' -> Atom "\x1c" 677 | | '\x1d' -> Atom "\x1d" 678 | | '\x1e' -> Atom "\x1e" 679 | | '\x1f' -> Atom "\x1f" 680 | | '\x20' -> Atom "\x20" 681 | | '\x21' -> Atom "\x21" 682 | | '\x22' -> Atom "\x22" 683 | | '\x23' -> Atom "\x23" 684 | | '\x24' -> Atom "\x24" 685 | | '\x25' -> Atom "\x25" 686 | | '\x26' -> Atom "\x26" 687 | | '\x27' -> Atom "\x27" 688 | | '\x28' -> Atom "\x28" 689 | | '\x29' -> Atom "\x29" 690 | | '\x2a' -> Atom "\x2a" 691 | | '\x2b' -> Atom "\x2b" 692 | | '\x2c' -> Atom "\x2c" 693 | | '\x2d' -> Atom "\x2d" 694 | | '\x2e' -> Atom "\x2e" 695 | | '\x2f' -> Atom "\x2f" 696 | | '\x30' -> Atom "\x30" 697 | | '\x31' -> Atom "\x31" 698 | | '\x32' -> Atom "\x32" 699 | | '\x33' -> Atom "\x33" 700 | | '\x34' -> Atom "\x34" 701 | | '\x35' -> Atom "\x35" 702 | | '\x36' -> Atom "\x36" 703 | | '\x37' -> Atom "\x37" 704 | | '\x38' -> Atom "\x38" 705 | | '\x39' -> Atom "\x39" 706 | | '\x3a' -> Atom "\x3a" 707 | | '\x3b' -> Atom "\x3b" 708 | | '\x3c' -> Atom "\x3c" 709 | | '\x3d' -> Atom "\x3d" 710 | | '\x3e' -> Atom "\x3e" 711 | | '\x3f' -> Atom "\x3f" 712 | | '\x40' -> Atom "\x40" 713 | | '\x41' -> Atom "\x41" 714 | | '\x42' -> Atom "\x42" 715 | | '\x43' -> Atom "\x43" 716 | | '\x44' -> Atom "\x44" 717 | | '\x45' -> Atom "\x45" 718 | | '\x46' -> Atom "\x46" 719 | | '\x47' -> Atom "\x47" 720 | | '\x48' -> Atom "\x48" 721 | | '\x49' -> Atom "\x49" 722 | | '\x4a' -> Atom "\x4a" 723 | | '\x4b' -> Atom "\x4b" 724 | | '\x4c' -> Atom "\x4c" 725 | | '\x4d' -> Atom "\x4d" 726 | | '\x4e' -> Atom "\x4e" 727 | | '\x4f' -> Atom "\x4f" 728 | | '\x50' -> Atom "\x50" 729 | | '\x51' -> Atom "\x51" 730 | | '\x52' -> Atom "\x52" 731 | | '\x53' -> Atom "\x53" 732 | | '\x54' -> Atom "\x54" 733 | | '\x55' -> Atom "\x55" 734 | | '\x56' -> Atom "\x56" 735 | | '\x57' -> Atom "\x57" 736 | | '\x58' -> Atom "\x58" 737 | | '\x59' -> Atom "\x59" 738 | | '\x5a' -> Atom "\x5a" 739 | | '\x5b' -> Atom "\x5b" 740 | | '\x5c' -> Atom "\x5c" 741 | | '\x5d' -> Atom "\x5d" 742 | | '\x5e' -> Atom "\x5e" 743 | | '\x5f' -> Atom "\x5f" 744 | | '\x60' -> Atom "\x60" 745 | | '\x61' -> Atom "\x61" 746 | | '\x62' -> Atom "\x62" 747 | | '\x63' -> Atom "\x63" 748 | | '\x64' -> Atom "\x64" 749 | | '\x65' -> Atom "\x65" 750 | | '\x66' -> Atom "\x66" 751 | | '\x67' -> Atom "\x67" 752 | | '\x68' -> Atom "\x68" 753 | | '\x69' -> Atom "\x69" 754 | | '\x6a' -> Atom "\x6a" 755 | | '\x6b' -> Atom "\x6b" 756 | | '\x6c' -> Atom "\x6c" 757 | | '\x6d' -> Atom "\x6d" 758 | | '\x6e' -> Atom "\x6e" 759 | | '\x6f' -> Atom "\x6f" 760 | | '\x70' -> Atom "\x70" 761 | | '\x71' -> Atom "\x71" 762 | | '\x72' -> Atom "\x72" 763 | | '\x73' -> Atom "\x73" 764 | | '\x74' -> Atom "\x74" 765 | | '\x75' -> Atom "\x75" 766 | | '\x76' -> Atom "\x76" 767 | | '\x77' -> Atom "\x77" 768 | | '\x78' -> Atom "\x78" 769 | | '\x79' -> Atom "\x79" 770 | | '\x7a' -> Atom "\x7a" 771 | | '\x7b' -> Atom "\x7b" 772 | | '\x7c' -> Atom "\x7c" 773 | | '\x7d' -> Atom "\x7d" 774 | | '\x7e' -> Atom "\x7e" 775 | | '\x7f' -> Atom "\x7f" 776 | | '\x80' -> Atom "\x80" 777 | | '\x81' -> Atom "\x81" 778 | | '\x82' -> Atom "\x82" 779 | | '\x83' -> Atom "\x83" 780 | | '\x84' -> Atom "\x84" 781 | | '\x85' -> Atom "\x85" 782 | | '\x86' -> Atom "\x86" 783 | | '\x87' -> Atom "\x87" 784 | | '\x88' -> Atom "\x88" 785 | | '\x89' -> Atom "\x89" 786 | | '\x8a' -> Atom "\x8a" 787 | | '\x8b' -> Atom "\x8b" 788 | | '\x8c' -> Atom "\x8c" 789 | | '\x8d' -> Atom "\x8d" 790 | | '\x8e' -> Atom "\x8e" 791 | | '\x8f' -> Atom "\x8f" 792 | | '\x90' -> Atom "\x90" 793 | | '\x91' -> Atom "\x91" 794 | | '\x92' -> Atom "\x92" 795 | | '\x93' -> Atom "\x93" 796 | | '\x94' -> Atom "\x94" 797 | | '\x95' -> Atom "\x95" 798 | | '\x96' -> Atom "\x96" 799 | | '\x97' -> Atom "\x97" 800 | | '\x98' -> Atom "\x98" 801 | | '\x99' -> Atom "\x99" 802 | | '\x9a' -> Atom "\x9a" 803 | | '\x9b' -> Atom "\x9b" 804 | | '\x9c' -> Atom "\x9c" 805 | | '\x9d' -> Atom "\x9d" 806 | | '\x9e' -> Atom "\x9e" 807 | | '\x9f' -> Atom "\x9f" 808 | | '\xa0' -> Atom "\xa0" 809 | | '\xa1' -> Atom "\xa1" 810 | | '\xa2' -> Atom "\xa2" 811 | | '\xa3' -> Atom "\xa3" 812 | | '\xa4' -> Atom "\xa4" 813 | | '\xa5' -> Atom "\xa5" 814 | | '\xa6' -> Atom "\xa6" 815 | | '\xa7' -> Atom "\xa7" 816 | | '\xa8' -> Atom "\xa8" 817 | | '\xa9' -> Atom "\xa9" 818 | | '\xaa' -> Atom "\xaa" 819 | | '\xab' -> Atom "\xab" 820 | | '\xac' -> Atom "\xac" 821 | | '\xad' -> Atom "\xad" 822 | | '\xae' -> Atom "\xae" 823 | | '\xaf' -> Atom "\xaf" 824 | | '\xb0' -> Atom "\xb0" 825 | | '\xb1' -> Atom "\xb1" 826 | | '\xb2' -> Atom "\xb2" 827 | | '\xb3' -> Atom "\xb3" 828 | | '\xb4' -> Atom "\xb4" 829 | | '\xb5' -> Atom "\xb5" 830 | | '\xb6' -> Atom "\xb6" 831 | | '\xb7' -> Atom "\xb7" 832 | | '\xb8' -> Atom "\xb8" 833 | | '\xb9' -> Atom "\xb9" 834 | | '\xba' -> Atom "\xba" 835 | | '\xbb' -> Atom "\xbb" 836 | | '\xbc' -> Atom "\xbc" 837 | | '\xbd' -> Atom "\xbd" 838 | | '\xbe' -> Atom "\xbe" 839 | | '\xbf' -> Atom "\xbf" 840 | | '\xc0' -> Atom "\xc0" 841 | | '\xc1' -> Atom "\xc1" 842 | | '\xc2' -> Atom "\xc2" 843 | | '\xc3' -> Atom "\xc3" 844 | | '\xc4' -> Atom "\xc4" 845 | | '\xc5' -> Atom "\xc5" 846 | | '\xc6' -> Atom "\xc6" 847 | | '\xc7' -> Atom "\xc7" 848 | | '\xc8' -> Atom "\xc8" 849 | | '\xc9' -> Atom "\xc9" 850 | | '\xca' -> Atom "\xca" 851 | | '\xcb' -> Atom "\xcb" 852 | | '\xcc' -> Atom "\xcc" 853 | | '\xcd' -> Atom "\xcd" 854 | | '\xce' -> Atom "\xce" 855 | | '\xcf' -> Atom "\xcf" 856 | | '\xd0' -> Atom "\xd0" 857 | | '\xd1' -> Atom "\xd1" 858 | | '\xd2' -> Atom "\xd2" 859 | | '\xd3' -> Atom "\xd3" 860 | | '\xd4' -> Atom "\xd4" 861 | | '\xd5' -> Atom "\xd5" 862 | | '\xd6' -> Atom "\xd6" 863 | | '\xd7' -> Atom "\xd7" 864 | | '\xd8' -> Atom "\xd8" 865 | | '\xd9' -> Atom "\xd9" 866 | | '\xda' -> Atom "\xda" 867 | | '\xdb' -> Atom "\xdb" 868 | | '\xdc' -> Atom "\xdc" 869 | | '\xdd' -> Atom "\xdd" 870 | | '\xde' -> Atom "\xde" 871 | | '\xdf' -> Atom "\xdf" 872 | | '\xe0' -> Atom "\xe0" 873 | | '\xe1' -> Atom "\xe1" 874 | | '\xe2' -> Atom "\xe2" 875 | | '\xe3' -> Atom "\xe3" 876 | | '\xe4' -> Atom "\xe4" 877 | | '\xe5' -> Atom "\xe5" 878 | | '\xe6' -> Atom "\xe6" 879 | | '\xe7' -> Atom "\xe7" 880 | | '\xe8' -> Atom "\xe8" 881 | | '\xe9' -> Atom "\xe9" 882 | | '\xea' -> Atom "\xea" 883 | | '\xeb' -> Atom "\xeb" 884 | | '\xec' -> Atom "\xec" 885 | | '\xed' -> Atom "\xed" 886 | | '\xee' -> Atom "\xee" 887 | | '\xef' -> Atom "\xef" 888 | | '\xf0' -> Atom "\xf0" 889 | | '\xf1' -> Atom "\xf1" 890 | | '\xf2' -> Atom "\xf2" 891 | | '\xf3' -> Atom "\xf3" 892 | | '\xf4' -> Atom "\xf4" 893 | | '\xf5' -> Atom "\xf5" 894 | | '\xf6' -> Atom "\xf6" 895 | | '\xf7' -> Atom "\xf7" 896 | | '\xf8' -> Atom "\xf8" 897 | | '\xf9' -> Atom "\xf9" 898 | | '\xfa' -> Atom "\xfa" 899 | | '\xfb' -> Atom "\xfb" 900 | | '\xfc' -> Atom "\xfc" 901 | | '\xfd' -> Atom "\xfd" 902 | | '\xfe' -> Atom "\xfe" 903 | | '\xff' -> Atom "\xff" 904 | ;; 905 | 906 | (*$*) 907 | 908 | let[@inline always] is_valid_char (char : char) : bool = Char.code char land lnot 0xff = 0 909 | 910 | let[@inline never] [@local never] [@specialise never] fallback_sexp_of_char (char : char) = 911 | Atom ((String.make [@inlined never]) 1 char) 912 | ;; 913 | 914 | let[@inline always] sexp_of_char (char : char) = 915 | if is_valid_char char 916 | then sexp_of_char_statically_allocated char [@tail] 917 | else fallback_sexp_of_char char [@tail] 918 | ;; 919 | 920 | let[@inline never] [@local never] [@specialise never] fallback_sexp_of_char__local 921 | (char : char) 922 | = 923 | Atom ((string_make_local [@inlined never]) 1 char) 924 | ;; 925 | 926 | let[@inline always] sexp_of_char__local (char : char) = 927 | if is_valid_char char 928 | then sexp_of_char_statically_allocated char 929 | else fallback_sexp_of_char__local char 930 | ;; 931 | -------------------------------------------------------------------------------- /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__local : ('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__local : 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__local : 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__local : 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__local : 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__local : 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__local : 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__local : 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__local : 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__local : 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__local : 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 -> Sexp.t) -> 'a ref -> Sexp.t 106 | 107 | (** As [sexp_of_ref], but returning a locally-allocated sexp. *) 108 | val sexp_of_ref__local : ('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 -> 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__local : ('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 -> Sexp.t) -> 'a option -> Sexp.t 120 | 121 | (** As [sexp_of_option], but returning a locally-allocated sexp. *) 122 | val sexp_of_option__local : ('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 -> 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__local : ('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 -> 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 -> Sexp.t) 140 | -> ('b -> Sexp.t) 141 | -> ('c -> Sexp.t) 142 | -> 'a * 'b * 'c 143 | -> Sexp.t 144 | 145 | (** [sexp_of_list conv lst] converts the value [lst] of type ['a list] to an S-expression. 146 | Uses [conv] to convert values of type ['a] to an S-expression. *) 147 | val sexp_of_list : ('a -> Sexp.t) -> 'a list -> Sexp.t 148 | 149 | (** As [sexp_of_list], but returning a locally-allocated sexp. *) 150 | val sexp_of_list__local : ('a -> Sexp.t) -> 'a list -> Sexp.t 151 | 152 | (** [sexp_of_array conv ar] converts the value [ar] of type ['a array] to an S-expression. 153 | Uses [conv] to convert values of type ['a] to an S-expression. *) 154 | val sexp_of_array : ('a -> Sexp.t) -> 'a array -> Sexp.t 155 | 156 | (** As [sexp_of_array], but returning a locally-allocated sexp. *) 157 | val sexp_of_array__local : ('a -> Sexp.t) -> 'a array -> Sexp.t 158 | 159 | (** [sexp_of_hashtbl conv_key conv_value htbl] converts the value [htbl] of type 160 | [('a, 'b) Hashtbl.t] to an S-expression. Uses [conv_key] to convert the hashtable keys 161 | of type ['a], and [conv_value] to convert hashtable values of type ['b] to 162 | S-expressions. *) 163 | val sexp_of_hashtbl : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) Hashtbl.t -> Sexp.t 164 | 165 | (** [sexp_of_opaque x] converts the value [x] of opaque type to an S-expression. This 166 | means the user need not provide converters, but the result cannot be interpreted. *) 167 | val sexp_of_opaque : 'a -> Sexp.t 168 | 169 | (** [sexp_of_fun f] converts the value [f] of function type to a dummy S-expression. 170 | Functions cannot be serialized as S-expressions, but at least a placeholder can be 171 | generated for pretty-printing. *) 172 | val sexp_of_fun : ('a -> 'b) -> Sexp.t 173 | 174 | (** {6 Conversion of S-expressions to OCaml-values} *) 175 | 176 | (** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be 177 | successfully converted to an OCaml-value. *) 178 | exception Of_sexp_error of exn * Sexp.t 179 | 180 | (** [record_check_extra_fields] checks for extra (= unknown) fields in record 181 | S-expressions. *) 182 | val record_check_extra_fields : bool Dynamic.t 183 | 184 | (** [of_sexp_error reason sexp] 185 | @raise Of_sexp_error (Failure reason, sexp). *) 186 | val of_sexp_error : string -> Sexp.t -> 'a 187 | 188 | (** [of_sexp_error exc sexp] 189 | @raise Of_sexp_error (exc, sexp). *) 190 | val of_sexp_error_exn : exn -> Sexp.t -> 'a 191 | 192 | (** [unit_of_sexp sexp] converts S-expression [sexp] to a value of type [unit]. *) 193 | val unit_of_sexp : Sexp.t -> unit 194 | 195 | (** [bool_of_sexp sexp] converts S-expression [sexp] to a value of type [bool]. *) 196 | val bool_of_sexp : Sexp.t -> bool 197 | 198 | (** [string_of_sexp sexp] converts S-expression [sexp] to a value of type [string]. *) 199 | val string_of_sexp : Sexp.t -> string 200 | 201 | (** [bytes_of_sexp sexp] converts S-expression [sexp] to a value of type [bytes]. *) 202 | val bytes_of_sexp : Sexp.t -> bytes 203 | 204 | (** [char_of_sexp sexp] converts S-expression [sexp] to a value of type [char]. *) 205 | val char_of_sexp : Sexp.t -> char 206 | 207 | (** [int_of_sexp sexp] converts S-expression [sexp] to a value of type [int]. *) 208 | val int_of_sexp : Sexp.t -> int 209 | 210 | (** [float_of_sexp sexp] converts S-expression [sexp] to a value of type [float]. *) 211 | val float_of_sexp : Sexp.t -> float 212 | 213 | (** [int32_of_sexp sexp] converts S-expression [sexp] to a value of type [int32]. *) 214 | val int32_of_sexp : Sexp.t -> int32 215 | 216 | (** [int64_of_sexp sexp] converts S-expression [sexp] to a value of type [int64]. *) 217 | val int64_of_sexp : Sexp.t -> int64 218 | 219 | (** [nativeint_of_sexp sexp] converts S-expression [sexp] to a value of type [nativeint]. *) 220 | val nativeint_of_sexp : Sexp.t -> nativeint 221 | 222 | (** [ref_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a ref] using 223 | conversion function [conv], which converts an S-expression to a value of type ['a]. *) 224 | val ref_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a ref 225 | 226 | (** [lazy_t_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a lazy_t] 227 | using conversion function [conv], which converts an S-expression to a value of type 228 | ['a]. *) 229 | val lazy_t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a lazy_t 230 | 231 | (** [option_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a option] 232 | using conversion function [conv], which converts an S-expression to a value of type 233 | ['a]. *) 234 | val option_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a option 235 | 236 | (** [option_of_sexp conv sexp] converts S-expression [sexp] to a value of type 237 | ['a or_null] using conversion function [conv], which converts an S-expression to a 238 | value of type ['a]. *) 239 | val or_null_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a Or_null_shim.t 240 | 241 | (** [pair_of_sexp conv1 conv2 sexp] converts S-expression [sexp] to a pair of type 242 | ['a * 'b] using conversion functions [conv1] and [conv2], which convert S-expressions 243 | to values of type ['a] and ['b] respectively. *) 244 | val pair_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> 'a * 'b 245 | 246 | (** [triple_of_sexp conv1 conv2 conv3 sexp] converts S-expression [sexp] to a triple of 247 | type ['a * 'b * 'c] using conversion functions [conv1], [conv2], and [conv3], which 248 | convert S-expressions to values of type ['a], ['b], and ['c] respectively. *) 249 | val triple_of_sexp 250 | : (Sexp.t -> 'a) 251 | -> (Sexp.t -> 'b) 252 | -> (Sexp.t -> 'c) 253 | -> Sexp.t 254 | -> 'a * 'b * 'c 255 | 256 | (** [list_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a list] 257 | using conversion function [conv], which converts an S-expression to a value of type 258 | ['a]. *) 259 | val list_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a list 260 | 261 | (** [array_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a array] 262 | using conversion function [conv], which converts an S-expression to a value of type 263 | ['a]. *) 264 | val array_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a array 265 | 266 | (** [hashtbl_of_sexp conv_key conv_value sexp] converts S-expression [sexp] to a value of 267 | type [('a, 'b) Hashtbl.t] using conversion function [conv_key], which converts an 268 | S-expression to hashtable key of type ['a], and function [conv_value], which converts 269 | an S-expression to hashtable value of type ['b]. *) 270 | val hashtbl_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) Hashtbl.t 271 | 272 | (** [opaque_of_sexp sexp] 273 | @raise Of_sexp_error when attempting to convert an S-expression to an opaque value. *) 274 | val opaque_of_sexp : Sexp.t -> 'a 275 | 276 | (** [fun_of_sexp sexp] 277 | @raise Of_sexp_error when attempting to convert an S-expression to a function. *) 278 | val fun_of_sexp : Sexp.t -> 'a 279 | 280 | (** Sexp Grammars *) 281 | 282 | include module type of struct 283 | include Sexp_conv_grammar 284 | end 285 | 286 | (** Exception converters *) 287 | 288 | (** [sexp_of_exn exc] converts exception [exc] to an S-expression. If no suitable 289 | converter is found, the standard converter in [Printexc] will be used to generate an 290 | atomic S-expression. *) 291 | val sexp_of_exn : exn -> Sexp.t 292 | 293 | (** Converts an exception to a string via sexp, falling back to [Printexc.to_string] if no 294 | sexp conversion is registered for this exception. 295 | 296 | This is different from [Printexc.to_string] in that it additionally uses the sexp 297 | converters registered with [~printexc:false]. Another difference is that the behavior 298 | of [Printexc] can be overridden with [Printexc.register], but here we always try sexp 299 | conversion first. *) 300 | val printexc_prefer_sexp : exn -> string 301 | 302 | (** [sexp_of_exn_opt exc] converts exception [exc] to [Some sexp]. If no suitable 303 | converter is found, [None] is returned instead. *) 304 | val sexp_of_exn_opt : exn -> Sexp.t option 305 | 306 | module Exn_converter : sig 307 | (** [add constructor sexp_of_exn] registers exception S-expression converter 308 | [sexp_of_exn] for exceptions with the given [constructor]. 309 | 310 | NOTE: [finalise] is ignored, and provided only for backward compatibility. *) 311 | val add 312 | : ?printexc:bool 313 | -> ?finalise:bool 314 | -> extension_constructor 315 | -> (exn -> Sexp.t) 316 | -> unit 317 | 318 | module For_unit_tests_only : sig 319 | val size : unit -> int 320 | end 321 | end 322 | 323 | (**/**) 324 | 325 | (*_ For the syntax extension *) 326 | external ignore : (_[@local_opt]) -> unit = "%ignore" 327 | external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" 328 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 42 | -------------------------------------------------------------------------------- /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 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 Sexp_grammar.t -> 'a option Sexp_grammar.t 29 | val list_sexp_grammar : 'a Sexp_grammar.t -> 'a list Sexp_grammar.t 30 | val array_sexp_grammar : 'a Sexp_grammar.t -> 'a array Sexp_grammar.t 31 | val opaque_sexp_grammar : 'a Sexp_grammar.t 32 | val fun_sexp_grammar : 'a Sexp_grammar.t 33 | -------------------------------------------------------------------------------- /src/sexp_conv_labeled_tuple.ml: -------------------------------------------------------------------------------- 1 | module Fields = struct 2 | type _ t = 3 | | Field : 4 | { name : string 5 | ; conv : Sexp.t -> 'a 6 | ; rest : 'b t 7 | } 8 | -> ('a * 'b) t 9 | | Empty : unit t 10 | 11 | let rec length_loop : type a. a t -> int -> int = 12 | fun t acc -> 13 | match t with 14 | | Empty -> acc 15 | | Field field -> length_loop field.rest (acc + 1) 16 | ;; 17 | 18 | let length t = length_loop t 0 19 | end 20 | 21 | let[@tail_mod_cons] rec of_list 22 | : type a. 23 | caller:string 24 | -> fields:a Fields.t 25 | -> len:int 26 | -> original_sexp:Sexp.t 27 | -> pos:int 28 | -> Sexp.t list 29 | -> a 30 | = 31 | fun ~caller ~fields ~len ~original_sexp ~pos list -> 32 | match fields with 33 | | Empty -> 34 | (match list with 35 | | [] -> () 36 | | _ :: _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp) 37 | | Field { name; conv; rest } -> 38 | (match list with 39 | | [] -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp 40 | | sexp :: list -> 41 | (match sexp with 42 | | List [ Atom atom; sexp ] -> 43 | if String.equal atom name 44 | then 45 | ( conv sexp 46 | , of_list ~caller ~fields:rest ~len ~original_sexp ~pos:(pos + 1) list ) 47 | else Sexp_conv_error.tuple_incorrect_label caller name pos original_sexp 48 | | _ -> Sexp_conv_error.tuple_pair_expected caller name sexp)) 49 | ;; 50 | 51 | let labeled_tuple_of_sexp ~caller ~fields ~create original_sexp = 52 | let len = Fields.length fields in 53 | match (original_sexp : Sexp.t) with 54 | | Atom _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp 55 | | List list -> create (of_list ~caller ~fields ~len ~original_sexp ~pos:0 list) 56 | ;; 57 | -------------------------------------------------------------------------------- /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 | { name : string 9 | ; conv : Sexp.t -> 'a 10 | ; rest : 'b t 11 | } 12 | -> ('a * 'b) t 13 | | Empty : unit t 14 | end 15 | 16 | val labeled_tuple_of_sexp 17 | : caller:string 18 | -> fields:'a Fields.t 19 | -> create:('a -> 'b) 20 | -> Sexp.t 21 | -> 'b 22 | -------------------------------------------------------------------------------- /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 : (unit -> 'a) -> ('a, Sexp.t -> 'a) t 9 | | Omit_nil : ('a, Sexp.t -> 'a) t 10 | | Required : ('a, Sexp.t -> '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 | end 16 | 17 | module Layout_witness = struct 18 | type _ t = 19 | | Value : _ t 20 | | Any : 'a. (unit -> 'a) t 21 | end 22 | 23 | module Fields = struct 24 | type _ t = 25 | | Empty : unit t 26 | | Field : 27 | { name : string 28 | ; kind : ('a, 'conv) Kind.t 29 | ; layout : 'a Layout_witness.t 30 | ; conv : 'conv 31 | ; rest : 'b t 32 | } 33 | -> ('a * 'b) t 34 | 35 | let length = 36 | let rec length_loop : type a. a t -> int -> int = 37 | fun t acc -> 38 | match t with 39 | | Field { rest; _ } -> length_loop rest (acc + 1) 40 | | Empty -> acc 41 | in 42 | fun t -> length_loop t 0 43 | ;; 44 | end 45 | 46 | module Malformed = struct 47 | (* Represents errors that can occur due to malformed record sexps. Accumulated as a 48 | value so we can report multiple names at once for extra fields, duplicate fields, or 49 | missing fields. *) 50 | type t = 51 | | Bool_payload 52 | | Missing_and_extras of 53 | { missing : string list 54 | ; extras : string list 55 | } 56 | | Dups of string list 57 | | Non_pair of Sexp.t option 58 | 59 | let missing missing = Missing_and_extras { missing; extras = [] } 60 | let extras extras = Missing_and_extras { missing = []; extras } 61 | 62 | let combine a b = 63 | match a, b with 64 | (* choose the first bool-payload or non-pair error that occurs *) 65 | | ((Bool_payload | Non_pair _) as t), _ -> t 66 | | _, ((Bool_payload | Non_pair _) as t) -> t 67 | (* combine lists of similar errors *) 68 | | ( Missing_and_extras { missing = missing_a; extras = extras_a } 69 | , Missing_and_extras { missing = missing_b; extras = extras_b } ) -> 70 | Missing_and_extras { missing = missing_a @ missing_b; extras = extras_a @ extras_b } 71 | | Dups a, Dups b -> Dups (a @ b) 72 | (* otherwise, dups > extras > missing *) 73 | | (Dups _ as t), _ | _, (Dups _ as t) -> t 74 | ;; 75 | 76 | let raise t ~caller ~context = 77 | match t with 78 | | Bool_payload -> record_sexp_bool_with_payload caller context 79 | | Missing_and_extras { missing; extras } -> 80 | record_missing_and_extra_fields caller ~missing ~extras context 81 | | Dups names -> record_duplicate_fields caller names context 82 | | Non_pair maybe_context -> 83 | let context = Option.value maybe_context ~default:context in 84 | record_only_pairs_expected caller context 85 | ;; 86 | end 87 | 88 | exception Malformed of Malformed.t 89 | 90 | module State = struct 91 | (* Stores sexps corresponding to record fields, in the order the fields were declared. 92 | Excludes fields already parsed in the fast path. 93 | 94 | List sexps represent a field that is present, such as (x 1) for a field named "x". 95 | Atom sexps represent a field that is absent, or at least not yet seen. *) 96 | type t = { state : Sexp.t array } [@@unboxed] 97 | 98 | let unsafe_get t pos = Array.unsafe_get t.state pos 99 | let unsafe_set t pos sexp = Array.unsafe_set t.state pos sexp 100 | let create len = { state = Array.make len (Sexp.Atom "") } 101 | end 102 | 103 | (* Parsing field values from state. *) 104 | 105 | let rec parse_value_malformed 106 | : type a b. Malformed.t -> fields:(a * b) Fields.t -> state:State.t -> pos:int -> a 107 | = 108 | fun malformed ~fields ~state ~pos -> 109 | let (Field field) = fields in 110 | let malformed = 111 | match parse_values ~fields:field.rest ~state ~pos:(pos + 1) with 112 | | (_ : b) -> malformed 113 | | exception Malformed other -> Malformed.combine malformed other 114 | in 115 | raise (Malformed malformed) 116 | 117 | and parse_value : type a b. fields:(a * b) Fields.t -> state:State.t -> pos:int -> a * b = 118 | fun ~fields ~state ~pos -> 119 | let (Field { name; kind; conv; rest; layout = _ }) = fields in 120 | let value : a = 121 | match kind, State.unsafe_get state pos with 122 | (* well-formed *) 123 | | Required, List [ _; sexp ] -> conv sexp 124 | | Default _, List [ _; sexp ] -> conv sexp 125 | | Omit_nil, List [ _; sexp ] -> conv sexp 126 | | Sexp_option, List [ _; sexp ] -> Some (conv sexp) 127 | | Sexp_list, List [ _; sexp ] -> list_of_sexp conv sexp 128 | | Sexp_array, List [ _; sexp ] -> array_of_sexp conv sexp 129 | | Sexp_bool, List [ _ ] -> true 130 | (* ill-formed *) 131 | | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) 132 | , (List (_ :: _ :: _ :: _) as sexp) ) -> 133 | parse_value_malformed (Non_pair (Some sexp)) ~fields ~state ~pos 134 | | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) 135 | , List ([] | [ _ ]) ) -> parse_value_malformed (Non_pair None) ~fields ~state ~pos 136 | | Sexp_bool, List ([] | _ :: _ :: _) -> 137 | parse_value_malformed Bool_payload ~fields ~state ~pos 138 | (* absent *) 139 | | Required, Atom _ -> 140 | parse_value_malformed (Malformed.missing [ name ]) ~fields ~state ~pos 141 | | Default default, Atom _ -> default () 142 | | Omit_nil, Atom _ -> conv (List []) 143 | | Sexp_option, Atom _ -> None 144 | | Sexp_list, Atom _ -> [] 145 | | Sexp_array, Atom _ -> [||] 146 | | Sexp_bool, Atom _ -> false 147 | in 148 | value, parse_values ~fields:rest ~state ~pos:(pos + 1) 149 | 150 | and parse_values : type a. fields:a Fields.t -> state:State.t -> pos:int -> a = 151 | fun ~fields ~state ~pos -> 152 | match fields with 153 | | Field _ -> parse_value ~fields ~state ~pos 154 | | Empty -> () 155 | ;; 156 | 157 | (* Populating state. Handles slow path cases where there may be reordered, duplicated, 158 | missing, or extra fields. *) 159 | 160 | let rec parse_spine_malformed malformed ~index ~extra ~seen ~state ~len sexps = 161 | let malformed = 162 | match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with 163 | | () -> malformed 164 | | exception Malformed other -> Malformed.combine malformed other 165 | in 166 | raise (Malformed malformed) 167 | 168 | and parse_spine_slow ~index ~extra ~seen ~state ~len sexps = 169 | match (sexps : Sexp.t list) with 170 | | [] -> () 171 | | (List (Atom name :: _) as field) :: sexps -> 172 | let i = index name in 173 | (match seen <= i && i < len with 174 | | true -> 175 | (* valid field for slow-path parsing *) 176 | let pos = i - seen in 177 | (match State.unsafe_get state pos with 178 | | Atom _ -> 179 | (* field not seen yet *) 180 | State.unsafe_set state pos field; 181 | parse_spine_slow ~index ~extra ~seen ~state ~len sexps 182 | | List _ -> 183 | (* field already seen *) 184 | parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps) 185 | | false -> 186 | (match 0 <= i && i < seen with 187 | | true -> 188 | (* field seen in fast path *) 189 | parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps 190 | | false -> 191 | (* extra field *) 192 | (match extra with 193 | | true -> parse_spine_slow ~index ~extra ~seen ~state ~len sexps 194 | | false -> 195 | parse_spine_malformed 196 | (Malformed.extras [ name ]) 197 | ~index 198 | ~extra 199 | ~seen 200 | ~state 201 | ~len 202 | sexps))) 203 | | sexp :: sexps -> 204 | parse_spine_malformed (Non_pair (Some sexp)) ~index ~extra ~seen ~state ~len sexps 205 | ;; 206 | 207 | (* Slow path for record parsing. Uses state to store fields as they are discovered. *) 208 | 209 | let parse_record_slow ~fields ~index ~extra ~seen sexps = 210 | let unseen = Fields.length fields in 211 | let state = State.create unseen in 212 | let len = seen + unseen in 213 | (* populate state *) 214 | let maybe_malformed = 215 | match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with 216 | | exception Malformed malformed -> Some malformed 217 | | () -> None 218 | in 219 | (* parse values from state *) 220 | let parsed_or_malformed = 221 | match parse_values ~fields ~state ~pos:0 with 222 | | values -> Ok values 223 | | exception Malformed malformed -> Error malformed 224 | in 225 | match maybe_malformed, parsed_or_malformed with 226 | | None, Ok values -> values 227 | | Some malformed, Ok _ | None, Error malformed -> raise (Malformed malformed) 228 | | Some malformed1, Error malformed2 -> 229 | raise (Malformed (Malformed.combine malformed1 malformed2)) 230 | ;; 231 | 232 | (* Fast path for record parsing. Directly parses and returns fields in the order they are 233 | declared. Falls back on slow path if any fields are absent, reordered, or malformed. *) 234 | 235 | let rec parse_field_fast 236 | : type a b. 237 | fields:(a * b) Fields.t 238 | -> index:(string -> int) 239 | -> extra:bool 240 | -> seen:int 241 | -> Sexp.t list 242 | -> a * b 243 | = 244 | fun ~fields ~index ~extra ~seen sexps -> 245 | let (Field { name; kind; conv; rest; layout = _ }) = fields in 246 | match sexps with 247 | | List (Atom atom :: args) :: others when String.equal atom name -> 248 | (match kind, args with 249 | | Required, [ sexp ] -> 250 | conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others 251 | | Default _, [ sexp ] -> 252 | conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others 253 | | Omit_nil, [ sexp ] -> 254 | conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others 255 | | Sexp_option, [ sexp ] -> 256 | ( Some (conv sexp) 257 | , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) 258 | | Sexp_list, [ sexp ] -> 259 | ( list_of_sexp conv sexp 260 | , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) 261 | | Sexp_array, [ sexp ] -> 262 | ( array_of_sexp conv sexp 263 | , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) 264 | | Sexp_bool, [] -> 265 | true, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others 266 | (* malformed field of some kind, dispatch to slow path *) 267 | | _, _ -> parse_record_slow ~fields ~index ~extra ~seen sexps) 268 | (* malformed or out-of-order field, dispatch to slow path *) 269 | | _ -> parse_record_slow ~fields ~index ~extra ~seen sexps 270 | 271 | and parse_spine_fast 272 | : type a. 273 | fields:a Fields.t 274 | -> index:(string -> int) 275 | -> extra:bool 276 | -> seen:int 277 | -> Sexp.t list 278 | -> a 279 | = 280 | fun ~fields ~index ~extra ~seen sexps -> 281 | match fields with 282 | | Field _ -> parse_field_fast ~fields ~index ~extra ~seen sexps 283 | | Empty -> 284 | (match sexps with 285 | | [] -> () 286 | | _ :: _ -> 287 | (* extra sexps, dispatch to slow path *) 288 | parse_record_slow ~fields ~index ~extra ~seen sexps) 289 | ;; 290 | 291 | let parse_record_fast ~fields ~index ~extra sexps = 292 | parse_spine_fast ~fields ~index ~extra ~seen:0 sexps 293 | ;; 294 | 295 | (* Entry points. *) 296 | 297 | let record_of_sexps 298 | ~caller 299 | ~context 300 | ~fields 301 | ~index_of_field 302 | ~allow_extra_fields 303 | ~create 304 | sexps 305 | = 306 | let allow_extra_fields = 307 | allow_extra_fields || not (Dynamic.get Sexp_conv.record_check_extra_fields) 308 | in 309 | match 310 | parse_record_fast ~fields ~index:index_of_field ~extra:allow_extra_fields sexps 311 | with 312 | | value -> create value 313 | | exception Malformed malformed -> Malformed.raise malformed ~caller ~context 314 | ;; 315 | 316 | let record_of_sexp ~caller ~fields ~index_of_field ~allow_extra_fields ~create sexp = 317 | match (sexp : Sexp.t) with 318 | | Atom _ as context -> record_list_instead_atom caller context 319 | | List sexps as context -> 320 | record_of_sexps 321 | ~caller 322 | ~context 323 | ~fields 324 | ~index_of_field 325 | ~allow_extra_fields 326 | ~create 327 | sexps 328 | ;; 329 | -------------------------------------------------------------------------------- /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 : (unit -> 'a) -> ('a, Sexp.t -> 'a) t 6 | | Omit_nil : ('a, Sexp.t -> 'a) t 7 | | Required : ('a, Sexp.t -> '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 | end 13 | 14 | (** Non-value fields must be stored as a closure [unit -> 'a] instead of as ['a] directly. 15 | This is because we can't store non-value things in arbitrary records. This closure 16 | involves some additional overhead not present in value fields. 17 | 18 | Users use [@sexp.non_value] to mark a field as a non-value. This carries the extra 19 | overhead explained above. *) 20 | module Layout_witness : sig 21 | type _ t = 22 | | Value : _ t 23 | | Any : 'a. (unit -> 'a) t 24 | end 25 | 26 | module Fields : sig 27 | (** A GADT specifying record fields. *) 28 | 29 | type _ t = 30 | | Empty : unit t 31 | | Field : 32 | { name : string 33 | ; kind : ('a, 'conv) Kind.t 34 | ; layout : 'a Layout_witness.t 35 | ; conv : 'conv 36 | ; rest : 'b t 37 | } 38 | -> ('a * 'b) t 39 | end 40 | 41 | (** Parses a record from a sexp that must be a list of fields. 42 | 43 | Uses [caller] as the source for error messages. Parses using the given [field]s. Uses 44 | [index_of_field] to look up field names found in sexps. If [allow_extra_fields] is 45 | true, extra fields are allowed and discarded without error. [create] is used to 46 | construct the final returned value. *) 47 | val record_of_sexp 48 | : caller:string 49 | -> fields:'a Fields.t 50 | -> index_of_field:(string -> int) 51 | -> allow_extra_fields:bool 52 | -> create:('a -> 'b) 53 | -> Sexp.t 54 | -> 'b 55 | 56 | (** Like [record_of_sexp], but for a list of sexps with no [List] wrapper. Used, for 57 | example, to parse arguments to a variant constructor with an inlined record argument. 58 | Reports [context] for parse errors when no more specific sexp is applicable. *) 59 | val record_of_sexps 60 | : caller:string 61 | -> context:Sexp.t 62 | -> fields:'a Fields.t 63 | -> index_of_field:(string -> int) 64 | -> allow_extra_fields:bool 65 | -> create:('a -> 'b) 66 | -> Sexp.t list 67 | -> 'b 68 | -------------------------------------------------------------------------------- /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" 15 | -------------------------------------------------------------------------------- /src/sexp_grammar.mli: -------------------------------------------------------------------------------- 1 | include Sexp_grammar_intf.Sexp_grammar 2 | -------------------------------------------------------------------------------- /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 t -> 'b t 190 | 191 | (** Add a key/value tag to a grammar. *) 192 | val tag : '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 216 | -------------------------------------------------------------------------------- /src/sexpable.ml: -------------------------------------------------------------------------------- 1 | module type S_any = sig 2 | type t 3 | 4 | val t_of_sexp : Sexp.t -> t 5 | val sexp_of_t : t -> Sexp.t 6 | end 7 | 8 | module type S_any__local = sig 9 | include S_any 10 | 11 | val sexp_of_t__local : t -> Sexp.t 12 | end 13 | 14 | module type S = sig 15 | type t 16 | 17 | include S_any with type t := t 18 | end 19 | 20 | module type S__local = sig 21 | type t 22 | 23 | include S_any__local with type t := t 24 | end 25 | 26 | module type S_any1 = sig 27 | type 'a t 28 | 29 | val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t 30 | val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t 31 | end 32 | 33 | module type S_any1__local = sig 34 | include S_any1 35 | 36 | val sexp_of_t__local : ('a -> Sexp.t) -> 'a t -> Sexp.t 37 | end 38 | 39 | module type S1 = sig 40 | type 'a t 41 | 42 | include S_any1 with type 'a t := 'a t 43 | end 44 | 45 | module type S1__local = sig 46 | type 'a t 47 | 48 | include S_any1__local with type 'a t := 'a t 49 | end 50 | 51 | module type S_any2 = sig 52 | type ('a, 'b) t 53 | 54 | val t_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t 55 | val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t 56 | end 57 | 58 | module type S_any2__local = sig 59 | include S_any2 60 | 61 | val sexp_of_t__local : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t 62 | end 63 | 64 | module type S2 = sig 65 | type ('a, 'b) t 66 | 67 | include S_any2 with type ('a, 'b) t := ('a, 'b) t 68 | end 69 | 70 | module type S2__local = sig 71 | type ('a, 'b) t 72 | 73 | include S_any2__local with type ('a, 'b) t := ('a, 'b) t 74 | end 75 | 76 | module type S_any3 = sig 77 | type ('a, 'b, 'c) t 78 | 79 | val t_of_sexp 80 | : (Sexp.t -> 'a) 81 | -> (Sexp.t -> 'b) 82 | -> (Sexp.t -> 'c) 83 | -> Sexp.t 84 | -> ('a, 'b, 'c) t 85 | 86 | val sexp_of_t 87 | : ('a -> Sexp.t) 88 | -> ('b -> Sexp.t) 89 | -> ('c -> Sexp.t) 90 | -> ('a, 'b, 'c) t 91 | -> Sexp.t 92 | end 93 | 94 | module type S_any3__local = sig 95 | include S_any3 96 | 97 | val sexp_of_t__local 98 | : ('a -> Sexp.t) 99 | -> ('b -> Sexp.t) 100 | -> ('c -> Sexp.t) 101 | -> ('a, 'b, 'c) t 102 | -> Sexp.t 103 | end 104 | 105 | module type S3 = sig 106 | type ('a, 'b, 'c) t 107 | 108 | include S_any3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t 109 | end 110 | 111 | module type S3__local = sig 112 | type ('a, 'b, 'c) t 113 | 114 | include S_any3__local with type ('a, 'b, 'c) t := ('a, 'b, 'c) t 115 | end 116 | 117 | module type S_with_grammar = sig 118 | include S 119 | 120 | val t_sexp_grammar : t Sexp_grammar.t 121 | end 122 | 123 | module type S1_with_grammar = sig 124 | include S1 125 | 126 | val t_sexp_grammar : 'a Sexp_grammar.t -> 'a t Sexp_grammar.t 127 | end 128 | 129 | module type S2_with_grammar = sig 130 | include S2 131 | 132 | val t_sexp_grammar : 'a Sexp_grammar.t -> 'b Sexp_grammar.t -> ('a, 'b) t Sexp_grammar.t 133 | end 134 | 135 | module type S3_with_grammar = sig 136 | include S3 137 | 138 | val t_sexp_grammar 139 | : 'a Sexp_grammar.t 140 | -> 'b Sexp_grammar.t 141 | -> 'c Sexp_grammar.t 142 | -> ('a, 'b, 'c) t Sexp_grammar.t 143 | end 144 | -------------------------------------------------------------------------------- /src/sexplib0.ml: -------------------------------------------------------------------------------- 1 | module Sexp = Sexp 2 | module Sexp_conv = Sexp_conv 3 | module Sexp_conv_error = Sexp_conv_error 4 | module Sexp_conv_record = Sexp_conv_record 5 | module Sexp_conv_labeled_tuple = Sexp_conv_labeled_tuple 6 | module Sexp_grammar = Sexp_grammar 7 | module Sexpable = Sexpable 8 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sexplib0_test) 3 | (libraries base expect_test_helpers_core.expect_test_helpers_base parsexp 4 | sexplib sexplib0) 5 | (preprocess 6 | (pps ppx_compare ppx_expect ppx_here ppx_sexp_conv ppx_sexp_value))) 7 | -------------------------------------------------------------------------------- /test/sexplib0_test.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Expect_test_helpers_base 3 | open Sexplib0 4 | 5 | let () = 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 | (** All possible ways of constructing [Sexp_conv_record.Layout_witness.t] values, together 18 | with a uniform interface for manipulating them. The tests below use this uniform 19 | interface to write tests that try all possible combinations of layouts (i.e., both 20 | [Any] and [Value]). *) 21 | module Layout_impl = struct 22 | type (_, _) t = 23 | | Value : ('a, 'a) t 24 | | Any : ('a, unit -> 'a) t 25 | 26 | type _ packed = T : ('a, _) t -> 'a packed [@@unboxed] 27 | 28 | let all = [ T Value; T Any ] 29 | let all_pairs () = List.cartesian_product all all 30 | 31 | let value : type a b. (a, b) t -> b -> a = function 32 | | Value -> fun x -> x 33 | | Any -> fun f -> f () 34 | ;; 35 | end 36 | 37 | let field 38 | : type a b c conv. 39 | name:string 40 | -> kind:(a, conv) Sexp_conv_record.Kind.t 41 | -> impl:(a, b) Layout_impl.t 42 | -> conv:conv 43 | -> rest:c Sexp_conv_record.Fields.t 44 | -> (b * c) Sexp_conv_record.Fields.t 45 | = 46 | fun ~name ~kind ~impl ~conv ~rest -> 47 | let const x () = x in 48 | let thunk f x = const (f x) in 49 | match impl with 50 | | Value -> Field { name; kind; layout = Value; conv; rest } 51 | | Any -> 52 | (match kind with 53 | | Default f -> 54 | Field { name; kind = Default (thunk f); layout = Value; conv = thunk conv; rest } 55 | | Omit_nil -> 56 | Field { name; kind = Omit_nil; layout = Value; conv = thunk conv; rest } 57 | | Required -> 58 | Field { name; kind = Required; layout = Value; conv = thunk conv; rest } 59 | | Sexp_array | Sexp_bool | Sexp_list | Sexp_option -> 60 | failwith "[array], [bool], [list], and [option] all have layout [value]") 61 | ;; 62 | 63 | let%expect_test "simple record" = 64 | List.iter (Layout_impl.all_pairs ()) ~f:(fun (T impl1, T impl2) -> 65 | let module M = struct 66 | type t = 67 | { x : int 68 | ; y : int 69 | } 70 | [@@deriving equal, sexp_of] 71 | 72 | let t_of_sexp sexp = 73 | Sexp_conv_record.record_of_sexp 74 | sexp 75 | ~caller:"M.t" 76 | ~fields: 77 | (field 78 | ~name:"x" 79 | ~kind:Required 80 | ~impl:impl1 81 | ~conv:int_of_sexp 82 | ~rest: 83 | (field 84 | ~name:"y" 85 | ~kind:Required 86 | ~impl:impl2 87 | ~conv:int_of_sexp 88 | ~rest:Empty)) 89 | ~index_of_field:(function 90 | | "x" -> 0 91 | | "y" -> 1 92 | | _ -> -1) 93 | ~allow_extra_fields:false 94 | ~create:(fun (x, (y, ())) -> 95 | { x = Layout_impl.value impl1 x; y = Layout_impl.value impl2 y }) 96 | ;; 97 | end 98 | in 99 | let test = test (module M) in 100 | (* in order *) 101 | test "((x 1) (y 2))"; 102 | [%expect {| (Ok ((x 1) (y 2))) |}]; 103 | (* reverse order *) 104 | test "((y 2) (x 1))"; 105 | [%expect {| (Ok ((x 1) (y 2))) |}]; 106 | (* duplicate fields *) 107 | test "((x 1) (x 2) (y 3) (y 4))"; 108 | [%expect 109 | {| 110 | (Error 111 | (Of_sexp_error 112 | "M.t_of_sexp: duplicate fields: x y" 113 | (invalid_sexp ((x 1) (x 2) (y 3) (y 4))))) 114 | |}]; 115 | (* extra fields *) 116 | test "((a 1) (b 2) (c 3))"; 117 | [%expect 118 | {| 119 | (Error 120 | (Of_sexp_error 121 | "M.t_of_sexp: extra fields found while some fields missing; extra fields: a b c; missing fields: x y" 122 | (invalid_sexp ((a 1) (b 2) (c 3))))) 123 | |}]; 124 | (* missing field *) 125 | test "((x 1))"; 126 | [%expect 127 | {| 128 | (Error 129 | (Of_sexp_error "M.t_of_sexp: missing fields: y" (invalid_sexp ((x 1))))) 130 | |}]; 131 | (* other missing field *) 132 | test "((y 2))"; 133 | [%expect 134 | {| 135 | (Error 136 | (Of_sexp_error "M.t_of_sexp: missing fields: x" (invalid_sexp ((y 2))))) 137 | |}]; 138 | (* multiple missing fields *) 139 | test "()"; 140 | [%expect 141 | {| (Error (Of_sexp_error "M.t_of_sexp: missing fields: x y" (invalid_sexp ()))) |}]; 142 | ()) 143 | ;; 144 | 145 | let%expect_test "record with extra fields" = 146 | List.iter (Layout_impl.all_pairs ()) ~f:(fun (T impl1, T impl2) -> 147 | let module M = struct 148 | type t = 149 | { x : int 150 | ; y : int 151 | } 152 | [@@deriving equal, sexp_of] 153 | 154 | let t_of_sexp = 155 | Sexp_conv_record.record_of_sexp 156 | ~caller:"M.t" 157 | ~fields: 158 | (field 159 | ~name:"x" 160 | ~kind:Required 161 | ~impl:impl1 162 | ~conv:int_of_sexp 163 | ~rest: 164 | (field 165 | ~name:"y" 166 | ~kind:Required 167 | ~impl:impl2 168 | ~conv:int_of_sexp 169 | ~rest:Empty)) 170 | ~index_of_field:(function 171 | | "x" -> 0 172 | | "y" -> 1 173 | | _ -> -1) 174 | ~allow_extra_fields:true 175 | ~create:(fun (x, (y, ())) -> 176 | { x = Layout_impl.value impl1 x; y = Layout_impl.value impl2 y }) 177 | ;; 178 | end 179 | in 180 | let test = test (module M) in 181 | (* in order *) 182 | test "((x 1) (y 2))"; 183 | [%expect {| (Ok ((x 1) (y 2))) |}]; 184 | (* reversed order *) 185 | test "((y 2) (x 1))"; 186 | [%expect {| (Ok ((x 1) (y 2))) |}]; 187 | (* extra field *) 188 | test "((x 1) (y 2) (z 3))"; 189 | [%expect {| (Ok ((x 1) (y 2))) |}]; 190 | (* missing field *) 191 | test "((x 1))"; 192 | [%expect 193 | {| 194 | (Error 195 | (Of_sexp_error "M.t_of_sexp: missing fields: y" (invalid_sexp ((x 1))))) 196 | |}]; 197 | (* other missing field *) 198 | test "((y 2))"; 199 | [%expect 200 | {| 201 | (Error 202 | (Of_sexp_error "M.t_of_sexp: missing fields: x" (invalid_sexp ((y 2))))) 203 | |}]; 204 | (* multiple missing fields *) 205 | test "()"; 206 | [%expect 207 | {| (Error (Of_sexp_error "M.t_of_sexp: missing fields: x y" (invalid_sexp ()))) |}]; 208 | ()) 209 | ;; 210 | 211 | let%expect_test "record with defaults" = 212 | List.iter (Layout_impl.all_pairs ()) ~f:(fun (T impl1, T impl2) -> 213 | let module M = struct 214 | type t = 215 | { x : int 216 | ; y : int 217 | } 218 | [@@deriving equal, sexp_of] 219 | 220 | let t_of_sexp = 221 | Sexp_conv_record.record_of_sexp 222 | ~caller:"M.t" 223 | ~fields: 224 | (field 225 | ~name:"x" 226 | ~kind:(Default (fun () -> 0)) 227 | ~impl:impl1 228 | ~conv:int_of_sexp 229 | ~rest: 230 | (field 231 | ~name:"y" 232 | ~kind:(Default (fun () -> 0)) 233 | ~impl:impl2 234 | ~conv:int_of_sexp 235 | ~rest:Empty)) 236 | ~index_of_field:(function 237 | | "x" -> 0 238 | | "y" -> 1 239 | | _ -> -1) 240 | ~allow_extra_fields:false 241 | ~create:(fun (x, (y, ())) -> 242 | { x = Layout_impl.value impl1 x; y = Layout_impl.value impl2 y }) 243 | ;; 244 | end 245 | in 246 | let test = test (module M) in 247 | (* in order *) 248 | test "((x 1) (y 2))"; 249 | [%expect {| (Ok ((x 1) (y 2))) |}]; 250 | (* reverse order *) 251 | test "((y 2) (x 1))"; 252 | [%expect {| (Ok ((x 1) (y 2))) |}]; 253 | (* extra field *) 254 | test "((x 1) (y 2) (z 3))"; 255 | [%expect 256 | {| 257 | (Error 258 | (Of_sexp_error 259 | "M.t_of_sexp: extra fields: z" 260 | (invalid_sexp ((x 1) (y 2) (z 3))))) 261 | |}]; 262 | (* missing field *) 263 | test "((x 1))"; 264 | [%expect {| (Ok ((x 1) (y 0))) |}]; 265 | (* other missing field *) 266 | test "((y 2))"; 267 | [%expect {| (Ok ((x 0) (y 2))) |}]; 268 | (* multiple missing fields *) 269 | test "()"; 270 | [%expect {| (Ok ((x 0) (y 0))) |}]; 271 | ()) 272 | ;; 273 | 274 | let%expect_test "record with omit nil" = 275 | List.iter (Layout_impl.all_pairs ()) ~f:(fun (T impl1, T impl2) -> 276 | let module M = struct 277 | type t = 278 | { a : int option 279 | ; b : int list 280 | } 281 | [@@deriving equal, sexp_of] 282 | 283 | let t_of_sexp = 284 | Sexp_conv_record.record_of_sexp 285 | ~caller:"M.t" 286 | ~fields: 287 | (field 288 | ~name:"a" 289 | ~kind:Omit_nil 290 | ~impl:impl1 291 | ~conv:(option_of_sexp int_of_sexp) 292 | ~rest: 293 | (field 294 | ~name:"b" 295 | ~kind:Omit_nil 296 | ~impl:impl2 297 | ~conv:(list_of_sexp int_of_sexp) 298 | ~rest:Empty)) 299 | ~index_of_field:(function 300 | | "a" -> 0 301 | | "b" -> 1 302 | | _ -> -1) 303 | ~allow_extra_fields:false 304 | ~create:(fun (a, (b, ())) -> 305 | { a = Layout_impl.value impl1 a; b = Layout_impl.value impl2 b }) 306 | ;; 307 | end 308 | in 309 | let test = test (module M) in 310 | (* in order *) 311 | test "((a (1)) (b (2 3)))"; 312 | [%expect {| (Ok ((a (1)) (b (2 3)))) |}]; 313 | (* reverse order *) 314 | test "((b ()) (a ()))"; 315 | [%expect {| (Ok ((a ()) (b ()))) |}]; 316 | (* extra field *) 317 | test "((a (1)) (b (2 3)) (z ()))"; 318 | [%expect 319 | {| 320 | (Error 321 | (Of_sexp_error 322 | "M.t_of_sexp: extra fields: z" 323 | (invalid_sexp ((a (1)) (b (2 3)) (z ()))))) 324 | |}]; 325 | (* missing field *) 326 | test "((a (1)))"; 327 | [%expect {| (Ok ((a (1)) (b ()))) |}]; 328 | (* other missing field *) 329 | test "((b (2 3)))"; 330 | [%expect {| (Ok ((a ()) (b (2 3)))) |}]; 331 | (* multiple missing fields *) 332 | test "()"; 333 | [%expect {| (Ok ((a ()) (b ()))) |}]; 334 | ()) 335 | ;; 336 | 337 | let%expect_test "record with sexp types" = 338 | let module M = struct 339 | type t = 340 | { a : int option 341 | ; b : int list 342 | ; c : int array 343 | ; d : bool 344 | } 345 | [@@deriving equal, sexp_of] 346 | 347 | let t_of_sexp = 348 | Sexp_conv_record.record_of_sexp 349 | ~caller:"M.t" 350 | ~fields: 351 | (Field 352 | { name = "a" 353 | ; kind = Sexp_option 354 | ; layout = Value 355 | ; conv = int_of_sexp 356 | ; rest = 357 | Field 358 | { name = "b" 359 | ; kind = Sexp_list 360 | ; layout = Value 361 | ; conv = int_of_sexp 362 | ; rest = 363 | Field 364 | { name = "c" 365 | ; kind = Sexp_array 366 | ; layout = Value 367 | ; conv = int_of_sexp 368 | ; rest = 369 | Field 370 | { name = "d" 371 | ; kind = Sexp_bool 372 | ; layout = Value 373 | ; conv = () 374 | ; rest = Empty 375 | } 376 | } 377 | } 378 | }) 379 | ~index_of_field:(function 380 | | "a" -> 0 381 | | "b" -> 1 382 | | "c" -> 2 383 | | "d" -> 3 384 | | _ -> -1) 385 | ~allow_extra_fields:false 386 | ~create:(fun (a, (b, (c, (d, ())))) -> { a; b; c; d }) 387 | ;; 388 | end 389 | in 390 | let test = test (module M) in 391 | (* in order *) 392 | test "((a 1) (b (2 3)) (c (4 5)) (d))"; 393 | [%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d true))) |}]; 394 | (* reverse order *) 395 | test "((d) (c ()) (b ()) (a 1))"; 396 | [%expect {| (Ok ((a (1)) (b ()) (c ()) (d true))) |}]; 397 | (* missing field d *) 398 | test "((a 1) (b (2 3)) (c (4 5)))"; 399 | [%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d false))) |}]; 400 | (* missing field c *) 401 | test "((a 1) (b (2 3)) (d))"; 402 | [%expect {| (Ok ((a (1)) (b (2 3)) (c ()) (d true))) |}]; 403 | (* missing field b *) 404 | test "((a 1) (c (2 3)) (d))"; 405 | [%expect {| (Ok ((a (1)) (b ()) (c (2 3)) (d true))) |}]; 406 | (* missing field a *) 407 | test "((b (1 2)) (c (3 4)) (d))"; 408 | [%expect {| (Ok ((a ()) (b (1 2)) (c (3 4)) (d true))) |}]; 409 | (* extra field *) 410 | test "((a 1) (b (2 3)) (c (4 5)) (d) (e (6 7)))"; 411 | [%expect 412 | {| 413 | (Error 414 | (Of_sexp_error 415 | "M.t_of_sexp: extra fields: e" 416 | (invalid_sexp ((a 1) (b (2 3)) (c (4 5)) (d) (e (6 7)))))) 417 | |}]; 418 | (* all fields missing *) 419 | test "()"; 420 | [%expect {| (Ok ((a ()) (b ()) (c ()) (d false))) |}]; 421 | () 422 | ;; 423 | 424 | let%expect_test "record with polymorphic fields" = 425 | let module M = struct 426 | type t = 427 | { a : 'a. 'a list 428 | ; b : 'a 'b. ('a, 'b) Result.t option 429 | } 430 | [@@deriving sexp_of] 431 | 432 | let equal = Poly.equal 433 | 434 | type a = { a : 'a. 'a list } [@@unboxed] 435 | type b = { b : 'a 'b. ('a, 'b) Result.t option } [@@unboxed] 436 | end 437 | in 438 | (* Unlike other tests, we write the skeleton of module [M] before performing the nested 439 | iteration over layout impls. This is for a silly OCaml value-restriction-flavored 440 | reason, not for a good reason: the below [all_pairs ()] introduces a weak type 441 | variable. That weak type variable ends up needs to unify with the local type [M.a] 442 | (and another one with [M.b]), so it's necessary for these local types to be defined 443 | first so this unification is not considered to make them "escape their scope". 444 | *) 445 | List.iter (Layout_impl.all_pairs ()) ~f:(fun (T impl1, T impl2) -> 446 | let module M = struct 447 | include M 448 | 449 | let t_of_sexp = 450 | let caller = "M.t" in 451 | Sexp_conv_record.record_of_sexp 452 | ~caller 453 | ~fields: 454 | (field 455 | ~name:"a" 456 | ~kind:Required 457 | ~impl:impl1 458 | ~conv:(fun sexp -> 459 | { a = 460 | list_of_sexp (Sexplib.Conv_error.record_poly_field_value caller) sexp 461 | }) 462 | ~rest: 463 | (field 464 | ~name:"b" 465 | ~kind:Required 466 | ~impl:impl2 467 | ~conv:(fun sexp -> 468 | { b = 469 | Option.t_of_sexp 470 | (Result.t_of_sexp 471 | (Sexplib.Conv_error.record_poly_field_value caller) 472 | (Sexplib.Conv_error.record_poly_field_value caller)) 473 | sexp 474 | }) 475 | ~rest:Empty)) 476 | ~index_of_field:(function 477 | | "a" -> 0 478 | | "b" -> 1 479 | | _ -> -1) 480 | ~allow_extra_fields:false 481 | ~create:(fun (a, (b, ())) -> 482 | let { a } = Layout_impl.value impl1 a 483 | and { b } = Layout_impl.value impl2 b in 484 | { a; b }) 485 | ;; 486 | end 487 | in 488 | let test = test (module M) in 489 | (* in order *) 490 | test "((a ()) (b ()))"; 491 | [%expect {| (Ok ((a ()) (b ()))) |}]; 492 | (* reverse order *) 493 | test "((b ()) (a ()))"; 494 | [%expect {| (Ok ((a ()) (b ()))) |}]; 495 | (* attempt to deserialize paramter to [a] *) 496 | test "((a (_)) (b ()))"; 497 | [%expect 498 | {| 499 | (Error 500 | (Of_sexp_error 501 | "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" 502 | (invalid_sexp _))) 503 | |}]; 504 | (* attempt to deserialize first parameter to [b] *) 505 | test "((a ()) (b ((Ok _))))"; 506 | [%expect 507 | {| 508 | (Error 509 | (Of_sexp_error 510 | "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" 511 | (invalid_sexp _))) 512 | |}]; 513 | (* attempt to deserialize second parameter to [b] *) 514 | test "((a ()) (b ((Error _))))"; 515 | [%expect 516 | {| 517 | (Error 518 | (Of_sexp_error 519 | "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" 520 | (invalid_sexp _))) 521 | |}]; 522 | (* multiple missing fields *) 523 | test "()"; 524 | [%expect 525 | {| (Error (Of_sexp_error "M.t_of_sexp: missing fields: a b" (invalid_sexp ()))) |}]; 526 | ()) 527 | ;; 528 | 529 | let%expect_test _ = 530 | let big_string = String.init 5_000_000 ~f:(fun i -> String.get (Int.to_string i) 0) in 531 | let sexp = [%sexp (big_string : string)] in 532 | let sexp_string = 533 | (* In an experimental compiler version, this would overflow the stack. *) 534 | Sexp.to_string sexp 535 | in 536 | print_endline (Int.to_string_hum (String.length sexp_string)); 537 | [%expect {| 5_000_000 |}] 538 | ;; 539 | 540 | (* Assert that the module types defined by sexplib0 are equivalent to those derived by 541 | ppx_sexp_conv. *) 542 | module _ = struct 543 | module type S = sig 544 | type t [@@deriving sexp] 545 | end 546 | 547 | module type S1 = sig 548 | type 'a t [@@deriving sexp] 549 | end 550 | 551 | module type S2 = sig 552 | type ('a, 'b) t [@@deriving sexp] 553 | end 554 | 555 | module type S3 = sig 556 | type ('a, 'b, 'c) t [@@deriving sexp] 557 | end 558 | 559 | module type S_with_grammar = sig 560 | type t [@@deriving sexp, sexp_grammar] 561 | end 562 | 563 | module type S1_with_grammar = sig 564 | type 'a t [@@deriving sexp, sexp_grammar] 565 | end 566 | 567 | module type S2_with_grammar = sig 568 | type ('a, 'b) t [@@deriving sexp, sexp_grammar] 569 | end 570 | 571 | module type S3_with_grammar = sig 572 | type ('a, 'b, 'c) t [@@deriving sexp, sexp_grammar] 573 | end 574 | 575 | let (T : ((module Sexpable.S), (module S)) Type_equal.t) = T 576 | let (T : ((module Sexpable.S1), (module S1)) Type_equal.t) = T 577 | let (T : ((module Sexpable.S2), (module S2)) Type_equal.t) = T 578 | let (T : ((module Sexpable.S3), (module S3)) Type_equal.t) = T 579 | let (T : ((module Sexpable.S_with_grammar), (module S_with_grammar)) Type_equal.t) = T 580 | let (T : ((module Sexpable.S1_with_grammar), (module S1_with_grammar)) Type_equal.t) = T 581 | let (T : ((module Sexpable.S2_with_grammar), (module S2_with_grammar)) Type_equal.t) = T 582 | let (T : ((module Sexpable.S3_with_grammar), (module S3_with_grammar)) Type_equal.t) = T 583 | end 584 | 585 | module%test Illegal_chars = struct 586 | (* Test [sexp_of_char] against the naive implementation that dynamically creates the 587 | length-1 string. The focus of this test is on illegal representations: immediates 588 | that lie outside the range representable by [char] *) 589 | 590 | let[@inline never] sexp_of_char' (char : char) : Sexp.t = 591 | Atom ((String.make [@inlined never]) 1 char) 592 | ;; 593 | 594 | let test_at ~start ~num_tests = 595 | List.init num_tests ~f:(( + ) start) 596 | |> List.iter ~f:(fun (c : int) -> 597 | let c : char = Stdlib.Obj.magic c in 598 | Expect_test_helpers_base.require_equal 599 | (module Sexp) 600 | (sexp_of_char c) 601 | (sexp_of_char' c)) 602 | ;; 603 | 604 | let%expect_test _ = 605 | test_at ~start:Int.min_value ~num_tests:0x10000; 606 | test_at ~start:(-0x10000) ~num_tests:0x20000; 607 | test_at ~start:(Int.max_value - 0xFFFF) ~num_tests:0x10000 608 | ;; 609 | end 610 | -------------------------------------------------------------------------------- /test/sexplib0_test.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | --------------------------------------------------------------------------------