diff options
| -rw-r--r-- | .gitignore | 5 | ||||
| -rw-r--r-- | CHANGES.md | 7 | ||||
| -rw-r--r-- | CONTRIBUTING.md | 67 | ||||
| -rw-r--r-- | LICENSE.md | 21 | ||||
| -rw-r--r-- | Makefile | 17 | ||||
| -rw-r--r-- | README.md | 9 | ||||
| -rw-r--r-- | bench/bench_record.ml | 105 | ||||
| -rw-r--r-- | bench/bench_record.mli | 1 | ||||
| -rw-r--r-- | bench/dune | 2 | ||||
| -rw-r--r-- | bench/sexplib0_bench.ml | 1 | ||||
| -rw-r--r-- | debian/changelog (renamed from changelog) | 0 | ||||
| -rw-r--r-- | debian/control (renamed from control) | 0 | ||||
| -rw-r--r-- | debian/copyright (renamed from copyright) | 0 | ||||
| -rw-r--r-- | debian/gbp.conf (renamed from gbp.conf) | 0 | ||||
| -rw-r--r-- | debian/libsexplib0-ocaml-dev.docs (renamed from libsexplib0-ocaml-dev.docs) | 0 | ||||
| -rw-r--r-- | debian/libsexplib0-ocaml-dev.install.in (renamed from libsexplib0-ocaml-dev.install.in) | 0 | ||||
| -rw-r--r-- | debian/libsexplib0-ocaml.docs (renamed from libsexplib0-ocaml.docs) | 0 | ||||
| -rw-r--r-- | debian/libsexplib0-ocaml.install.in (renamed from libsexplib0-ocaml.install.in) | 0 | ||||
| -rwxr-xr-x | debian/rules (renamed from rules) | 0 | ||||
| -rw-r--r-- | debian/source/format (renamed from source/format) | 0 | ||||
| -rw-r--r-- | debian/watch (renamed from watch) | 0 | ||||
| -rw-r--r-- | dune-project | 1 | ||||
| -rw-r--r-- | sexplib0.opam | 24 | ||||
| -rw-r--r-- | src/dune | 2 | ||||
| -rw-r--r-- | src/sexp.ml | 354 | ||||
| -rw-r--r-- | src/sexp.mli | 115 | ||||
| -rw-r--r-- | src/sexp_conv.ml | 415 | ||||
| -rw-r--r-- | src/sexp_conv.mli | 290 | ||||
| -rw-r--r-- | src/sexp_conv_error.ml | 140 | ||||
| -rw-r--r-- | src/sexp_conv_grammar.ml | 41 | ||||
| -rw-r--r-- | src/sexp_conv_grammar.mli | 32 | ||||
| -rw-r--r-- | src/sexp_conv_record.ml | 297 | ||||
| -rw-r--r-- | src/sexp_conv_record.mli | 54 | ||||
| -rw-r--r-- | src/sexp_grammar.ml | 207 | ||||
| -rw-r--r-- | src/sexpable.ml | 38 | ||||
| -rw-r--r-- | src/sexplib0.ml | 6 | ||||
| -rw-r--r-- | test/dune | 4 | ||||
| -rw-r--r-- | test/sexplib0_test.ml | 452 | ||||
| -rw-r--r-- | test/sexplib0_test.mli | 1 |
39 files changed, 2708 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6c14091 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +_build +*.install +*.merlin +_opam + diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..fdf7d1a --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,7 @@ +## Release v0.16.0 + +* Added `Sexp_conv_record`. Supports improvements to `ppx_sexp_conv` for deriving + `of_sexp` on record types. Provides a GADT-based generic interface to parsing record + sexps. This avoids having to generate the same field-parsing code over and over. + +* Added `sexp_grammar_with_tags` and `sexp_grammar_with_tag_list` to `Sexp_conv_grammar`. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..45e1a22 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,67 @@ +This repository contains open source software that is developed and +maintained by [Jane Street][js]. + +Contributions to this project are welcome and should be submitted via +GitHub pull requests. + +Signing contributions +--------------------- + +We require that you sign your contributions. Your signature certifies +that you wrote the patch or otherwise have the right to pass it on as +an open-source patch. The rules are pretty simple: if you can certify +the below (from [developercertificate.org][dco]): + +``` +Developer Certificate of Origin +Version 1.1 + +Copyright (C) 2004, 2006 The Linux Foundation and its contributors. +1 Letterman Drive +Suite D4700 +San Francisco, CA, 94129 + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. + + +Developer's Certificate of Origin 1.1 + +By making a contribution to this project, I certify that: + +(a) The contribution was created in whole or in part by me and I + have the right to submit it under the open source license + indicated in the file; or + +(b) The contribution is based upon previous work that, to the best + of my knowledge, is covered under an appropriate open source + license and I have the right under that license to submit that + work with modifications, whether created in whole or in part + by me, under the same open source license (unless I am + permitted to submit under a different license), as indicated + in the file; or + +(c) The contribution was provided directly to me by some other + person who certified (a), (b) or (c) and I have not modified + it. + +(d) I understand and agree that this project and the contribution + are public and that a record of the contribution (including all + personal information I submit with it, including my sign-off) is + maintained indefinitely and may be redistributed consistent with + this project or the open source license(s) involved. +``` + +Then you just add a line to every git commit message: + +``` +Signed-off-by: Joe Smith <joe.smith@email.com> +``` + +Use your real name (sorry, no pseudonyms or anonymous contributions.) + +If you set your `user.name` and `user.email` git configs, you can sign +your commit automatically with git commit -s. + +[dco]: http://developercertificate.org/ +[js]: https://opensource.janestreet.com/ diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..8c3a411 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2005--2023 Jane Street Group, LLC <opensource-contacts@janestreet.com> + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..1965878 --- /dev/null +++ b/Makefile @@ -0,0 +1,17 @@ +INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) + +default: + dune build + +install: + dune install $(INSTALL_ARGS) + +uninstall: + dune uninstall $(INSTALL_ARGS) + +reinstall: uninstall install + +clean: + dune clean + +.PHONY: default install uninstall reinstall clean diff --git a/README.md b/README.md new file mode 100644 index 0000000..6977148 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +"Sexplib0 - a low-dep version of Sexplib" +========================================= + +`sexplib0` is a lightweight portion of `sexplib`, for situations where a +dependency on `sexplib` is problematic. + +It has the type definition and the printing functions, but not parsing. + +See [sexplib](https://github.com/janestreet/sexplib) for documentation. diff --git a/bench/bench_record.ml b/bench/bench_record.ml new file mode 100644 index 0000000..ee70e28 --- /dev/null +++ b/bench/bench_record.ml @@ -0,0 +1,105 @@ +open Sexplib0.Sexp_conv + +let bench_t_of_sexp ~t_of_sexp string = + let sexp = Sys.opaque_identity (Parsexp.Single.parse_string_exn string) in + fun () -> t_of_sexp sexp +;; + +type t = + { a : int + ; b : int option + ; c : bool + ; d : int array + ; e : int list + ; f : int option + ; g : int + ; h : 'a. 'a list + } + +let t_of_sexp = + let open struct + type poly = { h : 'a. 'a list } [@@unboxed] + end in + Sexplib0.Sexp_conv_record.record_of_sexp + ~caller:"Record.t" + ~fields: + (Field + { name = "a" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field + { name = "b" + ; kind = Omit_nil + ; conv = option_of_sexp int_of_sexp + ; rest = + Field + { name = "c" + ; kind = Sexp_bool + ; conv = () + ; rest = + Field + { name = "d" + ; kind = Sexp_array + ; conv = int_of_sexp + ; rest = + Field + { name = "e" + ; kind = Sexp_list + ; conv = int_of_sexp + ; rest = + Field + { name = "f" + ; kind = Sexp_option + ; conv = int_of_sexp + ; rest = + Field + { name = "g" + ; kind = Default (fun () -> 0) + ; conv = int_of_sexp + ; rest = + Field + { name = "h" + ; kind = Required + ; conv = + (fun sexp -> + { h = + list_of_sexp + (Sexplib0.Sexp_conv_error + .record_poly_field_value + "Record.t") + sexp + }) + ; rest = Empty + } + } + } + } + } + } + } + }) + ~index_of_field:(function + | "a" -> 0 + | "b" -> 1 + | "c" -> 2 + | "d" -> 3 + | "e" -> 4 + | "f" -> 5 + | "g" -> 6 + | "h" -> 7 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun (a, (b, (c, (d, (e, (f, (g, ({ h }, ())))))))) -> + { a; b; c; d; e; f; g; h }) +;; + +let%bench_fun "t_of_sexp, full, in order" = + bench_t_of_sexp ~t_of_sexp "((a 1) (b (2)) (c) (d (3 4)) (e (5 6)) (f 7) (g 8) (h ()))" +;; + +let%bench_fun "t_of_sexp, full, reverse order" = + bench_t_of_sexp ~t_of_sexp "((h ()) (g 8) (f 7) (e (5 6)) (d (3 4)) (c) (b (2)) (a 1))" +;; + +let%bench_fun "t_of_sexp, empty" = bench_t_of_sexp ~t_of_sexp "((a 0) (h ()))" diff --git a/bench/bench_record.mli b/bench/bench_record.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/bench/bench_record.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/bench/dune b/bench/dune new file mode 100644 index 0000000..ba8029c --- /dev/null +++ b/bench/dune @@ -0,0 +1,2 @@ +(library (name sexplib0_bench) (libraries parsexp sexplib0) + (preprocess (pps ppx_bench)))
\ No newline at end of file diff --git a/bench/sexplib0_bench.ml b/bench/sexplib0_bench.ml new file mode 100644 index 0000000..0a5dfa8 --- /dev/null +++ b/bench/sexplib0_bench.ml @@ -0,0 +1 @@ +(*_ Deliberately empty. *) diff --git a/changelog b/debian/changelog index ac37dba..ac37dba 100644 --- a/changelog +++ b/debian/changelog diff --git a/copyright b/debian/copyright index 9860800..9860800 100644 --- a/copyright +++ b/debian/copyright diff --git a/gbp.conf b/debian/gbp.conf index cec628c..cec628c 100644 --- a/gbp.conf +++ b/debian/gbp.conf diff --git a/libsexplib0-ocaml-dev.docs b/debian/libsexplib0-ocaml-dev.docs index 64d114b..64d114b 100644 --- a/libsexplib0-ocaml-dev.docs +++ b/debian/libsexplib0-ocaml-dev.docs diff --git a/libsexplib0-ocaml-dev.install.in b/debian/libsexplib0-ocaml-dev.install.in index 1751ef4..1751ef4 100644 --- a/libsexplib0-ocaml-dev.install.in +++ b/debian/libsexplib0-ocaml-dev.install.in diff --git a/libsexplib0-ocaml.docs b/debian/libsexplib0-ocaml.docs index f4e971e..f4e971e 100644 --- a/libsexplib0-ocaml.docs +++ b/debian/libsexplib0-ocaml.docs diff --git a/libsexplib0-ocaml.install.in b/debian/libsexplib0-ocaml.install.in index bc9bcaa..bc9bcaa 100644 --- a/libsexplib0-ocaml.install.in +++ b/debian/libsexplib0-ocaml.install.in diff --git a/source/format b/debian/source/format index 163aaf8..163aaf8 100644 --- a/source/format +++ b/debian/source/format diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..eb10bcb --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 1.10)
\ No newline at end of file diff --git a/sexplib0.opam b/sexplib0.opam new file mode 100644 index 0000000..e35db0f --- /dev/null +++ b/sexplib0.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +version: "v0.16.0" +maintainer: "Jane Street developers" +authors: ["Jane Street Group, LLC"] +homepage: "https://github.com/janestreet/sexplib0" +bug-reports: "https://github.com/janestreet/sexplib0/issues" +dev-repo: "git+https://github.com/janestreet/sexplib0.git" +doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/sexplib0/index.html" +license: "MIT" +build: [ + ["dune" "build" "-p" name "-j" jobs] +] +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "2.0.0"} +] +available: arch != "arm32" & arch != "x86_32" +synopsis: "Library containing the definition of S-expressions and some base converters" +description: " +Part of Jane Street's Core library +The Core suite of libraries is an industrial strength alternative to +OCaml's standard library that was developed by Jane Street, the +largest industrial user of OCaml. +" diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..4fb59af --- /dev/null +++ b/src/dune @@ -0,0 +1,2 @@ +(library (name sexplib0) (public_name sexplib0) + (preprocess no_preprocessing))
\ No newline at end of file diff --git a/src/sexp.ml b/src/sexp.ml new file mode 100644 index 0000000..955cd43 --- /dev/null +++ b/src/sexp.ml @@ -0,0 +1,354 @@ +[@@@ocaml.warning "-3"] + +(* blit_string doesn't exist in [StdLabels.Bytes]... *) +let bytes_blit_string ~src ~src_pos ~dst ~dst_pos ~len = + Bytes.blit_string src src_pos dst dst_pos len +;; + +open StdLabels +open Format + +(** Type of S-expressions *) +type t = + | Atom of string + | List of t list + +let sexp_of_t t = t +let t_of_sexp t = t + +let rec compare_list a b = + match a, b with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | x :: xs, y :: ys -> + let res = compare x y in + if res <> 0 then res else compare_list xs ys + +and compare a b = + if a == b + then 0 + else ( + match a, b with + | Atom a, Atom b -> String.compare a b + | Atom _, _ -> -1 + | _, Atom _ -> 1 + | List a, List b -> compare_list a b) +;; + +let equal a b = compare a b = 0 + +exception Not_found_s of t +exception Of_sexp_error of exn * t + +module Printing = struct + (* Default indentation level for human-readable conversions *) + + let default_indent = ref 1 + + (* Escaping of strings used as atoms in S-expressions *) + + let must_escape str = + let len = String.length str in + len = 0 + || + let rec loop str ix = + match str.[ix] with + | '"' | '(' | ')' | ';' | '\\' -> true + | '|' -> + ix > 0 + && + let next = ix - 1 in + Char.equal str.[next] '#' || loop str next + | '#' -> + ix > 0 + && + let next = ix - 1 in + Char.equal str.[next] '|' || loop str next + | '\000' .. '\032' | '\127' .. '\255' -> true + | _ -> ix > 0 && loop str (ix - 1) + in + loop str (len - 1) + ;; + + let escaped s = + let n = ref 0 in + for i = 0 to String.length s - 1 do + n + := !n + + + match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | ' ' .. '~' -> 1 + | _ -> 4 + done; + if !n = String.length s + then s + else ( + let s' = Bytes.create !n in + n := 0; + for i = 0 to String.length s - 1 do + (match String.unsafe_get s i with + | ('\"' | '\\') as c -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n c + | '\n' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'n' + | '\t' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 't' + | '\r' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'r' + | '\b' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'b' + | ' ' .. '~' as c -> Bytes.unsafe_set s' !n c + | c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10)))); + incr n + done; + Bytes.unsafe_to_string s') + ;; + + let esc_str str = + let estr = escaped str in + let elen = String.length estr in + let res = Bytes.create (elen + 2) in + bytes_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen; + Bytes.unsafe_set res 0 '"'; + Bytes.unsafe_set res (elen + 1) '"'; + Bytes.unsafe_to_string res + ;; + + let index_of_newline str start = String.index_from_opt str start '\n' + + let get_substring str index end_pos_opt = + let end_pos = + match end_pos_opt with + | None -> String.length str + | Some end_pos -> end_pos + in + String.sub str ~pos:index ~len:(end_pos - index) + ;; + + let is_one_line str = + match index_of_newline str 0 with + | None -> true + | Some index -> index + 1 = String.length str + ;; + + let pp_hum_maybe_esc_str ppf str = + if not (must_escape str) + then pp_print_string ppf str + else if is_one_line str + then pp_print_string ppf (esc_str str) + else ( + let rec loop index = + let next_newline = index_of_newline str index in + let next_line = get_substring str index next_newline in + pp_print_string ppf (escaped next_line); + match next_newline with + | None -> () + | Some newline_index -> + pp_print_string ppf "\\"; + pp_force_newline ppf (); + pp_print_string ppf "\\n"; + loop (newline_index + 1) + in + pp_open_box ppf 0; + (* the leading space is to line up the lines *) + pp_print_string ppf " \""; + loop 0; + pp_print_string ppf "\""; + pp_close_box ppf ()) + ;; + + let mach_maybe_esc_str str = if must_escape str then esc_str str else str + + (* Output of S-expressions to formatters *) + + let rec pp_hum_indent indent ppf = function + | Atom str -> pp_hum_maybe_esc_str ppf str + | List (h :: t) -> + pp_open_box ppf indent; + pp_print_string ppf "("; + pp_hum_indent indent ppf h; + pp_hum_rest indent ppf t + | List [] -> pp_print_string ppf "()" + + and pp_hum_rest indent ppf = function + | h :: t -> + pp_print_space ppf (); + pp_hum_indent indent ppf h; + pp_hum_rest indent ppf t + | [] -> + pp_print_string ppf ")"; + pp_close_box ppf () + ;; + + let rec pp_mach_internal may_need_space ppf = function + | Atom str -> + let str' = mach_maybe_esc_str str in + let new_may_need_space = str' == str in + if may_need_space && new_may_need_space then pp_print_string ppf " "; + pp_print_string ppf str'; + new_may_need_space + | List (h :: t) -> + pp_print_string ppf "("; + let may_need_space = pp_mach_internal false ppf h in + pp_mach_rest may_need_space ppf t; + false + | List [] -> + pp_print_string ppf "()"; + false + + and pp_mach_rest may_need_space ppf = function + | h :: t -> + let may_need_space = pp_mach_internal may_need_space ppf h in + pp_mach_rest may_need_space ppf t + | [] -> pp_print_string ppf ")" + ;; + + let pp_hum ppf sexp = pp_hum_indent !default_indent ppf sexp + let pp_mach ppf sexp = ignore (pp_mach_internal false ppf sexp) + let pp = pp_mach + + (* Sexp size *) + + let rec size_loop ((v, c) as acc) = function + | Atom str -> v + 1, c + String.length str + | List lst -> List.fold_left lst ~init:acc ~f:size_loop + ;; + + let size sexp = size_loop (0, 0) sexp + + (* Buffer conversions *) + + let to_buffer_hum ~buf ?(indent = !default_indent) sexp = + let ppf = Format.formatter_of_buffer buf in + Format.fprintf ppf "%a@?" (pp_hum_indent indent) sexp + ;; + + let to_buffer_mach ~buf sexp = + let rec loop may_need_space = function + | Atom str -> + let str' = mach_maybe_esc_str str in + let new_may_need_space = str' == str in + if may_need_space && new_may_need_space then Buffer.add_char buf ' '; + Buffer.add_string buf str'; + new_may_need_space + | List (h :: t) -> + Buffer.add_char buf '('; + let may_need_space = loop false h in + loop_rest may_need_space t; + false + | List [] -> + Buffer.add_string buf "()"; + false + and loop_rest may_need_space = function + | h :: t -> + let may_need_space = loop may_need_space h in + loop_rest may_need_space t + | [] -> Buffer.add_char buf ')' + in + ignore (loop false sexp) + ;; + + let to_buffer = to_buffer_mach + + let to_buffer_gen ~buf ~add_char ~add_string sexp = + let rec loop may_need_space = function + | Atom str -> + let str' = mach_maybe_esc_str str in + let new_may_need_space = str' == str in + if may_need_space && new_may_need_space then add_char buf ' '; + add_string buf str'; + new_may_need_space + | List (h :: t) -> + add_char buf '('; + let may_need_space = loop false h in + loop_rest may_need_space t; + false + | List [] -> + add_string buf "()"; + false + and loop_rest may_need_space = function + | h :: t -> + let may_need_space = loop may_need_space h in + loop_rest may_need_space t + | [] -> add_char buf ')' + in + ignore (loop false sexp) + ;; + + (* The maximum size of a thing on the minor heap is 256 words. + Previously, this size of the returned buffer here was 4096 bytes, which + caused the Buffer to be allocated on the *major* heap every time. + + According to a simple benchmark by Ron, we can improve performance for + small s-expressions by a factor of ~4 if we only allocate 1024 bytes + (128 words + some small overhead) worth of buffer initially. And one + can argue that if it's free to allocate strings smaller than 256 words, + large s-expressions requiring larger expensive buffers won't notice + the extra two doublings from 1024 bytes to 2048 and 4096. And especially + performance-sensitive applications to always pass in a larger buffer to + use. *) + let buffer () = Buffer.create 1024 + + (* String conversions *) + + let to_string_hum ?indent = function + | Atom str + when match index_of_newline str 0 with + | None -> true + | Some _ -> false -> mach_maybe_esc_str str + | sexp -> + let buf = buffer () in + to_buffer_hum ?indent sexp ~buf; + Buffer.contents buf + ;; + + let to_string_mach = function + | Atom str -> mach_maybe_esc_str str + | sexp -> + let buf = buffer () in + to_buffer_mach sexp ~buf; + Buffer.contents buf + ;; + + let to_string = to_string_mach +end + +include Printing + +let of_float_style : [ `Underscores | `No_underscores ] ref = ref `No_underscores +let of_int_style : [ `Underscores | `No_underscores ] ref = ref `No_underscores + +module Private = struct + include Printing +end + +let message name fields = + let rec conv_fields = function + | [] -> [] + | (fname, fsexp) :: rest -> + (match fname with + | "" -> fsexp :: conv_fields rest + | _ -> List [ Atom fname; fsexp ] :: conv_fields rest) + in + List (Atom name :: conv_fields fields) +;; diff --git a/src/sexp.mli b/src/sexp.mli new file mode 100644 index 0000000..fe68a3c --- /dev/null +++ b/src/sexp.mli @@ -0,0 +1,115 @@ +(** Type of S-expressions *) + +type t = + | Atom of string + | List of t list + +(*_ We don't use [@@deriving sexp] as this would generated references to [Sexplib], + creating a circular dependency *) +val t_of_sexp : t -> t +val sexp_of_t : t -> t +val equal : t -> t -> bool +val compare : t -> t -> int + +(** [Not_found_s] is used by functions that historically raised [Not_found], to allow them + to raise an exception that contains an informative error message (as a sexp), while + still having an exception that can be distinguished from other exceptions. *) +exception Not_found_s of t + +(** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be + successfully converted to an OCaml-value. *) +exception Of_sexp_error of exn * t + +(** {1 Helpers} *) + +(** Helper to build nice s-expressions for error messages. It imitates the behavior of + [[%message ...]] from the ppx_sexp_message rewriter. + + [message name key_values] produces a s-expression list starting with atom [name] and + followed by list of size 2 of the form [(key value)]. When the key is the empty + string, [value] is used directly instead as for [[%message]]. + + For instance the following code: + + {[ + Sexp.message "error" + [ "x", sexp_of_int 42 + ; "" , sexp_of_exn Exit + ] + ]} + + produces the s-expression: + + {[ + (error (x 42) Exit) + ]} *) +val message : string -> (string * t) list -> t + +(** {1 Defaults} *) + +(** [default_indent] reference to default indentation level for human-readable + conversions. + + Initialisation value: 2. *) +val default_indent : int ref + +(** {1 Pretty printing of S-expressions} *) + +(** [pp_hum ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human readable + form. *) +val pp_hum : Format.formatter -> t -> unit + +(** [pp_hum_indent n ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human + readable form and indentation level [n]. *) +val pp_hum_indent : int -> Format.formatter -> t -> unit + +(** [pp_mach ppf sexp] outputs S-expression [sexp] to formatter [ppf] in machine readable + (i.e. most compact) form. *) +val pp_mach : Format.formatter -> t -> unit + +(** Same as [pp_mach]. *) +val pp : Format.formatter -> t -> unit + +(** {1 Conversion to strings} *) + +(** [to_string_hum ?indent sexp] converts S-expression [sexp] to a + string in human readable form with indentation level [indent]. + + @param indent default = [!default_indent] *) +val to_string_hum : ?indent:int -> t -> string + +(** [to_string_mach sexp] converts S-expression [sexp] to a string in + machine readable (i.e. most compact) form. *) +val to_string_mach : t -> string + +(** Same as [to_string_mach]. *) +val to_string : t -> string + +(** {1 Styles} *) + +val of_float_style : [ `Underscores | `No_underscores ] ref +val of_int_style : [ `Underscores | `No_underscores ] ref + +(*_ See the Jane Street Style Guide for an explanation of [Private] submodules: + + https://opensource.janestreet.com/standards/#private-submodules *) +module Private : sig + (*_ Exported for sexplib *) + + val size : t -> int * int + val buffer : unit -> Buffer.t + val to_buffer : buf:Buffer.t -> t -> unit + val to_buffer_hum : buf:Buffer.t -> ?indent:int -> t -> unit + val to_buffer_mach : buf:Buffer.t -> t -> unit + + val to_buffer_gen + : buf:'buffer + -> add_char:('buffer -> char -> unit) + -> add_string:('buffer -> string -> unit) + -> t + -> unit + + val mach_maybe_esc_str : string -> string + val must_escape : string -> bool + val esc_str : string -> string +end diff --git a/src/sexp_conv.ml b/src/sexp_conv.ml new file mode 100644 index 0000000..9cc83e7 --- /dev/null +++ b/src/sexp_conv.ml @@ -0,0 +1,415 @@ +(* Utility Module for S-expression Conversions *) + +open StdLabels +open MoreLabels +open Printf +open Sexp + +(* Conversion of OCaml-values to S-expressions *) +external format_float : string -> float -> string = "caml_format_float" + +(* '%.17g' is guaranteed to be round-trippable. + + '%.15g' will be round-trippable and not have noise at the last digit or two for a float + which was converted from a decimal (string) with <= 15 significant digits. So it's + worth trying first to avoid things like "3.1400000000000001". + + See comment above [to_string_round_trippable] in {!Core.Float} for + detailed explanation and examples. *) +let default_string_of_float = + ref (fun x -> + let y = format_float "%.15G" x in + if float_of_string y = x then y else format_float "%.17G" x) +;; + +let read_old_option_format = ref true +let write_old_option_format = ref true +let list_map f l = List.rev (List.rev_map l ~f) +let sexp_of_unit () = List [] +let sexp_of_bool b = Atom (string_of_bool b) +let sexp_of_string str = Atom str +let sexp_of_bytes bytes = Atom (Bytes.to_string bytes) +let sexp_of_char c = Atom (String.make 1 c) +let sexp_of_int n = Atom (string_of_int n) +let sexp_of_float n = Atom (!default_string_of_float n) +let sexp_of_int32 n = Atom (Int32.to_string n) +let sexp_of_int64 n = Atom (Int64.to_string n) +let sexp_of_nativeint n = Atom (Nativeint.to_string n) +let sexp_of_ref sexp_of__a rf = sexp_of__a !rf +let sexp_of_lazy_t sexp_of__a lv = sexp_of__a (Lazy.force lv) + +let sexp_of_option sexp_of__a = function + | Some x when !write_old_option_format -> List [ sexp_of__a x ] + | Some x -> List [ Atom "some"; sexp_of__a x ] + | None when !write_old_option_format -> List [] + | None -> Atom "none" +;; + +let sexp_of_pair sexp_of__a sexp_of__b (a, b) = List [ sexp_of__a a; sexp_of__b b ] + +let sexp_of_triple sexp_of__a sexp_of__b sexp_of__c (a, b, c) = + List [ sexp_of__a a; sexp_of__b b; sexp_of__c c ] +;; + +(* List.rev (List.rev_map ...) is tail recursive, the OCaml standard + library List.map is NOT. *) +let sexp_of_list sexp_of__a lst = List (List.rev (List.rev_map lst ~f:sexp_of__a)) + +let sexp_of_array sexp_of__a ar = + let lst_ref = ref [] in + for i = Array.length ar - 1 downto 0 do + lst_ref := sexp_of__a ar.(i) :: !lst_ref + done; + List !lst_ref +;; + +let sexp_of_hashtbl sexp_of_key sexp_of_val htbl = + let coll ~key:k ~data:v acc = List [ sexp_of_key k; sexp_of_val v ] :: acc in + List (Hashtbl.fold htbl ~init:[] ~f:coll) +;; + +let sexp_of_opaque _ = Atom "<opaque>" +let sexp_of_fun _ = Atom "<fun>" + +(* Exception converter registration and lookup *) + +module Exn_converter = struct + (* These exception registration functions assume that context-switches + cannot happen unless there is an allocation. It is reasonable to expect + that this will remain true for the foreseeable future. That way we + avoid using mutexes and thus a dependency on the threads library. *) + + (* Fast and automatic exception registration *) + + module Registration = struct + type t = + { sexp_of_exn : exn -> Sexp.t + ; (* If [printexc = true] then this sexp converter is used for Printexc.to_string *) + printexc : bool + } + end + + module Exn_table = Ephemeron.K1.Make (struct + type t = extension_constructor + + let equal = ( == ) + let hash = Obj.Extension_constructor.id + end) + + let the_exn_table : Registration.t Exn_table.t = Exn_table.create 17 + + (* Ephemerons are used so that [sexp_of_exn] closure don't keep the + extension_constructor live. *) + let add ?(printexc = true) ?finalise:_ extension_constructor sexp_of_exn = + Exn_table.add the_exn_table extension_constructor { sexp_of_exn; printexc } + ;; + + let find_auto ~for_printexc exn = + let extension_constructor = Obj.Extension_constructor.of_val exn in + match Exn_table.find_opt the_exn_table extension_constructor with + | None -> None + | Some { sexp_of_exn; printexc } -> + (match for_printexc, printexc with + | false, _ | _, true -> Some (sexp_of_exn exn) + | true, false -> None) + ;; + + module For_unit_tests_only = struct + let size () = (Exn_table.stats_alive the_exn_table).num_bindings + end +end + +let sexp_of_exn_opt_for_printexc exn = Exn_converter.find_auto ~for_printexc:true exn +let sexp_of_exn_opt exn = Exn_converter.find_auto ~for_printexc:false exn + +let sexp_of_exn exn = + match sexp_of_exn_opt exn with + | None -> List [ Atom (Printexc.to_string exn) ] + | Some sexp -> sexp +;; + +let exn_to_string e = Sexp.to_string_hum (sexp_of_exn e) + +(* {[exception Blah [@@deriving sexp]]} generates a call to the function + [Exn_converter.add] defined in this file. So we are guaranted that as soon as we + mark an exception as sexpable, this module will be linked in and this printer will be + registered, which is what we want. *) +let () = + Printexc.register_printer (fun exn -> + match sexp_of_exn_opt_for_printexc exn with + | None -> None + | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) +;; + +let printexc_prefer_sexp exn = + match sexp_of_exn_opt exn with + | None -> Printexc.to_string exn + | Some sexp -> Sexp.to_string_hum ~indent:2 sexp +;; + +(* Conversion of S-expressions to OCaml-values *) + +exception Of_sexp_error = Sexp.Of_sexp_error + +let record_check_extra_fields = ref true +let of_sexp_error_exn exc sexp = raise (Of_sexp_error (exc, sexp)) +let of_sexp_error what sexp = raise (Of_sexp_error (Failure what, sexp)) + +let unit_of_sexp sexp = + match sexp with + | List [] -> () + | Atom _ | List _ -> of_sexp_error "unit_of_sexp: empty list needed" sexp +;; + +let bool_of_sexp sexp = + match sexp with + | Atom ("true" | "True") -> true + | Atom ("false" | "False") -> false + | Atom _ -> of_sexp_error "bool_of_sexp: unknown string" sexp + | List _ -> of_sexp_error "bool_of_sexp: atom needed" sexp +;; + +let string_of_sexp sexp = + match sexp with + | Atom str -> str + | List _ -> of_sexp_error "string_of_sexp: atom needed" sexp +;; + +let bytes_of_sexp sexp = + match sexp with + | Atom str -> Bytes.of_string str + | List _ -> of_sexp_error "bytes_of_sexp: atom needed" sexp +;; + +let char_of_sexp sexp = + match sexp with + | Atom str -> + if String.length str <> 1 + then of_sexp_error "char_of_sexp: atom string must contain one character only" sexp; + str.[0] + | List _ -> of_sexp_error "char_of_sexp: atom needed" sexp +;; + +let int_of_sexp sexp = + match sexp with + | Atom str -> + (try int_of_string str with + | exc -> of_sexp_error ("int_of_sexp: " ^ exn_to_string exc) sexp) + | List _ -> of_sexp_error "int_of_sexp: atom needed" sexp +;; + +let float_of_sexp sexp = + match sexp with + | Atom str -> + (try float_of_string str with + | exc -> of_sexp_error ("float_of_sexp: " ^ exn_to_string exc) sexp) + | List _ -> of_sexp_error "float_of_sexp: atom needed" sexp +;; + +let int32_of_sexp sexp = + match sexp with + | Atom str -> + (try Int32.of_string str with + | exc -> of_sexp_error ("int32_of_sexp: " ^ exn_to_string exc) sexp) + | List _ -> of_sexp_error "int32_of_sexp: atom needed" sexp +;; + +let int64_of_sexp sexp = + match sexp with + | Atom str -> + (try Int64.of_string str with + | exc -> of_sexp_error ("int64_of_sexp: " ^ exn_to_string exc) sexp) + | List _ -> of_sexp_error "int64_of_sexp: atom needed" sexp +;; + +let nativeint_of_sexp sexp = + match sexp with + | Atom str -> + (try Nativeint.of_string str with + | exc -> of_sexp_error ("nativeint_of_sexp: " ^ exn_to_string exc) sexp) + | List _ -> of_sexp_error "nativeint_of_sexp: atom needed" sexp +;; + +let ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp) +let lazy_t_of_sexp a__of_sexp sexp = Lazy.from_val (a__of_sexp sexp) + +let option_of_sexp a__of_sexp sexp = + if !read_old_option_format + then ( + match sexp with + | List [] | Atom ("none" | "None") -> None + | List [ el ] | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) + | List _ -> of_sexp_error "option_of_sexp: list must represent optional value" sexp + | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp) + else ( + match sexp with + | Atom ("none" | "None") -> None + | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) + | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp + | List _ -> of_sexp_error "option_of_sexp: list must be (some el)" sexp) +;; + +let pair_of_sexp a__of_sexp b__of_sexp sexp = + match sexp with + | List [ a_sexp; b_sexp ] -> + let a = a__of_sexp a_sexp in + let b = b__of_sexp b_sexp in + a, b + | List _ -> + of_sexp_error "pair_of_sexp: list must contain exactly two elements only" sexp + | Atom _ -> of_sexp_error "pair_of_sexp: list needed" sexp +;; + +let triple_of_sexp a__of_sexp b__of_sexp c__of_sexp sexp = + match sexp with + | List [ a_sexp; b_sexp; c_sexp ] -> + let a = a__of_sexp a_sexp in + let b = b__of_sexp b_sexp in + let c = c__of_sexp c_sexp in + a, b, c + | List _ -> + of_sexp_error "triple_of_sexp: list must contain exactly three elements only" sexp + | Atom _ -> of_sexp_error "triple_of_sexp: list needed" sexp +;; + +let list_of_sexp a__of_sexp sexp = + match sexp with + | List lst -> + let rev_lst = List.rev_map lst ~f:a__of_sexp in + List.rev rev_lst + | Atom _ -> of_sexp_error "list_of_sexp: list needed" sexp +;; + +let array_of_sexp a__of_sexp sexp = + match sexp with + | List [] -> [||] + | List (h :: t) -> + let len = List.length t + 1 in + let res = Array.make len (a__of_sexp h) in + let rec loop i = function + | [] -> res + | h :: t -> + res.(i) <- a__of_sexp h; + loop (i + 1) t + in + loop 1 t + | Atom _ -> of_sexp_error "array_of_sexp: list needed" sexp +;; + +let hashtbl_of_sexp key_of_sexp val_of_sexp sexp = + match sexp with + | List lst -> + let htbl = Hashtbl.create 0 in + let act = function + | List [ k_sexp; v_sexp ] -> + Hashtbl.add htbl ~key:(key_of_sexp k_sexp) ~data:(val_of_sexp v_sexp) + | List _ | Atom _ -> of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp + in + List.iter lst ~f:act; + htbl + | Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp +;; + +let opaque_of_sexp sexp = + of_sexp_error "opaque_of_sexp: cannot convert opaque values" sexp +;; + +let fun_of_sexp sexp = of_sexp_error "fun_of_sexp: cannot convert function values" sexp + +(* Sexp Grammars *) + +include Sexp_conv_grammar + +(* Registering default exception printers *) + +let get_flc_error name (file, line, chr) = Atom (sprintf "%s %s:%d:%d" name file line chr) + +let () = + List.iter + ~f:(fun (extension_constructor, handler) -> + Exn_converter.add ~printexc:false ~finalise:false extension_constructor handler) + [ ( [%extension_constructor Assert_failure] + , function + | Assert_failure arg -> get_flc_error "Assert_failure" arg + | _ -> assert false ) + ; ( [%extension_constructor Exit] + , function + | Exit -> Atom "Exit" + | _ -> assert false ) + ; ( [%extension_constructor End_of_file] + , function + | End_of_file -> Atom "End_of_file" + | _ -> assert false ) + ; ( [%extension_constructor Failure] + , function + | Failure arg -> List [ Atom "Failure"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Not_found] + , function + | Not_found -> Atom "Not_found" + | _ -> assert false ) + ; ( [%extension_constructor Invalid_argument] + , function + | Invalid_argument arg -> List [ Atom "Invalid_argument"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Match_failure] + , function + | Match_failure arg -> get_flc_error "Match_failure" arg + | _ -> assert false ) + ; ( [%extension_constructor Not_found_s] + , function + | Not_found_s arg -> List [ Atom "Not_found_s"; arg ] + | _ -> assert false ) + ; ( [%extension_constructor Sys_error] + , function + | Sys_error arg -> List [ Atom "Sys_error"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Arg.Help] + , function + | Arg.Help arg -> List [ Atom "Arg.Help"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Arg.Bad] + , function + | Arg.Bad arg -> List [ Atom "Arg.Bad"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Lazy.Undefined] + , function + | Lazy.Undefined -> Atom "Lazy.Undefined" + | _ -> assert false ) + ; ( [%extension_constructor Parsing.Parse_error] + , function + | Parsing.Parse_error -> Atom "Parsing.Parse_error" + | _ -> assert false ) + ; ( [%extension_constructor Queue.Empty] + , function + | Queue.Empty -> Atom "Queue.Empty" + | _ -> assert false ) + ; ( [%extension_constructor Scanf.Scan_failure] + , function + | Scanf.Scan_failure arg -> List [ Atom "Scanf.Scan_failure"; Atom arg ] + | _ -> assert false ) + ; ( [%extension_constructor Stack.Empty] + , function + | Stack.Empty -> Atom "Stack.Empty" + | _ -> assert false ) + ; ( [%extension_constructor Sys.Break] + , function + | Sys.Break -> Atom "Sys.Break" + | _ -> assert false ) + ] +;; + +let () = + List.iter + ~f:(fun (extension_constructor, handler) -> + Exn_converter.add ~printexc:true ~finalise:false extension_constructor handler) + [ ( [%extension_constructor Of_sexp_error] + , function + | Of_sexp_error (exc, sexp) -> + List [ Atom "Sexplib.Conv.Of_sexp_error"; sexp_of_exn exc; sexp ] + | _ -> assert false ) + ] +;; + +external ignore : _ -> unit = "%ignore" +external ( = ) : 'a -> 'a -> bool = "%equal" diff --git a/src/sexp_conv.mli b/src/sexp_conv.mli new file mode 100644 index 0000000..a1c21e8 --- /dev/null +++ b/src/sexp_conv.mli @@ -0,0 +1,290 @@ +(** Utility Module for S-expression Conversions *) + +(** {6 Conversion of OCaml-values to S-expressions} *) + +(** [default_string_of_float] reference to the default function used + to convert floats to strings. + + Initially set to [fun n -> sprintf "%.20G" n]. *) +val default_string_of_float : (float -> string) ref + +(** [write_old_option_format] reference for the default option format + used to write option values. If set to [true], the old-style option + format will be used, the new-style one otherwise. + + Initially set to [true]. *) +val write_old_option_format : bool ref + +(** [read_old_option_format] reference for the default option format + used to read option values. [Of_sexp_error] will be raised + with old-style option values if this reference is set to [false]. + Reading new-style option values is always supported. Using a global + reference instead of changing the converter calling conventions is + the only way to avoid breaking old code with the standard macros. + + Initially set to [true]. *) +val read_old_option_format : bool ref + +(** We re-export a tail recursive map function, because some modules + override the standard library functions (e.g. [StdLabels]) which + wrecks havoc with the camlp4 extension. *) +val list_map : ('a -> 'b) -> 'a list -> 'b list + +(** [sexp_of_unit ()] converts a value of type [unit] to an S-expression. *) +val sexp_of_unit : unit -> Sexp.t + +(** [sexp_of_bool b] converts the value [x] of type [bool] to an + S-expression. *) +val sexp_of_bool : bool -> Sexp.t + +(** [sexp_of_bool str] converts the value [str] of type [string] to an + S-expression. *) +val sexp_of_string : string -> Sexp.t + +(** [sexp_of_bool str] converts the value [str] of type [bytes] to an + S-expression. *) +val sexp_of_bytes : bytes -> Sexp.t + +(** [sexp_of_char c] converts the value [c] of type [char] to an + S-expression. *) +val sexp_of_char : char -> Sexp.t + +(** [sexp_of_int n] converts the value [n] of type [int] to an + S-expression. *) +val sexp_of_int : int -> Sexp.t + +(** [sexp_of_float n] converts the value [n] of type [float] to an + S-expression. *) +val sexp_of_float : float -> Sexp.t + +(** [sexp_of_int32 n] converts the value [n] of type [int32] to an + S-expression. *) +val sexp_of_int32 : int32 -> Sexp.t + +(** [sexp_of_int64 n] converts the value [n] of type [int64] to an + S-expression. *) +val sexp_of_int64 : int64 -> Sexp.t + +(** [sexp_of_nativeint n] converts the value [n] of type [nativeint] to an + S-expression. *) +val sexp_of_nativeint : nativeint -> Sexp.t + +(** [sexp_of_ref conv r] converts the value [r] of type ['a ref] to + an S-expression. Uses [conv] to convert values of type ['a] to an + S-expression. *) +val sexp_of_ref : ('a -> Sexp.t) -> 'a ref -> Sexp.t + +(** [sexp_of_lazy_t conv l] converts the value [l] of type ['a lazy_t] to + an S-expression. Uses [conv] to convert values of type ['a] to an + S-expression. *) +val sexp_of_lazy_t : ('a -> Sexp.t) -> 'a lazy_t -> Sexp.t + +(** [sexp_of_option conv opt] converts the value [opt] of type ['a + option] to an S-expression. Uses [conv] to convert values of type + ['a] to an S-expression. *) +val sexp_of_option : ('a -> Sexp.t) -> 'a option -> Sexp.t + +(** [sexp_of_pair conv1 conv2 pair] converts a pair to an S-expression. + It uses its first argument to convert the first element of the pair, + and its second argument to convert the second element of the pair. *) +val sexp_of_pair : ('a -> Sexp.t) -> ('b -> Sexp.t) -> 'a * 'b -> Sexp.t + +(** [sexp_of_triple conv1 conv2 conv3 triple] converts a triple to + an S-expression using [conv1], [conv2], and [conv3] to convert its + elements. *) +val sexp_of_triple + : ('a -> Sexp.t) + -> ('b -> Sexp.t) + -> ('c -> Sexp.t) + -> 'a * 'b * 'c + -> Sexp.t + +(** [sexp_of_list conv lst] converts the value [lst] of type ['a + list] to an S-expression. Uses [conv] to convert values of type + ['a] to an S-expression. *) +val sexp_of_list : ('a -> Sexp.t) -> 'a list -> Sexp.t + +(** [sexp_of_array conv ar] converts the value [ar] of type ['a + array] to an S-expression. Uses [conv] to convert values of type + ['a] to an S-expression. *) +val sexp_of_array : ('a -> Sexp.t) -> 'a array -> Sexp.t + +(** [sexp_of_hashtbl conv_key conv_value htbl] converts the value [htbl] + of type [('a, 'b) Hashtbl.t] to an S-expression. Uses [conv_key] + to convert the hashtable keys of type ['a], and [conv_value] to + convert hashtable values of type ['b] to S-expressions. *) +val sexp_of_hashtbl : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) Hashtbl.t -> Sexp.t + +(** [sexp_of_opaque x] converts the value [x] of opaque type to an + S-expression. This means the user need not provide converters, + but the result cannot be interpreted. *) +val sexp_of_opaque : 'a -> Sexp.t + +(** [sexp_of_fun f] converts the value [f] of function type to a + dummy S-expression. Functions cannot be serialized as S-expressions, + but at least a placeholder can be generated for pretty-printing. *) +val sexp_of_fun : ('a -> 'b) -> Sexp.t + +(** {6 Conversion of S-expressions to OCaml-values} *) + +(** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression + could not be successfully converted to an OCaml-value. *) +exception Of_sexp_error of exn * Sexp.t + +(** [record_check_extra_fields] checks for extra (= unknown) fields + in record S-expressions. *) +val record_check_extra_fields : bool ref + +(** [of_sexp_error reason sexp] @raise Of_sexp_error (Failure reason, sexp). *) +val of_sexp_error : string -> Sexp.t -> 'a + +(** [of_sexp_error exc sexp] @raise Of_sexp_error (exc, sexp). *) +val of_sexp_error_exn : exn -> Sexp.t -> 'a + +(** [unit_of_sexp sexp] converts S-expression [sexp] to a value of type + [unit]. *) +val unit_of_sexp : Sexp.t -> unit + +(** [bool_of_sexp sexp] converts S-expression [sexp] to a value of type + [bool]. *) +val bool_of_sexp : Sexp.t -> bool + +(** [string_of_sexp sexp] converts S-expression [sexp] to a value of type + [string]. *) +val string_of_sexp : Sexp.t -> string + +(** [bytes_of_sexp sexp] converts S-expression [sexp] to a value of type + [bytes]. *) +val bytes_of_sexp : Sexp.t -> bytes + +(** [char_of_sexp sexp] converts S-expression [sexp] to a value of type + [char]. *) +val char_of_sexp : Sexp.t -> char + +(** [int_of_sexp sexp] converts S-expression [sexp] to a value of type + [int]. *) +val int_of_sexp : Sexp.t -> int + +(** [float_of_sexp sexp] converts S-expression [sexp] to a value of type + [float]. *) +val float_of_sexp : Sexp.t -> float + +(** [int32_of_sexp sexp] converts S-expression [sexp] to a value of type + [int32]. *) +val int32_of_sexp : Sexp.t -> int32 + +(** [int64_of_sexp sexp] converts S-expression [sexp] to a value of type + [int64]. *) +val int64_of_sexp : Sexp.t -> int64 + +(** [nativeint_of_sexp sexp] converts S-expression [sexp] to a value + of type [nativeint]. *) +val nativeint_of_sexp : Sexp.t -> nativeint + +(** [ref_of_sexp conv sexp] converts S-expression [sexp] to a value + of type ['a ref] using conversion function [conv], which converts + an S-expression to a value of type ['a]. *) +val ref_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a ref + +(** [lazy_t_of_sexp conv sexp] converts S-expression [sexp] to a value + of type ['a lazy_t] using conversion function [conv], which converts + an S-expression to a value of type ['a]. *) +val lazy_t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a lazy_t + +(** [option_of_sexp conv sexp] converts S-expression [sexp] to a value + of type ['a option] using conversion function [conv], which converts + an S-expression to a value of type ['a]. *) +val option_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a option + +(** [pair_of_sexp conv1 conv2 sexp] converts S-expression [sexp] to a pair + of type ['a * 'b] using conversion functions [conv1] and [conv2], + which convert S-expressions to values of type ['a] and ['b] + respectively. *) +val pair_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> 'a * 'b + +(** [triple_of_sexp conv1 conv2 conv3 sexp] converts S-expression [sexp] + to a triple of type ['a * 'b * 'c] using conversion functions [conv1], + [conv2], and [conv3], which convert S-expressions to values of type + ['a], ['b], and ['c] respectively. *) +val triple_of_sexp + : (Sexp.t -> 'a) + -> (Sexp.t -> 'b) + -> (Sexp.t -> 'c) + -> Sexp.t + -> 'a * 'b * 'c + +(** [list_of_sexp conv sexp] converts S-expression [sexp] to a value + of type ['a list] using conversion function [conv], which converts + an S-expression to a value of type ['a]. *) +val list_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a list + +(** [array_of_sexp conv sexp] converts S-expression [sexp] to a value + of type ['a array] using conversion function [conv], which converts + an S-expression to a value of type ['a]. *) +val array_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a array + +(** [hashtbl_of_sexp conv_key conv_value sexp] converts S-expression + [sexp] to a value of type [('a, 'b) Hashtbl.t] using conversion + function [conv_key], which converts an S-expression to hashtable + key of type ['a], and function [conv_value], which converts an + S-expression to hashtable value of type ['b]. *) +val hashtbl_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) Hashtbl.t + +(** [opaque_of_sexp sexp] @raise Of_sexp_error when attempting to + convert an S-expression to an opaque value. *) +val opaque_of_sexp : Sexp.t -> 'a + +(** [fun_of_sexp sexp] @raise Of_sexp_error when attempting to + convert an S-expression to a function. *) +val fun_of_sexp : Sexp.t -> 'a + +(** Sexp Grammars *) + +include module type of struct + include Sexp_conv_grammar +end + +(** Exception converters *) + +(** [sexp_of_exn exc] converts exception [exc] to an S-expression. + If no suitable converter is found, the standard converter in + [Printexc] will be used to generate an atomic S-expression. *) +val sexp_of_exn : exn -> Sexp.t + +(** Converts an exception to a string via sexp, falling back to [Printexc.to_string] if no + sexp conversion is registered for this exception. + + This is different from [Printexc.to_string] in that it additionally uses the sexp + converters registered with [~printexc:false]. Another difference is that the behavior + of [Printexc] can be overridden with [Printexc.register], but here we always try sexp + conversion first. +*) +val printexc_prefer_sexp : exn -> string + +(** [sexp_of_exn_opt exc] converts exception [exc] to [Some sexp]. + If no suitable converter is found, [None] is returned instead. *) +val sexp_of_exn_opt : exn -> Sexp.t option + +module Exn_converter : sig + (** [add constructor sexp_of_exn] registers exception S-expression + converter [sexp_of_exn] for exceptions with the given [constructor]. + + NOTE: [finalise] is ignored, and provided only for backward compatibility. *) + val add + : ?printexc:bool + -> ?finalise:bool + -> extension_constructor + -> (exn -> Sexp.t) + -> unit + + + module For_unit_tests_only : sig + val size : unit -> int + end +end + +(**/**) + +(*_ For the syntax extension *) +external ignore : _ -> unit = "%ignore" +external ( = ) : 'a -> 'a -> bool = "%equal" diff --git a/src/sexp_conv_error.ml b/src/sexp_conv_error.ml new file mode 100644 index 0000000..6272673 --- /dev/null +++ b/src/sexp_conv_error.ml @@ -0,0 +1,140 @@ +(* Conv_error: Module for Handling Errors during Automated S-expression + Conversions *) + +open StdLabels +open Printf +open Sexp_conv + +exception Of_sexp_error = Of_sexp_error + +(* Errors concerning tuples *) + +let tuple_of_size_n_expected loc n sexp = + of_sexp_error (sprintf "%s_of_sexp: tuple of size %d expected" loc n) sexp +;; + +(* Errors concerning sum types *) + +let stag_no_args loc sexp = + of_sexp_error (loc ^ "_of_sexp: this constructor does not take arguments") sexp +;; + +let stag_incorrect_n_args loc tag sexp = + let msg = sprintf "%s_of_sexp: sum tag %S has incorrect number of arguments" loc tag in + of_sexp_error msg sexp +;; + +let stag_takes_args loc sexp = + of_sexp_error (loc ^ "_of_sexp: this constructor requires arguments") sexp +;; + +let nested_list_invalid_sum loc sexp = + of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw a nested list") sexp +;; + +let empty_list_invalid_sum loc sexp = + of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw an empty list") sexp +;; + +let unexpected_stag loc sexp = + of_sexp_error (loc ^ "_of_sexp: unexpected variant constructor") sexp +;; + +(* Errors concerning records *) + +let record_sexp_bool_with_payload loc sexp = + let msg = + loc ^ "_of_sexp: record conversion: a [sexp.bool] field was given a payload." + in + of_sexp_error msg sexp +;; + +let record_only_pairs_expected loc sexp = + let msg = + loc + ^ "_of_sexp: record conversion: only pairs expected, their first element must be an \ + atom" + in + of_sexp_error msg sexp +;; + +let record_superfluous_fields ~what ~loc rev_fld_names sexp = + let fld_names_str = String.concat (List.rev rev_fld_names) ~sep:" " in + let msg = sprintf "%s_of_sexp: %s: %s" loc what fld_names_str in + of_sexp_error msg sexp +;; + +let record_duplicate_fields loc rev_fld_names sexp = + record_superfluous_fields ~what:"duplicate fields" ~loc rev_fld_names sexp +;; + +let record_extra_fields loc rev_fld_names sexp = + record_superfluous_fields ~what:"extra fields" ~loc rev_fld_names sexp +;; + +let rec record_get_undefined_loop fields = function + | [] -> String.concat (List.rev fields) ~sep:" " + | (true, field) :: rest -> record_get_undefined_loop (field :: fields) rest + | _ :: rest -> record_get_undefined_loop fields rest +;; + +let record_undefined_elements loc sexp lst = + let undefined = record_get_undefined_loop [] lst in + let msg = + sprintf "%s_of_sexp: the following record elements were undefined: %s" loc undefined + in + of_sexp_error msg sexp +;; + +let record_list_instead_atom loc sexp = + let msg = loc ^ "_of_sexp: list instead of atom for record expected" in + of_sexp_error msg sexp +;; + +let record_poly_field_value loc sexp = + let msg = + loc + ^ "_of_sexp: cannot convert values of types resulting from polymorphic record fields" + in + of_sexp_error msg sexp +;; + +(* Errors concerning polymorphic variants *) + +exception No_variant_match + +let no_variant_match () = raise No_variant_match + +let no_matching_variant_found loc sexp = + of_sexp_error (loc ^ "_of_sexp: no matching variant found") sexp +;; + +let ptag_no_args loc sexp = + of_sexp_error (loc ^ "_of_sexp: polymorphic variant does not take arguments") sexp +;; + +let ptag_incorrect_n_args loc cnstr sexp = + let msg = + sprintf + "%s_of_sexp: polymorphic variant tag %S has incorrect number of arguments" + loc + cnstr + in + of_sexp_error msg sexp +;; + +let ptag_takes_args loc sexp = + of_sexp_error (loc ^ "_of_sexp: polymorphic variant tag takes an argument") sexp +;; + +let nested_list_invalid_poly_var loc sexp = + of_sexp_error (loc ^ "_of_sexp: a nested list is an invalid polymorphic variant") sexp +;; + +let empty_list_invalid_poly_var loc sexp = + of_sexp_error (loc ^ "_of_sexp: the empty list is an invalid polymorphic variant") sexp +;; + +let empty_type loc sexp = + of_sexp_error (loc ^ "_of_sexp: trying to convert an empty type") sexp +;; diff --git a/src/sexp_conv_grammar.ml b/src/sexp_conv_grammar.ml new file mode 100644 index 0000000..e1bb43d --- /dev/null +++ b/src/sexp_conv_grammar.ml @@ -0,0 +1,41 @@ +open StdLabels + +let sexp_grammar_with_tags grammar ~tags = + List.fold_right tags ~init:grammar ~f:(fun (key, value) grammar -> + Sexp_grammar.Tagged { key; value; grammar }) +;; + +let sexp_grammar_with_tag_list x ~tags = + List.fold_right tags ~init:x ~f:(fun (key, value) grammar -> + Sexp_grammar.Tag { key; value; grammar }) +;; + +let unit_sexp_grammar : unit Sexp_grammar.t = { untyped = List Empty } +let bool_sexp_grammar : bool Sexp_grammar.t = { untyped = Bool } +let string_sexp_grammar : string Sexp_grammar.t = { untyped = String } +let bytes_sexp_grammar : bytes Sexp_grammar.t = { untyped = String } +let char_sexp_grammar : char Sexp_grammar.t = { untyped = Char } +let int_sexp_grammar : int Sexp_grammar.t = { untyped = Integer } +let float_sexp_grammar : float Sexp_grammar.t = { untyped = Float } +let int32_sexp_grammar : int32 Sexp_grammar.t = { untyped = Integer } +let int64_sexp_grammar : int64 Sexp_grammar.t = { untyped = Integer } +let nativeint_sexp_grammar : nativeint Sexp_grammar.t = { untyped = Integer } +let sexp_t_sexp_grammar : Sexp.t Sexp_grammar.t = { untyped = Any "Sexp.t" } +let ref_sexp_grammar grammar = Sexp_grammar.coerce grammar +let lazy_t_sexp_grammar grammar = Sexp_grammar.coerce grammar + +let option_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ option Sexp_grammar.t = + { untyped = Option untyped } +;; + +let list_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ list Sexp_grammar.t = + { untyped = List (Many untyped) } +;; + +let array_sexp_grammar ({ untyped } : _ Sexp_grammar.t) : _ array Sexp_grammar.t = + { untyped = List (Many untyped) } +;; + +let empty_sexp_grammar : _ Sexp_grammar.t = { untyped = Union [] } +let opaque_sexp_grammar = empty_sexp_grammar +let fun_sexp_grammar = empty_sexp_grammar diff --git a/src/sexp_conv_grammar.mli b/src/sexp_conv_grammar.mli new file mode 100644 index 0000000..167da1a --- /dev/null +++ b/src/sexp_conv_grammar.mli @@ -0,0 +1,32 @@ +(** Grammar constructors. *) + +val sexp_grammar_with_tags + : Sexp_grammar.grammar + -> tags:(string * Sexp.t) list + -> Sexp_grammar.grammar + +val sexp_grammar_with_tag_list + : 'a Sexp_grammar.with_tag_list + -> tags:(string * Sexp.t) list + -> 'a Sexp_grammar.with_tag_list + +(** Sexp grammar definitions. *) + +val unit_sexp_grammar : unit Sexp_grammar.t +val bool_sexp_grammar : bool Sexp_grammar.t +val string_sexp_grammar : string Sexp_grammar.t +val bytes_sexp_grammar : bytes Sexp_grammar.t +val char_sexp_grammar : char Sexp_grammar.t +val int_sexp_grammar : int Sexp_grammar.t +val float_sexp_grammar : float Sexp_grammar.t +val int32_sexp_grammar : int32 Sexp_grammar.t +val int64_sexp_grammar : int64 Sexp_grammar.t +val nativeint_sexp_grammar : nativeint Sexp_grammar.t +val sexp_t_sexp_grammar : Sexp.t Sexp_grammar.t +val ref_sexp_grammar : 'a Sexp_grammar.t -> 'a ref Sexp_grammar.t +val lazy_t_sexp_grammar : 'a Sexp_grammar.t -> 'a lazy_t Sexp_grammar.t +val option_sexp_grammar : 'a Sexp_grammar.t -> 'a option Sexp_grammar.t +val list_sexp_grammar : 'a Sexp_grammar.t -> 'a list Sexp_grammar.t +val array_sexp_grammar : 'a Sexp_grammar.t -> 'a array Sexp_grammar.t +val opaque_sexp_grammar : 'a Sexp_grammar.t +val fun_sexp_grammar : 'a Sexp_grammar.t diff --git a/src/sexp_conv_record.ml b/src/sexp_conv_record.ml new file mode 100644 index 0000000..7be09fe --- /dev/null +++ b/src/sexp_conv_record.ml @@ -0,0 +1,297 @@ +open! StdLabels +open! Sexp_conv +open! Sexp_conv_error + +module Kind = struct + type (_, _) t = + | Default : (unit -> 'a) -> ('a, Sexp.t -> 'a) t + | Omit_nil : ('a, Sexp.t -> 'a) t + | Required : ('a, Sexp.t -> 'a) t + | Sexp_array : ('a array, Sexp.t -> 'a) t + | Sexp_bool : (bool, unit) t + | Sexp_list : ('a list, Sexp.t -> 'a) t + | Sexp_option : ('a option, Sexp.t -> 'a) t +end + +module Fields = struct + type _ t = + | Empty : unit t + | Field : + { name : string + ; kind : ('a, 'conv) Kind.t + ; conv : 'conv + ; rest : 'b t + } + -> ('a * 'b) t + + let length = + let rec length_loop : type a. a t -> int -> int = + fun t acc -> + match t with + | Field { rest; _ } -> length_loop rest (acc + 1) + | Empty -> acc + in + fun t -> length_loop t 0 + ;; +end + +module Malformed = struct + (* Represents errors that can occur due to malformed record sexps. Accumulated as a + value so we can report multiple names at once for extra fields, duplicate fields, or + missing fields. *) + type t = + | Bool_payload + | Extras of string list + | Dups of string list + | Missing of string list + | Non_pair of Sexp.t option + + let combine a b = + match a, b with + (* choose the first bool-payload or non-pair error that occurs *) + | ((Bool_payload | Non_pair _) as t), _ -> t + | _, ((Bool_payload | Non_pair _) as t) -> t + (* combine lists of similar errors *) + | Extras a, Extras b -> Extras (a @ b) + | Dups a, Dups b -> Dups (a @ b) + | Missing a, Missing b -> Missing (a @ b) + (* otherwise, dups > extras > missing *) + | (Dups _ as t), _ | _, (Dups _ as t) -> t + | (Extras _ as t), _ | _, (Extras _ as t) -> t + ;; + + let raise t ~caller ~context = + match t with + | Bool_payload -> record_sexp_bool_with_payload caller context + | Extras names -> record_extra_fields caller (List.rev names) context + | Dups names -> record_duplicate_fields caller (List.rev names) context + | Missing names -> + List.map names ~f:(fun name -> true, name) + |> record_undefined_elements caller context + | Non_pair maybe_context -> + let context = Option.value maybe_context ~default:context in + record_only_pairs_expected caller context + ;; +end + +exception Malformed of Malformed.t + +module State = struct + (* Stores sexps corresponding to record fields, in the order the fields were declared. + Excludes fields already parsed in the fast path. + + List sexps represent a field that is present, such as (x 1) for a field named "x". + Atom sexps represent a field that is absent, or at least not yet seen. *) + type t = { state : Sexp.t array } [@@unboxed] + + let unsafe_get t pos = Array.unsafe_get t.state pos + let unsafe_set t pos sexp = Array.unsafe_set t.state pos sexp + let absent = Sexp.Atom "" + let create len = { state = Array.make len absent } +end + +(* Parsing field values from state. *) + +let rec parse_value_malformed + : type a b. Malformed.t -> fields:(a * b) Fields.t -> state:State.t -> pos:int -> a + = + fun malformed ~fields ~state ~pos -> + let (Field field) = fields in + let malformed = + match parse_values ~fields:field.rest ~state ~pos:(pos + 1) with + | (_ : b) -> malformed + | exception Malformed other -> Malformed.combine malformed other + in + raise (Malformed malformed) + +and parse_value : type a b. fields:(a * b) Fields.t -> state:State.t -> pos:int -> a * b = + fun ~fields ~state ~pos -> + let (Field { name; kind; conv; rest }) = fields in + let value : a = + match kind, State.unsafe_get state pos with + (* well-formed *) + | Required, List [ _; sexp ] -> conv sexp + | Default _, List [ _; sexp ] -> conv sexp + | Omit_nil, List [ _; sexp ] -> conv sexp + | Sexp_option, List [ _; sexp ] -> Some (conv sexp) + | Sexp_list, List [ _; sexp ] -> list_of_sexp conv sexp + | Sexp_array, List [ _; sexp ] -> array_of_sexp conv sexp + | Sexp_bool, List [ _ ] -> true + (* ill-formed *) + | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) + , (List (_ :: _ :: _ :: _) as sexp) ) -> + parse_value_malformed (Non_pair (Some sexp)) ~fields ~state ~pos + | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) + , List ([] | [ _ ]) ) -> parse_value_malformed (Non_pair None) ~fields ~state ~pos + | Sexp_bool, List ([] | _ :: _ :: _) -> + parse_value_malformed Bool_payload ~fields ~state ~pos + (* absent *) + | Required, Atom _ -> parse_value_malformed (Missing [ name ]) ~fields ~state ~pos + | Default default, Atom _ -> default () + | Omit_nil, Atom _ -> conv (List []) + | Sexp_option, Atom _ -> None + | Sexp_list, Atom _ -> [] + | Sexp_array, Atom _ -> [||] + | Sexp_bool, Atom _ -> false + in + value, parse_values ~fields:rest ~state ~pos:(pos + 1) + +and parse_values : type a. fields:a Fields.t -> state:State.t -> pos:int -> a = + fun ~fields ~state ~pos -> + match fields with + | Field _ -> parse_value ~fields ~state ~pos + | Empty -> () +;; + +(* Populating state. Handles slow path cases where there may be reordered, duplicated, + missing, or extra fields. *) + +let rec parse_spine_malformed malformed ~index ~extra ~seen ~state ~len sexps = + let malformed = + match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with + | () -> malformed + | exception Malformed other -> Malformed.combine malformed other + in + raise (Malformed malformed) + +and parse_spine_slow ~index ~extra ~seen ~state ~len sexps = + match (sexps : Sexp.t list) with + | [] -> () + | (List (Atom name :: _) as field) :: sexps -> + let i = index name in + (match seen <= i && i < len with + | true -> + (* valid field for slow-path parsing *) + let pos = i - seen in + (match State.unsafe_get state pos with + | Atom _ -> + (* field not seen yet *) + State.unsafe_set state pos field; + parse_spine_slow ~index ~extra ~seen ~state ~len sexps + | List _ -> + (* field already seen *) + parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps) + | false -> + (match 0 <= i && i < seen with + | true -> + (* field seen in fast path *) + parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps + | false -> + (* extra field *) + (match extra with + | true -> parse_spine_slow ~index ~extra ~seen ~state ~len sexps + | false -> + parse_spine_malformed (Extras [ name ]) ~index ~extra ~seen ~state ~len sexps))) + | sexp :: sexps -> + parse_spine_malformed (Non_pair (Some sexp)) ~index ~extra ~seen ~state ~len sexps +;; + +(* Slow path for record parsing. Uses state to store fields as they are discovered. *) + +let parse_record_slow ~fields ~index ~extra ~seen sexps = + let unseen = Fields.length fields in + let state = State.create unseen in + let len = seen + unseen in + (* populate state *) + parse_spine_slow ~index ~extra ~seen ~state ~len sexps; + (* parse values from state *) + parse_values ~fields ~state ~pos:0 +;; + +(* Fast path for record parsing. Directly parses and returns fields in the order they are + declared. Falls back on slow path if any fields are absent, reordered, or malformed. *) + +let rec parse_field_fast + : type a b. + fields:(a * b) Fields.t + -> index:(string -> int) + -> extra:bool + -> seen:int + -> Sexp.t list + -> a * b + = + fun ~fields ~index ~extra ~seen sexps -> + let (Field { name; kind; conv; rest }) = fields in + match sexps with + | List (Atom atom :: args) :: others when String.equal atom name -> + (match kind, args with + | Required, [ sexp ] -> + conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others + | Default _, [ sexp ] -> + conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others + | Omit_nil, [ sexp ] -> + conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others + | Sexp_option, [ sexp ] -> + ( Some (conv sexp) + , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) + | Sexp_list, [ sexp ] -> + ( list_of_sexp conv sexp + , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) + | Sexp_array, [ sexp ] -> + ( array_of_sexp conv sexp + , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) + | Sexp_bool, [] -> + true, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others + (* malformed field of some kind, dispatch to slow path *) + | _, _ -> parse_record_slow ~fields ~index ~extra ~seen sexps) + (* malformed or out-of-order field, dispatch to slow path *) + | _ -> parse_record_slow ~fields ~index ~extra ~seen sexps + +and parse_spine_fast + : type a. + fields:a Fields.t + -> index:(string -> int) + -> extra:bool + -> seen:int + -> Sexp.t list + -> a + = + fun ~fields ~index ~extra ~seen sexps -> + match fields with + | Field _ -> parse_field_fast ~fields ~index ~extra ~seen sexps + | Empty -> + (match sexps with + | [] -> () + | _ :: _ -> + (* extra sexps, dispatch to slow path *) + parse_record_slow ~fields ~index ~extra ~seen sexps) +;; + +let parse_record_fast ~fields ~index ~extra sexps = + parse_spine_fast ~fields ~index ~extra ~seen:0 sexps +;; + +(* Entry points. *) + +let record_of_sexps + ~caller + ~context + ~fields + ~index_of_field + ~allow_extra_fields + ~create + sexps + = + let allow_extra_fields = + allow_extra_fields || not !Sexp_conv.record_check_extra_fields + in + match + parse_record_fast ~fields ~index:index_of_field ~extra:allow_extra_fields sexps + with + | value -> create value + | exception Malformed malformed -> Malformed.raise malformed ~caller ~context +;; + +let record_of_sexp ~caller ~fields ~index_of_field ~allow_extra_fields ~create sexp = + match (sexp : Sexp.t) with + | Atom _ as context -> record_list_instead_atom caller context + | List sexps as context -> + record_of_sexps + ~caller + ~context + ~fields + ~index_of_field + ~allow_extra_fields + ~create + sexps +;; diff --git a/src/sexp_conv_record.mli b/src/sexp_conv_record.mli new file mode 100644 index 0000000..82a4f69 --- /dev/null +++ b/src/sexp_conv_record.mli @@ -0,0 +1,54 @@ +module Kind : sig + (** A GADT specifying how to parse a record field. See documentation for + [ppx_sexp_conv]. *) + type (_, _) t = + | Default : (unit -> 'a) -> ('a, Sexp.t -> 'a) t + | Omit_nil : ('a, Sexp.t -> 'a) t + | Required : ('a, Sexp.t -> 'a) t + | Sexp_array : ('a array, Sexp.t -> 'a) t + | Sexp_bool : (bool, unit) t + | Sexp_list : ('a list, Sexp.t -> 'a) t + | Sexp_option : ('a option, Sexp.t -> 'a) t +end + +module Fields : sig + (** A GADT specifying record fields. *) + type _ t = + | Empty : unit t + | Field : + { name : string + ; kind : ('a, 'conv) Kind.t + ; conv : 'conv + ; rest : 'b t + } + -> ('a * 'b) t +end + +(** Parses a record from a sexp that must be a list of fields. + + Uses [caller] as the source for error messages. Parses using the given [field]s. Uses + [index_of_field] to look up field names found in sexps. If [allow_extra_fields] is + true, extra fields are allowed and discarded without error. [create] is used to + construct the final returned value. +*) +val record_of_sexp + : caller:string + -> fields:'a Fields.t + -> index_of_field:(string -> int) + -> allow_extra_fields:bool + -> create:('a -> 'b) + -> Sexp.t + -> 'b + +(** Like [record_of_sexp], but for a list of sexps with no [List] wrapper. Used, for + example, to parse arguments to a variant constructor with an inlined record argument. + Reports [context] for parse errors when no more specific sexp is applicable. *) +val record_of_sexps + : caller:string + -> context:Sexp.t + -> fields:'a Fields.t + -> index_of_field:(string -> int) + -> allow_extra_fields:bool + -> create:('a -> 'b) + -> Sexp.t list + -> 'b diff --git a/src/sexp_grammar.ml b/src/sexp_grammar.ml new file mode 100644 index 0000000..5ee724f --- /dev/null +++ b/src/sexp_grammar.ml @@ -0,0 +1,207 @@ +(** Representation of S-expression grammars *) + +(** This module defines a representation for s-expression grammars. Using ppx_sexp_conv + and [[@@deriving sexp_grammar]] produces a grammar that is compatible with the derived + [of_sexp] for a given type. + + As with other derived definitions, polymorphic types derive a function that takes a + grammar for each type argument and produces a grammar for the monomorphized type. + + Monomorphic types derive a grammar directly. To avoid top-level side effects, + [[@@deriving sexp_grammar]] wraps grammars in the [Lazy] constructor as needed. + + This type may change over time as our needs for expressive grammars change. We will + attempt to make changes backward-compatible, or at least provide a reasonable upgrade + path. *) + +[@@@warning "-30"] (* allow duplicate field names *) + +(** Grammar of a sexp. *) +type grammar = + | Any of string (** accepts any sexp; string is a type name for human readability *) + | Bool (** accepts the atoms "true" or "false", modulo capitalization *) + | Char (** accepts any single-character atom *) + | Integer (** accepts any atom matching ocaml integer syntax, regardless of bit width *) + | Float (** accepts any atom matching ocaml float syntax *) + | String (** accepts any atom *) + | Option of grammar (** accepts an option, both [None] vs [Some _] and [()] vs [(_)]. *) + | List of list_grammar (** accepts a list *) + | Variant of variant (** accepts clauses keyed by a leading or sole atom *) + | Union of grammar list (** accepts a sexp if any of the listed grammars accepts it *) + | Tagged of grammar with_tag + (** annotates a grammar with a client-specific key/value pair *) + | Tyvar of string + (** Name of a type variable, e.g. [Tyvar "a"] for ['a]. Only meaningful when the body of + the innermost enclosing [defn] defines a corresponding type variable. *) + | Tycon of string * grammar list * defn list + (** Type constructor applied to arguments, and its definition. + + For example, writing [Tycon ("tree", [ Integer ], defns)] represents [int tree], for + whatever [tree] is defined as in [defns]. The following defines [tree] as a binary + tree with the parameter type stored at the leaves. + + {[ + let defns = + [ { tycon = "tree" + ; tyvars = ["a"] + ; grammar = + Variant + { name_kind = Capitalized + ; clauses = + [ { name = "Node" + ; args = Cons (Recursive ("node", [Tyvar "a"]), Empty) + } + ; { name = "Leaf" + ; args = Cons (Recursive ("leaf", [Tyvar "a"]), Empty) + } + ] + } + } + ; { tycon = "node" + ; tyvars = ["a"] + ; grammar = List (Many (Recursive "tree", [Tyvar "a"])) + } + ; { tycon = "leaf" + ; tyvars = ["a"] + ; grammar = [Tyvar "a"] + } + ] + ;; + ]} + + To illustrate the meaning of [Tycon] with respect to [defns], and to demonstrate one + way to access them, it is equivalent to expand the definition of "tree" one level + and move the [defns] to enclosed recursive references: + + {[ + Tycon ("tree", [ Integer ], defns) + --> + Variant + { name_kind = Capitalized + ; clauses = + [ { name = "Node" + ; args = Cons (Tycon ("node", [Tyvar "a"], defns), Empty) + } + ; { name = "Leaf" + ; args = Cons (Tycon ("leaf", [Tyvar "a"], defns), Empty) + } + ] + } + ]} + + This transformation exposes the structure of a grammar with recursive references, + while preserving the meaning of recursively-defined elements. *) + | Recursive of string * grammar list + (** Type constructor applied to arguments. Used to denote recursive type references. + Only meaningful when used inside the [defn]s of a [Tycon] grammar, to refer to a + type constructor in the nearest enclosing [defn] list. *) + | Lazy of grammar lazy_t + (** Lazily computed grammar. Use [Lazy] to avoid top-level side effects. To define + recursive grammars, use [Recursive] instead. *) + +(** Grammar of a list of sexps. *) +and list_grammar = + | Empty (** accepts an empty list of sexps *) + | Cons of grammar * list_grammar + (** accepts a non-empty list with head and tail matching the given grammars *) + | Many of grammar (** accepts zero or more sexps, each matching the given grammar *) + | Fields of record (** accepts sexps representing fields of a record *) + +(** Case sensitivity options for names of variant constructors. *) +and case_sensitivity = + | Case_insensitive (** Comparison is case insensitive. Used for custom parsers. *) + | Case_sensitive (** Comparison is case sensitive. Used for polymorphic variants. *) + | Case_sensitive_except_first_character + (** Comparison is case insensitive for the first character and case sensitive afterward. + Used for regular variants. *) + +(** Grammar of variants. Accepts any sexp matching one of the clauses. *) +and variant = + { case_sensitivity : case_sensitivity + ; clauses : clause with_tag_list list + } + +(** Grammar of a single variant clause. Accepts sexps based on the [clause_kind]. *) +and clause = + { name : string + ; clause_kind : clause_kind + } + +(** Grammar of a single variant clause's contents. [Atom_clause] accepts an atom matching + the clause's name. [List_clause] accepts a list whose head is an atom matching the + clause's name and whose tail matches [args]. The clause's name is matched modulo the + variant's [name_kind]. *) +and clause_kind = + | Atom_clause + | List_clause of { args : list_grammar } + +(** Grammar of a record. Accepts any list of sexps specifying each of the fields, + regardless of order. If [allow_extra_fields] is specified, ignores sexps with names + not found in [fields]. *) +and record = + { allow_extra_fields : bool + ; fields : field with_tag_list list + } + +(** Grammar of a record field. A field must show up exactly once in a record if + [required], or at most once otherwise. Accepts a list headed by [name] as an atom, + followed by sexps matching [args]. *) +and field = + { name : string + ; required : bool + ; args : list_grammar + } + +(** Grammar tagged with client-specific key/value pair. *) +and 'a with_tag = + { key : string + ; value : Sexp.t + ; grammar : 'a + } + +and 'a with_tag_list = + | Tag of 'a with_tag_list with_tag + | No_tag of 'a + +(** Grammar of a recursive type definition. Names the [tycon] being defined, and the + [tyvars] it takes as parameters. Specifies the [grammar] of the [tycon]. The grammar + may refer to any of the [tyvars], and to any of the [tycon]s from the same set of + [Recursive] definitions. *) +and defn = + { tycon : string + ; tyvars : string list + ; grammar : grammar + } + +(** Top-level grammar type. Has a phantom type parameter to associate each grammar with + the type its sexps represent. This makes it harder to apply grammars to the wrong + type, while grammars can still be easily coerced to a new type if needed. *) +type _ t = { untyped : grammar } [@@unboxed] + +let coerce (type a b) ({ untyped = _ } as t : a t) : b t = t + +let tag (type a) ({ untyped = grammar } : a t) ~key ~value : a t = + { untyped = Tagged { key; value; grammar } } +;; + +(** This reserved key is used for all tags generated from doc comments. *) +let doc_comment_tag = "sexp_grammar.doc_comment" + +(** This reserved key can be used to associate a type name with a grammar. *) +let type_name_tag = "sexp_grammar.type_name" + +(** This reserved key indicates that a sexp represents a key/value association. The tag's + value is ignored. *) +let assoc_tag = "sexp_grammar.assoc" + +(** This reserved key indicates that a sexp is a key in a key/value association. The tag's + value is ignored. *) +let assoc_key_tag = "sexp_grammar.assoc.key" + +(** This reserved key indicates that a sexp is a value in a key/value association. The + tag's value is ignored. *) +let assoc_value_tag = "sexp_grammar.assoc.value" + +(** When the key is set to [Atom "false"] for a variant clause, that clause should not be + suggested in auto-completion based on the sexp grammar. *) +let completion_suggested = "sexp_grammar.completion-suggested" diff --git a/src/sexpable.ml b/src/sexpable.ml new file mode 100644 index 0000000..4d62f4f --- /dev/null +++ b/src/sexpable.ml @@ -0,0 +1,38 @@ +module type S = sig + type t + + val t_of_sexp : Sexp.t -> t + val sexp_of_t : t -> Sexp.t +end + +module type S1 = sig + type 'a t + + val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t + val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t +end + +module type S2 = sig + type ('a, 'b) t + + val t_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t + val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t +end + +module type S3 = sig + type ('a, 'b, 'c) t + + val t_of_sexp + : (Sexp.t -> 'a) + -> (Sexp.t -> 'b) + -> (Sexp.t -> 'c) + -> Sexp.t + -> ('a, 'b, 'c) t + + val sexp_of_t + : ('a -> Sexp.t) + -> ('b -> Sexp.t) + -> ('c -> Sexp.t) + -> ('a, 'b, 'c) t + -> Sexp.t +end diff --git a/src/sexplib0.ml b/src/sexplib0.ml new file mode 100644 index 0000000..6fc8163 --- /dev/null +++ b/src/sexplib0.ml @@ -0,0 +1,6 @@ +module Sexp = Sexp +module Sexp_conv = Sexp_conv +module Sexp_conv_error = Sexp_conv_error +module Sexp_conv_record = Sexp_conv_record +module Sexp_grammar = Sexp_grammar +module Sexpable = Sexpable diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..2f7a7de --- /dev/null +++ b/test/dune @@ -0,0 +1,4 @@ +(library (name sexplib0_test) + (libraries base expect_test_helpers_core.expect_test_helpers_base sexplib0) + (preprocess + (pps ppx_compare ppx_expect ppx_here ppx_sexp_conv ppx_sexp_value)))
\ No newline at end of file diff --git a/test/sexplib0_test.ml b/test/sexplib0_test.ml new file mode 100644 index 0000000..4ff76b1 --- /dev/null +++ b/test/sexplib0_test.ml @@ -0,0 +1,452 @@ +open! Base +open Expect_test_helpers_base +open Sexplib0 + +let () = sexp_style := Sexp_style.simple_pretty + +module type S = sig + type t [@@deriving equal, sexp] +end + +let test (type a) (module M : S with type t = a) string = + let sexp = Parsexp.Single.parse_string_exn string in + let result = Or_error.try_with (fun () -> M.t_of_sexp sexp) in + print_s [%sexp (result : M.t Or_error.t)] +;; + +let%expect_test "simple record" = + let module M = struct + type t = + { x : int + ; y : int + } + [@@deriving equal, sexp_of] + + let t_of_sexp = + Sexp_conv_record.record_of_sexp + ~caller:"M.t" + ~fields: + (Field + { name = "x" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field { name = "y"; kind = Required; conv = int_of_sexp; rest = Empty } + }) + ~index_of_field:(function + | "x" -> 0 + | "y" -> 1 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun (x, (y, ())) -> { x; y }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((x 1) (y 2))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* reverse order *) + test "((y 2) (x 1))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* duplicate fields *) + test "((x 1) (x 2) (y 3) (y 4))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: duplicate fields: x y" + (invalid_sexp ((x 1) (x 2) (y 3) (y 4))))) |}]; + (* extra fields *) + test "((a 1) (b 2) (c 3))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: extra fields: a b c" + (invalid_sexp ((a 1) (b 2) (c 3))))) |}]; + (* missing field *) + test "((x 1))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: y" + (invalid_sexp ((x 1))))) |}]; + (* other missing field *) + test "((y 2))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: x" + (invalid_sexp ((y 2))))) |}]; + (* multiple missing fields *) + test "()"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: x y" + (invalid_sexp ()))) |}]; + () +;; + +let%expect_test "record with extra fields" = + let module M = struct + type t = + { x : int + ; y : int + } + [@@deriving equal, sexp_of] + + let t_of_sexp = + Sexp_conv_record.record_of_sexp + ~caller:"M.t" + ~fields: + (Field + { name = "x" + ; kind = Required + ; conv = int_of_sexp + ; rest = + Field { name = "y"; kind = Required; conv = int_of_sexp; rest = Empty } + }) + ~index_of_field:(function + | "x" -> 0 + | "y" -> 1 + | _ -> -1) + ~allow_extra_fields:true + ~create:(fun (x, (y, ())) -> { x; y }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((x 1) (y 2))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* reversed order *) + test "((y 2) (x 1))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* extra field *) + test "((x 1) (y 2) (z 3))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* missing field *) + test "((x 1))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: y" + (invalid_sexp ((x 1))))) |}]; + (* other missing field *) + test "((y 2))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: x" + (invalid_sexp ((y 2))))) |}]; + (* multiple missing fields *) + test "()"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: x y" + (invalid_sexp ()))) |}]; + () +;; + +let%expect_test "record with defaults" = + let module M = struct + type t = + { x : int + ; y : int + } + [@@deriving equal, sexp_of] + + let t_of_sexp = + Sexp_conv_record.record_of_sexp + ~caller:"M.t" + ~fields: + (Field + { name = "x" + ; kind = Default (fun () -> 0) + ; conv = int_of_sexp + ; rest = + Field + { name = "y" + ; kind = Default (fun () -> 0) + ; conv = int_of_sexp + ; rest = Empty + } + }) + ~index_of_field:(function + | "x" -> 0 + | "y" -> 1 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun (x, (y, ())) -> { x; y }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((x 1) (y 2))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* reverse order *) + test "((y 2) (x 1))"; + [%expect {| (Ok ((x 1) (y 2))) |}]; + (* extra field *) + test "((x 1) (y 2) (z 3))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: extra fields: z" + (invalid_sexp ((x 1) (y 2) (z 3))))) |}]; + (* missing field *) + test "((x 1))"; + [%expect {| (Ok ((x 1) (y 0))) |}]; + (* other missing field *) + test "((y 2))"; + [%expect {| (Ok ((x 0) (y 2))) |}]; + (* multiple missing fields *) + test "()"; + [%expect {| (Ok ((x 0) (y 0))) |}]; + () +;; + +let%expect_test "record with omit nil" = + let module M = struct + type t = + { a : int option + ; b : int list + } + [@@deriving equal, sexp_of] + + let t_of_sexp = + Sexp_conv_record.record_of_sexp + ~caller:"M.t" + ~fields: + (Field + { name = "a" + ; kind = Omit_nil + ; conv = option_of_sexp int_of_sexp + ; rest = + Field + { name = "b" + ; kind = Omit_nil + ; conv = list_of_sexp int_of_sexp + ; rest = Empty + } + }) + ~index_of_field:(function + | "a" -> 0 + | "b" -> 1 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun (a, (b, ())) -> { a; b }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((a (1)) (b (2 3)))"; + [%expect {| (Ok ((a (1)) (b (2 3)))) |}]; + (* reverse order *) + test "((b ()) (a ()))"; + [%expect {| (Ok ((a ()) (b ()))) |}]; + (* extra field *) + test "((a (1)) (b (2 3)) (z ()))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: extra fields: z" + (invalid_sexp ((a (1)) (b (2 3)) (z ()))))) |}]; + (* missing field *) + test "((a (1)))"; + [%expect {| (Ok ((a (1)) (b ()))) |}]; + (* other missing field *) + test "((b (2 3)))"; + [%expect {| (Ok ((a ()) (b (2 3)))) |}]; + (* multiple missing fields *) + test "()"; + [%expect {| (Ok ((a ()) (b ()))) |}]; + () +;; + +let%expect_test "record with sexp types" = + let module M = struct + type t = + { a : int option + ; b : int list + ; c : int array + ; d : bool + } + [@@deriving equal, sexp_of] + + let t_of_sexp = + Sexp_conv_record.record_of_sexp + ~caller:"M.t" + ~fields: + (Field + { name = "a" + ; kind = Sexp_option + ; conv = int_of_sexp + ; rest = + Field + { name = "b" + ; kind = Sexp_list + ; conv = int_of_sexp + ; rest = + Field + { name = "c" + ; kind = Sexp_array + ; conv = int_of_sexp + ; rest = + Field + { name = "d"; kind = Sexp_bool; conv = (); rest = Empty } + } + } + }) + ~index_of_field:(function + | "a" -> 0 + | "b" -> 1 + | "c" -> 2 + | "d" -> 3 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun (a, (b, (c, (d, ())))) -> { a; b; c; d }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((a 1) (b (2 3)) (c (4 5)) (d))"; + [%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d true))) |}]; + (* reverse order *) + test "((d) (c ()) (b ()) (a 1))"; + [%expect {| (Ok ((a (1)) (b ()) (c ()) (d true))) |}]; + (* missing field d *) + test "((a 1) (b (2 3)) (c (4 5)))"; + [%expect {| (Ok ((a (1)) (b (2 3)) (c (4 5)) (d false))) |}]; + (* missing field c *) + test "((a 1) (b (2 3)) (d))"; + [%expect {| (Ok ((a (1)) (b (2 3)) (c ()) (d true))) |}]; + (* missing field b *) + test "((a 1) (c (2 3)) (d))"; + [%expect {| (Ok ((a (1)) (b ()) (c (2 3)) (d true))) |}]; + (* missing field a *) + test "((b (1 2)) (c (3 4)) (d))"; + [%expect {| (Ok ((a ()) (b (1 2)) (c (3 4)) (d true))) |}]; + (* extra field *) + test "((a 1) (b (2 3)) (c (4 5)) (d) (e (6 7)))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: extra fields: e" + (invalid_sexp ((a 1) (b (2 3)) (c (4 5)) (d) (e (6 7)))))) |}]; + (* all fields missing *) + test "()"; + [%expect {| (Ok ((a ()) (b ()) (c ()) (d false))) |}]; + () +;; + +let%expect_test "record with polymorphic fields" = + let module M = struct + type t = + { a : 'a. 'a list + ; b : 'a 'b. ('a, 'b) Result.t option + } + [@@deriving sexp_of] + + let equal = Poly.equal + + let t_of_sexp = + let open struct + type a = { a : 'a. 'a list } [@@unboxed] + type b = { b : 'a 'b. ('a, 'b) Result.t option } [@@unboxed] + end in + let caller = "M.t" in + Sexp_conv_record.record_of_sexp + ~caller + ~fields: + (Field + { name = "a" + ; kind = Required + ; conv = + (fun sexp -> + { a = + list_of_sexp + (Sexplib.Conv_error.record_poly_field_value caller) + sexp + }) + ; rest = + Field + { name = "b" + ; kind = Required + ; conv = + (fun sexp -> + { b = + Option.t_of_sexp + (Result.t_of_sexp + (Sexplib.Conv_error.record_poly_field_value caller) + (Sexplib.Conv_error.record_poly_field_value caller)) + sexp + }) + ; rest = Empty + } + }) + ~index_of_field:(function + | "a" -> 0 + | "b" -> 1 + | _ -> -1) + ~allow_extra_fields:false + ~create:(fun ({ a }, ({ b }, ())) -> { a; b }) + ;; + end + in + let test = test (module M) in + (* in order *) + test "((a ()) (b ()))"; + [%expect {| (Ok ((a ()) (b ()))) |}]; + (* reverse order *) + test "((b ()) (a ()))"; + [%expect {| (Ok ((a ()) (b ()))) |}]; + (* attempt to deserialize paramter to [a] *) + test "((a (_)) (b ()))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" + (invalid_sexp _))) |}]; + (* attempt to deserialize first parameter to [b] *) + test "((a ()) (b ((Ok _))))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" + (invalid_sexp _))) |}]; + (* attempt to deserialize second parameter to [b] *) + test "((a ()) (b ((Error _))))"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: cannot convert values of types resulting from polymorphic record fields" + (invalid_sexp _))) |}]; + (* multiple missing fields *) + test "()"; + [%expect + {| + (Error + (Of_sexp_error + "M.t_of_sexp: the following record elements were undefined: a b" + (invalid_sexp ()))) |}]; + () +;; diff --git a/test/sexplib0_test.mli b/test/sexplib0_test.mli new file mode 100644 index 0000000..74bb729 --- /dev/null +++ b/test/sexplib0_test.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) |