pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=df916dfe8d0538a0dbfcdcb35c6e933ac9fc8130 sexplib0-0.16.0/000077500000000000000000000000001442175067100133335ustar00rootroot00000000000000sexplib0-0.16.0/.gitignore000066400000000000000000000000411442175067100153160ustar00rootroot00000000000000_build *.install *.merlin _opam sexplib0-0.16.0/CHANGES.md000066400000000000000000000005531442175067100147300ustar00rootroot00000000000000## 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`. sexplib0-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100155630ustar00rootroot00000000000000This 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 ``` 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/ sexplib0-0.16.0/LICENSE.md000066400000000000000000000021461442175067100147420ustar00rootroot00000000000000The MIT License Copyright (c) 2005--2023 Jane Street Group, LLC 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. sexplib0-0.16.0/Makefile000066400000000000000000000004031442175067100147700ustar00rootroot00000000000000INSTALL_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 sexplib0-0.16.0/README.md000066400000000000000000000005311442175067100146110ustar00rootroot00000000000000"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. sexplib0-0.16.0/bench/000077500000000000000000000000001442175067100144125ustar00rootroot00000000000000sexplib0-0.16.0/bench/bench_record.ml000066400000000000000000000072561442175067100173730ustar00rootroot00000000000000open 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 ()))" sexplib0-0.16.0/bench/bench_record.mli000066400000000000000000000000551442175067100175320ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) sexplib0-0.16.0/bench/dune000066400000000000000000000001321442175067100152640ustar00rootroot00000000000000(library (name sexplib0_bench) (libraries parsexp sexplib0) (preprocess (pps ppx_bench)))sexplib0-0.16.0/bench/sexplib0_bench.ml000066400000000000000000000000331442175067100176250ustar00rootroot00000000000000(*_ Deliberately empty. *) sexplib0-0.16.0/dune-project000066400000000000000000000000201442175067100156450ustar00rootroot00000000000000(lang dune 1.10)sexplib0-0.16.0/sexplib0.opam000066400000000000000000000015071442175067100157420ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/sexplib0" bug-reports: "https://github.com/janestreet/sexplib0/issues" dev-repo: "git+https://github.com/janestreet/sexplib0.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/sexplib0/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "2.0.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Library containing the definition of S-expressions and some base converters" description: " Part of Jane Street's Core library The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. " sexplib0-0.16.0/src/000077500000000000000000000000001442175067100141225ustar00rootroot00000000000000sexplib0-0.16.0/src/dune000066400000000000000000000001171442175067100147770ustar00rootroot00000000000000(library (name sexplib0) (public_name sexplib0) (preprocess no_preprocessing))sexplib0-0.16.0/src/sexp.ml000066400000000000000000000233711442175067100154410ustar00rootroot00000000000000[@@@ocaml.warning "-3"] (* blit_string doesn't exist in [StdLabels.Bytes]... *) let bytes_blit_string ~src ~src_pos ~dst ~dst_pos ~len = Bytes.blit_string src src_pos dst dst_pos len ;; open StdLabels open Format (** Type of S-expressions *) type t = | Atom of string | List of t list let sexp_of_t t = t let t_of_sexp t = t let rec compare_list a b = match a, b with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x :: xs, y :: ys -> let res = compare x y in if res <> 0 then res else compare_list xs ys and compare a b = if a == b then 0 else ( match a, b with | Atom a, Atom b -> String.compare a b | Atom _, _ -> -1 | _, Atom _ -> 1 | List a, List b -> compare_list a b) ;; let equal a b = compare a b = 0 exception Not_found_s of t exception Of_sexp_error of exn * t module Printing = struct (* Default indentation level for human-readable conversions *) let default_indent = ref 1 (* Escaping of strings used as atoms in S-expressions *) let must_escape str = let len = String.length str in len = 0 || let rec loop str ix = match str.[ix] with | '"' | '(' | ')' | ';' | '\\' -> true | '|' -> ix > 0 && let next = ix - 1 in Char.equal str.[next] '#' || loop str next | '#' -> ix > 0 && let next = ix - 1 in Char.equal str.[next] '|' || loop str next | '\000' .. '\032' | '\127' .. '\255' -> true | _ -> ix > 0 && loop str (ix - 1) in loop str (len - 1) ;; let escaped s = let n = ref 0 in for i = 0 to String.length s - 1 do n := !n + match String.unsafe_get s i with | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 | ' ' .. '~' -> 1 | _ -> 4 done; if !n = String.length s then s else ( let s' = Bytes.create !n in n := 0; for i = 0 to String.length s - 1 do (match String.unsafe_get s i with | ('\"' | '\\') as c -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c | '\n' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' | '\t' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' | '\r' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' | '\b' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' | ' ' .. '~' as c -> Bytes.unsafe_set s' !n c | c -> let a = Char.code c in Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); incr n; Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); incr n; Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10)))); incr n done; Bytes.unsafe_to_string s') ;; let esc_str str = let estr = escaped str in let elen = String.length estr in let res = Bytes.create (elen + 2) in bytes_blit_string ~src:estr ~src_pos:0 ~dst:res ~dst_pos:1 ~len:elen; Bytes.unsafe_set res 0 '"'; Bytes.unsafe_set res (elen + 1) '"'; Bytes.unsafe_to_string res ;; let index_of_newline str start = String.index_from_opt str start '\n' let get_substring str index end_pos_opt = let end_pos = match end_pos_opt with | None -> String.length str | Some end_pos -> end_pos in String.sub str ~pos:index ~len:(end_pos - index) ;; let is_one_line str = match index_of_newline str 0 with | None -> true | Some index -> index + 1 = String.length str ;; let pp_hum_maybe_esc_str ppf str = if not (must_escape str) then pp_print_string ppf str else if is_one_line str then pp_print_string ppf (esc_str str) else ( let rec loop index = let next_newline = index_of_newline str index in let next_line = get_substring str index next_newline in pp_print_string ppf (escaped next_line); match next_newline with | None -> () | Some newline_index -> pp_print_string ppf "\\"; pp_force_newline ppf (); pp_print_string ppf "\\n"; loop (newline_index + 1) in pp_open_box ppf 0; (* the leading space is to line up the lines *) pp_print_string ppf " \""; loop 0; pp_print_string ppf "\""; pp_close_box ppf ()) ;; let mach_maybe_esc_str str = if must_escape str then esc_str str else str (* Output of S-expressions to formatters *) let rec pp_hum_indent indent ppf = function | Atom str -> pp_hum_maybe_esc_str ppf str | List (h :: t) -> pp_open_box ppf indent; pp_print_string ppf "("; pp_hum_indent indent ppf h; pp_hum_rest indent ppf t | List [] -> pp_print_string ppf "()" and pp_hum_rest indent ppf = function | h :: t -> pp_print_space ppf (); pp_hum_indent indent ppf h; pp_hum_rest indent ppf t | [] -> pp_print_string ppf ")"; pp_close_box ppf () ;; let rec pp_mach_internal may_need_space ppf = function | Atom str -> let str' = mach_maybe_esc_str str in let new_may_need_space = str' == str in if may_need_space && new_may_need_space then pp_print_string ppf " "; pp_print_string ppf str'; new_may_need_space | List (h :: t) -> pp_print_string ppf "("; let may_need_space = pp_mach_internal false ppf h in pp_mach_rest may_need_space ppf t; false | List [] -> pp_print_string ppf "()"; false and pp_mach_rest may_need_space ppf = function | h :: t -> let may_need_space = pp_mach_internal may_need_space ppf h in pp_mach_rest may_need_space ppf t | [] -> pp_print_string ppf ")" ;; let pp_hum ppf sexp = pp_hum_indent !default_indent ppf sexp let pp_mach ppf sexp = ignore (pp_mach_internal false ppf sexp) let pp = pp_mach (* Sexp size *) let rec size_loop ((v, c) as acc) = function | Atom str -> v + 1, c + String.length str | List lst -> List.fold_left lst ~init:acc ~f:size_loop ;; let size sexp = size_loop (0, 0) sexp (* Buffer conversions *) let to_buffer_hum ~buf ?(indent = !default_indent) sexp = let ppf = Format.formatter_of_buffer buf in Format.fprintf ppf "%a@?" (pp_hum_indent indent) sexp ;; let to_buffer_mach ~buf sexp = let rec loop may_need_space = function | Atom str -> let str' = mach_maybe_esc_str str in let new_may_need_space = str' == str in if may_need_space && new_may_need_space then Buffer.add_char buf ' '; Buffer.add_string buf str'; new_may_need_space | List (h :: t) -> Buffer.add_char buf '('; let may_need_space = loop false h in loop_rest may_need_space t; false | List [] -> Buffer.add_string buf "()"; false and loop_rest may_need_space = function | h :: t -> let may_need_space = loop may_need_space h in loop_rest may_need_space t | [] -> Buffer.add_char buf ')' in ignore (loop false sexp) ;; let to_buffer = to_buffer_mach let to_buffer_gen ~buf ~add_char ~add_string sexp = let rec loop may_need_space = function | Atom str -> let str' = mach_maybe_esc_str str in let new_may_need_space = str' == str in if may_need_space && new_may_need_space then add_char buf ' '; add_string buf str'; new_may_need_space | List (h :: t) -> add_char buf '('; let may_need_space = loop false h in loop_rest may_need_space t; false | List [] -> add_string buf "()"; false and loop_rest may_need_space = function | h :: t -> let may_need_space = loop may_need_space h in loop_rest may_need_space t | [] -> add_char buf ')' in ignore (loop false sexp) ;; (* The maximum size of a thing on the minor heap is 256 words. Previously, this size of the returned buffer here was 4096 bytes, which caused the Buffer to be allocated on the *major* heap every time. According to a simple benchmark by Ron, we can improve performance for small s-expressions by a factor of ~4 if we only allocate 1024 bytes (128 words + some small overhead) worth of buffer initially. And one can argue that if it's free to allocate strings smaller than 256 words, large s-expressions requiring larger expensive buffers won't notice the extra two doublings from 1024 bytes to 2048 and 4096. And especially performance-sensitive applications to always pass in a larger buffer to use. *) let buffer () = Buffer.create 1024 (* String conversions *) let to_string_hum ?indent = function | Atom str when match index_of_newline str 0 with | None -> true | Some _ -> false -> mach_maybe_esc_str str | sexp -> let buf = buffer () in to_buffer_hum ?indent sexp ~buf; Buffer.contents buf ;; let to_string_mach = function | Atom str -> mach_maybe_esc_str str | sexp -> let buf = buffer () in to_buffer_mach sexp ~buf; Buffer.contents buf ;; let to_string = to_string_mach end include Printing let of_float_style : [ `Underscores | `No_underscores ] ref = ref `No_underscores let of_int_style : [ `Underscores | `No_underscores ] ref = ref `No_underscores module Private = struct include Printing end let message name fields = let rec conv_fields = function | [] -> [] | (fname, fsexp) :: rest -> (match fname with | "" -> fsexp :: conv_fields rest | _ -> List [ Atom fname; fsexp ] :: conv_fields rest) in List (Atom name :: conv_fields fields) ;; sexplib0-0.16.0/src/sexp.mli000066400000000000000000000067271442175067100156200ustar00rootroot00000000000000(** 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 sexplib0-0.16.0/src/sexp_conv.ml000066400000000000000000000324141442175067100164640ustar00rootroot00000000000000(* Utility Module for S-expression Conversions *) open StdLabels open MoreLabels open Printf open Sexp (* Conversion of OCaml-values to S-expressions *) external format_float : string -> float -> string = "caml_format_float" (* '%.17g' is guaranteed to be round-trippable. '%.15g' will be round-trippable and not have noise at the last digit or two for a float which was converted from a decimal (string) with <= 15 significant digits. So it's worth trying first to avoid things like "3.1400000000000001". See comment above [to_string_round_trippable] in {!Core.Float} for detailed explanation and examples. *) let default_string_of_float = ref (fun x -> let y = format_float "%.15G" x in if float_of_string y = x then y else format_float "%.17G" x) ;; let read_old_option_format = ref true let write_old_option_format = ref true let list_map f l = List.rev (List.rev_map l ~f) let sexp_of_unit () = List [] let sexp_of_bool b = Atom (string_of_bool b) let sexp_of_string str = Atom str let sexp_of_bytes bytes = Atom (Bytes.to_string bytes) let sexp_of_char c = Atom (String.make 1 c) let sexp_of_int n = Atom (string_of_int n) let sexp_of_float n = Atom (!default_string_of_float n) let sexp_of_int32 n = Atom (Int32.to_string n) let sexp_of_int64 n = Atom (Int64.to_string n) let sexp_of_nativeint n = Atom (Nativeint.to_string n) let sexp_of_ref sexp_of__a rf = sexp_of__a !rf let sexp_of_lazy_t sexp_of__a lv = sexp_of__a (Lazy.force lv) let sexp_of_option sexp_of__a = function | Some x when !write_old_option_format -> List [ sexp_of__a x ] | Some x -> List [ Atom "some"; sexp_of__a x ] | None when !write_old_option_format -> List [] | None -> Atom "none" ;; let sexp_of_pair sexp_of__a sexp_of__b (a, b) = List [ sexp_of__a a; sexp_of__b b ] let sexp_of_triple sexp_of__a sexp_of__b sexp_of__c (a, b, c) = List [ sexp_of__a a; sexp_of__b b; sexp_of__c c ] ;; (* List.rev (List.rev_map ...) is tail recursive, the OCaml standard library List.map is NOT. *) let sexp_of_list sexp_of__a lst = List (List.rev (List.rev_map lst ~f:sexp_of__a)) let sexp_of_array sexp_of__a ar = let lst_ref = ref [] in for i = Array.length ar - 1 downto 0 do lst_ref := sexp_of__a ar.(i) :: !lst_ref done; List !lst_ref ;; let sexp_of_hashtbl sexp_of_key sexp_of_val htbl = let coll ~key:k ~data:v acc = List [ sexp_of_key k; sexp_of_val v ] :: acc in List (Hashtbl.fold htbl ~init:[] ~f:coll) ;; let sexp_of_opaque _ = Atom "" let sexp_of_fun _ = Atom "" (* Exception converter registration and lookup *) module Exn_converter = struct (* These exception registration functions assume that context-switches cannot happen unless there is an allocation. It is reasonable to expect that this will remain true for the foreseeable future. That way we avoid using mutexes and thus a dependency on the threads library. *) (* Fast and automatic exception registration *) module Registration = struct type t = { sexp_of_exn : exn -> Sexp.t ; (* If [printexc = true] then this sexp converter is used for Printexc.to_string *) printexc : bool } end module Exn_table = Ephemeron.K1.Make (struct type t = extension_constructor let equal = ( == ) let hash = Obj.Extension_constructor.id end) let the_exn_table : Registration.t Exn_table.t = Exn_table.create 17 (* Ephemerons are used so that [sexp_of_exn] closure don't keep the extension_constructor live. *) let add ?(printexc = true) ?finalise:_ extension_constructor sexp_of_exn = Exn_table.add the_exn_table extension_constructor { sexp_of_exn; printexc } ;; let find_auto ~for_printexc exn = let extension_constructor = Obj.Extension_constructor.of_val exn in match Exn_table.find_opt the_exn_table extension_constructor with | None -> None | Some { sexp_of_exn; printexc } -> (match for_printexc, printexc with | false, _ | _, true -> Some (sexp_of_exn exn) | true, false -> None) ;; module For_unit_tests_only = struct let size () = (Exn_table.stats_alive the_exn_table).num_bindings end end let sexp_of_exn_opt_for_printexc exn = Exn_converter.find_auto ~for_printexc:true exn let sexp_of_exn_opt exn = Exn_converter.find_auto ~for_printexc:false exn let sexp_of_exn exn = match sexp_of_exn_opt exn with | None -> List [ Atom (Printexc.to_string exn) ] | Some sexp -> sexp ;; let exn_to_string e = Sexp.to_string_hum (sexp_of_exn e) (* {[exception Blah [@@deriving sexp]]} generates a call to the function [Exn_converter.add] defined in this file. So we are guaranted that as soon as we mark an exception as sexpable, this module will be linked in and this printer will be registered, which is what we want. *) let () = Printexc.register_printer (fun exn -> match sexp_of_exn_opt_for_printexc exn with | None -> None | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) ;; let printexc_prefer_sexp exn = match sexp_of_exn_opt exn with | None -> Printexc.to_string exn | Some sexp -> Sexp.to_string_hum ~indent:2 sexp ;; (* Conversion of S-expressions to OCaml-values *) exception Of_sexp_error = Sexp.Of_sexp_error let record_check_extra_fields = ref true let of_sexp_error_exn exc sexp = raise (Of_sexp_error (exc, sexp)) let of_sexp_error what sexp = raise (Of_sexp_error (Failure what, sexp)) let unit_of_sexp sexp = match sexp with | List [] -> () | Atom _ | List _ -> of_sexp_error "unit_of_sexp: empty list needed" sexp ;; let bool_of_sexp sexp = match sexp with | Atom ("true" | "True") -> true | Atom ("false" | "False") -> false | Atom _ -> of_sexp_error "bool_of_sexp: unknown string" sexp | List _ -> of_sexp_error "bool_of_sexp: atom needed" sexp ;; let string_of_sexp sexp = match sexp with | Atom str -> str | List _ -> of_sexp_error "string_of_sexp: atom needed" sexp ;; let bytes_of_sexp sexp = match sexp with | Atom str -> Bytes.of_string str | List _ -> of_sexp_error "bytes_of_sexp: atom needed" sexp ;; let char_of_sexp sexp = match sexp with | Atom str -> if String.length str <> 1 then of_sexp_error "char_of_sexp: atom string must contain one character only" sexp; str.[0] | List _ -> of_sexp_error "char_of_sexp: atom needed" sexp ;; let int_of_sexp sexp = match sexp with | Atom str -> (try int_of_string str with | exc -> of_sexp_error ("int_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "int_of_sexp: atom needed" sexp ;; let float_of_sexp sexp = match sexp with | Atom str -> (try float_of_string str with | exc -> of_sexp_error ("float_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "float_of_sexp: atom needed" sexp ;; let int32_of_sexp sexp = match sexp with | Atom str -> (try Int32.of_string str with | exc -> of_sexp_error ("int32_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "int32_of_sexp: atom needed" sexp ;; let int64_of_sexp sexp = match sexp with | Atom str -> (try Int64.of_string str with | exc -> of_sexp_error ("int64_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "int64_of_sexp: atom needed" sexp ;; let nativeint_of_sexp sexp = match sexp with | Atom str -> (try Nativeint.of_string str with | exc -> of_sexp_error ("nativeint_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "nativeint_of_sexp: atom needed" sexp ;; let ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp) let lazy_t_of_sexp a__of_sexp sexp = Lazy.from_val (a__of_sexp sexp) let option_of_sexp a__of_sexp sexp = if !read_old_option_format then ( match sexp with | List [] | Atom ("none" | "None") -> None | List [ el ] | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) | List _ -> of_sexp_error "option_of_sexp: list must represent optional value" sexp | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp) else ( match sexp with | Atom ("none" | "None") -> None | List [ Atom ("some" | "Some"); el ] -> Some (a__of_sexp el) | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp | List _ -> of_sexp_error "option_of_sexp: list must be (some el)" sexp) ;; let pair_of_sexp a__of_sexp b__of_sexp sexp = match sexp with | List [ a_sexp; b_sexp ] -> let a = a__of_sexp a_sexp in let b = b__of_sexp b_sexp in a, b | List _ -> of_sexp_error "pair_of_sexp: list must contain exactly two elements only" sexp | Atom _ -> of_sexp_error "pair_of_sexp: list needed" sexp ;; let triple_of_sexp a__of_sexp b__of_sexp c__of_sexp sexp = match sexp with | List [ a_sexp; b_sexp; c_sexp ] -> let a = a__of_sexp a_sexp in let b = b__of_sexp b_sexp in let c = c__of_sexp c_sexp in a, b, c | List _ -> of_sexp_error "triple_of_sexp: list must contain exactly three elements only" sexp | Atom _ -> of_sexp_error "triple_of_sexp: list needed" sexp ;; let list_of_sexp a__of_sexp sexp = match sexp with | List lst -> let rev_lst = List.rev_map lst ~f:a__of_sexp in List.rev rev_lst | Atom _ -> of_sexp_error "list_of_sexp: list needed" sexp ;; let array_of_sexp a__of_sexp sexp = match sexp with | List [] -> [||] | List (h :: t) -> let len = List.length t + 1 in let res = Array.make len (a__of_sexp h) in let rec loop i = function | [] -> res | h :: t -> res.(i) <- a__of_sexp h; loop (i + 1) t in loop 1 t | Atom _ -> of_sexp_error "array_of_sexp: list needed" sexp ;; let hashtbl_of_sexp key_of_sexp val_of_sexp sexp = match sexp with | List lst -> let htbl = Hashtbl.create 0 in let act = function | List [ k_sexp; v_sexp ] -> Hashtbl.add htbl ~key:(key_of_sexp k_sexp) ~data:(val_of_sexp v_sexp) | List _ | Atom _ -> of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp in List.iter lst ~f:act; htbl | Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp ;; let opaque_of_sexp sexp = of_sexp_error "opaque_of_sexp: cannot convert opaque values" sexp ;; let fun_of_sexp sexp = of_sexp_error "fun_of_sexp: cannot convert function values" sexp (* Sexp Grammars *) include Sexp_conv_grammar (* Registering default exception printers *) let get_flc_error name (file, line, chr) = Atom (sprintf "%s %s:%d:%d" name file line chr) let () = List.iter ~f:(fun (extension_constructor, handler) -> Exn_converter.add ~printexc:false ~finalise:false extension_constructor handler) [ ( [%extension_constructor Assert_failure] , function | Assert_failure arg -> get_flc_error "Assert_failure" arg | _ -> assert false ) ; ( [%extension_constructor Exit] , function | Exit -> Atom "Exit" | _ -> assert false ) ; ( [%extension_constructor End_of_file] , function | End_of_file -> Atom "End_of_file" | _ -> assert false ) ; ( [%extension_constructor Failure] , function | Failure arg -> List [ Atom "Failure"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Not_found] , function | Not_found -> Atom "Not_found" | _ -> assert false ) ; ( [%extension_constructor Invalid_argument] , function | Invalid_argument arg -> List [ Atom "Invalid_argument"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Match_failure] , function | Match_failure arg -> get_flc_error "Match_failure" arg | _ -> assert false ) ; ( [%extension_constructor Not_found_s] , function | Not_found_s arg -> List [ Atom "Not_found_s"; arg ] | _ -> assert false ) ; ( [%extension_constructor Sys_error] , function | Sys_error arg -> List [ Atom "Sys_error"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Arg.Help] , function | Arg.Help arg -> List [ Atom "Arg.Help"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Arg.Bad] , function | Arg.Bad arg -> List [ Atom "Arg.Bad"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Lazy.Undefined] , function | Lazy.Undefined -> Atom "Lazy.Undefined" | _ -> assert false ) ; ( [%extension_constructor Parsing.Parse_error] , function | Parsing.Parse_error -> Atom "Parsing.Parse_error" | _ -> assert false ) ; ( [%extension_constructor Queue.Empty] , function | Queue.Empty -> Atom "Queue.Empty" | _ -> assert false ) ; ( [%extension_constructor Scanf.Scan_failure] , function | Scanf.Scan_failure arg -> List [ Atom "Scanf.Scan_failure"; Atom arg ] | _ -> assert false ) ; ( [%extension_constructor Stack.Empty] , function | Stack.Empty -> Atom "Stack.Empty" | _ -> assert false ) ; ( [%extension_constructor Sys.Break] , function | Sys.Break -> Atom "Sys.Break" | _ -> assert false ) ] ;; let () = List.iter ~f:(fun (extension_constructor, handler) -> Exn_converter.add ~printexc:true ~finalise:false extension_constructor handler) [ ( [%extension_constructor Of_sexp_error] , function | Of_sexp_error (exc, sexp) -> List [ Atom "Sexplib.Conv.Of_sexp_error"; sexp_of_exn exc; sexp ] | _ -> assert false ) ] ;; external ignore : _ -> unit = "%ignore" external ( = ) : 'a -> 'a -> bool = "%equal" sexplib0-0.16.0/src/sexp_conv.mli000066400000000000000000000255721442175067100166440ustar00rootroot00000000000000(** Utility Module for S-expression Conversions *) (** {6 Conversion of OCaml-values to S-expressions} *) (** [default_string_of_float] reference to the default function used to convert floats to strings. Initially set to [fun n -> sprintf "%.20G" n]. *) val default_string_of_float : (float -> string) ref (** [write_old_option_format] reference for the default option format used to write option values. If set to [true], the old-style option format will be used, the new-style one otherwise. Initially set to [true]. *) val write_old_option_format : bool ref (** [read_old_option_format] reference for the default option format used to read option values. [Of_sexp_error] will be raised with old-style option values if this reference is set to [false]. Reading new-style option values is always supported. Using a global reference instead of changing the converter calling conventions is the only way to avoid breaking old code with the standard macros. Initially set to [true]. *) val read_old_option_format : bool ref (** We re-export a tail recursive map function, because some modules override the standard library functions (e.g. [StdLabels]) which wrecks havoc with the camlp4 extension. *) val list_map : ('a -> 'b) -> 'a list -> 'b list (** [sexp_of_unit ()] converts a value of type [unit] to an S-expression. *) val sexp_of_unit : unit -> Sexp.t (** [sexp_of_bool b] converts the value [x] of type [bool] to an S-expression. *) val sexp_of_bool : bool -> Sexp.t (** [sexp_of_bool str] converts the value [str] of type [string] to an S-expression. *) val sexp_of_string : string -> Sexp.t (** [sexp_of_bool str] converts the value [str] of type [bytes] to an S-expression. *) val sexp_of_bytes : bytes -> Sexp.t (** [sexp_of_char c] converts the value [c] of type [char] to an S-expression. *) val sexp_of_char : char -> Sexp.t (** [sexp_of_int n] converts the value [n] of type [int] to an S-expression. *) val sexp_of_int : int -> Sexp.t (** [sexp_of_float n] converts the value [n] of type [float] to an S-expression. *) val sexp_of_float : float -> Sexp.t (** [sexp_of_int32 n] converts the value [n] of type [int32] to an S-expression. *) val sexp_of_int32 : int32 -> Sexp.t (** [sexp_of_int64 n] converts the value [n] of type [int64] to an S-expression. *) val sexp_of_int64 : int64 -> Sexp.t (** [sexp_of_nativeint n] converts the value [n] of type [nativeint] to an S-expression. *) val sexp_of_nativeint : nativeint -> Sexp.t (** [sexp_of_ref conv r] converts the value [r] of type ['a ref] to an S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *) val sexp_of_ref : ('a -> Sexp.t) -> 'a ref -> Sexp.t (** [sexp_of_lazy_t conv l] converts the value [l] of type ['a lazy_t] to an S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *) val sexp_of_lazy_t : ('a -> Sexp.t) -> 'a lazy_t -> Sexp.t (** [sexp_of_option conv opt] converts the value [opt] of type ['a option] to an S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *) val sexp_of_option : ('a -> Sexp.t) -> 'a option -> Sexp.t (** [sexp_of_pair conv1 conv2 pair] converts a pair to an S-expression. It uses its first argument to convert the first element of the pair, and its second argument to convert the second element of the pair. *) val sexp_of_pair : ('a -> Sexp.t) -> ('b -> Sexp.t) -> 'a * 'b -> Sexp.t (** [sexp_of_triple conv1 conv2 conv3 triple] converts a triple to an S-expression using [conv1], [conv2], and [conv3] to convert its elements. *) val sexp_of_triple : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> 'a * 'b * 'c -> Sexp.t (** [sexp_of_list conv lst] converts the value [lst] of type ['a list] to an S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *) val sexp_of_list : ('a -> Sexp.t) -> 'a list -> Sexp.t (** [sexp_of_array conv ar] converts the value [ar] of type ['a array] to an S-expression. Uses [conv] to convert values of type ['a] to an S-expression. *) val sexp_of_array : ('a -> Sexp.t) -> 'a array -> Sexp.t (** [sexp_of_hashtbl conv_key conv_value htbl] converts the value [htbl] of type [('a, 'b) Hashtbl.t] to an S-expression. Uses [conv_key] to convert the hashtable keys of type ['a], and [conv_value] to convert hashtable values of type ['b] to S-expressions. *) val sexp_of_hashtbl : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) Hashtbl.t -> Sexp.t (** [sexp_of_opaque x] converts the value [x] of opaque type to an S-expression. This means the user need not provide converters, but the result cannot be interpreted. *) val sexp_of_opaque : 'a -> Sexp.t (** [sexp_of_fun f] converts the value [f] of function type to a dummy S-expression. Functions cannot be serialized as S-expressions, but at least a placeholder can be generated for pretty-printing. *) val sexp_of_fun : ('a -> 'b) -> Sexp.t (** {6 Conversion of S-expressions to OCaml-values} *) (** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be successfully converted to an OCaml-value. *) exception Of_sexp_error of exn * Sexp.t (** [record_check_extra_fields] checks for extra (= unknown) fields in record S-expressions. *) val record_check_extra_fields : bool ref (** [of_sexp_error reason sexp] @raise Of_sexp_error (Failure reason, sexp). *) val of_sexp_error : string -> Sexp.t -> 'a (** [of_sexp_error exc sexp] @raise Of_sexp_error (exc, sexp). *) val of_sexp_error_exn : exn -> Sexp.t -> 'a (** [unit_of_sexp sexp] converts S-expression [sexp] to a value of type [unit]. *) val unit_of_sexp : Sexp.t -> unit (** [bool_of_sexp sexp] converts S-expression [sexp] to a value of type [bool]. *) val bool_of_sexp : Sexp.t -> bool (** [string_of_sexp sexp] converts S-expression [sexp] to a value of type [string]. *) val string_of_sexp : Sexp.t -> string (** [bytes_of_sexp sexp] converts S-expression [sexp] to a value of type [bytes]. *) val bytes_of_sexp : Sexp.t -> bytes (** [char_of_sexp sexp] converts S-expression [sexp] to a value of type [char]. *) val char_of_sexp : Sexp.t -> char (** [int_of_sexp sexp] converts S-expression [sexp] to a value of type [int]. *) val int_of_sexp : Sexp.t -> int (** [float_of_sexp sexp] converts S-expression [sexp] to a value of type [float]. *) val float_of_sexp : Sexp.t -> float (** [int32_of_sexp sexp] converts S-expression [sexp] to a value of type [int32]. *) val int32_of_sexp : Sexp.t -> int32 (** [int64_of_sexp sexp] converts S-expression [sexp] to a value of type [int64]. *) val int64_of_sexp : Sexp.t -> int64 (** [nativeint_of_sexp sexp] converts S-expression [sexp] to a value of type [nativeint]. *) val nativeint_of_sexp : Sexp.t -> nativeint (** [ref_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a ref] using conversion function [conv], which converts an S-expression to a value of type ['a]. *) val ref_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a ref (** [lazy_t_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a lazy_t] using conversion function [conv], which converts an S-expression to a value of type ['a]. *) val lazy_t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a lazy_t (** [option_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a option] using conversion function [conv], which converts an S-expression to a value of type ['a]. *) val option_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a option (** [pair_of_sexp conv1 conv2 sexp] converts S-expression [sexp] to a pair of type ['a * 'b] using conversion functions [conv1] and [conv2], which convert S-expressions to values of type ['a] and ['b] respectively. *) val pair_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> 'a * 'b (** [triple_of_sexp conv1 conv2 conv3 sexp] converts S-expression [sexp] to a triple of type ['a * 'b * 'c] using conversion functions [conv1], [conv2], and [conv3], which convert S-expressions to values of type ['a], ['b], and ['c] respectively. *) val triple_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> 'a * 'b * 'c (** [list_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a list] using conversion function [conv], which converts an S-expression to a value of type ['a]. *) val list_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a list (** [array_of_sexp conv sexp] converts S-expression [sexp] to a value of type ['a array] using conversion function [conv], which converts an S-expression to a value of type ['a]. *) val array_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a array (** [hashtbl_of_sexp conv_key conv_value sexp] converts S-expression [sexp] to a value of type [('a, 'b) Hashtbl.t] using conversion function [conv_key], which converts an S-expression to hashtable key of type ['a], and function [conv_value], which converts an S-expression to hashtable value of type ['b]. *) val hashtbl_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) Hashtbl.t (** [opaque_of_sexp sexp] @raise Of_sexp_error when attempting to convert an S-expression to an opaque value. *) val opaque_of_sexp : Sexp.t -> 'a (** [fun_of_sexp sexp] @raise Of_sexp_error when attempting to convert an S-expression to a function. *) val fun_of_sexp : Sexp.t -> 'a (** Sexp Grammars *) include module type of struct include Sexp_conv_grammar end (** Exception converters *) (** [sexp_of_exn exc] converts exception [exc] to an S-expression. If no suitable converter is found, the standard converter in [Printexc] will be used to generate an atomic S-expression. *) val sexp_of_exn : exn -> Sexp.t (** Converts an exception to a string via sexp, falling back to [Printexc.to_string] if no sexp conversion is registered for this exception. This is different from [Printexc.to_string] in that it additionally uses the sexp converters registered with [~printexc:false]. Another difference is that the behavior of [Printexc] can be overridden with [Printexc.register], but here we always try sexp conversion first. *) val printexc_prefer_sexp : exn -> string (** [sexp_of_exn_opt exc] converts exception [exc] to [Some sexp]. If no suitable converter is found, [None] is returned instead. *) val sexp_of_exn_opt : exn -> Sexp.t option module Exn_converter : sig (** [add constructor sexp_of_exn] registers exception S-expression converter [sexp_of_exn] for exceptions with the given [constructor]. NOTE: [finalise] is ignored, and provided only for backward compatibility. *) val add : ?printexc:bool -> ?finalise:bool -> extension_constructor -> (exn -> Sexp.t) -> unit module For_unit_tests_only : sig val size : unit -> int end end (**/**) (*_ For the syntax extension *) external ignore : _ -> unit = "%ignore" external ( = ) : 'a -> 'a -> bool = "%equal" sexplib0-0.16.0/src/sexp_conv_error.ml000066400000000000000000000074221442175067100176760ustar00rootroot00000000000000(* Conv_error: Module for Handling Errors during Automated S-expression Conversions *) open StdLabels open Printf open Sexp_conv exception Of_sexp_error = Of_sexp_error (* Errors concerning tuples *) let tuple_of_size_n_expected loc n sexp = of_sexp_error (sprintf "%s_of_sexp: tuple of size %d expected" loc n) sexp ;; (* Errors concerning sum types *) let stag_no_args loc sexp = of_sexp_error (loc ^ "_of_sexp: this constructor does not take arguments") sexp ;; let stag_incorrect_n_args loc tag sexp = let msg = sprintf "%s_of_sexp: sum tag %S has incorrect number of arguments" loc tag in of_sexp_error msg sexp ;; let stag_takes_args loc sexp = of_sexp_error (loc ^ "_of_sexp: this constructor requires arguments") sexp ;; let nested_list_invalid_sum loc sexp = of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw a nested list") sexp ;; let empty_list_invalid_sum loc sexp = of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw an empty list") sexp ;; let unexpected_stag loc sexp = of_sexp_error (loc ^ "_of_sexp: unexpected variant constructor") sexp ;; (* Errors concerning records *) let record_sexp_bool_with_payload loc sexp = let msg = loc ^ "_of_sexp: record conversion: a [sexp.bool] field was given a payload." in of_sexp_error msg sexp ;; let record_only_pairs_expected loc sexp = let msg = loc ^ "_of_sexp: record conversion: only pairs expected, their first element must be an \ atom" in of_sexp_error msg sexp ;; let record_superfluous_fields ~what ~loc rev_fld_names sexp = let fld_names_str = String.concat (List.rev rev_fld_names) ~sep:" " in let msg = sprintf "%s_of_sexp: %s: %s" loc what fld_names_str in of_sexp_error msg sexp ;; let record_duplicate_fields loc rev_fld_names sexp = record_superfluous_fields ~what:"duplicate fields" ~loc rev_fld_names sexp ;; let record_extra_fields loc rev_fld_names sexp = record_superfluous_fields ~what:"extra fields" ~loc rev_fld_names sexp ;; let rec record_get_undefined_loop fields = function | [] -> String.concat (List.rev fields) ~sep:" " | (true, field) :: rest -> record_get_undefined_loop (field :: fields) rest | _ :: rest -> record_get_undefined_loop fields rest ;; let record_undefined_elements loc sexp lst = let undefined = record_get_undefined_loop [] lst in let msg = sprintf "%s_of_sexp: the following record elements were undefined: %s" loc undefined in of_sexp_error msg sexp ;; let record_list_instead_atom loc sexp = let msg = loc ^ "_of_sexp: list instead of atom for record expected" in of_sexp_error msg sexp ;; let record_poly_field_value loc sexp = let msg = loc ^ "_of_sexp: cannot convert values of types resulting from polymorphic record fields" in of_sexp_error msg sexp ;; (* Errors concerning polymorphic variants *) exception No_variant_match let no_variant_match () = raise No_variant_match let no_matching_variant_found loc sexp = of_sexp_error (loc ^ "_of_sexp: no matching variant found") sexp ;; let ptag_no_args loc sexp = of_sexp_error (loc ^ "_of_sexp: polymorphic variant does not take arguments") sexp ;; let ptag_incorrect_n_args loc cnstr sexp = let msg = sprintf "%s_of_sexp: polymorphic variant tag %S has incorrect number of arguments" loc cnstr in of_sexp_error msg sexp ;; let ptag_takes_args loc sexp = of_sexp_error (loc ^ "_of_sexp: polymorphic variant tag takes an argument") sexp ;; let nested_list_invalid_poly_var loc sexp = of_sexp_error (loc ^ "_of_sexp: a nested list is an invalid polymorphic variant") sexp ;; let empty_list_invalid_poly_var loc sexp = of_sexp_error (loc ^ "_of_sexp: the empty list is an invalid polymorphic variant") sexp ;; let empty_type loc sexp = of_sexp_error (loc ^ "_of_sexp: trying to convert an empty type") sexp ;; sexplib0-0.16.0/src/sexp_conv_grammar.ml000066400000000000000000000033211442175067100201650ustar00rootroot00000000000000open 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 sexplib0-0.16.0/src/sexp_conv_grammar.mli000066400000000000000000000023451442175067100203430ustar00rootroot00000000000000(** 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 sexplib0-0.16.0/src/sexp_conv_record.ml000066400000000000000000000237111442175067100200220ustar00rootroot00000000000000open! StdLabels open! Sexp_conv open! Sexp_conv_error module Kind = struct type (_, _) t = | Default : (unit -> 'a) -> ('a, Sexp.t -> 'a) t | Omit_nil : ('a, Sexp.t -> 'a) t | Required : ('a, Sexp.t -> 'a) t | Sexp_array : ('a array, Sexp.t -> 'a) t | Sexp_bool : (bool, unit) t | Sexp_list : ('a list, Sexp.t -> 'a) t | Sexp_option : ('a option, Sexp.t -> 'a) t end module Fields = struct type _ t = | Empty : unit t | Field : { name : string ; kind : ('a, 'conv) Kind.t ; conv : 'conv ; rest : 'b t } -> ('a * 'b) t let length = let rec length_loop : type a. a t -> int -> int = fun t acc -> match t with | Field { rest; _ } -> length_loop rest (acc + 1) | Empty -> acc in fun t -> length_loop t 0 ;; end module Malformed = struct (* Represents errors that can occur due to malformed record sexps. Accumulated as a value so we can report multiple names at once for extra fields, duplicate fields, or missing fields. *) type t = | Bool_payload | Extras of string list | Dups of string list | Missing of string list | Non_pair of Sexp.t option let combine a b = match a, b with (* choose the first bool-payload or non-pair error that occurs *) | ((Bool_payload | Non_pair _) as t), _ -> t | _, ((Bool_payload | Non_pair _) as t) -> t (* combine lists of similar errors *) | Extras a, Extras b -> Extras (a @ b) | Dups a, Dups b -> Dups (a @ b) | Missing a, Missing b -> Missing (a @ b) (* otherwise, dups > extras > missing *) | (Dups _ as t), _ | _, (Dups _ as t) -> t | (Extras _ as t), _ | _, (Extras _ as t) -> t ;; let raise t ~caller ~context = match t with | Bool_payload -> record_sexp_bool_with_payload caller context | Extras names -> record_extra_fields caller (List.rev names) context | Dups names -> record_duplicate_fields caller (List.rev names) context | Missing names -> List.map names ~f:(fun name -> true, name) |> record_undefined_elements caller context | Non_pair maybe_context -> let context = Option.value maybe_context ~default:context in record_only_pairs_expected caller context ;; end exception Malformed of Malformed.t module State = struct (* Stores sexps corresponding to record fields, in the order the fields were declared. Excludes fields already parsed in the fast path. List sexps represent a field that is present, such as (x 1) for a field named "x". Atom sexps represent a field that is absent, or at least not yet seen. *) type t = { state : Sexp.t array } [@@unboxed] let unsafe_get t pos = Array.unsafe_get t.state pos let unsafe_set t pos sexp = Array.unsafe_set t.state pos sexp let absent = Sexp.Atom "" let create len = { state = Array.make len absent } end (* Parsing field values from state. *) let rec parse_value_malformed : type a b. Malformed.t -> fields:(a * b) Fields.t -> state:State.t -> pos:int -> a = fun malformed ~fields ~state ~pos -> let (Field field) = fields in let malformed = match parse_values ~fields:field.rest ~state ~pos:(pos + 1) with | (_ : b) -> malformed | exception Malformed other -> Malformed.combine malformed other in raise (Malformed malformed) and parse_value : type a b. fields:(a * b) Fields.t -> state:State.t -> pos:int -> a * b = fun ~fields ~state ~pos -> let (Field { name; kind; conv; rest }) = fields in let value : a = match kind, State.unsafe_get state pos with (* well-formed *) | Required, List [ _; sexp ] -> conv sexp | Default _, List [ _; sexp ] -> conv sexp | Omit_nil, List [ _; sexp ] -> conv sexp | Sexp_option, List [ _; sexp ] -> Some (conv sexp) | Sexp_list, List [ _; sexp ] -> list_of_sexp conv sexp | Sexp_array, List [ _; sexp ] -> array_of_sexp conv sexp | Sexp_bool, List [ _ ] -> true (* ill-formed *) | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) , (List (_ :: _ :: _ :: _) as sexp) ) -> parse_value_malformed (Non_pair (Some sexp)) ~fields ~state ~pos | ( (Required | Default _ | Omit_nil | Sexp_option | Sexp_list | Sexp_array) , List ([] | [ _ ]) ) -> parse_value_malformed (Non_pair None) ~fields ~state ~pos | Sexp_bool, List ([] | _ :: _ :: _) -> parse_value_malformed Bool_payload ~fields ~state ~pos (* absent *) | Required, Atom _ -> parse_value_malformed (Missing [ name ]) ~fields ~state ~pos | Default default, Atom _ -> default () | Omit_nil, Atom _ -> conv (List []) | Sexp_option, Atom _ -> None | Sexp_list, Atom _ -> [] | Sexp_array, Atom _ -> [||] | Sexp_bool, Atom _ -> false in value, parse_values ~fields:rest ~state ~pos:(pos + 1) and parse_values : type a. fields:a Fields.t -> state:State.t -> pos:int -> a = fun ~fields ~state ~pos -> match fields with | Field _ -> parse_value ~fields ~state ~pos | Empty -> () ;; (* Populating state. Handles slow path cases where there may be reordered, duplicated, missing, or extra fields. *) let rec parse_spine_malformed malformed ~index ~extra ~seen ~state ~len sexps = let malformed = match parse_spine_slow ~index ~extra ~seen ~state ~len sexps with | () -> malformed | exception Malformed other -> Malformed.combine malformed other in raise (Malformed malformed) and parse_spine_slow ~index ~extra ~seen ~state ~len sexps = match (sexps : Sexp.t list) with | [] -> () | (List (Atom name :: _) as field) :: sexps -> let i = index name in (match seen <= i && i < len with | true -> (* valid field for slow-path parsing *) let pos = i - seen in (match State.unsafe_get state pos with | Atom _ -> (* field not seen yet *) State.unsafe_set state pos field; parse_spine_slow ~index ~extra ~seen ~state ~len sexps | List _ -> (* field already seen *) parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps) | false -> (match 0 <= i && i < seen with | true -> (* field seen in fast path *) parse_spine_malformed (Dups [ name ]) ~index ~extra ~seen ~state ~len sexps | false -> (* extra field *) (match extra with | true -> parse_spine_slow ~index ~extra ~seen ~state ~len sexps | false -> parse_spine_malformed (Extras [ name ]) ~index ~extra ~seen ~state ~len sexps))) | sexp :: sexps -> parse_spine_malformed (Non_pair (Some sexp)) ~index ~extra ~seen ~state ~len sexps ;; (* Slow path for record parsing. Uses state to store fields as they are discovered. *) let parse_record_slow ~fields ~index ~extra ~seen sexps = let unseen = Fields.length fields in let state = State.create unseen in let len = seen + unseen in (* populate state *) parse_spine_slow ~index ~extra ~seen ~state ~len sexps; (* parse values from state *) parse_values ~fields ~state ~pos:0 ;; (* Fast path for record parsing. Directly parses and returns fields in the order they are declared. Falls back on slow path if any fields are absent, reordered, or malformed. *) let rec parse_field_fast : type a b. fields:(a * b) Fields.t -> index:(string -> int) -> extra:bool -> seen:int -> Sexp.t list -> a * b = fun ~fields ~index ~extra ~seen sexps -> let (Field { name; kind; conv; rest }) = fields in match sexps with | List (Atom atom :: args) :: others when String.equal atom name -> (match kind, args with | Required, [ sexp ] -> conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others | Default _, [ sexp ] -> conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others | Omit_nil, [ sexp ] -> conv sexp, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others | Sexp_option, [ sexp ] -> ( Some (conv sexp) , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) | Sexp_list, [ sexp ] -> ( list_of_sexp conv sexp , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) | Sexp_array, [ sexp ] -> ( array_of_sexp conv sexp , parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others ) | Sexp_bool, [] -> true, parse_spine_fast ~fields:rest ~index ~extra ~seen:(seen + 1) others (* malformed field of some kind, dispatch to slow path *) | _, _ -> parse_record_slow ~fields ~index ~extra ~seen sexps) (* malformed or out-of-order field, dispatch to slow path *) | _ -> parse_record_slow ~fields ~index ~extra ~seen sexps and parse_spine_fast : type a. fields:a Fields.t -> index:(string -> int) -> extra:bool -> seen:int -> Sexp.t list -> a = fun ~fields ~index ~extra ~seen sexps -> match fields with | Field _ -> parse_field_fast ~fields ~index ~extra ~seen sexps | Empty -> (match sexps with | [] -> () | _ :: _ -> (* extra sexps, dispatch to slow path *) parse_record_slow ~fields ~index ~extra ~seen sexps) ;; let parse_record_fast ~fields ~index ~extra sexps = parse_spine_fast ~fields ~index ~extra ~seen:0 sexps ;; (* Entry points. *) let record_of_sexps ~caller ~context ~fields ~index_of_field ~allow_extra_fields ~create sexps = let allow_extra_fields = allow_extra_fields || not !Sexp_conv.record_check_extra_fields in match parse_record_fast ~fields ~index:index_of_field ~extra:allow_extra_fields sexps with | value -> create value | exception Malformed malformed -> Malformed.raise malformed ~caller ~context ;; let record_of_sexp ~caller ~fields ~index_of_field ~allow_extra_fields ~create sexp = match (sexp : Sexp.t) with | Atom _ as context -> record_list_instead_atom caller context | List sexps as context -> record_of_sexps ~caller ~context ~fields ~index_of_field ~allow_extra_fields ~create sexps ;; sexplib0-0.16.0/src/sexp_conv_record.mli000066400000000000000000000032311442175067100201660ustar00rootroot00000000000000module 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 sexplib0-0.16.0/src/sexp_grammar.ml000066400000000000000000000203671442175067100171510ustar00rootroot00000000000000(** 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" sexplib0-0.16.0/src/sexpable.ml000066400000000000000000000013141442175067100162560ustar00rootroot00000000000000module 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 sexplib0-0.16.0/src/sexplib0.ml000066400000000000000000000003021442175067100161750ustar00rootroot00000000000000module Sexp = Sexp module Sexp_conv = Sexp_conv module Sexp_conv_error = Sexp_conv_error module Sexp_conv_record = Sexp_conv_record module Sexp_grammar = Sexp_grammar module Sexpable = Sexpable sexplib0-0.16.0/test/000077500000000000000000000000001442175067100143125ustar00rootroot00000000000000sexplib0-0.16.0/test/dune000066400000000000000000000002761442175067100151750ustar00rootroot00000000000000(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)))sexplib0-0.16.0/test/sexplib0_test.ml000066400000000000000000000271341442175067100174400ustar00rootroot00000000000000open! 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 ()))) |}]; () ;; sexplib0-0.16.0/test/sexplib0_test.mli000066400000000000000000000000551442175067100176020ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)