unikernel/duniverse/sexplib0/.gitignore

@@ -0,0 +1,5 @@
+_build
+*.install
+*.merlin
+_opam
+

unikernel/duniverse/sexplib0/.ocamlformat

@@ -0,0 +1 @@
+profile=janestreet

unikernel/duniverse/sexplib0/CHANGES.md

@@ -0,0 +1,18 @@
+## Release v0.17.0
+
+* Add a test that `Sexp.to_string` works on large input.
+
+* Improve error messages produced by `Sexp_conv`
+
+* Use `[@tail_mod_cons]` in `sexp_of_list`.
+
+* Add support for labeled tuples, a compiler extension available at:
+  https://github.com/ocaml-flambda/flambda-backend
+
+## 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`.

unikernel/duniverse/sexplib0/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/

unikernel/duniverse/sexplib0/LICENSE.md

@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2005--2024 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.

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/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.

unikernel/duniverse/sexplib0/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 ()))"

unikernel/duniverse/sexplib0/bench/bench_record.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/sexplib0/bench/dune

@@ -0,0 +1,5 @@
+(library
+ (name sexplib0_bench)
+ (libraries parsexp sexplib0)
+ (preprocess
+  (pps ppx_bench)))

unikernel/duniverse/sexplib0/bench/sexplib0_bench.ml

@@ -0,0 +1 @@
+(*_ Deliberately empty. *)

unikernel/duniverse/sexplib0/dune-project

@@ -0,0 +1 @@
+(lang dune 3.11)

unikernel/duniverse/sexplib0/sexplib0.opam

@@ -0,0 +1,24 @@
+opam-version: "2.0"
+version: "v0.17.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.14.0"}
+  "dune" {>= "3.11.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.
+"

unikernel/duniverse/sexplib0/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name sexplib0)
+ (public_name sexplib0)
+ (preprocess no_preprocessing)
+ (ocamlopt_flags :standard -O3))

unikernel/duniverse/sexplib0/src/sexp.ml

@@ -0,0 +1,361 @@
+[@@@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 rec equal a b =
+  a == b
+  ||
+  match a, b with
+  | Atom a, Atom b -> String.equal a b
+  | Atom _, _ | _, Atom _ -> false
+  | List a, List b -> List.equal ~eq:equal a b
+;;
+
+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)
+;;

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/src/sexp_conv.ml

@@ -0,0 +1,411 @@
+(* 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.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 ]
+;;
+
+let sexp_of_list sexp_of__a lst = List (List.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 -> List.map lst ~f:a__of_sexp
+  | 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"

unikernel/duniverse/sexplib0/src/sexp_conv.mli

@@ -0,0 +1,289 @@
+(** 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_string str] converts the value [str] of type [string] to an
+    S-expression. *)
+val sexp_of_string : string -> Sexp.t
+
+(** [sexp_of_bytes 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"

unikernel/duniverse/sexplib0/src/sexp_conv_error.ml

@@ -0,0 +1,111 @@
+(* 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
+
+let error ~loc ~sexp msg = of_sexp_error (sprintf "%s_of_sexp: %s" loc msg) sexp
+let simple_error msg loc sexp = error ~loc ~sexp msg
+
+(* Errors concerning tuples *)
+
+let tuple_of_size_n_expected loc n sexp =
+  error ~loc ~sexp (sprintf "tuple of size %d expected" n)
+;;
+
+let tuple_pair_expected loc name sexp =
+  let msg = sprintf "%s_of_sexp: expected a pair beginning with label %s" loc name in
+  of_sexp_error msg sexp
+;;
+
+let tuple_incorrect_label loc name pos sexp =
+  let msg =
+    sprintf "%s_of_sexp: incorrect label for element %s at position %i" loc name pos
+  in
+  of_sexp_error msg sexp
+;;
+
+(* Errors concerning sum types *)
+
+let stag_no_args = simple_error "this constructor does not take arguments"
+
+let stag_incorrect_n_args loc tag sexp =
+  error ~loc ~sexp (sprintf "sum tag %S has incorrect number of arguments" tag)
+;;
+
+let stag_takes_args = simple_error "this constructor requires arguments"
+let nested_list_invalid_sum = simple_error "expected a variant type, saw a nested list"
+let empty_list_invalid_sum = simple_error "expected a variant type, saw an empty list"
+let unexpected_stag = simple_error "unexpected variant constructor"
+
+(* Errors concerning records *)
+
+let record_sexp_bool_with_payload =
+  simple_error "record conversion: a [sexp.bool] field was given a payload."
+;;
+
+let record_only_pairs_expected =
+  simple_error
+    "record conversion: only pairs expected, their first element must be an atom"
+;;
+
+let record_invalid_fields ~what ~loc fld_names sexp =
+  let fld_names_str = String.concat fld_names ~sep:" " in
+  error ~loc ~sexp (sprintf "%s: %s" what fld_names_str)
+;;
+
+let record_duplicate_fields loc fld_names sexp =
+  record_invalid_fields ~what:"duplicate fields" ~loc fld_names sexp
+;;
+
+let record_extra_fields loc fld_names sexp =
+  record_invalid_fields ~what:"extra fields" ~loc 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 "the following record elements were undefined: %s" undefined in
+  error ~loc ~sexp msg
+;;
+
+let record_list_instead_atom = simple_error "list instead of atom for record expected"
+
+let record_poly_field_value =
+  simple_error "cannot convert values of types resulting from polymorphic record fields"
+;;
+
+(* Errors concerning polymorphic variants *)
+
+exception No_variant_match
+
+let no_variant_match () = raise No_variant_match
+let no_matching_variant_found = simple_error "no matching variant found"
+let ptag_no_args = simple_error "polymorphic variant does not take arguments"
+
+let ptag_incorrect_n_args loc cnstr sexp =
+  error
+    ~loc
+    ~sexp
+    (sprintf "polymorphic variant tag %S has incorrect number of arguments" cnstr)
+;;
+
+let ptag_takes_args = simple_error "polymorphic variant tag takes an argument"
+
+let nested_list_invalid_poly_var =
+  simple_error "a nested list is an invalid polymorphic variant"
+;;
+
+let empty_list_invalid_poly_var =
+  simple_error "the empty list is an invalid polymorphic variant"
+;;
+
+let empty_type = simple_error "trying to convert an empty type"

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/src/sexp_conv_labeled_tuple.ml

@@ -0,0 +1,56 @@
+module Fields = struct
+  type _ t =
+    | Field :
+        { name : string
+        ; conv : Sexp.t -> 'a
+        ; rest : 'b t
+        }
+        -> ('a * 'b) t
+    | Empty : unit t
+
+  let rec length_loop : type a. a t -> int -> int =
+    fun t acc ->
+    match t with
+    | Empty -> acc
+    | Field field -> length_loop field.rest (acc + 1)
+  ;;
+
+  let length t = length_loop t 0
+end
+
+let[@tail_mod_cons] rec of_list
+  : type a.
+    caller:string
+    -> fields:a Fields.t
+    -> len:int
+    -> original_sexp:Sexp.t
+    -> pos:int
+    -> Sexp.t list
+    -> a
+  =
+  fun ~caller ~fields ~len ~original_sexp ~pos list ->
+  match fields with
+  | Empty ->
+    (match list with
+     | [] -> ()
+     | _ :: _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp)
+  | Field { name; conv; rest } ->
+    (match list with
+     | [] -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp
+     | sexp :: list ->
+       (match sexp with
+        | List [ Atom atom; sexp ] ->
+          if String.equal atom name
+          then
+            ( conv sexp
+            , of_list ~caller ~fields:rest ~len ~original_sexp ~pos:(pos + 1) list )
+          else Sexp_conv_error.tuple_incorrect_label caller name pos original_sexp
+        | _ -> Sexp_conv_error.tuple_pair_expected caller name sexp))
+;;
+
+let labeled_tuple_of_sexp ~caller ~fields ~create original_sexp =
+  let len = Fields.length fields in
+  match (original_sexp : Sexp.t) with
+  | Atom _ -> Sexp_conv_error.tuple_of_size_n_expected caller len original_sexp
+  | List list -> create (of_list ~caller ~fields ~len ~original_sexp ~pos:0 list)
+;;

unikernel/duniverse/sexplib0/src/sexp_conv_labeled_tuple.mli

@@ -0,0 +1,21 @@
+(* Parses sexps for labeled tuples, a language feature currently only implemented in Jane
+   Street's experimental branch of the compiler
+   (https://github.com/ocaml-flambda/flambda-backend/). *)
+
+module Fields : sig
+  type _ t =
+    | Field :
+        { name : string
+        ; conv : Sexp.t -> 'a
+        ; rest : 'b t
+        }
+        -> ('a * 'b) t
+    | Empty : unit t
+end
+
+val labeled_tuple_of_sexp
+  :  caller:string
+  -> fields:'a Fields.t
+  -> create:('a -> 'b)
+  -> Sexp.t
+  -> 'b

unikernel/duniverse/sexplib0/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 names context
+    | Dups names -> record_duplicate_fields caller 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
+;;

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/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"

unikernel/duniverse/sexplib0/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

unikernel/duniverse/sexplib0/src/sexplib0.ml

@@ -0,0 +1,7 @@
+module Sexp = Sexp
+module Sexp_conv = Sexp_conv
+module Sexp_conv_error = Sexp_conv_error
+module Sexp_conv_record = Sexp_conv_record
+module Sexp_conv_labeled_tuple = Sexp_conv_labeled_tuple
+module Sexp_grammar = Sexp_grammar
+module Sexpable = Sexpable

unikernel/duniverse/sexplib0/test/dune

@@ -0,0 +1,5 @@
+(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)))

unikernel/duniverse/sexplib0/test/sexplib0_test.ml

@@ -0,0 +1,478 @@
+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 ())))
+    |}];
+  ()
+;;
+
+let%expect_test _ =
+  let big_string = String.init 5_000_000 ~f:(fun i -> String.get (Int.to_string i) 0) in
+  let sexp = [%sexp (big_string : string)] in
+  let sexp_string =
+    (* In an experimental compiler version, this would overflow the stack. *)
+    Sexp.to_string sexp
+  in
+  print_endline (Int.to_string_hum (String.length sexp_string));
+  [%expect {| 5_000_000 |}]
+;;

unikernel/duniverse/sexplib0/test/sexplib0_test.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)