pax_global_header00006660000000000000000000000064127103557610014521gustar00rootroot0000000000000052 comment=9e6e44ebbc6c765c370f093c9bde4c4257cb64a9 sexplib-113.33.03/000077500000000000000000000000001271035576100135025ustar00rootroot00000000000000sexplib-113.33.03/.gitignore000066400000000000000000000001021271035576100154630ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte sexplib-113.33.03/CHANGES.md000066400000000000000000000347161271035576100151070ustar00rootroot00000000000000## 113.33.00 - Changes `Sexp.to_string` to escape all non-ASCII characters. Previously chars >= 127 are escaped or not depending on: 1. other character in the string 2. the system 3. environment variable settings (2) and (3) are because `String.escaped` from the stdlib uses the C function `isprint` which is locale and OS dependent. This can cause invalid UTF-8 sequence to be printed by sexplib, which is annoying: https://github.com/janestreet/sexplib/issues/18 Starting with this release, sexplib: 1. copies the `String.escaped` function of OCaml 4.03 which escapes all non-ascii characters 2. make sure we escape the string when it contains characters >= 127 - Clean up the documentation for sexplib, modernizing it to include `ppx_sexp_conv`, and breaking up the documentation between sexplib and `ppx_sexp_conv`. Also changed the formatting to use org-mode, so it will render properly on github. Markdown doesn't render well by default, unless you use quite different conventions about linebeaks. - In sexp macro library, avoid returning success when there is any error reading a sexp. In particular, this prevents sexp resolve <(echo '(:use x)') from silently succeeding. Also, now we no longer read an included file multiple times. This lets even crazy stuff like this to work: $ echo 'hi ' | sexp resolve <(echo '((:include /dev/stdin) (:include /dev/stdin))') ## 113.24.00 - Switch code in `lib` subdir to ppx-style. ## 112.35.00 - Inline some calls that js_of_ocaml was unable to recognise as tail-recursive (cf. issue #14) ## 112.24.00 Minor update: documentation. ## 112.17.00 - Added `sexp_of_` support for GADTs, and remove the not-quite-working support for `of_sexp`. ## 112.06.00 - Improved the implementation of `Exn.sexp_of_t`, using the unique id in exceptions in OCaml 4.02. We use the identifier to map exception constructors to converters. ## 112.01.00 - Replaced occurrences of `Obj.magic 0` with `Obj.magic None`. With the former the compiler might think the destination type is always an integer and instruct the GC to ignore references to such values. The latter doesn't have this problem as options are not always integers. ## 111.25.00 - Fix compatibility with OCaml 4.02 ## 111.17.00 - Make the camlp4 dependency optional ## 111.13.00 - In `Sexplib.Std`, renamed `Macro` as `Sexp_macro`. ## 111.11.00 - Added error locations to `Macro`-expansion errors. ## 110.01.00 - Added `with sexp` support for mutually recursive types with common fields. For instance: ```ocaml type a = { fl : float } and b = { fl : int } with sexp ``` Closes #3 - Fixed the behavior of sexplib on `private` types. sexplib used to ignore the `private` modifier, which means generated functions had the wrong type. Now, it generates a function with the right type for `sexp_of` and refuses to generate anything for `of_sexp`. - Added `Macro.expand_local_macros`, which macro expands sexps, failing on `:include` macros. - Fixed `Macro`'s handling of nested `:include`'s which was broken with respect to paths. Prior to this fix, `:include`'s were broken with respect to the path used to resolve the filename. Including a file outside the current directory which included another file relative to that one would break. ## 109.60.00 - Moved unix-specific code to a new object section, sexplib_unix ## 109.53.00 - Changed `sexp_of_float` to (usually) use as few digits as possible, without losing precision. - Split the part of `Sexplib` that depends on `Num` into a separate library, `Sexplib_num`. This was done to eliminate the dependence of `Core_kernel` on `Num`, which is not usable on javascript. ## 109.52.00 - Added a `Macro` module, with `load_sexp*` functions that support file includes and templates. The following new syntaxes are supported: ```ocaml (:include filename) (:let f (arg1 ... argn) sexp1 ... sexpn) (:use f (arg1 valn) ... (argn valn)) (:concat a1 ... an) ``` - Added support to `with sexp` for a subset of GADTs. The new support is for types that use existentially quantified variables or plain variants written with GADT syntax. Existentially quantified variables still have to be wrapped with `sexp_opaque` generate compiling code. - Fixed a type error in the code generated by `with sexp` in some cases of variant inclusions. ## 109.20.00 - Renamed converter generated by `with sexp` for polymorphic variants so it is hidden from the toplevel. `of_sexp` created a value named `_of_sexp__` to handle polymorphic variants. To hide it from the toplevel, we renamed it as `___of_sexp__`. We kept the `__` suffix to avoid any confusion with a type named `__`. ## 109.12.00 - A tiny lexer improvement in `lexer.mll`. Used `lexbuf.lex_{start|curr}_pos` instead of `lexbuf.lex_{start|curr}_p.pos_cnum` for computing the length of a lexeme since the difference is the same. ## 109.10.00 - Improved error messages in presence of GADTs. - Made `with sexp` work with types containing `as` in signatures. ## 109.09.00 - Fixed an `unused rec` warning in the code generated by `pa_sexp` in rare cases. ## 2012-07-15 - Added support for S-expression default record fields. - Added syntax for S-expression comments and for nested block comments. - Fixed a few minor bugs and inconsistencies in the parsers and updated their whitespace handling to conform with the upcoming OCaml 4.00 compiler. The parser specification now also supports Menhir. - Rewrote README in Markdown and improved documentation. - Minor bug fix in the preprocessing module. - Eliminated new warnings available in OCaml 4.00. ## 2011-09-18 - Improved documentation. ## 2011-09-15 - Fixes to improve package dependency resolution. ## 2011-07-05 - Fixed a parser position bug. Parser positions passed by the user were not updated correctly. - Internal code beautification. ## 2011-07-04 - Internal updates to sync with Jane Street. ## 2011-01-30 - Fixed a code generation bug with toplevel entries. Thanks to Yong Lu for the report! ## 2010-12-27 - Added support for MoreLabels.Hashtbl and improved reporting of error locations with preprocessor. ## 2010-12-26 - Worked around a compiler bug that is expected to be fixed in OCaml 3.12.1. This workaround temporarily removes the interface for module Conv (conv.mli), thus exposing the internals. This should not cause any problems for end users as long as they do not depend on the exported internal representations. The interface will become constrained again as soon as the fixed compiler is out. ## 2010-12-22 Major release. - Merged with Jane Street version. This has caused an API-change that requires "open Sexplib.Conv" at the top of files that use the syntax extension. - Renamed functions: * sexp_of_lazy -> sexp_of_lazy_t * lazy_of_sexp -> lazy_t_of_sexp - Some standard library modules are now re-exported with predefined S-expression converters in module Conv. ## 2010-09-25 - Fixed inferred types of generated functions when dealing with arrow types. ## 2010-08-26 - Fixed a lexer bug when parsing comments. ## 2010-05-21 - Added support for sexp_bool record field annotations. ## 2010-05-18 - Improved performance of converting S-expressions to strings. ## 2010-04-12 - Changed API of Of_sexp_error exception. ## 2010-04-07 - Added of_(big)string_conv_exn functions. ## 2010-04-01 - Merged with Jane Street version. Major new features (various functions): * Type-annotated parsing for better error messages * Greatly improved performance of exception converters ## 2009-12-21 - Improved saving of files. ## 2009-10-12 - Added sexp_array record field extension. ## 2009-09-19 - Added missing variant type cases. - Fixed handling of variance annotations. ## 2009-09-15 - Internal cleanups. ## 2009-07-28 - Added better support for conversion of exception types. ## 2009-06-23 - Fixed build problem. Thanks to Sylvain Le Gall for the patch! ## 2009-05-08 - Fixed build problems on Windows and OCamlMakefile issues. Thanks to Sylvain Le Gall for the patch! ## 2009-04-22 - Added macro support for all types of vectors, matrices, and for bigstrings. ## 2009-04-21 - Merged with Jane Street version, no user-relevant changes. ## 2009-03-09 - Merged with Jane Street version, no user-relevant changes. ## 2009-03-01 - Fixed build problem on Mac OS X by updating OCamlMakefile. ## 2009-01-20 - Automatically add S-expression pretty-printers to toplevels. ## 2008-09-30 - Added a new feature: sexp_opaque. It prevents the need for / use of type converters for a given type in a particular type context. Removed abstract types to unify them with this new concept. ## 2008-09-29 - Added a new feature: sexp_list. This is similar to the handling of sexp_option. By default an empty list is assumed for unspecified records using sexp_list as qualifier. Such record fields bound to empty lists will also not be printed anymore for better readability. ## 2008-09-23 - Added missing Not_found-exception to standard exception converters. ## 2008-08-20 - Removed dependency on threads. Fixed build problems. ## 2008-08-08 - Nifty new feature: exceptions can now be converted to S-expressions, too! The "with sexp" syntax extension can be used with exceptions, thus registering a conversion function. A global exception conversion function can then be called to convert an arbitrary exception into an S-expression, which can then be printed out. This should greatly improve readability of uncaught exceptions while making life extremely easy for the developer. - Renamed the ParseError exception to Parse_error to be more compliant with Jane Street naming conventions. ## 2008-07-25 - Added utilities for conversion error handling. Minor fixes. ## 2008-04-24 - Made Sexp-interface manifest. ## 2008-03-20 - Fixed META-file (missing num dependency). ## 2008-03-17 - Improved META-file. ## 2008-03-13 - Fully allow function types in converters. Raise runtime exceptions on converting from S-expressions instead when function type encountered. ## 2008-02-11 - Fixed code generation problems with variance annotations in signatures, and empty types. ## 2007-12-17 - Added support for generating signature entries for S-expression converters. Thanks to Till Varoquaux for the patch! ## 2007-11-29 - Added support for converting big_int, nat, num, and ratio. ## 2007-11-26 - Added support for parsing from bigstrings (char bigarrays). ## 2007-11-02 - Added syntax support for option types to use the ordinary sum type syntax. This should improve readability. The old syntax will be accepted, too, if Conv.read_old_option_format is set to true (this is currently the default). The old format will be used for writing if Conv.write_old_option_format is true (currently the default). The old syntax is deprecated and will probably not be supported by default in the near future. Reading new-style option values will always succeed. ## 2007-09-14 - Fixed bug in S-expression preprocessor concerning record field names. ## 2007-08-06 - Added support for converting functions to S-expressions. ## 2007-07-20 - Fixed position information and improved speed of S-expression parser. Fixed S-expression macro bug concerning contained polymorphic variants. ## 2007-06-28 - Improved Sexplib code generation. ## 2007-06-22 - Fixed escaping bug in S-expression parser. ## 2007-06-01 - Added correct handling of recursive types + test case. ## 2007-04-18 - Added missing conversion functions from S-expressions to pairs and triples. ## 2007-03-21 - Updated OCamlMakefile. ## 2007-03-02 - Improved error messages when parsing illegal type definitions. ## 2007-01-30 - Added triple conversions. ## 2006-11-22 - Updated OCamlMakefile. ## 2006-10-13 - Improved checking of records for extra or duplicate fields. ## 2006-09-06 - Added support for polymorphic record fields. ## 2006-09-05 - Added support for manifest types. ## 2006-08-16 - Improved error messages. ## 2006-07-28 - Added a new, hand-written S-expression parser that supports partial parsing and should be approx. 10x faster than the previous one. ## 2006-06-20 - Fixed a code generation problem leading to compilation errors concerning the use of type aliases within polymorphic variant type definitions. This fix also solves potential erroneous appearances of backtracking exceptions in user code. ## 2006-03-21 - Added -for-pack option to Makefile and cleaned up distribution for a new public release. ## 2006-03-13 - Sexplib now accepts capitalized booleans. ## 2006-03-03 - Added customizable indentation levels. - Improved documentation. - Fixed API-problem concerning backward compatibility. ## 2006-03-01 - Added a missing flush for string conversions with a buffer. ## 2006-02-08 - Eliminated unused variable warnings in Sexplib-generated code. ## 2006-01-11 - Added functions for pretty-printing to buffers. - Improved performance of outputting S-expressions to channels. ## 2006-01-09 - Added functions load_sexp and load_sexps. ## 2006-01-04 - Changed float conversion from %E to %G (more readable). ## 2005-12-28 - Made machine representation for S-expressions more compact ## 2005-12-15 - Fixed a problem appearing with OCaml-release 3.08.4: CamlP4 obviously performs more strict checking on some constructs now and crashed with an exception when generating S-expression code for records containing only one field ("singleton tuple problem"). This problem is fixed now. ## 2005-11-25 - Fixed problem with type variables that could not be generalized. ## 2005-11-23 - Added a missing case in type definitions (path alias) ## 2005-11-17 - Major release: 2.0 Fixed a major design problem. The user now has to pass lex buffers instead of channels to input-functions. Reason: trailing characters in channels were lost due to ocamllex buffering them in the non-exposed lex buffer. This lex buffer is now exposed. The functions have been renamed ("input_X" -> "scan_X") to reflect this change. ## 2005-11-16 - Added label to conversion function "input_cnv_sexps". ## 2005-11-11 - Fixed a bug in the pretty-printer: strings in atoms were not escaped in the function "to_string_mach" (and therefore also "to_string"). ## 2005-11-07 - Initial release. sexplib-113.33.03/CHANGES.txt000066400000000000000000000240331271035576100153150ustar00rootroot000000000000002012-07-15: Added support for S-expression default record fields. Added syntax for S-expression comments and for nested block comments. Fixed a few minor bugs and inconsistencies in the parsers and updated their whitespace handling to conform with the upcoming OCaml 4.00 compiler. The parser specification now also supports Menhir. Rewrote README in Markdown and improved documentation. Minor bug fix in the preprocessing module. Eliminated new warnings available in OCaml 4.00. 2011-09-18: Improved documentation. 2011-09-15: Fixes to improve package dependency resolution. 2011-07-05: Fixed a parser position bug. Parser positions passed by the user were not updated correctly. Internal code beautification. 2011-07-04: Internal updates to sync with Jane Street. 2011-01-30: Fixed a code generation bug with toplevel entries. Thanks to Yong Lu for the report! 2010-12-27: Added support for MoreLabels.Hashtbl and improved reporting of error locations with preprocessor. 2010-12-26: Worked around a compiler bug that is expected to be fixed in OCaml 3.12.1. This workaround temporarily removes the interface for module Conv (conv.mli), thus exposing the internals. This should not cause any problems for end users as long as they do not depend on the exported internal representations. The interface will become constrained again as soon as the fixed compiler is out. 2010-12-22: Major release. Merged with Jane Street version. This has caused an API-change that requires "open Sexplib.Conv" at the top of files that use the syntax extension. Renamed functions: * sexp_of_lazy -> sexp_of_lazy_t * lazy_of_sexp -> lazy_t_of_sexp Some standard library modules are now re-exported with predefined S-expression converters in module Conv. 2010-09-25: Fixed inferred types of generated functions when dealing with arrow types. 2010-08-26: Fixed a lexer bug when parsing comments. 2010-05-21: Added support for sexp_bool record field annotations. 2010-05-18: Improved performance of converting S-expressions to strings. 2010-04-12: Changed API of Of_sexp_error exception. 2010-04-07: Added of_(big)string_conv_exn functions. 2010-04-01: Merged with Jane Street version. Major new features (various functions): * Type-annotated parsing for better error messages * Greatly improved performance of exception converters 2009-12-21: Improved saving of files. 2009-10-12: Added sexp_array record field extension. 2009-09-19: Added missing variant type cases. Fixed handling of variance annotations. 2009-09-15: Internal cleanups. 2009-07-28: Added better support for conversion of exception types. 2009-06-23: Fixed build problem. Thanks to Sylvain Le Gall for the patch! 2009-05-08: Fixed build problems on Windows and OCamlMakefile issues. Thanks to Sylvain Le Gall for the patch! 2009-04-22: Added macro support for all types of vectors, matrices, and for bigstrings. 2009-04-21: Merged with Jane Street version, no user-relevant changes. 2009-03-09: Merged with Jane Street version, no user-relevant changes. 2009-03-01: Fixed build problem on Mac OS X by updating OCamlMakefile. 2009-01-20: Automatically add S-expression pretty-printers to toplevels. 2008-09-30: Added a new feature: sexp_opaque. It prevents the need for / use of type converters for a given type in a particular type context. Removed abstract types to unify them with this new concept. 2008-09-29: Added a new feature: sexp_list. This is similar to the handling of sexp_option. By default an empty list is assumed for unspecified records using sexp_list as qualifier. Such record fields bound to empty lists will also not be printed anymore for better readability. 2008-09-23: Added missing Not_found-exception to standard exception converters. 2008-08-20: Removed dependency on threads. Fixed build problems. 2008-08-08: Nifty new feature: exceptions can now be converted to S-expressions, too! The "with sexp" syntax extension can be used with exceptions, thus registering a conversion function. A global exception conversion function can then be called to convert an arbitrary exception into an S-expression, which can then be printed out. This should greatly improve readability of uncaught exceptions while making life extremely easy for the developer. Renamed the ParseError exception to Parse_error to be more compliant with Jane Street naming conventions. 2008-07-25: Added utilities for conversion error handling. Minor fixes. 2008-04-24: Made Sexp-interface manifest. 2008-03-20: Fixed META-file (missing num dependency). 2008-03-17: Improved META-file. 2008-03-13: Fully allow function types in converters. Raise runtime exceptions on converting from S-expressions instead when function type encountered. 2008-02-11: Fixed code generation problems with variance annotations in signatures, and empty types. 2007-12-17: Added support for generating signature entries for S-expression converters. Thanks to Till Varoquaux for the patch! 2007-11-29: Added support for converting big_int, nat, num, and ratio. 2007-11-26: Added support for parsing from bigstrings (char bigarrays). 2007-11-02: Added syntax support for option types to use the ordinary sum type syntax. This should improve readability. The old syntax will be accepted, too, if Conv.read_old_option_format is set to true (this is currently the default). The old format will be used for writing if Conv.write_old_option_format is true (currently the default). The old syntax is deprecated and will probably not be supported by default in the near future. Reading new-style option values will always succeed. 2007-09-14: Fixed bug in S-expression preprocessor concerning record field names. 2007-08-06: Added support for converting functions to S-expressions. 2007-07-20: Fixed position information and improved speed of S-expression parser. Fixed S-expression macro bug concerning contained polymorphic variants. 2007-06-28: Improved Sexplib code generation. 2007-06-22: Fixed escaping bug in S-expression parser. 2007-06-01: Added correct handling of recursive types + test case. 2007-04-18: Added missing conversion functions from S-expressions to pairs and triples. 2007-03-21: Updated OCamlMakefile. 2007-03-02: Improved error messages when parsing illegal type definitions. 2007-01-30: Added triple conversions. 2006-11-22: Updated OCamlMakefile. 2006-10-13: Improved checking of records for extra or duplicate fields. 2006-09-06: Added support for polymorphic record fields. 2006-09-05: Added support for manifest types. 2006-08-16: Improved error messages. 2006-07-28: Added a new, hand-written S-expression parser that supports partial parsing and should be approx. 10x faster than the previous one. 2006-06-20: Fixed a code generation problem leading to compilation errors concerning the use of type aliases within polymorphic variant type definitions. This fix also solves potential erroneous appearances of backtracking exceptions in user code. 2006-03-21: Added -for-pack option to Makefile and cleaned up distribution for a new public release. 2006-03-13: Sexplib now accepts capitalized booleans. 2006-03-03: Added customizable indentation levels. Improved documentation. Fixed API-problem concerning backward compatibility. 2006-03-03: Added customizable indentation levels. Improved documentation. 2006-03-01: Added a missing flush for string conversions with a buffer. 2006-02-08: Eliminated unused variable warnings in Sexplib-generated code. 2006-01-11: Added functions for pretty-printing to buffers. Improved performance of outputting S-expressions to channels. 2006-01-09: Added functions load_sexp and load_sexps. 2006-01-04: Changed float conversion from %E to %G (more readable). 2005-12-28: Made machine representation for S-expressions more compact 2005-12-15: Fixed a problem appearing with OCaml-release 3.08.4: CamlP4 obviously performs more strict checking on some constructs now and crashed with an exception when generating S-expression code for records containing only one field ("singleton tuple problem"). This problem is fixed now. 2005-11-25: Fixed problem with type variables that could not be generalized. 2005-11-23: Added a missing case in type definitions (path alias) 2005-11-17: Major release: 2.0 Fixed a major design problem. The user now has to pass lex buffers instead of channels to input-functions. Reason: trailing characters in channels were lost due to ocamllex buffering them in the non-exposed lex buffer. This lex buffer is now exposed. The functions have been renamed ("input_X" -> "scan_X") to reflect this change. 2005-11-16: Added label to conversion function "input_cnv_sexps". 2005-11-11: Fixed a bug in the pretty-printer: strings in atoms were not escaped in the function "to_string_mach" (and therefore also "to_string"). 2005-11-07: Initial release. sexplib-113.33.03/COPYRIGHT.txt000066400000000000000000000007631271035576100156210ustar00rootroot00000000000000Most of this library was written by: Markus Mottl This work is derived from the library "Tywith", version 0.45. The library "Tywith" was written and is distributed by: Martin Sandin The original license of "Tywith" can be found in the file "LICENSE-Tywith.txt". The following company has sponsored and has copyright in part of this work: Jane Street Holding, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA sexplib-113.33.03/INRIA-DISCLAIMER.txt000066400000000000000000000013321271035576100165160ustar00rootroot00000000000000THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. sexplib-113.33.03/LICENSE-Tywith.txt000066400000000000000000000030101271035576100166050ustar00rootroot00000000000000--------------------------------------------------------------------------- Copyright (c) 2004 Martin Sandin All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --------------------------------------------------------------------------- sexplib-113.33.03/LICENSE.txt000066400000000000000000000261361271035576100153350ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. sexplib-113.33.03/META.ab000066400000000000000000000015151271035576100145360ustar00rootroot00000000000000version = "$(pkg_version)" description = "Library for serializing OCaml values to and from S-expressions" requires = "bigarray" archive(byte ) = "sexplib.cma" archive(native) = "sexplib.cmxa" plugin(byte ) = "sexplib.cma" plugin(native) = "sexplib.cmxs" exists_if = "sexplib.cma" package "num" ( version = "$(pkg_version)" description = "" requires = "num sexplib" archive(byte ) = "sexplib_num.cma" archive(native) = "sexplib_num.cmxa" plugin(byte ) = "sexplib_num.cma" plugin(native) = "sexplib_num.cmxs" exists_if = "sexplib_num.cma" ) package "unix" ( version = "$(pkg_version)" description = "" requires = "sexplib unix" archive(byte ) = "sexplib_unix.cma" archive(native) = "sexplib_unix.cmxa" plugin(byte ) = "sexplib_unix.cma" plugin(native) = "sexplib_unix.cmxs" exists_if = "sexplib_unix.cma" ) sexplib-113.33.03/Makefile000066400000000000000000000034151271035576100151450ustar00rootroot00000000000000# Generic Makefile for oasis project SETUP := setup.exe NAME := sexplib PREFIX = $(shell grep ^prefix= setup.data | cut -d\" -f 2) # Default rule default: build setup.exe: _oasis setup.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup.ml || \ ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup.ml || true for f in setup.*; do [ $$f = $@ -o $$f = setup.ml ] || rm -f $$f; done build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) $(MAKE) $(NAME).install doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) $(MAKE) $(NAME).install $(NAME).install: install.ml setup.log setup.data ocaml -I "$(OCAML_TOPLEVEL_PATH)" install.ml install: $(NAME).install opam-installer -i --prefix $(PREFIX) $(NAME).install uninstall: $(NAME).install opam-installer -u --prefix $(PREFIX) $(NAME).install reinstall: $(NAME).install opam-installer -u --prefix $(PREFIX) $(NAME).install &> /dev/null || true opam-installer -i --prefix $(PREFIX) $(NAME).install bin.tar.gz: $(NAME).install rm -rf _install mkdir _install opam-installer -i --prefix _install $(NAME).install tar czf bin.tar.gz -C _install . rm -rf _install bin.lzo: $(NAME).install rm -rf _install mkdir _install opam-installer -i --prefix _install $(NAME).install cd _install && lzop -1 -P -o ../bin.lzo `find . -type f` rm -rf _install clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure sexplib-113.33.03/README.org000066400000000000000000000077521271035576100151630ustar00rootroot00000000000000* Sexplib - S-Expressions for OCaml =sexplib= contains functionality for parsing and pretty-printing s-expressions. S-expressions are defined by the following type: #+begin_src ocaml type sexp = Atom of string | List of sexp list #+end_src and are rendered as parenthesized lists of strings, /e.g./ =(This (is an) (s expression))=. This library is often used in conjunction with =ppx_sexp_conv=, a syntax extension which generates code from type definitions for efficiently converting OCaml-values to s-expressions and vice versa. Together, these two libraries make it easy and convenient to convert your OCaml values to and from a human-readable serializable form, without the tedium of having to write your own converters. The library also offers functionality for extracting and replacing sub-expressions in s-expressions. Here, we'll only document =sexplib= proper. If you want to know more about the way in which OCaml types are mapped on to s-expressions, you should look at the documentation for =ppx_sexp_conv=. ** Lexical conventions of s-expression Whitespace, which consists of space, newline, horizontal tab, and form feed, is ignored unless within an OCaml-string, where it is treated according to OCaml-conventions. The left parenthesis opens a new list, the right one closes it again. Lists can be empty. The double quote denotes the beginning and end of a string following the lexical conventions of OCaml (see the [[http://www.ocaml.org/pub/docs/manual-ocaml][OCaml-manual]] for details). All characters other than double quotes, left- and right parentheses, whitespace, carriage return, and comment-introducing characters or sequences (see next paragraph) are considered part of a contiguous string. ** Comments There are three kinds of comments: - _line comments_ are introduced with =;=, and end at the newline. - _sexp comments_ are introduced with =#;=, and end at the end of the following s-expression - _block comments_ are introduced with =#|= and end with =|#=. These can be nested, and double-quotes within them must be balanced and be lexically correct OCaml strings. ** Grammar of s-expressions s-expressions are either strings (= atoms) or lists. The lists can recursively contain further s-expressions or be empty, and must be balanced, /i.e./ parentheses must match. ** Examples #+begin_src scheme this_is_an_atom_123'&^%! ; this is a comment "another atom in an OCaml-string \"string in a string\" \123" ; empty list follows below () ; a more complex example ( ( list in a list ; comment within a list (list in a list in a list) 42 is the answer to all questions #; (this S-expression (has been commented out) ) #| Block comments #| can be "nested" |# |# ) ) #+end_src ** I/O and Type Conversions There are multiple ways of performing I/O with s-expressions. If exact error locations are required when type conversions fail, s-expressions need to be parsed with location annotations. The associated parser is slower, however, and needs more memory. In most cases users may therefore want to use functions like =load_sexp_conv= or =load_sexp_conv_exn=, which load s-expressions from files and convert them. They initially read the file without location annotations for performance reasons. Only if conversions fail, the file will be reparsed with location annotations. Type errors can then be reported accurately with file name, line number, column, and file position. ** Custom converters In addition to the converters provided automatically by =ppx_sexp_conv=, it's possible to write one's own sexp-converter. For such converters to be available by other automatically generated converters, it should follow the convention of being defined in the same scope as the type, and should be named =sexp_of_[type]= and =[type_of_sexp]=. You must report failures by raising the =Of_sexp_error=-exception so that then =sexplib='s tools for pinpointing the location of type errors within an s-expression file will work properly. sexplib-113.33.03/THIRD-PARTY.txt000066400000000000000000000013601271035576100160120ustar00rootroot00000000000000The repository contains 3rd-party code in the following locations and under the following licenses: - type_conv, sexplib and bin_prot: based on Tywith, by Martin Sandin. License can be found in base/sexplib/LICENSE-Tywith.txt, base/type_conv/LICENSE-Tywith.txt, and base/bin_prot/LICENSE-Tywith.txt. - Core's implementation of union-find: based on an implementation by Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License can be found in base/core/MLton-license. - Various Core libraries are based on INRIA's OCaml distribution. Relicensed under Apache 2.0, as permitted under the Caml License for Consortium members: http://caml.inria.fr/consortium/license.en.html See also the disclaimer INRIA-DISCLAIMER.txt. sexplib-113.33.03/_oasis000066400000000000000000000036601271035576100147070ustar00rootroot00000000000000OASISFormat: 0.4 OCamlVersion: >= 4.02.3 FindlibVersion: >= 1.3.2 Name: sexplib Version: 113.33.03 Synopsis: Library for serializing OCaml values to and from S-expressions Authors: Jane Street Group, LLC Copyrights: (C) 2005-2016 Jane Street Group LLC Maintainers: Jane Street Group, LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/sexplib Plugins: StdFiles (0.3), DevFiles (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild BetaFeatures: section_object AlphaFeatures: ocamlbuild_more_args XOCamlbuildPluginTags: package(js-build-tools.ocamlbuild_goodies) FilesAB: META.ab 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. Library sexplib Path: src Pack: true Modules: Conv, Conv_error, Exn_magic, Lexer, Macro, Parser, Parser_with_layout, Path, Pre_sexp, Sexp, Sexp_intf, Sexp_with_layout, Src_pos, Std, Type, Type_with_layout BuildDepends: bigarray Library sexplib_num Path: num/lib Pack: true Modules: Sexplib_num_conv, Std BuildDepends: num, sexplib Library sexplib_unix Path: unix/lib Pack: true Modules: Sexplib_unix_conv BuildDepends: sexplib, unix sexplib-113.33.03/_tags000066400000000000000000000005321271035576100145220ustar00rootroot00000000000000<**/*.ml{,i}>: warn(-40), no_alias_deps <**/*>: thread # This prevents the implicit addition of -ppx options by ocamlfind <**/*>: predicate(custom_ppx) : for-pack(Sexplib) : for-pack(Sexplib_num) : for-pack(Sexplib_unix) : pp(cpp -undef -traditional -Isyntax -w) # OASIS_START # OASIS_STOP sexplib-113.33.03/configure000077500000000000000000000001111271035576100154020ustar00rootroot00000000000000#!/bin/sh # OASIS_START make configure CONFIGUREFLAGS="$*" # OASIS_STOP sexplib-113.33.03/descr000066400000000000000000000004131271035576100145230ustar00rootroot00000000000000Library for serializing OCaml values to and from S-expressions 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. sexplib-113.33.03/install.ml000066400000000000000000000003541271035576100155040ustar00rootroot00000000000000#use "topfind";; #require "js-build-tools.oasis2opam_install";; open Oasis2opam_install;; generate ~package:"sexplib" [ oasis_lib "sexplib" ; oasis_lib "sexplib_num" ; oasis_lib "sexplib_unix" ; file "META" ~section:"lib" ] sexplib-113.33.03/myocamlbuild.ml000066400000000000000000000005301271035576100165130ustar00rootroot00000000000000(* OASIS_START *) (* OASIS_STOP *) # 3 "myocamlbuild.ml" module JS = Jane_street_ocamlbuild_goodies let dev_mode = true let () = Ocamlbuild_plugin.dispatch (fun hook -> JS.alt_cmxs_of_cmxa_rule hook; JS.pass_predicates_to_ocamldep hook; if dev_mode && not Sys.win32 then JS.track_external_deps hook; dispatch_default hook) sexplib-113.33.03/num/000077500000000000000000000000001271035576100143015ustar00rootroot00000000000000sexplib-113.33.03/num/lib/000077500000000000000000000000001271035576100150475ustar00rootroot00000000000000sexplib-113.33.03/num/lib/sexplib_num_conv.ml000066400000000000000000000023501271035576100207530ustar00rootroot00000000000000open Sexplib.Sexp open Sexplib.Conv let exn_to_string e = to_string_hum (sexp_of_exn e) let sexp_of_big_int n = Atom (Big_int.string_of_big_int n) let sexp_of_nat n = Atom (Nat.string_of_nat n) let sexp_of_ratio n = Atom (Ratio.string_of_ratio n) let sexp_of_num n = Atom (Num.string_of_num n) let big_int_of_sexp sexp = match sexp with | Atom str -> (try Big_int.big_int_of_string str with exc -> of_sexp_error ("big_int_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "big_int_of_sexp: atom needed" sexp let nat_of_sexp sexp = match sexp with | Atom str -> (try Nat.nat_of_string str with exc -> of_sexp_error ("nat_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "nat_of_sexp: atom needed" sexp let ratio_of_sexp sexp = match sexp with | Atom str -> (try Ratio.ratio_of_string str with exc -> of_sexp_error ("ratio_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "ratio_of_sexp: atom needed" sexp let num_of_sexp sexp = match sexp with | Atom str -> (try Num.num_of_string str with exc -> of_sexp_error ("num_of_sexp: " ^ exn_to_string exc) sexp) | List _ -> of_sexp_error "num_of_sexp: atom needed" sexp sexplib-113.33.03/num/lib/sexplib_num_conv.mli000066400000000000000000000020671271035576100211310ustar00rootroot00000000000000open Sexplib val sexp_of_big_int : Big_int.big_int -> Sexp.t (** [sexp_of_big_int n] converts the value [n] of type [Big_int.big_int] to an S-expression. *) val sexp_of_nat : Nat.nat -> Sexp.t (** [sexp_of_nat n] converts the value [n] of type [Nat.nat] to an S-expression. *) val sexp_of_ratio : Ratio.ratio -> Sexp.t (** [sexp_of_ratio n] converts the value [n] of type [Ratio.ratio] to an S-expression. *) val sexp_of_num : Num.num -> Sexp.t (** [sexp_of_num n] converts the value [n] of type [Num.num] to an S-expression. *) val big_int_of_sexp : Sexp.t -> Big_int.big_int (** [big_int_of_sexp sexp] converts S-expression [sexp] to a value of type [Big_int.big_int]. *) val nat_of_sexp : Sexp.t -> Nat.nat (** [nat_of_sexp sexp] converts S-expression [sexp] to a value of type [Nat.nat]. *) val ratio_of_sexp : Sexp.t -> Ratio.ratio (** [ratio_of_sexp sexp] converts S-expression [sexp] to a value of type [Nat.ratio]. *) val num_of_sexp : Sexp.t -> Num.num (** [num_of_sexp sexp] converts S-expression [sexp] to a value of type [Nat.num]. *) sexplib-113.33.03/num/lib/std.ml000066400000000000000000000011141271035576100161700ustar00rootroot00000000000000 module Big_int = struct include Big_int let sexp_of_big_int = Sexplib_num_conv.sexp_of_big_int let big_int_of_sexp = Sexplib_num_conv.big_int_of_sexp end module Nat = struct include Nat let sexp_of_nat = Sexplib_num_conv.sexp_of_nat let nat_of_sexp = Sexplib_num_conv.nat_of_sexp end module Ratio = struct include Ratio let sexp_of_ratio = Sexplib_num_conv.sexp_of_ratio let ratio_of_sexp = Sexplib_num_conv.ratio_of_sexp end module Num = struct include Num let sexp_of_num = Sexplib_num_conv.sexp_of_num let num_of_sexp = Sexplib_num_conv.num_of_sexp end sexplib-113.33.03/opam000066400000000000000000000010471271035576100143630ustar00rootroot00000000000000opam-version: "1.2" maintainer: "opensource@janestreet.com" authors: ["Jane Street Group, LLC "] homepage: "https://github.com/janestreet/sexplib" bug-reports: "https://github.com/janestreet/sexplib/issues" dev-repo: "https://github.com/janestreet/sexplib.git" license: "Apache-2.0" build: [ ["./configure" "--prefix" prefix] [make] ] depends: [ "ocamlbuild" {build} "oasis" {build & >= "0.4"} "ocamlfind" {build & >= "1.3.2"} "js-build-tools" {build} ] available: [ ocaml-version = "4.02.3" ] sexplib-113.33.03/setup.ml000066400000000000000000000001331271035576100151710ustar00rootroot00000000000000(* OASIS_START *) open OASISDynRun;; open OASISTypes;; (* OASIS_STOP *) let () = setup () sexplib-113.33.03/src/000077500000000000000000000000001271035576100142715ustar00rootroot00000000000000sexplib-113.33.03/src/conv.ml000066400000000000000000000506531271035576100156010ustar00rootroot00000000000000(* Utility Module for S-expression Conversions *) open Printf open Bigarray open Sexp module String = Bytes type sexp_bool = bool type 'a sexp_option = 'a option type 'a sexp_list = 'a list type 'a sexp_array = 'a array type 'a sexp_opaque = 'a type bigstring = Sexp.bigstring type float32_vec = (float, float32_elt, fortran_layout) Array1.t type float64_vec = (float, float64_elt, fortran_layout) Array1.t type vec = float64_vec type float32_mat = (float, float32_elt, fortran_layout) Array2.t type float64_mat = (float, float64_elt, fortran_layout) Array2.t type mat = float64_mat (* 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_kernel.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 f l) 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_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 sexp_of__a lst)) 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 k v acc = List [sexp_of_key k; sexp_of_val v] :: acc in List (Hashtbl.fold coll htbl []) let sexp_of_float_vec vec = let lst_ref = ref [] in for i = Array1.dim vec downto 1 do lst_ref := sexp_of_float vec.{i} :: !lst_ref done; List !lst_ref let sexp_of_bigstring (bstr : bigstring) = let n = Array1.dim bstr in let str = String.create n in for i = 0 to n - 1 do str.[i] <- bstr.{i} done; Atom str let sexp_of_float32_vec (vec : float32_vec) = sexp_of_float_vec vec let sexp_of_float64_vec (vec : float64_vec) = sexp_of_float_vec vec let sexp_of_vec (vec : vec) = sexp_of_float_vec vec let sexp_of_float_mat mat = let m = Array2.dim1 mat in let n = Array2.dim2 mat in let lst_ref = ref [] in for col = n downto 1 do let vec = Array2.slice_right mat col in for row = m downto 1 do lst_ref := sexp_of_float vec.{row} :: !lst_ref done done; List (sexp_of_int m :: sexp_of_int n :: !lst_ref) let sexp_of_float32_mat (mat : float32_mat) = sexp_of_float_mat mat let sexp_of_float64_mat (mat : float64_mat) = sexp_of_float_mat mat let sexp_of_mat (mat : mat) = sexp_of_float_mat mat let sexp_of_opaque _ = Atom "" let sexp_of_fun _ = Atom "" let string_of__of__sexp_of to_sexp x = Sexp.to_string (to_sexp x) (* Exception converter registration and lookup *) module Exn_converter = struct type t = int64 module Ids = Map.Make (Int64) let exn_id_cnt = ref Int64.max_int let exn_handlers : (exn -> Sexp.t option) Ids.t ref = ref Ids.empty (* 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. *) let rec add_slow sexp_of_exn = let exn_id = !exn_id_cnt in let new_exn_id = Int64.sub exn_id Int64.one in let new_exn_handlers = Ids.add exn_id sexp_of_exn !exn_handlers in (* This trick avoids mutexes and should be fairly efficient *) if !exn_id_cnt != exn_id then add_slow sexp_of_exn else begin (* These two assignments should always be atomic *) exn_id_cnt := new_exn_id; exn_handlers := new_exn_handlers; exn_id end let rec del_slow exn_id = let old_exn_handlers = !exn_handlers in let new_exn_handlers = Ids.remove exn_id old_exn_handlers in (* This trick avoids mutexes and should be fairly efficient *) if !exn_handlers != old_exn_handlers then del_slow exn_id else exn_handlers := new_exn_handlers exception Found_sexp_opt of Sexp.t option let find_slow exn = try let act _id sexp_of_exn = let sexp_opt = sexp_of_exn exn in if sexp_opt <> None then raise (Found_sexp_opt sexp_opt) in Ids.iter act !exn_handlers; None with Found_sexp_opt sexp_opt -> sexp_opt (* Fast and automatic exception registration *) module Int = struct type t = int let compare t1 t2 = compare (t1 : int) t2 end module Exn_ids = Map.Make (Int) let exn_id_map : (exn -> Sexp.t) Exn_ids.t ref = ref Exn_ids.empty (* [Obj.extension_id] works on both the exception itself, and the extension slot of the exception. *) let rec clean_up_handler (slot : Obj.t) = let id = Obj.extension_id slot in let old_exn_id_map = !exn_id_map in let new_exn_id_map = Exn_ids.remove id old_exn_id_map in (* This trick avoids mutexes and should be fairly efficient *) if !exn_id_map != old_exn_id_map then clean_up_handler slot else exn_id_map := new_exn_id_map let add_auto ?(finalise = true) exn sexp_of_exn = let id = Obj.extension_id exn in let rec loop () = let old_exn_id_map = !exn_id_map in let new_exn_id_map = Exn_ids.add id sexp_of_exn old_exn_id_map in (* This trick avoids mutexes and should be fairly efficient *) if !exn_id_map != old_exn_id_map then loop () else begin exn_id_map := new_exn_id_map; if finalise then Gc.finalise clean_up_handler (Obj.extension_slot exn) end in loop () let find_auto exn = let id = Obj.extension_id exn in match Exn_ids.find id !exn_id_map with | exception Not_found -> None | sexp_of_exn -> Some (sexp_of_exn exn) let max_exn_tags = ref 20 let set_max_exn_tags n = if n < 1 then failwith "Sexplib.Conv.Exn_converter.set_max_exn_tags: n < 1" else max_exn_tags := n let get_max_exn_tags () = !max_exn_tags end let sexp_of_exn_opt exn = let sexp_opt = Exn_converter.find_auto exn in if sexp_opt = None then Exn_converter.find_slow exn else sexp_opt 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_auto] 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 exn with | None -> None | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) (* Conversion of S-expressions to OCaml-values *) exception Of_sexp_error = Pre_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 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 a__of_sexp lst 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_of_sexp k_sexp) (val_of_sexp v_sexp) | List _ | Atom _ -> of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp in List.iter act lst; htbl | Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp let bigstring_of_sexp sexp = match sexp with | Atom str -> let len = String.length str in let bstr = Array1.create char c_layout len in for i = 0 to len - 1 do bstr.{i} <- str.[i] done; bstr | List _ -> of_sexp_error "bigstring_of_sexp: atom needed" sexp let float_vec_of_sexp empty_float_vec create_float_vec sexp = match sexp with | List [] -> empty_float_vec | List lst -> let len = List.length lst in let res = create_float_vec len in let rec loop i = function | [] -> res | h :: t -> res.{i} <- float_of_sexp h; loop (i + 1) t in loop 1 lst | Atom _ -> of_sexp_error "float_vec_of_sexp: list needed" sexp let create_float32_vec = Array1.create float32 fortran_layout let create_float64_vec = Array1.create float64 fortran_layout let empty_float32_vec = create_float32_vec 0 let empty_float64_vec = create_float64_vec 0 let float32_vec_of_sexp = float_vec_of_sexp empty_float32_vec create_float32_vec let float64_vec_of_sexp = float_vec_of_sexp empty_float64_vec create_float64_vec let vec_of_sexp = float_vec_of_sexp empty_float64_vec create_float64_vec let check_too_much_data sexp data res = if data = [] then res else of_sexp_error "float_mat_of_sexp: too much data" sexp let float_mat_of_sexp create_float_mat sexp = match sexp with | List (sm :: sn :: data) -> let m = int_of_sexp sm in let n = int_of_sexp sn in let res = create_float_mat m n in if m = 0 || n = 0 then check_too_much_data sexp data res else let rec loop_cols col data = let vec = Array2.slice_right res col in let rec loop_rows row = function | [] -> of_sexp_error "float_mat_of_sexp: not enough data" sexp | h :: t -> vec.{row} <- float_of_sexp h; if row = m then if col = n then check_too_much_data sexp t res else loop_cols (col + 1) t else loop_rows (row + 1) t in loop_rows 1 data in loop_cols 1 data | List _ -> of_sexp_error "float_mat_of_sexp: list too short" sexp | Atom _ -> of_sexp_error "float_mat_of_sexp: list needed" sexp let create_float32_mat = Array2.create float32 fortran_layout let create_float64_mat = Array2.create float64 fortran_layout let float32_mat_of_sexp = float_mat_of_sexp create_float32_mat let float64_mat_of_sexp = float_mat_of_sexp create_float64_mat let mat_of_sexp = float_mat_of_sexp create_float64_mat 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 let of_string__of__of_sexp of_sexp s = try let sexp = Sexp.of_string s in of_sexp sexp with e -> failwith (sprintf "of_string failed on %s with %s" s (exn_to_string e)) (* 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 (fun (exc, handler) -> Exn_converter.add_auto ~finalise:false exc handler) [ ( Assert_failure ("", 0, 0), (function | Assert_failure arg -> get_flc_error "Assert_failure" arg | _ -> assert false) );( Exit, (function | Exit -> Atom "Exit" | _ -> assert false) );( End_of_file, (function | End_of_file -> Atom "End_of_file" | _ -> assert false) );( Failure "", (function | Failure arg -> List [Atom "Failure"; Atom arg ] | _ -> assert false) );( Not_found, (function | Not_found -> Atom "Not_found" | _ -> assert false) );( Invalid_argument "", (function | Invalid_argument arg -> List [Atom "Invalid_argument"; Atom arg ] | _ -> assert false) );( Match_failure ("", 0, 0), (function | Match_failure arg -> get_flc_error "Match_failure" arg | _ -> assert false) );( Sys_error "", (function | Sys_error arg -> List [Atom "Sys_error"; Atom arg ] | _ -> assert false) );( Arg.Help "", (function | Arg.Help arg -> List [Atom "Arg.Help"; Atom arg ] | _ -> assert false) );( Arg.Bad "", (function | Arg.Bad arg -> List [Atom "Arg.Bad"; Atom arg ] | _ -> assert false) );( Lazy.Undefined, (function | Lazy.Undefined -> Atom "Lazy.Undefined" | _ -> assert false) );( Parsing.Parse_error, (function | Parsing.Parse_error -> Atom "Parsing.Parse_error" | _ -> assert false) );( Queue.Empty, (function | Queue.Empty -> Atom "Queue.Empty" | _ -> assert false) );( Scanf.Scan_failure "", (function | Scanf.Scan_failure arg -> List [Atom "Scanf.Scan_failure"; Atom arg ] | _ -> assert false) );( Stack.Empty, (function | Stack.Empty -> Atom "Stack.Empty" | _ -> assert false) );( Stream.Failure, (function | Stream.Failure -> Atom "Stream.Failure" | _ -> assert false) );( Stream.Error "", (function | Stream.Error arg -> List [Atom "Stream.Error"; Atom arg ] | _ -> assert false) );( Sys.Break, (function | Sys.Break -> Atom "Sys.Break" | _ -> assert false) );( Of_sexp_error (Exit, Atom ""), (function | Of_sexp_error (exc, sexp) -> List [Atom "Sexplib.Conv.Of_sexp_error"; sexp_of_exn exc; sexp] | _ -> assert false) );( Parse_error { Pre_sexp. location = ""; err_msg = ""; parse_state = `Sexp { Pre_sexp. parse_pos = { Pre_sexp.Parse_pos. text_line = 0; text_char = 0; global_offset = 0; buf_pos = 0; }; pstack = []; pbuf = Buffer.create 0; }; }, (function | Parse_error pe -> let ppos = match pe.parse_state with | `Sexp { parse_pos; pstack=_; pbuf=_ } | `Annot { parse_pos; pstack=_; pbuf=_ } -> parse_pos in List [ Atom "Sexplib.Sexp.Parse_error"; List [ List [Atom "location"; Atom pe.location]; List [Atom "err_msg"; Atom pe.err_msg]; List [Atom "text_line"; sexp_of_int ppos.Parse_pos.text_line]; List [Atom "text_char"; sexp_of_int ppos.Parse_pos.text_char]; List [ Atom "global_offset"; sexp_of_int ppos.Parse_pos.global_offset ]; List [Atom "buf_pos"; sexp_of_int ppos.Parse_pos.buf_pos]; ] ] | _ -> assert false) );( Of_string_conv_exn.E { Of_string_conv_exn. exc = Exit; sexp = Atom ""; sub_sexp = Atom ""; }, (function | Of_string_conv_exn.E osce -> List [ Atom "Sexplib.Sexp.Of_string_conv_exn.E"; List [ List [Atom "exc"; sexp_of_exn osce.Of_string_conv_exn.exc]; List [Atom "sexp"; osce.Of_string_conv_exn.sexp]; List [Atom "sub_sexp"; osce.Of_string_conv_exn.sub_sexp]; ] ] | _ -> assert false) );( Sexp.Annotated.Conv_exn ("", Exit), (function | Sexp.Annotated.Conv_exn (loc, exn) -> List [ Atom "Sexplib.Sexp.Annotated.Conv_exn"; Atom loc; sexp_of_exn exn; ] | _ -> assert false) ); ] sexplib-113.33.03/src/conv.mli000066400000000000000000000352301271035576100157440ustar00rootroot00000000000000(** Utility Module for S-expression Conversions *) open Bigarray (** Dummy definitions for "optional" options, lists, and for opaque types *) type sexp_bool = bool type 'a sexp_option = 'a option type 'a sexp_list = 'a list type 'a sexp_array = 'a array type 'a sexp_opaque = 'a (** {6 Type aliases} *) type bigstring = Sexp.bigstring type float32_vec = (float, float32_elt, fortran_layout) Array1.t type float64_vec = (float, float64_elt, fortran_layout) Array1.t type vec = float64_vec type float32_mat = (float, float32_elt, fortran_layout) Array2.t type float64_mat = (float, float64_elt, fortran_layout) Array2.t type mat = float64_mat (** {6 Conversion of OCaml-values to S-expressions} *) val default_string_of_float : (float -> string) ref (** [default_string_of_float] reference to the default function used to convert floats to strings. Initially set to [fun n -> sprintf "%.20G" n]. *) val write_old_option_format : bool 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 read_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]. *) (** 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 val sexp_of_unit : unit -> Sexp.t (** [sexp_of_unit ()] converts a value of type [unit] to an S-expression. *) val sexp_of_bool : bool -> Sexp.t (** [sexp_of_bool b] converts the value [x] of type [bool] to an S-expression. *) val sexp_of_string : string -> Sexp.t (** [sexp_of_bool str] converts the value [str] of type [string] to an S-expression. *) val sexp_of_char : char -> Sexp.t (** [sexp_of_char c] converts the value [c] of type [char] to an S-expression. *) val sexp_of_int : int -> Sexp.t (** [sexp_of_int n] converts the value [n] of type [int] to an S-expression. *) val sexp_of_float : float -> Sexp.t (** [sexp_of_float n] converts the value [n] of type [float] to an S-expression. *) val sexp_of_int32 : int32 -> Sexp.t (** [sexp_of_int32 n] converts the value [n] of type [int32] to an S-expression. *) val sexp_of_int64 : int64 -> Sexp.t (** [sexp_of_int64 n] converts the value [n] of type [int64] to an S-expression. *) val sexp_of_nativeint : nativeint -> Sexp.t (** [sexp_of_nativeint n] converts the value [n] of type [nativeint] to an S-expression. *) val sexp_of_ref : ('a -> Sexp.t) -> 'a ref -> 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_lazy_t : ('a -> Sexp.t) -> 'a lazy_t -> 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_option : ('a -> Sexp.t) -> 'a option -> 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_pair : ('a -> Sexp.t) -> ('b -> Sexp.t) -> 'a * 'b -> 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_triple : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> 'a * 'b * 'c -> 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_list : ('a -> Sexp.t) -> 'a list -> 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_array : ('a -> Sexp.t) -> 'a array -> 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_hashtbl : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) Hashtbl.t -> 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_bigstring : bigstring -> Sexp.t (** [sexp_of_bigstring bstr] converts a bigstring (character bigarray in C-layout) to an S-expression. *) val sexp_of_float32_vec : float32_vec -> Sexp.t (** [sexp_of_float32_vec vec] converts the one-dimensional bigarray [vec] of 32-bit floats in Fortran-layout to an S-expression. *) val sexp_of_float64_vec : float64_vec -> Sexp.t (** [sexp_of_float64_vec vec] converts the one-dimensional bigarray [vec] of 64-bit floats in Fortran-layout to an S-expression. *) val sexp_of_vec : vec -> Sexp.t (** [sexp_of_vec vec] same as {!Conv.sexp_of_float64_vec}. *) val sexp_of_float32_mat : float32_mat -> Sexp.t (** [sexp_of_float32_mat mat] converts the two-dimensional bigarray [mat] of 32-bit floats in Fortran-layout to an S-expression. *) val sexp_of_float64_mat : float64_mat -> Sexp.t (** [sexp_of_float64_mat mat] converts the two-dimensional bigarray [mat] of 64-bit floats in Fortran-layout to an S-expression. *) val sexp_of_mat : mat -> Sexp.t (** [sexp_of_mat mat] same as {!Conv.sexp_of_float64_mat}. *) val sexp_of_opaque : 'a -> 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_fun : ('a -> 'b) -> 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 string_of__of__sexp_of : ('a -> Sexp.t) -> 'a -> string (** [string_of__of__sexp_of conv x] converts the OCaml-value [x] to an S-expression represented as a string by using conversion function [conv]. *) (** {6 Conversion of S-expressions to OCaml-values} *) exception Of_sexp_error of exn * Sexp.t (** [Of_sexp_error (exn, sexp)] the exception raised when an S-expression could not be successfully converted to an OCaml-value. *) val record_check_extra_fields : bool ref (** [record_check_extra_fields] checks for extra (= unknown) fields in record S-expressions. *) val of_sexp_error : string -> Sexp.t -> 'a (** [of_sexp_error reason sexp] @raise Of_sexp_error (Failure reason, sexp). *) val of_sexp_error_exn : exn -> Sexp.t -> 'a (** [of_sexp_error exc sexp] @raise Of_sexp_error (exc, sexp). *) val unit_of_sexp : Sexp.t -> unit (** [unit_of_sexp sexp] converts S-expression [sexp] to a value of type [unit]. *) val bool_of_sexp : Sexp.t -> bool (** [bool_of_sexp sexp] converts S-expression [sexp] to a value of type [bool]. *) val string_of_sexp : Sexp.t -> string (** [string_of_sexp sexp] converts S-expression [sexp] to a value of type [string]. *) val char_of_sexp : Sexp.t -> char (** [char_of_sexp sexp] converts S-expression [sexp] to a value of type [char]. *) val int_of_sexp : Sexp.t -> int (** [int_of_sexp sexp] converts S-expression [sexp] to a value of type [int]. *) val float_of_sexp : Sexp.t -> float (** [float_of_sexp sexp] converts S-expression [sexp] to a value of type [float]. *) val int32_of_sexp : Sexp.t -> int32 (** [int32_of_sexp sexp] converts S-expression [sexp] to a value of type [int32]. *) val int64_of_sexp : Sexp.t -> int64 (** [int64_of_sexp sexp] converts S-expression [sexp] to a value of type [int64]. *) val nativeint_of_sexp : Sexp.t -> nativeint (** [nativeint_of_sexp sexp] converts S-expression [sexp] to a value of type [nativeint]. *) val ref_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a ref (** [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 lazy_t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a lazy_t (** [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 option_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a option (** [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 pair_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> 'a * 'b (** [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 triple_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> (Sexp.t -> 'c) -> Sexp.t -> 'a * 'b * 'c (** [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 list_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a list (** [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 array_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a array (** [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 hashtbl_of_sexp : (Sexp.t -> 'a) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) Hashtbl.t (** [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 bigstring_of_sexp : Sexp.t -> bigstring (** [bigstring_of_sexp sexp] converts S-expression [sexp] to a bigstring (character bigarray in C-layout). *) val float32_vec_of_sexp : Sexp.t -> float32_vec (** [float32_vec_of_sexp sexp] converts S-expression [sexp] to a one-dimensional bigarray of 32-bit floats in Fortran-layout. *) val float64_vec_of_sexp : Sexp.t -> float64_vec (** [float64_vec_of_sexp sexp] converts S-expression [sexp] to a one-dimensional bigarray of 64-bit floats in Fortran-layout. *) val vec_of_sexp : Sexp.t -> vec (** [vec_of_sexp sexp] same as {!float64_vec_of_sexp}. *) val float32_mat_of_sexp : Sexp.t -> float32_mat (** [float32_mat_of_sexp sexp] converts S-expression [sexp] to a two-dimensional bigarray of 32-bit floats in Fortran-layout. *) val float64_mat_of_sexp : Sexp.t -> float64_mat (** [float64_mat_of_sexp sexp] converts S-expression [sexp] to a two-dimensional bigarray of 64-bit floats in Fortran-layout. *) val mat_of_sexp : Sexp.t -> mat (** [mat_of_sexp sexp] same as {!Conv.float64_mat_of_sexp}. *) val opaque_of_sexp : Sexp.t -> 'a (** [opaque_of_sexp sexp] @raise Of_sexp_error when attempting to convert an S-expression to an opaque value. *) val fun_of_sexp : Sexp.t -> 'a (** [fun_of_sexp sexp] @raise Of_sexp_error when attempting to convert an S-expression to a function. *) val of_string__of__of_sexp : (Sexp.t -> 'a) -> string -> 'a (** [of_string__of__of_sexp conv str] converts the S-expression [str] represented as a string to an OCaml-value by using conversion function [conv]. *) (** Exception converters *) val sexp_of_exn : exn -> Sexp.t (** [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_opt : exn -> Sexp.t option (** [sexp_of_exn_opt exc] converts exception [exc] to [Some sexp]. If no suitable converter is found, [None] is returned instead. *) module Exn_converter : sig type t (** Type of handles for exception S-expression converters *) val set_max_exn_tags : int -> unit [@@ocaml.deprecated] val get_max_exn_tags : unit -> int [@@ocaml.deprecated] val add_auto : ?finalise : bool -> exn -> (exn -> Sexp.t) -> unit (** [add_auto ?finalise templ sexp_of_exn] registers exception S-expression converter [sexp_of_exn] for exceptions having same constructor as template [templ]. NOTE: if the exception belongs to a transient module, e.g. local modules (including functor instantiations), first-class modules, etc., a manually written [sexp_of_exn] must use [Obj.magic] internally to avoid matching or creating the exception, otherwise the handler can never be reclaimed once the exception ceases to exist. If [finalise] is [true], then the exception will be automatically registered for removal with the GC (default). Finalisation will not work with exceptions that have been allocated outside the heap, which is the case for some standard ones e.g. [Sys_error]. NOTE: Use with great caution, this function is primarily intended for automated use! If unsure, use [add_slow] instead. @param finalise default = [true] *) val add_slow : (exn -> Sexp.t option) -> t (** [add_slow sexp_of_exn] registers exception S-expression converter [sexp_of_exn] and returns a handle. Exception converters registered this way are much slower than with [add], but this function does not require an exception template. NOTE: if you call this function explicitly, or the "sexp"-macro for exceptions from within local modules, you will eventually have to unregister it manually with {!del}, otherwise there is a space leak! *) val del_slow : t -> unit (** [del_slow handle] unregisters exception S-expression converter with handle [handle]. In multi-threaded contexts it is not guaranteed that the unregistered converter will not be called after this function returns. *) end sexplib-113.33.03/src/conv_error.ml000066400000000000000000000071431271035576100170060ustar00rootroot00000000000000(* Conv_error: Module for Handling Errors during Automated S-expression Conversions *) open Printf open Conv (* 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: sum tag 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: sum tag must be a structured value") sexp let nested_list_invalid_sum loc sexp = of_sexp_error (loc ^ "_of_sexp: a nested list is an invalid sum") sexp let empty_list_invalid_sum loc sexp = of_sexp_error (loc ^ "_of_sexp: the empty list is an invalid sum") sexp let unexpected_stag loc sexp = of_sexp_error (loc ^ "_of_sexp: unexpected sum tag") sexp (* Errors concerning records *) 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) 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) | (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 of string * Sexp.t let no_variant_match loc sexp = raise (No_variant_match (loc ^ "_of_sexp", sexp)) let no_matching_variant_found loc sexp = of_sexp_error (loc ^ ": 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 silly_type loc sexp = of_sexp_error (loc ^ "_of_sexp: trying to convert a silly type") sexp let empty_type loc sexp = of_sexp_error (loc ^ "_of_sexp: trying to convert an empty type") sexp sexplib-113.33.03/src/exn_magic.ml000066400000000000000000000161301271035576100165560ustar00rootroot00000000000000let register exc exc_name = Conv.Exn_converter.add_auto exc (fun _exc -> Sexp.Atom exc_name) let magic_field repr n = Obj.magic (Obj.field repr n) let register1 make_exc exc_name sexp_of_arg1 = let exc = make_exc (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in Sexp.List [ Sexp.Atom exc_name; sexp1; ]) let register2 make_exc exc_name sexp_of_arg1 sexp_of_arg2 = let exc = make_exc (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; ]) let register3 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; ]) let register4 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; ]) let register5 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; ]) let register6 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 sexp_of_arg6 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in let sexp6 = sexp_of_arg6 (magic_field repr 6) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; sexp6; ]) let register7 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 sexp_of_arg6 sexp_of_arg7 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in let sexp6 = sexp_of_arg6 (magic_field repr 6) in let sexp7 = sexp_of_arg7 (magic_field repr 7) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; sexp6; sexp7; ]) let register8 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 sexp_of_arg6 sexp_of_arg7 sexp_of_arg8 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in let sexp6 = sexp_of_arg6 (magic_field repr 6) in let sexp7 = sexp_of_arg7 (magic_field repr 7) in let sexp8 = sexp_of_arg8 (magic_field repr 8) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; sexp6; sexp7; sexp8; ]) let register9 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 sexp_of_arg6 sexp_of_arg7 sexp_of_arg8 sexp_of_arg9 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in let sexp6 = sexp_of_arg6 (magic_field repr 6) in let sexp7 = sexp_of_arg7 (magic_field repr 7) in let sexp8 = sexp_of_arg8 (magic_field repr 8) in let sexp9 = sexp_of_arg9 (magic_field repr 9) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; sexp6; sexp7; sexp8; sexp9; ]) let register10 make_exc exc_name sexp_of_arg1 sexp_of_arg2 sexp_of_arg3 sexp_of_arg4 sexp_of_arg5 sexp_of_arg6 sexp_of_arg7 sexp_of_arg8 sexp_of_arg9 sexp_of_arg10 = let exc = make_exc (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) (Obj.magic None) in Conv.Exn_converter.add_auto exc (fun exc -> let repr = Obj.repr exc in let sexp1 = sexp_of_arg1 (magic_field repr 1) in let sexp2 = sexp_of_arg2 (magic_field repr 2) in let sexp3 = sexp_of_arg3 (magic_field repr 3) in let sexp4 = sexp_of_arg4 (magic_field repr 4) in let sexp5 = sexp_of_arg5 (magic_field repr 5) in let sexp6 = sexp_of_arg6 (magic_field repr 6) in let sexp7 = sexp_of_arg7 (magic_field repr 7) in let sexp8 = sexp_of_arg8 (magic_field repr 8) in let sexp9 = sexp_of_arg9 (magic_field repr 9) in let sexp10 = sexp_of_arg10 (magic_field repr 10) in Sexp.List [ Sexp.Atom exc_name; sexp1; sexp2; sexp3; sexp4; sexp5; sexp6; sexp7; sexp8; sexp9; sexp10; ]) sexplib-113.33.03/src/exn_magic.mli000066400000000000000000000036221271035576100167310ustar00rootroot00000000000000val register : exn -> string -> unit val register1 : ('a -> exn) -> string -> ('a -> Sexp.t) -> unit val register2 : ('a -> 'b -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> unit val register3 : ('a -> 'b -> 'c -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> unit val register4 : ('a -> 'b -> 'c -> 'd -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> unit val register5 : ('a -> 'b -> 'c -> 'd -> 'e -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> unit val register6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> ('f -> Sexp.t) -> unit val register7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> ('f -> Sexp.t) -> ('g -> Sexp.t) -> unit val register8 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> ('f -> Sexp.t) -> ('g -> Sexp.t) -> ('h -> Sexp.t) -> unit val register9 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> ('f -> Sexp.t) -> ('g -> Sexp.t) -> ('h -> Sexp.t) -> ('i -> Sexp.t) -> unit val register10 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> exn) -> string -> ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('c -> Sexp.t) -> ('d -> Sexp.t) -> ('e -> Sexp.t) -> ('f -> Sexp.t) -> ('g -> Sexp.t) -> ('h -> Sexp.t) -> ('i -> Sexp.t) -> ('j -> Sexp.t) -> unit sexplib-113.33.03/src/intro.txt000066400000000000000000000266041271035576100161750ustar00rootroot00000000000000@indexes {2 Modules} @all_modules {2 What is Sexplib?} This library contains functionality for parsing and pretty-printing S-expressions. In addition to that it contains a preprocessing module for Camlp4, which can be used to automatically generate code from type definitions for efficiently converting OCaml-values to S-expressions and vice versa. In combination with the parsing and pretty-printing functionality this frees users from having to write their own I/O-routines for datastructures they define. Possible errors during automatic conversions from S-expressions to OCaml-values are reported in human-readable ways with exact location information. Another module in this library allows you to extract and replace sub-expressions in S-expressions. {2 How can you use it?} Make sure you have installed the [type_conv] package on your system, too. It should be obtainable at the same site as [sexplib]. The API (.mli-files) in the [sexplib] library directory is fully documented. Module [Sexp] contains all I/O-functions for S-expressions, module [Conv] helper functions for converting OCaml-values of standard types to S-expressions. Module [Path] supports sub-expression extraction and substitution. Module [pa_sexp_conv.ml] contains the extensions for the Camlp4-preprocessor. It adds the new construct [with sexp] (and [with sexp_of] and [with of_sexp], which are implied by the first). When using this construct right after a type definition, function definitions will be generated automatically, which perform S-expression conversions. E.g. given the following type definition: @color{[type t = A | B with sexp]} The above will generate the functions [sexp_of_t] and [t_of_sexp]. The preprocessor also supports automatic addition of conversion functions to signatures. Just add [with sexp] to the type in a signature, and the appropriate function signatures will be generated. See the file [lib_test/conv_test.ml] for example usage. It also demonstrates how to extract and substitute sub-expressions. {2 Syntax Specification of S-expressions} {9 Lexical conventions of S-expression} Whitespace, which consists of space, newline, carriage return, horizontal tab and form feed, is ignored unless within an OCaml-string, where it is treated according to OCaml-conventions. The semicolon introduces comments. Comments are ignored, and range up to the next newline character. The left parenthesis opens a new list, the right parenthesis closes it again. Lists can be empty. The double quote denotes the beginning and end of a string following the lexical conventions of OCaml (see OCaml-manual for details). All characters other than double quotes, left- and right parentheses, and whitespace are considered part of a contiguous string. {9 Grammar of S-expressions} S-expressions are either strings (= atoms) or lists. The lists can recursively contain further S-expressions or be empty, and must be balanced, i.e. parentheses must match. {9 Examples} {[this_is_an_atom_123'&^%! ; this is a comment "another atom in an OCaml-string \"string in a string\" \123" ; empty list follows below () ; a more complex example ( ( list in a list ; comment within a list (list in a list in a list) 42 is the answer to all questions ) )]} {9 Conversion of basic OCaml-values} Basic OCaml-values like the unit-value, integers (in all representations), floats, strings, and booleans are represented in S-exp syntax in the same way as in OCaml. Strings may also appear without quotes if this does not clash with the lexical conventions for S-expressions. {9 Conversion of OCaml-tuples} OCaml-tuples are simple lists of values in the same order as in the tuple. E.g.: {[(3.14, "foo", "bar bla", 27) <===> (3.14 foo "bar bla" 27)]} {9 Conversion of OCaml-records} OCaml-records are represented as lists of pairs in S-expression syntax. Each pair consists of the name of the record field (first element), and its value (second element). E.g.: @color{[{ foo = 3; bar = "some string"; }]} [<===>] {[( (foo 3) (bar "some string") )]} Type specifications of records allow the use of a special type [sexp_option] which indicates that a record field should be optional. E.g.: @color{[type t = { x : int option; y : int sexp_option; }]} The type [sexp_option] is equivalent to ordinary options, but is treated specially by the code generator. The above would lead to the following equivalences of values and S-expressions: @color{[{ x = Some 1; y = Some 2; }]} [<===>] {[( (x (some 1)) (y 2) )]} And: @color{[{ x = None; y = None; }]} [<===>] {[( (x none) )]} Note how [sexp_option] allows you to leave away record fields that should default to [None]. It is also unnecessary (and actually wrong) now to write down such a value as an option, i.e. the [some]-tag must be dropped if the field should be defined. The types [sexp_list], [sexp_array], and [sexp_bool] can be used in ways similar to the type [sexp_option]. They assume the empty list, empty array, and false value respectively as default values. {9 Conversion of sum types} Constant constructors in sum types are represented as strings. Constructors with arguments are represented as lists, the first element being the constructor name, the rest being its arguments. Constructors may also be started in lowercase in S-expressions, but will always be converted to uppercase when converting from OCaml-values. For example: @color{[type t = A | B of int * float * t with sexp ]} {[B (42, 3.14, B (-1, 2.72, A)) <===> (B 42 3.14 (B -1 2.72 A))]} The above example also demonstrates recursion in datastructures. {9 Conversion of variant types} The conversion of polymorphic variants is almost the same as with sum types. The notable difference is that variant constructors must always start with an either lower- or uppercase character, matching the way it was specified in the type definition. This is because OCaml also distinguishes between upper- and lowercase variant constructors. Note that type specifications containing unions of variant types are also supported by the S-expression converter. {9 Conversion of OCaml-lists and arrays} OCaml-lists and arrays are straightforwardly represented as S-expression lists. {9 Conversion of option types} The option type is converted like ordinary polymorphic sum types, i.e.: {[None <===> none Some value <===> (some value)]} There is a deprecated version of the syntax in which values of option type are represented as lists in S-expressions: {[None <===> () Some value <===> (value)]} Reading of the old-style S-expression syntax for option values is only supported if the reference [Conv.read_old_option_format] is set to [true] (currently the default, which may change soon). A conversion exception is raised otherwise. The old format will be written only if [Conv.write_old_option_format] is true (also currently the default). Reading of the new format is always supported. {9 Conversion of polymorphic values} There is nothing special about polymorphic values as long as there are conversion functions for the type parameters. E.g.: @color{[type 'a t = A | B of 'a with sexp type foo = int t with sexp]} In the above case the conversion functions will behave as if [foo] had been defined as a monomorphic version of [t] with ['a] replaced by [int] on the right hand side. If a datastructure is indeed polymorphic, and you want to convert it, you will have to supply the conversion functions for the type parameters at runtime. E.g. in the above example, if you wanted to convert a value of type ['a t], you would have to write something like this: @color{[sexp_of_t sexp_of_a v]} where [sexp_of_a], which may also be named differently in this particular case, is a function that converts values of type ['a] to an S-expression. Types with more than one parameter require passing conversion functions for those parameters in the order of their appearance on the left hand side of the type definition. {9 Conversion of abstract datatypes} Of course, if you want to convert an abstract datatype to an S-expression, you will have to roll your own conversion function, which should produce values of type [Sexp.t] directly. If, however, you want to make use of your abstract type within definitions of other types, make sure that you call your conversion function appropriately: it should be in the same scope as the typename, and must be named [sexp_of_{typename}]. {9 Conversion of hashtables} Hashtables, which are abstract values in OCaml, are represented as association lists, i.e. lists of key-value pairs, e.g.: @color{[((foo 42) (bar 3))]} Reading in the above S-expression as hashtable mapping strings to integers ([(string, int) Hashtbl.t]) will map ["foo"] to 42 and ["bar"] to 3. Note that the order of elements in the list may matter, because duplicates are kept: bindings will be inserted into the hashtable in order of appearence. Therefore, the last binding of a key will be the ``visible'' one, the others are ``hidden''. See the OCaml-documentation on hashtables for details. Note, too, that polymorphic equality may not hold between conversions. You will have to use a function implementing logical equality for that purpose. {9 Conversion of opaque values} Opaque values are ones for which we do not want to perform conversions. This may be, because we do not have S-expression converters for them, or because we do not want to apply them in a particular type context, e.g. if the resulting S-expression should be printed out but without superfluous information. To prevent the preprocessor from generating calls to converters, simply apply the qualifier [sexp_opaque] as if it were a type constructor, e.g.: @color{[type foo = int * stuff sexp_opaque with sexp]} Thus, there is no need to specify converters for type [stuff], and if there are any, they will not be used in this particular context. Needless to say, it is not possible to convert such an S-expression back to the original value. Here is an example conversion: {[(42, some_stuff) ===> (42, )]} {9 Conversion of exceptions} S-expression converters for exceptions can be automatically registered using the [with sexp] macro, e.g.: @color{[module M = struct exception Foo of int with sexp end]} Such exceptions will be translated in a similar way as sum types, but their constructor will be prefixed with the fully qualified module path (here: [M.Foo]) so as to be able to discriminate between them without problems. The user can then easily convert an exception matching the above one to an S-expression using [Sexplib.Conv.sexp_of_exn]. User-defined conversion functions can be registered, too, by calling [Sexplib.Conv.add_exn_converter]. This should make it very convenient for users to catch arbitrary exceptions escaping their program and pretty-printing them, including all arguments, as S-expressions. The library already contains mappings for all known exceptions that can escape functions in the OCaml standard library. {2 I/O and type conversions} There are multiple ways of performing I/O with S-expressions. If exact error locations are required when type conversions fail, S-expressions need to be parsed with location annotations. In most cases users may want to use functions like e.g. [load_sexp_conv] or [load_sexp_conv_exn], which load S-expressions from files and convert them. Only when conversions fail, the file will be reparsed with annotations, which is slower, and type errors will be reported accurately with file, line number, column, and file position. sexplib-113.33.03/src/lexer.mli000066400000000000000000000002301271035576100161060ustar00rootroot00000000000000val main : ?buf:Buffer.t -> Lexing.lexbuf -> Parser.token val main_with_layout : ?buf:Buffer.t -> Lexing.lexbuf -> Parser_with_layout.token sexplib-113.33.03/src/lexer.mll000066400000000000000000000240411271035576100161170ustar00rootroot00000000000000{ (** Lexer: Lexer Specification for S-expressions *) open Printf open Lexing let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let lf = '\010' let dec_code c1 c2 c3 = 100 * (Char.code c1 - 48) + 10 * (Char.code c2 - 48) + (Char.code c3 - 48) let hex_code c1 c2 = let d1 = Char.code c1 in let val1 = if d1 >= 97 then d1 - 87 else if d1 >= 65 then d1 - 55 else d1 - 48 in let d2 = Char.code c2 in let val2 = if d2 >= 97 then d2 - 87 else if d2 >= 65 then d2 - 55 else d2 - 48 in val1 * 16 + val2 let found_newline ({ lex_curr_p; _ } as lexbuf) diff = lexbuf.lex_curr_p <- { lex_curr_p with pos_lnum = lex_curr_p.pos_lnum + 1; pos_bol = lex_curr_p.pos_cnum - diff; } (* same length computation as in [Lexing.lexeme] *) let lexeme_len { lex_start_pos; lex_curr_pos; _ } = lex_curr_pos - lex_start_pos let main_failure lexbuf msg = let { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } = lexeme_start_p lexbuf in let msg = sprintf "Sexplib.Lexer.main: %s at line %d char %d" msg pos_lnum (pos_cnum - pos_bol) in failwith msg module type T = sig module Quoted_string_buffer : sig type t val create : int -> t val add_char : t -> char -> unit val add_substring : t -> string -> int -> int -> unit val add_lexeme : t -> lexbuf -> unit val clear : t -> unit val of_buffer : Buffer.t -> t end module Token : sig type t val lparen : t val rparen : t val eof : t val simple_string : string -> t val hash_semi : t val quoted_string : Lexing.position -> Quoted_string_buffer.t -> t type s = Quoted_string_buffer.t -> Lexing.lexbuf -> t val comment : string -> main:s -> s val block_comment : Lexing.position -> main:s -> s end end module Make (X : T) : sig val main : ?buf:Buffer.t -> Lexing.lexbuf -> X.Token.t end = struct (* BEGIN FUNCTOR BODY CONTAINING GENERATED CODE *) open X } let lf = '\010' let lf_cr = ['\010' '\013'] let dos_newline = "\013\010" let blank = [' ' '\009' '\012'] let unquoted = [^ ';' '(' ')' '"'] # blank # lf_cr let digit = ['0'-'9'] let hexdigit = digit | ['a'-'f' 'A'-'F'] let unquoted_start = unquoted # ['#' '|'] | '#' unquoted # ['|'] | '|' unquoted # ['#'] rule main buf = parse | lf | dos_newline { found_newline lexbuf 0; main buf lexbuf } | blank+ { main buf lexbuf } | (';' (_ # lf_cr)*) as text { Token.comment text ~main buf lexbuf } | '(' { Token.lparen } | ')' { Token.rparen } | '"' { let pos = Lexing.lexeme_start_p lexbuf in Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf pos lexbuf; let tok = Token.quoted_string pos buf in Quoted_string_buffer.clear buf; tok } | "#;" { Token.hash_semi } | "#|" { let pos = Lexing.lexeme_start_p lexbuf in Quoted_string_buffer.add_lexeme buf lexbuf; scan_block_comment buf [pos] lexbuf; let tok = Token.block_comment pos ~main buf lexbuf in Quoted_string_buffer.clear buf; tok } | "|#" { main_failure lexbuf "illegal end of comment" } | "#" "#"+ "|" unquoted* (* unquoted_start can match ##, so ##| (which should be refused) would not not be parsed by this case if the regexp on the left was not there *) | "|" "|"+ "#" unquoted* | unquoted_start unquoted* ("#|" | "|#") unquoted* { main_failure lexbuf "comment tokens in unquoted atom" } | "#" | "|" | unquoted_start unquoted* as str { Token.simple_string str } | eof { Token.eof } and scan_string buf start = parse | '"' { Quoted_string_buffer.add_lexeme buf lexbuf; () } | '\\' lf [' ' '\t']* { let len = lexeme_len lexbuf - 2 in found_newline lexbuf len; Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | '\\' dos_newline [' ' '\t']* { let len = lexeme_len lexbuf - 3 in found_newline lexbuf len; Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | '\\' (['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as c) { Quoted_string_buffer.add_char buf (char_for_backslash c); Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | '\\' (digit as c1) (digit as c2) (digit as c3) { let v = dec_code c1 c2 c3 in if v > 255 then ( let { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } = lexeme_end_p lexbuf in let msg = sprintf "Sexplib.Lexer.scan_string: \ illegal escape at line %d char %d: `\\%c%c%c'" pos_lnum (pos_cnum - pos_bol - 3) c1 c2 c3 in failwith msg); Quoted_string_buffer.add_char buf (Char.chr v); Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | '\\' 'x' (hexdigit as c1) (hexdigit as c2) { let v = hex_code c1 c2 in Quoted_string_buffer.add_char buf (Char.chr v); Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | '\\' (_ as c) { Quoted_string_buffer.add_char buf '\\'; Quoted_string_buffer.add_char buf c; Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | lf { found_newline lexbuf 0; Quoted_string_buffer.add_char buf lf; Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | ([^ '\\' '"'] # lf)+ { let ofs = lexbuf.lex_start_pos in let len = lexbuf.lex_curr_pos - ofs in Quoted_string_buffer.add_substring buf lexbuf.lex_buffer ofs len; Quoted_string_buffer.add_lexeme buf lexbuf; scan_string buf start lexbuf } | eof { let msg = sprintf "Sexplib.Lexer.scan_string: unterminated string at line %d char %d" start.pos_lnum (start.pos_cnum - start.pos_bol) in failwith msg } and scan_block_comment buf locs = parse | ('#'* | '|'*) lf { Quoted_string_buffer.add_lexeme buf lexbuf; found_newline lexbuf 0; scan_block_comment buf locs lexbuf } | (('#'* | '|'*) [^ '"' '#' '|'] # lf)+ { Quoted_string_buffer.add_lexeme buf lexbuf; scan_block_comment buf locs lexbuf } | ('#'* | '|'*) '"' { Quoted_string_buffer.add_lexeme buf lexbuf; let cur = lexeme_end_p lexbuf in let start = { cur with pos_cnum = cur.pos_cnum - 1 } in scan_string buf start lexbuf; scan_block_comment buf locs lexbuf } | '#'+ '|' { Quoted_string_buffer.add_lexeme buf lexbuf; let cur = lexeme_end_p lexbuf in let start = { cur with pos_cnum = cur.pos_cnum - 2 } in scan_block_comment buf (start :: locs) lexbuf } | '|'+ '#' { Quoted_string_buffer.add_lexeme buf lexbuf; match locs with | [_] -> () (* the comment is finished *) | _ :: (_ :: _ as t) -> scan_block_comment buf t lexbuf | [] -> assert false (* impossible *) } | eof { match locs with | [] -> assert false | { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } :: _ -> let msg = sprintf "Sexplib.Lexer.scan_block_comment: \ unterminated block comment at line %d char %d" pos_lnum (pos_cnum - pos_bol) in failwith msg } { (* RESUME FUNCTOR BODY CONTAINING GENERATED CODE *) let main ?buf = let buf = match buf with | None -> Quoted_string_buffer.create 64 | Some buf -> Buffer.clear buf; Quoted_string_buffer.of_buffer buf in main buf end (* END FUNCTOR BODY CONTAINING GENERATED CODE *) module Vanilla = Make (struct module Quoted_string_buffer = struct include Buffer let add_lexeme _ _ = () let of_buffer b = b end module Token = struct open Parser type t = token type s = Quoted_string_buffer.t -> Lexing.lexbuf -> t let eof = EOF let lparen = LPAREN let rparen = RPAREN let hash_semi = HASH_SEMI let simple_string x = STRING x let quoted_string _ buf = STRING (Buffer.contents buf) let block_comment _pos ~main buf lexbuf = main buf lexbuf let comment _text ~main buf lexbuf = main buf lexbuf (* skip and continue lexing *) end end) module With_layout = Make (struct module Quoted_string_buffer = struct type t = { contents : Buffer.t; lexeme : Buffer.t; } let create n = {contents = Buffer.create n; lexeme = Buffer.create n} let of_buffer contents = { contents; lexeme = Buffer.create 64 } let add_char t ch = Buffer.add_char t.contents ch let add_substring t str ofs len = Buffer.add_substring t.contents str ofs len let add_lexeme t lexbuf = Buffer.add_string t.lexeme (Lexing.lexeme lexbuf) let clear t = Buffer.clear t.lexeme; Buffer.clear t.contents end module Token = struct open Parser_with_layout type t = token type s = Quoted_string_buffer.t -> Lexing.lexbuf -> t let eof = EOF let lparen = LPAREN let rparen = RPAREN let hash_semi = HASH_SEMI let simple_string x = STRING (x, None) let quoted_string pos {Quoted_string_buffer.contents; lexeme} = STRING (Buffer.contents contents, Some (pos, Buffer.contents lexeme)) let block_comment pos ~main:_ {Quoted_string_buffer.contents = _; lexeme} _lexbuf = COMMENT (Buffer.contents lexeme, Some pos) let comment text ~main:_ _buf _lexbuf = COMMENT (text, None) end end) let main = Vanilla.main let main_with_layout = With_layout.main } sexplib-113.33.03/src/macro.ml000066400000000000000000000372051271035576100157330ustar00rootroot00000000000000open Format exception Include_loop_detected of string exception Of_sexp_error = Pre_sexp.Of_sexp_error exception Macro_conv_error of exn * Sexp.t * [`expanded of Sexp.t] let () = let open Sexp in Conv.Exn_converter.add_auto ~finalise:false (Macro_conv_error (Failure "", List [], `expanded (List []))) (function | Macro_conv_error (exn, unexpanded, `expanded expanded) -> List [Atom "Sexplib.Macro.Macro_conv_error"; List [Conv.sexp_of_exn exn; unexpanded; List [Atom "expanded"; expanded]]] | _ -> assert false) let macro_error err t = Of_sexp_error (Failure (sprintf "Error evaluating macros: %s" err), t) type 'a conv = [ `Result of 'a | `Error of exn * Sexp.t ] type 'a annot_conv = (* 'a Sexp.Annotated.conv = *) [ `Result of 'a | `Error of exn * Sexp.Annotated.t ] module List = struct (* Think about tail recursion when adding more list functions in here. *) let length = List.length let fold_left = List.fold_left let mem = List.mem let assq = List.assq let iter x ~f = List.iter f x let rev_append = List.rev_append let rev = List.rev let assoc = List.assoc let map l ~f = let rec aux acc = function | [] -> List.rev acc | hd :: tl -> aux ((f hd) :: acc) tl in aux [] l let concat_map l ~f = let rec aux acc = function | [] -> List.rev acc | hd :: tl -> aux (List.rev_append (f hd) acc) tl in aux [] l let rec find_map ~f xs = match xs with | [] -> None | x :: xs -> match f x with | Some x -> Some x | None -> find_map ~f xs let exists ~f xs = List.exists f xs let rec find_a_dup = function | [] -> None | x :: xs -> if List.mem x xs then Some x else find_a_dup xs end let (@) = `redefine_a_tail_rec_append_if_you_need_it let _ = (@) module Vars = struct include Set.Make (String) let add_list set xs = List.fold_left (fun vars v -> add v vars) set xs let of_list xs = add_list empty xs end (* Map from template names to template argument lists and bodies. The argument lists are not necessary for the formal evaluation rules, but are useful to catch errors early. *) module Bindings = Map.Make (String) (* A physical association list mapping sexps after :include are inlined to sexps that they originate from. This map allows us to recover the original sexp that gave rise to an error and to give a precise error location. *) type trail = (Sexp.t * Sexp.t) list let rec find_arg result trail = try find_arg (List.assq result trail) trail with Not_found -> result let atom = function | Sexp.Atom str -> str | Sexp.List _ as t -> raise (macro_error "Atom expected" t) let atoms = function | Sexp.Atom _ as t -> raise (macro_error "Atom list expected" t) | Sexp.List ts -> List.map ~f:atom ts (* If [~raise_if_any:true], raise an error if a free variable is encountered. *) let free_variables_gen ~raise_if_any ts = (* Tail-recursive w.r.t the number of sexps in a list, but not sexp depth. *) let rec free_in_list bound ts acc = match ts with | Sexp.List (Sexp.Atom ":let" :: v :: vs :: def) :: ts -> let acc = free_in_list (Vars.add_list bound (atoms vs)) def acc in free_in_list (Vars.add (atom v) bound) ts acc | t :: ts -> let acc = free bound t acc in free_in_list bound ts acc | [] -> acc and free bound t acc = match t with | Sexp.List (Sexp.Atom ":use" :: v :: args) -> let acc = if Vars.mem (atom v) bound then acc else if raise_if_any then let msg = "Undefined variable (included files cannot reference variables from outside)" in raise (macro_error msg v) else Vars.add (atom v) acc in List.fold_left (fun acc t -> free bound t acc) acc args | Sexp.List ts -> free_in_list bound ts acc | Sexp.Atom _ -> acc in free_in_list Vars.empty ts Vars.empty let check_no_free_variables ts = ignore (free_variables_gen ~raise_if_any:true ts) let free_variables ts = free_variables_gen ~raise_if_any:false ts let expand_local_macros_exn ~trail ts = let add_result = match trail with | None -> fun ~arg:_ ~result:_ -> () | Some ref -> fun ~arg ~result -> ref := (result, arg) :: !ref in (* tail-recursive *) let rec expand_list defs ts acc = match ts with | Sexp.List (Sexp.Atom ":let" :: v :: args :: def) as t :: ts -> if def = [] then raise (macro_error "Empty let bodies not allowed" t); let v = atom v in let args = atoms args in let free = free_variables def in let args_set = Vars.of_list args in let unused = Vars.diff args_set free in if not (Vars.is_empty unused) then raise (macro_error (sprintf "Unused variables: %s" (String.concat ", " (Vars.elements unused))) t); let undeclared = Vars.diff free args_set in if not (Vars.is_empty undeclared) then raise (macro_error (sprintf "Undeclared arguments in let: %s" (String.concat ", " (Vars.elements undeclared))) t); begin match List.find_a_dup args with | None -> () | Some dup -> raise (macro_error (sprintf "Duplicated let argument: %s" dup) t) end; expand_list (Bindings.add v (args, def) defs) ts acc | t :: ts -> expand_list defs ts (List.rev_append (expand defs t) acc) | [] -> List.rev acc and expand defs t = match t with | Sexp.Atom (":use" | ":let" | ":include" | ":concat" as s) -> raise (macro_error ("Unexpected " ^ s) t) | Sexp.Atom _ as t -> [t] | Sexp.List (Sexp.Atom ":use" :: v :: args) -> let split_arg = function | Sexp.List (Sexp.Atom v :: def) -> v, def | arg -> raise (macro_error "Malformed argument" arg) in let evaluate_and_bind arg_defs (v, def) = (* It is important we evaluate with respect to defs here, to avoid one argument shadowing the next one. *) let def = expand_list defs def [] in Bindings.add v ([], def) arg_defs in let formal_args, body = try Bindings.find (atom v) defs with Not_found -> raise (macro_error "Undefined variable" v) in let args = List.map ~f:split_arg args in let arg_names = List.map ~f:(fun (v, _) -> v) args in if arg_names <> formal_args then raise (macro_error (sprintf ("Formal args of %s differ from supplied args," ^^ " formal args are [%s]") (atom v) (String.concat ", " formal_args)) t); let defs = List.fold_left evaluate_and_bind Bindings.empty args in expand_list defs body [] | Sexp.List (Sexp.Atom ":concat" :: ts) as t -> let ts = expand_list defs ts [] in let ts = try List.map ~f:atom ts with _ -> let error = let appl = Sexp.List (Sexp.Atom ":concat" :: ts) in sprintf "Malformed concat application: %s" (Sexp.to_string appl) in raise (macro_error error t) in let result = Sexp.Atom (String.concat "" ts) in add_result ~arg:t ~result; [result] | Sexp.List ts -> let ts = expand_list defs ts [] in let result = Sexp.List ts in add_result ~arg:t ~result; [result] in expand_list Bindings.empty ts [] let expand_local_macros ts = try `Result (expand_local_macros_exn ts ~trail:None) with Of_sexp_error (e, t) -> `Error (e, t) module type Sexp_loader = sig module Monad : sig type 'a t val return : 'a -> 'a t module Monad_infix : sig val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t end module List : sig val iter : 'a list -> f:('a -> unit t) -> unit t val map : 'a list -> f:('a -> 'b t) -> 'b list t end end val load_sexps : string -> Sexp.t list Monad.t val load_annotated_sexps : string -> Sexp.Annotated.t list Monad.t end module Loader (S : Sexp_loader) = struct module M = S.Monad open M.Monad_infix type 'a file_contents = (string * 'a) list type mode = [ `Fast of Sexp.t list file_contents | `Find_error of Sexp.Annotated.t list file_contents ] let make_absolute_path ~with_respect_to file = if Filename.is_relative file then Filename.concat (Filename.dirname with_respect_to) file else file let load_all_includes file : Sexp.t list file_contents M.t = let file_contents = ref [] in let rec load visited file = if List.mem file visited then raise (Include_loop_detected file); if List.mem file (List.map ~f:fst !file_contents) then M.return () else begin S.load_sexps file >>= fun ts -> file_contents := (file, ts) :: !file_contents; M.List.iter ts ~f:(load_includes (file :: visited) file) end and load_includes visited file = function | Sexp.List [Sexp.Atom ":include"; Sexp.Atom include_file] -> let include_file = make_absolute_path ~with_respect_to:file include_file in load visited include_file | Sexp.List ts -> M.List.iter ts ~f:(load_includes visited file) | Sexp.Atom _ -> M.return () in load [] file >>= fun () -> M.return !file_contents let load_all_annotated_includes file_contents : Sexp.Annotated.t list file_contents M.t = M.List.map file_contents ~f:(fun (file, _) -> S.load_annotated_sexps file >>= fun ts -> M.return (file, ts)) let find_annotated bad_sexp annot_file_contents = List.find_map annot_file_contents ~f:(fun (file, annot_sexps) -> List.find_map annot_sexps ~f:(fun annot_sexp -> match Sexp.Annotated.find_sexp annot_sexp bad_sexp with | None -> None | Some annot_sexp -> Some (file, annot_sexp))) (* This function has to compute a transformation trail even though all of the returned errors are of the form [Of_sexp_error (_, t)] where [t] is a physical subexpression of the input, in the event where an error happens not during macro expansion but during conversion to ocaml values. *) let expand_and_convert ~multiple (mode : mode) file f = let trail = ref ([] : trail) in let add_result ~arg ~result = match mode with | `Fast _ -> () | `Find_error _ -> trail := (result, arg) :: !trail in let file_contents = match mode with | `Fast file_contents -> file_contents | `Find_error annot_file_contents -> List.map ~f:(fun (file, annot_sexps) -> (file, List.map ~f:Sexp.Annotated.get_sexp annot_sexps)) annot_file_contents in let rec inline_includes current_file = function | Sexp.Atom _ as t -> [t] (* We expand an :include in list context, because that corresponds to the naive string substitution semantics. *) | Sexp.List [Sexp.Atom ":include"; Sexp.Atom include_file] -> load_and_inline (make_absolute_path ~with_respect_to:current_file include_file) | Sexp.List ts as t -> let ts = List.concat_map ts ~f:(inline_includes current_file) in let t' = Sexp.List ts in add_result ~arg:t ~result:t'; [t'] and load_and_inline file = (* The lookup always succeeds, because [file_contents] is a result of [load_all_includes]. *) let ts = List.concat_map (List.assoc file file_contents) ~f:(inline_includes file) in (* This checks that, after expanding the includes of file1, file1 doesn't have any free variables. So if file1 is included in file2, it won't use any of the variable of file2 in scope where file1 is included. However, the inclusion of file1 may shadow variables from file2. *) check_no_free_variables ts; ts in let map_results ts ~f = if multiple then List.map ~f ts else match ts with | [t]-> [f t] | ts -> failwith (sprintf "wrong number of sexps in %s, expecting 1, got %d" file (List.length ts)) in match mode with | `Fast _ -> let ts = expand_local_macros_exn ~trail:None (load_and_inline file) in map_results ts ~f:(fun t -> `Result (f t)) | `Find_error annot_file_contents -> let locate_error f = try `Result (f ()) with Of_sexp_error (exc, bad_sexp) as e -> (* Find the original sexp that caused the error. *) let unexpanded_bad_sexp = find_arg bad_sexp !trail in match find_annotated unexpanded_bad_sexp annot_file_contents with | Some (file, unexpanded_bad_annot_sexp) -> let exc = match Sexp.Annotated.get_conv_exn ~file ~exc unexpanded_bad_annot_sexp with | Of_sexp_error (inner_exc, unexpanded_bad_sexp) as exc -> if bad_sexp = unexpanded_bad_sexp then exc else Macro_conv_error (inner_exc, unexpanded_bad_sexp, `expanded bad_sexp) | exc -> exc in `Error (exc, unexpanded_bad_annot_sexp) (* This case should never happen. *) | None -> raise e in let inline_and_expand () = expand_local_macros_exn ~trail:(Some trail) (load_and_inline file) in match locate_error inline_and_expand with | `Error _ as e -> [e] | `Result ts -> map_results ts ~f:(fun t -> locate_error (fun () -> f t)) let load ~multiple file f = load_all_includes file >>= fun file_contents -> try M.return (expand_and_convert ~multiple (`Fast file_contents) file f) with Of_sexp_error _ as original_exn -> begin load_all_annotated_includes file_contents >>= fun annotated_file_contents -> let result = (expand_and_convert ~multiple (`Find_error annotated_file_contents) file f) in if List.exists result ~f:(function | `Result _ -> false | `Error _ -> true) then M.return result else (* Avoid returning success in the case there was an error. This can be bad e.g. when reading the input from a pipe. *) raise original_exn end let load_sexps_conv file f = load ~multiple:true file f let load_sexp_conv file f = load ~multiple:false file f >>= function | [a] -> M.return a | _ -> assert false end exception Error_in_file of string * exn let () = Conv.Exn_converter.add_auto ~finalise:false (Error_in_file ("foo", Exit)) (function | Error_in_file (file, exn) -> Sexp.List [Sexp.Atom ("Error in file " ^ file); Conv.sexp_of_exn exn] | _ -> assert false) let add_error_location file = function | Sexp.Parse_error e -> let err_msg = sprintf "%s: %s" file e.Sexp.err_msg in Sexp.Parse_error { e with Sexp.err_msg } | Failure e -> Failure (sprintf "%s: %s" file e) | error -> Error_in_file (file, error) module Simple_sexp_loader = struct module Monad = struct type 'a t = 'a let return a = a module Monad_infix = struct let ( >>= ) a f = f a end module List = List end let load_sexps file = try Sexp.load_sexps file with e -> raise (add_error_location file e) let load_annotated_sexps file = try Sexp.Annotated.load_sexps file with e -> raise (add_error_location file e) end module Simple_loader = Loader (Simple_sexp_loader) let id a = a let load_sexp_conv = Simple_loader.load_sexp_conv let load_sexp_conv_exn file f = match load_sexp_conv file f with | `Result a -> a | `Error (exn, _) -> raise exn let load_sexp file = load_sexp_conv_exn file id let load_sexps_conv = Simple_loader.load_sexps_conv let load_sexps_conv_exn file f = let results = load_sexps_conv file f in List.map results ~f:(function | `Error (exn, _) -> raise exn | `Result a -> a) let load_sexps file = load_sexps_conv_exn file id sexplib-113.33.03/src/macro.mli000066400000000000000000000150211271035576100160740ustar00rootroot00000000000000(** Support for variable expansion and templates within s-expressions. The functions in this module evaluate the following constructs within s-expressions: {ul {- [(:include filename)] is replaced with the list of s-expressions contained in [filename], as if the contents of [filename] were directly inserted in place of [(:include filename)]. A relative [filename] is taken with respect to the file that contains the include macro.} {- [(:let v (v1 ... vn) S1 ... Sm)] defines a template [v] with arguments [v1, ..., vn] and body [S1 ... Sm]. The definition itself is removed from the input. The variables [v1, ..., vn] must be exactly the free variables of [S1, ..., Sm] (see below for the meaning of "free variable"). In particular, since a macro argument cannot be a function, a let body cannot call a macro that is defined elsewhere, only a macro that is defined in the body itself. However if you want to use the same macro inside two macros, it is still possible to define it in a separate file and include it in both macros. The list [S1 ... Sm] may not be empty.} {- [(:use v (v1 SS1) ... (vn SSn))] expands to the body of the template [v] with lists of s-expressions [SS1, ..., SSn] substituted for the arguments [v1, ..., vn] of [v].} {- [(:concat S1 ... Sn)] evaluates [S1 ... Sn] to atoms [C1, ..., Cn] when possible and is replaced by the string concatenation [C1 | ... | Cn].}} Macros other than [:include] will be called 'local'. All [:include] macros are resolved before all the local macros, which means that included file names cannot contain variables. The occurrence of variable [v] in [(:use v ...)] can be either free or bound, depending on the surrounding sexp. The occurrence is free iff it it's not bound, and it's bound iff one of the following two conditions apply: {ol {- All occurrences of [v1], ..., [vn] in the body of [(:let v (v1 ... vn) S1 ... Sm)] are bound.} {- All occurrences of [v] from the appearance of [(:let v (v1 ... vn) S1 ... Sm)] to the end of the sexp nesting level are bound.}} Trying to [:use] an unbound variable is an error. Neither the top level file nor any of the included files may contain unbound variables. The [load...] functions of this module mirror the corresponding functions of the [Sexp] module except that they expand the macros in the loaded file and may throw additional exceptions. Example ------- Assume that [input.sexp] contains {[ (:include defs.sexp) (:include template.sexp) (:use f (a (:use a)) (b (:use b))) ]} the file [defs.sexp] contains {[ (:let a () hello) (:let b () " world") ]} and the file [template.sexp] contains {[ (:let f (a b) (:concat (:use a) (:use b))) ]} Then [load_sexp "input.sexp"] will return "hello world". Formal Evaluation Rules ----------------------- In the following [v] denotes a variable (an atom), [S] denotes a sexp, and [SS] denotes a list of sexps. Given a map [V] we write [V(v ~> a)] to update the map. Evaluation rules are of the form [V : SS => SS'] where [V] is a set of bindings of the form [v ~> SSv], each binding defining a template [v] with body [SSv]. First some boilerplate rules: a sexp without macros evaluates to itself: {[ V : => V : S => SS1 V : SS => SS2 ------------------- V : S SS => SS1 SS2 C is an atom ------------ V : C => C V : SS => SS' ----------------- V : (SS) => (SS') ]} Now the interesting rules. {[ free_vars(SSv) = {v1, ..., vn} V(v ~> SSv) : SS => SS' -------------------------------------- V : (:let v (v1 ... vn) SSv) SS => SS' V(v) = SS V : SSi => SSi' for each i V(v1 ~> SS1', ..., vn ~> SSn') : SS => SS' ------------------------------------------ V : (:use v (v1 SS1) ... (vn SSn)) => SS' v not defined in V ----------------------- V : (:use v ...) => _|_ V : Si => Ci Each Ci is an atom ------------------------------------------------------- V : (:concat S1 ... Sn) => String.concat [C1; ...; Cn] ]} As follows from the let-rule, let definitions may only refer to the variables explicitly mentioned in the argument list. This avoids the complexities of variable capture and allows us to forego closure building. *) type 'a conv = [ `Result of 'a | `Error of exn * Sexp.t ] type 'a annot_conv = ([ `Result of 'a | `Error of exn * Sexp.Annotated.t ] as 'body) constraint 'body = 'a Sexp.Annotated.conv val load_sexp : string -> Sexp.t (** [load_sexp file] like [{!Sexp.load_sexp} file], but resolves the macros contained in [file]. *) val load_sexps : string -> Sexp.t list (** [load_sexps file] like [{!Sexp.load_sexps} file], but resolves the macros contained in [file]. *) val load_sexp_conv : string -> (Sexp.t -> 'a) -> 'a annot_conv (** [load_sexp_conv file f] uses {!load_sexp} and converts the result using [f]. *) val load_sexps_conv : string -> (Sexp.t -> 'a) -> 'a annot_conv list (** [load_sexps_conv file f] uses {!load_sexps} and converts the result using [f]. *) val load_sexp_conv_exn : string -> (Sexp.t -> 'a) -> 'a (** [load_sexp_conv_exn file f] like {!load_sexp_conv}, but raises an exception in case of conversion error. *) val load_sexps_conv_exn : string -> (Sexp.t -> 'a) -> 'a list (** [load_sexps_conv_exn file f] like {!load_sexps_conv}, but raises an exception in case of conversion error. *) val expand_local_macros : Sexp.t list -> Sexp.t list conv (** [expand_local_macros sexps] takes a list of sexps and performs macro-expansion on them, except that an error will be returned if an :include macro is found. *) (** A version of [load_sexps] that is functorized with respect to the functions that load the sexps from files and the corresponding monad. *) module type Sexp_loader = sig module Monad : sig type 'a t val return : 'a -> 'a t module Monad_infix : sig val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t end module List : sig val iter : 'a list -> f:('a -> unit t) -> unit t val map : 'a list -> f:('a -> 'b t) -> 'b list t end end val load_sexps : string -> Sexp.t list Monad.t val load_annotated_sexps : string -> Sexp.Annotated.t list Monad.t end module Loader (S : Sexp_loader) : sig val load_sexp_conv : string -> (Sexp.t -> 'a) -> 'a annot_conv S.Monad.t val load_sexps_conv : string -> (Sexp.t -> 'a) -> 'a annot_conv list S.Monad.t end val add_error_location : string -> exn -> exn sexplib-113.33.03/src/parser.mly000066400000000000000000000026131271035576100163120ustar00rootroot00000000000000%{ (* Parser: Grammar Specification for Parsing S-expressions *) open Lexing let parse_failure what = let pos = Parsing.symbol_start_pos () in let msg = Printf.sprintf "Sexplib.Parser: failed to parse line %d char %d: %s" pos.pos_lnum (pos.pos_cnum - pos.pos_bol) what in failwith msg %} %token STRING %token LPAREN RPAREN EOF HASH_SEMI %start sexp %type sexp %start sexp_opt %type sexp_opt %start sexps %type sexps %start rev_sexps %type rev_sexps %% sexp: | sexp_comments sexp_but_no_comment { $2 } | sexp_but_no_comment { $1 } sexp_but_no_comment : STRING { Type.Atom $1 } | LPAREN RPAREN { Type.List [] } | LPAREN rev_sexps_aux RPAREN { Type.List (List.rev $2) } | error { parse_failure "sexp" } sexp_comment : HASH_SEMI sexp_but_no_comment { () } | HASH_SEMI sexp_comments sexp_but_no_comment { () } sexp_comments : sexp_comment { () } | sexp_comments sexp_comment { () } sexp_opt : sexp_but_no_comment { Some $1 } | sexp_comments sexp_but_no_comment { Some $2 } | EOF { None } | sexp_comments EOF { None } rev_sexps_aux : sexp_but_no_comment { [$1] } | sexp_comment { [] } | rev_sexps_aux sexp_but_no_comment { $2 :: $1 } | rev_sexps_aux sexp_comment { $1 } rev_sexps : rev_sexps_aux EOF { $1 } | EOF { [] } sexps : rev_sexps_aux EOF { List.rev $1 } | EOF { [] } sexplib-113.33.03/src/parser_with_layout.mly000066400000000000000000000051101271035576100207350ustar00rootroot00000000000000%{ (* Parser: Grammar Specification for Parsing S-expressions *) (* compare to parser.mly *) open Lexing let parse_failure what = let pos = Parsing.symbol_start_pos () in let msg = Printf.sprintf "Sexplib.Parser: failed to parse line %d char %d: %s" pos.pos_lnum (pos.pos_cnum - pos.pos_bol) what in failwith msg module With_pos = struct open Type_with_layout.Parsed let coerce = Src_pos.Absolute.of_lexing let start_pos () = coerce (Parsing.symbol_start_pos ()) let end_pos () = let p = Parsing.symbol_end_pos () in coerce { p with Lexing.pos_cnum = p.Lexing.pos_cnum - 1 } let atom (x, y) = let (pos, y) = match y with | None -> (start_pos (), None) | Some (pos, x) -> (coerce pos, Some x) in Atom (pos, x, y) let list ts = List (start_pos (), ts, end_pos ()) let sexp x = Sexp x let comment x = Comment x let sexp_comment cs t = Sexp_comment (start_pos (), cs, t) let plain_comment (x, pos_opt) = let pos = match pos_opt with | None -> start_pos () | Some pos -> coerce pos in Plain_comment (pos, x) end %} %token STRING %token COMMENT %token LPAREN RPAREN EOF HASH_SEMI %start sexp %type sexp %start sexp_opt %type sexp_opt %start sexps %type sexps %start sexps_abs %type sexps_abs %start rev_sexps %type rev_sexps %% sexp_but_no_comment_abs : STRING { With_pos.atom $1 } | LPAREN rev_sexps_abs RPAREN { With_pos.list (List.rev $2) } | error { parse_failure "sexp" } comment_abs : COMMENT { With_pos.plain_comment $1 } | HASH_SEMI rev_comments_abs sexp_but_no_comment_abs { With_pos.sexp_comment (List.rev $2) $3 } rev_comments_abs : /* nothing */ { [] } | rev_comments_abs comment_abs { $2 :: $1 } sexp_abs : sexp_but_no_comment_abs { With_pos.sexp $1 } | comment_abs { With_pos.comment $1 } rev_sexps_abs : /* empty */ { [] } | rev_sexps_abs sexp_abs { $2 :: $1 } sexp : sexp_abs { Type_with_layout.relativize $1 } sexp_opt : sexp { Some $1 } | EOF { None } rev_sexps_aux : sexp { [$1] } | rev_sexps_aux sexp { $2 :: $1 } rev_sexps : rev_sexps_aux EOF { $1 } | EOF { [] } sexps : rev_sexps_aux EOF { List.rev $1 } | EOF { [] } /* for debugging positions */ sexps_abs : rev_sexps_abs EOF { List.rev $1 } sexplib-113.33.03/src/path.ml000066400000000000000000000126601271035576100155640ustar00rootroot00000000000000(* Path: Module for Substitutions within S-expressions *) open Format open Sexp module String = Bytes type el = Pos of int | Match of string * int | Rec of string type t = el list let illegal_atom loc sexp = failwith (sprintf "Path.%s: illegal atom: %s" loc (Sexp.to_string sexp)) let extract_pos_lst loc sexp ix lst = let rec loop acc n = function | [] -> let sexp_str = Sexp.to_string sexp in failwith ( sprintf "Path.%s: illegal index %d in: %s" loc ix sexp_str) | h :: t -> if n = 0 then let subst = function | None -> List.rev_append acc t | Some x -> List.rev_append acc (x :: t) in subst, h else loop (h :: acc) (n - 1) t in loop [] ix lst let extract_pos n = function | List lst as sexp -> let subst, el = extract_pos_lst "extract_pos" sexp n lst in (fun x -> List (subst x)), el | Atom _ as sexp -> illegal_atom "extract_pos" sexp let extract_match tag arg_ix = function | List (Atom str as sexp :: args) when str = tag -> let subst, el = extract_pos_lst "extract_match" (List args) arg_ix args in (fun maybe_x -> List (sexp :: subst maybe_x)), el | List _ as sexp -> let sexp_str = Sexp.to_string sexp in failwith ("Path.extract_match: unexpected nested list in: " ^ sexp_str) | Atom _ as sexp -> illegal_atom "extract_match" sexp let extract_rec key = function | List lst as sexp -> let rec loop acc = function | [] -> let sexp_str = Sexp.to_string sexp in failwith ( sprintf "Path.extract_rec: key \"%s\" not found in: %s" key sexp_str) | List [Atom str as sexp; v] :: rest when str = key -> let subst x = List (List.rev_append acc (List [sexp; x] :: rest)) in subst, v | h :: t -> loop (h :: acc) t in loop [] lst | Atom _ as sexp -> illegal_atom "extract_rec" sexp let id x = x let rec subst_option (sup_subst, el) rest = let sub_subst, sub_el = subst_path el rest in let subst x = sup_subst (Some (sub_subst x)) in subst, sub_el and subst_path sexp = function | Pos n :: t -> subst_option (extract_pos n sexp) t | Match (tag, arg_ix) :: t -> subst_option (extract_match tag arg_ix sexp) t | Rec key :: rest -> let rec_subst, el = extract_rec key sexp in let sub_subst, sub_el = subst_path el rest in let subst x = rec_subst (sub_subst x) in subst, sub_el | [] -> id, sexp let implode lst = let len = List.length lst in let str = String.create len in let rec loop ix = function | h :: t -> str.[ix] <- h; loop (ix + 1) t | [] -> str in loop 0 lst let fail_parse msg = failwith ("Path.parse: " ^ msg) let parse str = let len = String.length str in if len = 0 then fail_parse "path empty" else let rec loop acc dot_ix = match str.[dot_ix] with | '.' -> let dot_ix1 = dot_ix + 1 in if dot_ix1 = len then List.rev acc else let rec parse_dot acc str_acc ix = if ix = len then List.rev_append acc [Rec (implode (List.rev str_acc))] else match str.[ix] with | '[' -> let rec parse_index index_acc ix = if ix = len then fail_parse "EOF reading index" else match str.[ix], index_acc with | '0'..'9' as c, None -> parse_index (Some (int_of_char c - 48)) (ix + 1) | '0'..'9' as c, Some index_acc -> let new_index_acc = Some (10 * index_acc + int_of_char c - 48) in parse_index new_index_acc (ix + 1) | ']', None -> fail_parse "empty index" | ']', Some index_acc -> let path_el = if str_acc = [] then Pos index_acc else Match (implode (List.rev str_acc), index_acc) in let ix1 = ix + 1 in if ix1 = len then List.rev_append acc [path_el] else loop (path_el :: acc) ix1 | c, _ -> fail_parse ( sprintf "illegal character in index: %c" c) in parse_index None (ix + 1) | '\\' -> let ix1 = ix + 1 in if ix1 = len then fail_parse "EOF after escape" else parse_dot acc (str.[ix1] :: str_acc) (ix + 1) | '.' -> if str_acc = [] then fail_parse "double '.'"; let path_el = Rec (implode (List.rev str_acc)) in parse_dot (path_el :: acc) [] (ix + 1) | c -> parse_dot acc (c :: str_acc) (ix + 1) in parse_dot acc [] dot_ix1 | c -> fail_parse (sprintf "'.' expected; got '%c'" c) in loop [] 0 let get_subst path str sexp = let path = match path, str with | Some path, _ -> path | None, Some str -> parse str | None, None -> [] in subst_path sexp path let get ?path ?str sexp = snd (get_subst path str sexp) let replace ?path ?str sexp ~subst = let subst_fun, _ = get_subst path str sexp in subst_fun subst let replace_no_path ~str sexp ~subst = replace ~str sexp ~subst sexplib-113.33.03/src/path.mli000066400000000000000000000104671271035576100157400ustar00rootroot00000000000000(** Path: Module for Substitutions within S-expressions *) (** {6 Types} *) (** Type of substitution elements *) type el = | Pos of int (** [Pos n] denotes [n]th element in a tuple *) | Match of string * int (** [Match (tag, n)] denotes [n]th argument of sum matching [tag] *) | Rec of string (** [Rec name] denotes the record field having [name] *) (** Type of substitution paths *) type t = el list (** {6 High-level functions} *) val parse : string -> t (** [parse str] @return a substitution path represented by string [str]. Syntax: "." -> separates path elements; must be present at start of string. "\[4\]" -> specifies the 4th element in a tuple. "some_tag\[4\]" -> tries to match [some_tag], then denotes its 4th argument. "name" -> denotes record field having [name] Example from test code: ".t.x.B[1]" -> choose record field with name [t], then subfield [x]. Match this value against [B], and denote its first argument. @raise Failure if the path is syntactically invalid. *) val get : ?path : t -> ?str : string -> Sexp.t -> Sexp.t (** [get ?path ?str sexp] if [path] is provided, use it as path. Otherwise, if [str] is provided, parse it as a path. If neither is provided, assume an empty path. @return the sub-expression from S-expression [sexp] denoted by the path. @raise Failure if path is syntactically invalid or if the path structure clashes with the structure of the data. *) val replace : ?path : t -> ?str : string -> Sexp.t -> subst : Sexp.t -> Sexp.t (** [replace ?path ?str sexp ~subst] like [get], but does not extract a sub-expression but substitutes it with [subst]. @return resulting S-expression. @raise Failure if path is syntactically invalid or if the path structure clashes with the structure of the data. *) val replace_no_path : str : string -> Sexp.t -> subst : Sexp.t -> Sexp.t (** [replace_no_path ~str sexp ~subst] like [replace], but does not take optional arguments. [str] must be specified. @raise Failure if path is syntactically invalid or if the path structure clashes with the structure of the data. *) val subst_path : Sexp.t -> t -> (Sexp.t -> Sexp.t) * Sexp.t (** [subst_path sexp path] @return the tuple [(subst, sub)], where [subst] is a function that returns an S-expression in which the subexpression denoted by [path] in [sexp] has been substituted by its argument. [sub] is the denoted subexpression. Note that [subst sub = sexp]. @raise Failure if path is syntactically invalid or if the path structure clashes with the structure of the data. *) (** {6 Low-level functions} *) val extract_pos : int -> Sexp.t -> (Sexp.t option -> Sexp.t) * Sexp.t (** [extract_pos n sexp] @return the tuple [(subst, sub)], where [subst] is a function that returns an S-expression in which the subexpression denoted at position [n] in [sexp], which must be a list, has been substituted by [value] if the optional argument is [Some value], or removes the denoted subexpression if the optional argument is [None]. [sub] is the denoted subexpression. Note that [subst (Some sub) = sexp]. @raise Failure if the position cannot be resolved within the given S-expression. *) val extract_match : string -> int -> Sexp.t -> (Sexp.t option -> Sexp.t) * Sexp.t (** [extract_match tag n sexp] @return the tuple [(subst, sub)], where [subst] is a function that returns an S-expression in which the subexpression denoted by matching [tag] and taking its [n]th argument in [sexp] has been substituted by [value] if the argument is [Some value], or removes the denoted subexpression if the optional argument is [None]. [sub] is the denoted subexpression. Note that [subst (Some sub) = sexp]. @raise Failure if the S-expression does not represent a sum tag. *) val extract_rec : string -> Sexp.t -> (Sexp.t -> Sexp.t) * Sexp.t (** [extract_rec name sexp] @return the tuple [(subst, sub)], where [subst] is a function that returns an S-expression in which the subexpression denoted by matching field name [name] in [sexp] has been substituted by its argument. [sub] is the denoted subexpression. Note that [subst (Some sub) = sexp]. @raise Failure if the S-expression does not represent a record. *) sexplib-113.33.03/src/pre_sexp.ml000066400000000000000000001320761271035576100164610ustar00rootroot00000000000000(* Sexp: Module for handling S-expressions (I/O, etc.) *) open Format open Bigarray module String = Bytes include Type exception Of_sexp_error of exn * t type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t (* 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 ix = match str.[ix] with | '"' | '(' | ')' | ';' | '\\' -> true | '|' -> ix > 0 && let next = ix - 1 in str.[next] = '#' || loop next | '#' -> ix > 0 && let next = ix - 1 in str.[next] = '|' || loop next | '\000' .. '\032' | '\127' .. '\255' -> true | _ -> ix > 0 && loop (ix - 1) in loop (len - 1) let escaped s = let open Bytes in let n = ref 0 in for i = 0 to length s - 1 do n := !n + (match unsafe_get s i with | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 | ' ' .. '~' -> 1 | _ -> 4) done; if !n = length s then copy s else begin let s' = create !n in n := 0; for i = 0 to length s - 1 do begin match unsafe_get s i with | ('\"' | '\\') as c -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c | '\n' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' | '\t' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' | '\r' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' | '\b' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' | (' ' .. '~') as c -> unsafe_set s' !n c | c -> let a = Char.code c in unsafe_set s' !n '\\'; incr n; unsafe_set s' !n (Char.chr (48 + a / 100)); incr n; unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); incr n; unsafe_set s' !n (Char.chr (48 + a mod 10)); end; incr n done; s' end let esc_str str = let estr = escaped str in let elen = String.length estr in let res = String.create (elen + 2) in String.blit estr 0 res 1 elen; res.[0] <- '"'; res.[elen + 1] <- '"'; res let index_of_newline str start = try Some (String.index_from str start '\n') with Not_found -> None 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 index (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 begin 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 (); end 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 size_loop acc lst 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) (* Output of S-expressions to I/O-channels *) (* 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 let with_new_buffer oc f = let buf = buffer () in f buf; Buffer.output_buffer oc buf let output_hum oc sexp = with_new_buffer oc (fun buf -> to_buffer_hum sexp ~buf) let output_hum_indent indent oc sexp = with_new_buffer oc (fun buf -> to_buffer_hum ~indent sexp ~buf) let output_mach oc sexp = with_new_buffer oc (fun buf -> to_buffer_mach sexp ~buf) let output = output_mach (* Output of S-expressions to file *) (* The temp file functions in the OCaml Filename module do not support permissions. But opening a file with given permissions is different from opening it and chmoding it to these permissions, because the umask is taken in account. Under Unix there's no easy way to get the umask in a thread-safe way. *) module Tmp_file = struct let prng = ref None let temp_file_name prefix suffix = let rand_state = match !prng with | Some v -> v | None -> let ret = Random.State.make_self_init () in prng := Some ret; ret in let rnd = (Random.State.bits rand_state) land 0xFFFFFF in Printf.sprintf "%s%06x%s" prefix rnd suffix (* Keep the permissions loose. Sexps are usually shared and rarely private*) let open_temp_file ?(perm = 0o666) prefix suffix = let rec try_name counter = let name = temp_file_name prefix suffix in try let oc = open_out_gen [Open_wronly; Open_creat; Open_excl; Open_text] perm name in name, oc with Sys_error _ as e -> if counter >= 1000 then raise e else try_name (counter + 1) in try_name 0 end let save_of_output ?perm output_function file sexp = let tmp_name, oc = Tmp_file.open_temp_file ?perm file "tmp" in begin try output_function oc sexp; close_out oc; with e -> close_out_noerr oc; begin try Sys.remove tmp_name with _ -> () end; raise e end; Sys.rename tmp_name file let output_sexp_nl do_output oc sexp = do_output oc sexp; output_string oc "\n" let save_hum ?perm file sexp = save_of_output ?perm (output_sexp_nl output_hum) file sexp let save_mach ?perm file sexp = save_of_output ?perm output_mach file sexp let save = save_mach let output_sexps_nl do_output oc sexps = List.iter (output_sexp_nl do_output oc) sexps let save_sexps_hum ?perm file sexps = save_of_output ?perm (output_sexps_nl output_hum) file sexps let save_sexps_mach ?perm file sexps = save_of_output ?perm (output_sexps_nl output_mach) file sexps let save_sexps = save_sexps_mach (* String conversions *) let to_string_hum ?indent = function | Atom str when index_of_newline str 0 = None -> 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 (* Scan functions *) let scan_sexp ?buf lexbuf = Parser.sexp (Lexer.main ?buf) lexbuf let scan_sexp_opt ?buf lexbuf = Parser.sexp_opt (Lexer.main ?buf) lexbuf let scan_sexps ?buf lexbuf = Parser.sexps (Lexer.main ?buf) lexbuf let scan_rev_sexps ?buf lexbuf = Parser.rev_sexps (Lexer.main ?buf) lexbuf let get_main_buf buf = let buf = match buf with | None -> Buffer.create 128 | Some buf -> buf in Lexer.main ~buf let scan_fold_sexps ?buf ~f ~init lexbuf = let main = get_main_buf buf in let rec loop acc = match Parser.sexp_opt main lexbuf with | None -> acc | Some sexp -> loop (f acc sexp) in loop init let scan_iter_sexps ?buf ~f lexbuf = scan_fold_sexps ?buf lexbuf ~init:() ~f:(fun () sexp -> f sexp) let scan_sexps_conv ?buf ~f lexbuf = let coll acc sexp = f sexp :: acc in List.rev (scan_fold_sexps ?buf ~f:coll ~init:[] lexbuf) (* Partial parsing *) module Annot = struct type pos = { line : int; col : int; offset : int } type range = { start_pos : pos; end_pos : pos } type t = Atom of range * Type.t | List of range * t list * Type.t type 'a conv = [ `Result of 'a | `Error of exn * t ] exception Conv_exn of string * exn type stack = { mutable positions : pos list; mutable stack : t list list; } let get_sexp = function Atom (_, sexp) | List (_, _, sexp) -> sexp let get_range = function Atom (range, _) | List (range, _, _) -> range exception Annot_sexp of t let find_sexp annot_sexp sexp = let rec loop annot_sexp = match annot_sexp with | Atom (_, sub_sexp) | List (_, _, sub_sexp) when sexp == sub_sexp -> raise (Annot_sexp annot_sexp) | List (_, annots, _) -> List.iter loop annots | Atom _ -> () in try loop annot_sexp; None with Annot_sexp res -> Some res end module Parse_pos = struct type t = { mutable text_line : int; mutable text_char : int; mutable global_offset : int; mutable buf_pos : int; } let create ?(text_line = 1) ?(text_char = 0) ?(buf_pos = 0) ?(global_offset = 0) () = let fail msg = failwith ("Sexplib.Sexp.Parse_pos.create: " ^ msg) in if text_line < 1 then fail "text_line < 1" else if text_char < 0 then fail "text_char < 0" else if global_offset < 0 then fail "global_offset < 0" else if buf_pos < 0 then fail "buf_pos < 0" else { text_line; text_char; global_offset; buf_pos } let with_buf_pos t buf_pos = { t with buf_pos } end module Cont_state = struct type t = | Parsing_whitespace | Parsing_atom | Parsing_list | Parsing_sexp_comment | Parsing_block_comment let to_string = function | Parsing_whitespace -> "Parsing_whitespace" | Parsing_atom -> "Parsing_atom" | Parsing_list -> "Parsing_list" | Parsing_sexp_comment -> "Parsing_sexp_comment" | Parsing_block_comment -> "Parsing_block_comment" end type ('a, 't) parse_result = | Done of 't * Parse_pos.t | Cont of Cont_state.t * ('a, 't) parse_fun and ('a, 't) parse_fun = pos : int -> len : int -> 'a -> ('a, 't) parse_result type 't parse_state = { parse_pos : Parse_pos.t; mutable pstack : 't; pbuf : Buffer.t; } type parse_error = { location : string; err_msg : string; parse_state : [ | `Sexp of t list list parse_state | `Annot of Annot.stack parse_state ] } exception Parse_error of parse_error let bump_text_line { parse_pos; _ } = parse_pos.Parse_pos.text_line <- parse_pos.Parse_pos.text_line + 1; parse_pos.Parse_pos.text_char <- 0 let bump_text_pos { parse_pos; _ } = parse_pos.Parse_pos.text_char <- parse_pos.Parse_pos.text_char + 1 let bump_pos_cont state str ~max_pos ~pos cont = bump_text_pos state; cont state str ~max_pos ~pos:(pos + 1) let bump_line_cont state str ~max_pos ~pos cont = bump_text_line state; cont state str ~max_pos ~pos:(pos + 1) let add_bump bump state str ~max_pos ~pos c cont = Buffer.add_char state.pbuf c; bump state; cont state str ~max_pos ~pos:(pos + 1) let add_bump_pos state str ~max_pos ~pos c cont = add_bump bump_text_pos state str ~max_pos ~pos c cont let add_bump_line state str ~max_pos ~pos c cont = add_bump bump_text_line state str ~max_pos ~pos c cont let set_parse_pos parse_pos buf_pos = let len = buf_pos - parse_pos.Parse_pos.buf_pos in parse_pos.Parse_pos.buf_pos <- buf_pos; parse_pos.Parse_pos.global_offset <- parse_pos.Parse_pos.global_offset + len let mk_parse_pos { parse_pos; _ } buf_pos = set_parse_pos parse_pos buf_pos; parse_pos let raise_parse_error parse_state location buf_pos err_msg = match parse_state with | `Sexp { parse_pos; _ } | `Annot { parse_pos; _ } -> set_parse_pos parse_pos buf_pos; let parse_error = { location; err_msg; parse_state } in raise (Parse_error parse_error) let raise_unexpected_char parse_state location buf_pos c = let err_msg = sprintf "unexpected character: '%c'" c in raise_parse_error parse_state location buf_pos err_msg let mk_cont_parser cont_parse = (); fun _state str ~max_pos ~pos -> let len = max_pos - pos + 1 in cont_parse ~pos ~len str (* Macro for generating parsers *) #define MK_PARSER( \ TYPE, GET_LEN, PARSE, GET_CHAR, \ GET_PSTACK, SET_PSTACK, \ REGISTER_POS, REGISTER_POS1, \ MK_ATOM, MK_LIST, INIT_PSTACK, MK_PARSE_STATE) \ let bump_found_atom bump state str ~max_pos ~pos cont = \ let pbuf = state.pbuf in \ let pbuf_str = Buffer.contents pbuf in \ let atom = MK_ATOM in \ match GET_PSTACK with \ | [] -> Done (atom, mk_parse_pos state pos) \ | rev_sexp_lst :: sexp_stack -> \ Buffer.clear pbuf; \ let pstack = (atom :: rev_sexp_lst) :: sexp_stack in \ SET_PSTACK; \ bump state; \ cont state str ~max_pos ~pos:(pos + 1) \ \ let check_str_bounds loc ~pos ~len (str : TYPE) = \ if pos < 0 then invalid_arg (loc ^ ": pos < 0"); \ if len < 0 then invalid_arg (loc ^ ": len < 0"); \ let str_len = GET_LEN str in \ let pos_len = pos + len in \ if pos_len > str_len then invalid_arg (loc ^ ": pos + len > str_len"); \ pos_len - 1 \ \ let mk_cont_state name cont state ~cont_state = \ let parse_fun = \ let used_ref = ref false in \ fun ~pos ~len str -> \ if !used_ref then \ failwith "Sexplib.Sexp: parser continuation called twice" \ else begin \ used_ref := true; \ let max_pos = check_str_bounds name ~pos ~len str in \ cont state str ~max_pos ~pos \ end \ in \ Cont (cont_state, parse_fun) \ \ let mk_cont name cont state = \ let cont_state = \ match GET_PSTACK = [], Buffer.length state.pbuf = 0 with \ | true, true -> Cont_state.Parsing_whitespace \ | false, true -> Cont_state.Parsing_list \ | _, false -> Cont_state.Parsing_atom \ in \ mk_cont_state name cont state ~cont_state \ \ let rec PARSE state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse" PARSE state \ else \ match GET_CHAR with \ | '(' -> \ REGISTER_POS \ let pstack = [] :: GET_PSTACK in \ SET_PSTACK; \ bump_pos_cont state str ~max_pos ~pos PARSE \ | ')' as c -> \ (match GET_PSTACK with \ | [] -> raise_unexpected_char (MK_PARSE_STATE state) "parse" pos c \ | rev_sexp_lst :: sexp_stack -> \ let sexp_lst = List.rev rev_sexp_lst in \ let sexp = MK_LIST in \ match sexp_stack with \ | [] -> Done (sexp, mk_parse_pos state (pos + 1)) \ | higher_rev_sexp_lst :: higher_sexp_stack -> \ let pstack = \ (sexp :: higher_rev_sexp_lst) :: higher_sexp_stack \ in \ SET_PSTACK; \ bump_pos_cont state str ~max_pos ~pos PARSE) \ | ' ' | '\009' | '\012' -> bump_pos_cont state str ~max_pos ~pos PARSE \ | '\010' -> bump_line_cont state str ~max_pos ~pos PARSE \ | '\013' -> bump_pos_cont state str ~max_pos ~pos parse_nl \ | ';' -> bump_pos_cont state str ~max_pos ~pos parse_comment \ | '"' -> \ REGISTER_POS1 \ bump_pos_cont state str ~max_pos ~pos parse_quoted \ | c -> \ REGISTER_POS \ let parse = \ match c with \ | '#' -> maybe_parse_comment \ | '|' -> maybe_parse_close_comment \ | _ -> parse_atom \ in \ add_bump_pos state str ~max_pos ~pos c parse \ \ and parse_nl state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_nl" parse_nl state \ else \ let c = GET_CHAR in \ if c = '\010' then bump_line_cont state str ~max_pos ~pos PARSE \ else raise_unexpected_char (MK_PARSE_STATE state) "parse_nl" pos c \ \ and parse_comment state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_comment" parse_comment state \ else \ match GET_CHAR with \ | '\010' -> bump_line_cont state str ~max_pos ~pos PARSE \ | '\013' -> bump_pos_cont state str ~max_pos ~pos parse_nl \ | _ -> bump_pos_cont state str ~max_pos ~pos parse_comment \ \ and maybe_parse_comment state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "maybe_parse_comment" maybe_parse_comment state \ else \ match GET_CHAR with \ | ';' -> bump_pos_cont state str ~max_pos ~pos parse_sexp_comment \ | '|' -> bump_pos_cont state str ~max_pos ~pos parse_block_comment \ | _ -> parse_atom state str ~max_pos ~pos \ \ and maybe_parse_close_comment state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "maybe_parse_close_comment" maybe_parse_close_comment state \ else \ if GET_CHAR <> '#' then parse_atom state str ~max_pos ~pos \ else \ let err_msg = "end of block comment without start" in \ raise_parse_error (MK_PARSE_STATE state) \ "maybe_parse_close_comment" pos err_msg \ \ and parse_sexp_comment state str ~max_pos ~pos = \ let pbuf_str = "" in \ ignore (MK_ATOM); \ Buffer.clear state.pbuf; \ let old_pstack = GET_PSTACK in \ let pstack = [] in \ SET_PSTACK; \ let rec loop parse state str ~max_pos ~pos = \ match parse state str ~max_pos ~pos with \ | Done (_sexp, { Parse_pos.buf_pos = pos; _ }) -> \ Buffer.clear state.pbuf; \ let pstack = old_pstack in \ SET_PSTACK; \ PARSE state str ~max_pos ~pos \ | Cont (_, cont_parse) -> \ Buffer.clear state.pbuf; \ let parse = mk_cont_parser cont_parse in \ mk_cont_state "parse_sexp_comment" (loop parse) state \ ~cont_state:Cont_state.Parsing_sexp_comment \ in \ loop PARSE state str ~max_pos ~pos \ \ and parse_block_comment state str ~max_pos ~pos = \ let pbuf_str = "" in \ ignore (MK_ATOM); \ Buffer.clear state.pbuf; \ let old_pstack = GET_PSTACK in \ let pstack = [] in \ SET_PSTACK; \ let rec loop depth state str ~max_pos ~pos = \ let rec parse_block_depth state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "parse_block_depth" parse_block_depth state \ else \ match GET_CHAR with \ | '\010' -> bump_line_cont state str ~max_pos ~pos parse_block_depth \ | '"' -> \ REGISTER_POS1 \ let rec parse_block_quote parse state str ~max_pos ~pos = \ match parse state str ~max_pos ~pos with \ | Done (_sexp, { Parse_pos.buf_pos = pos; _ }) -> \ Buffer.clear state.pbuf; \ parse_block_depth state str ~max_pos ~pos \ | Cont (_, cont_parse) -> \ Buffer.clear state.pbuf; \ let parse = mk_cont_parser cont_parse in \ mk_cont_state "parse_block_quote" \ (parse_block_quote parse) state \ ~cont_state:Cont_state.Parsing_block_comment \ in \ bump_pos_cont state str ~max_pos ~pos \ (parse_block_quote parse_quoted) \ | '#' -> bump_pos_cont state str ~max_pos ~pos parse_open_block \ | '|' -> bump_pos_cont state str ~max_pos ~pos parse_close_block \ | _ -> bump_pos_cont state str ~max_pos ~pos parse_block_depth \ and parse_open_block state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "parse_open_block" parse_open_block state \ else \ if GET_CHAR = '|' then \ bump_pos_cont state str ~max_pos ~pos (loop (depth + 1)) \ else parse_block_depth state str ~max_pos ~pos \ and parse_close_block state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "parse_close_block" parse_close_block state \ else if GET_CHAR = '#' then \ let parse = \ if depth = 1 then \ let () = Buffer.clear state.pbuf in \ let pstack = old_pstack in \ SET_PSTACK; \ PARSE \ else loop (depth - 1) \ in \ bump_pos_cont state str ~max_pos ~pos parse \ else parse_block_depth state str ~max_pos ~pos \ in \ parse_block_depth state str ~max_pos ~pos \ in \ loop 1 state str ~max_pos ~pos \ \ and parse_atom state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_atom" parse_atom state \ else \ match GET_CHAR with \ | ' ' | '\009' | '\012' -> \ bump_found_atom bump_text_pos state str ~max_pos ~pos PARSE \ | '#' as c -> \ add_bump_pos state str ~max_pos ~pos c maybe_parse_bad_atom_hash \ | '|' as c -> \ add_bump_pos state str ~max_pos ~pos c maybe_parse_bad_atom_pipe \ | '(' -> \ let pbuf = state.pbuf in \ let pbuf_str = Buffer.contents pbuf in \ let atom = MK_ATOM in \ (match GET_PSTACK with \ | [] -> Done (atom, mk_parse_pos state pos) \ | rev_sexp_lst :: sexp_stack -> \ REGISTER_POS \ Buffer.clear pbuf; \ let pstack = [] :: (atom :: rev_sexp_lst) :: sexp_stack in \ SET_PSTACK; \ bump_pos_cont state str ~max_pos ~pos PARSE) \ | ')' -> \ let pbuf = state.pbuf in \ let pbuf_str = Buffer.contents pbuf in \ let atom = MK_ATOM in \ (match GET_PSTACK with \ | [] -> Done (atom, mk_parse_pos state pos) \ | rev_sexp_lst :: sexp_stack -> \ let sexp_lst = List.rev_append rev_sexp_lst [atom] in \ let sexp = MK_LIST in \ match sexp_stack with \ | [] -> Done (sexp, mk_parse_pos state (pos + 1)) \ | higher_rev_sexp_lst :: higher_sexp_stack -> \ Buffer.clear pbuf; \ let pstack = \ (sexp :: higher_rev_sexp_lst) :: higher_sexp_stack \ in \ SET_PSTACK; \ bump_pos_cont state str ~max_pos ~pos PARSE) \ | '\010' -> bump_found_atom bump_text_line state str ~max_pos ~pos PARSE \ | '\013' -> \ bump_found_atom bump_text_pos state str ~max_pos ~pos parse_nl \ | ';' -> \ bump_found_atom bump_text_pos state str ~max_pos ~pos parse_comment \ | '"' -> \ bump_found_atom \ bump_text_pos state str ~max_pos ~pos reg_parse_quoted \ | c -> \ (* This is [add_bump_pos state str ~max_pos ~pos c parse_atom] inlined by \ hand, see https://github.com/janestreet/sexplib/pull/14 for details: *) \ Buffer.add_char state.pbuf c; \ bump_text_pos state; \ parse_atom state str ~max_pos ~pos:(pos + 1) \ \ and maybe_parse_bad_atom_pipe state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "maybe_parse_bad_atom_pipe" maybe_parse_bad_atom_pipe state \ else \ match GET_CHAR with \ | '#' -> \ let err_msg = "illegal end of block comment in unquoted atom" in \ raise_parse_error (MK_PARSE_STATE state) "maybe_parse_bad_atom_pipe" \ pos err_msg \ | _ -> parse_atom state str ~max_pos ~pos \ \ and maybe_parse_bad_atom_hash state str ~max_pos ~pos = \ if pos > max_pos then \ mk_cont "maybe_parse_bad_atom_hash" maybe_parse_bad_atom_hash state \ else \ match GET_CHAR with \ | '|' -> \ let err_msg = "illegal start of block comment in unquoted atom" in \ raise_parse_error (MK_PARSE_STATE state) "maybe_parse_bad_atom_hash" \ pos err_msg \ | _ -> parse_atom state str ~max_pos ~pos \ \ and reg_parse_quoted state str ~max_pos ~pos = \ REGISTER_POS \ parse_quoted state str ~max_pos ~pos \ \ and parse_quoted state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_quoted" parse_quoted state \ else \ match GET_CHAR with \ | '"' -> \ let pbuf = state.pbuf in \ let pbuf_str = Buffer.contents pbuf in \ let atom = MK_ATOM in \ (match GET_PSTACK with \ | [] -> Done (atom, mk_parse_pos state (pos + 1)) \ | rev_sexp_lst :: sexp_stack -> \ Buffer.clear pbuf; \ let pstack = (atom :: rev_sexp_lst) :: sexp_stack in \ SET_PSTACK; \ bump_pos_cont state str ~max_pos ~pos PARSE) \ | '\\' -> bump_pos_cont state str ~max_pos ~pos parse_escaped \ | '\010' as c -> add_bump_line state str ~max_pos ~pos c parse_quoted \ | c -> \ (* This is [add_bump_pos state str ~max_pos ~pos c parse_quoted] inlined by \ hand, see https://github.com/janestreet/sexplib/pull/14 for details: *) \ Buffer.add_char state.pbuf c; \ bump_text_pos state; \ parse_quoted state str ~max_pos ~pos:(pos + 1) \ \ and parse_escaped state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_escaped" parse_escaped state \ else \ match GET_CHAR with \ | '\010' -> bump_line_cont state str ~max_pos ~pos parse_skip_ws \ | '\013' -> bump_pos_cont state str ~max_pos ~pos parse_skip_ws_nl \ | '0' .. '9' as c -> \ bump_text_pos state; \ let d = Char.code c - 48 in \ parse_dec state str ~max_pos ~pos:(pos + 1) ~count:2 ~d \ | 'x' -> \ bump_text_pos state; \ parse_hex state str ~max_pos ~pos:(pos + 1) ~count:2 ~d:0 \ | ('\\' | '"' | '\'' ) as c -> \ add_bump_pos state str ~max_pos ~pos c parse_quoted \ | 'n' -> add_bump_pos state str ~max_pos ~pos '\n' parse_quoted \ | 't' -> add_bump_pos state str ~max_pos ~pos '\t' parse_quoted \ | 'b' -> add_bump_pos state str ~max_pos ~pos '\b' parse_quoted \ | 'r' -> add_bump_pos state str ~max_pos ~pos '\r' parse_quoted \ | c -> \ Buffer.add_char state.pbuf '\\'; \ add_bump_pos state str ~max_pos ~pos c parse_quoted \ \ and parse_skip_ws state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_skip_ws" parse_skip_ws state \ else \ match GET_CHAR with \ | ' ' | '\009' -> bump_pos_cont state str ~max_pos ~pos parse_skip_ws \ | _ -> parse_quoted state str ~max_pos ~pos \ \ and parse_skip_ws_nl state str ~max_pos ~pos = \ if pos > max_pos then mk_cont "parse_skip_ws_nl" parse_skip_ws_nl state \ else \ if GET_CHAR = '\010' then \ bump_line_cont state str ~max_pos ~pos parse_skip_ws \ else begin \ Buffer.add_char state.pbuf '\013'; \ parse_quoted state str ~max_pos ~pos \ end \ \ and parse_dec state str ~max_pos ~pos ~count ~d = \ if pos > max_pos then mk_cont "parse_dec" (parse_dec ~count ~d) state \ else \ match GET_CHAR with \ | '0' .. '9' as c -> \ let d = 10 * d + Char.code c - 48 in \ if count = 1 then \ if d > 255 then \ let err_msg = sprintf "illegal decimal escape: \\%d" d in \ raise_parse_error (MK_PARSE_STATE state) "parse_dec" pos err_msg \ else \ add_bump_pos state str ~max_pos ~pos (Char.chr d) parse_quoted \ else ( \ bump_text_pos state; \ parse_dec state str ~max_pos ~pos:(pos + 1) ~count:(count - 1) ~d) \ | c -> raise_unexpected_char (MK_PARSE_STATE state) "parse_dec" pos c \ \ and parse_hex state str ~max_pos ~pos ~count ~d = \ if pos > max_pos then mk_cont "parse_hex" (parse_hex ~count ~d) state \ else \ match GET_CHAR with \ | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c -> \ let corr = \ if c >= 'a' then 87 \ else if c >= 'A' then 55 \ else 48 \ in \ let d = 16 * d + Char.code c - corr in \ if count = 1 then \ if d > 255 then \ let err_msg = sprintf "illegal hexadecimal escape: \\%x" d in \ raise_parse_error (MK_PARSE_STATE state) "parse_hex" pos err_msg \ else \ add_bump_pos state str ~max_pos ~pos (Char.chr d) parse_quoted \ else ( \ bump_text_pos state; \ parse_hex state str ~max_pos ~pos:(pos + 1) ~count:(count - 1) ~d) \ | c -> raise_unexpected_char (MK_PARSE_STATE state) "parse_hex" pos c \ \ let PARSE ?(parse_pos = Parse_pos.create ()) ?len str = \ let pos = parse_pos.Parse_pos.buf_pos in \ let len = \ match len with \ | Some len -> len \ | None -> GET_LEN str - pos \ in \ let max_pos = check_str_bounds "parse" ~pos ~len str in \ let state = \ { \ parse_pos; \ pstack = INIT_PSTACK; \ pbuf = Buffer.create 128; \ } \ in \ PARSE state str ~max_pos ~pos MK_PARSER( string, String.length, parse_str, str.[pos], state.pstack, state.pstack <- pstack, ,, Atom pbuf_str, List sexp_lst, [], `Sexp ) let parse = parse_str (* Annot parsers *) let get_glob_ofs parse_pos pos = parse_pos.Parse_pos.global_offset + pos - parse_pos.Parse_pos.buf_pos let mk_annot_pos ({ Parse_pos.text_line = line; text_char = col; _ } as parse_pos) pos = { Annot.line; col; offset = get_glob_ofs parse_pos pos } let mk_annot_pos1 ({ Parse_pos.text_line = line; text_char = col; _ } as parse_pos) pos = { Annot.line; col = col + 1; offset = get_glob_ofs parse_pos pos } let add_annot_pos { parse_pos; pstack; pbuf = _ } pos = pstack.Annot.positions <- mk_annot_pos parse_pos pos :: pstack.Annot.positions let add_annot_pos1 { parse_pos; pstack; pbuf = _ } pos = pstack.Annot.positions <- mk_annot_pos1 parse_pos pos :: pstack.Annot.positions let get_annot_range { parse_pos; pstack; pbuf = _ } pos = let start_pos = match pstack.Annot.positions with | [] -> assert false (* impossible *) | h :: t -> pstack.Annot.positions <- t; h in let end_pos = { Annot. line = parse_pos.Parse_pos.text_line; col = parse_pos.Parse_pos.text_char; offset = get_glob_ofs parse_pos pos; } in { Annot.start_pos; end_pos } let mk_annot_atom parse_state str pos = Annot.Atom (get_annot_range parse_state pos, Atom str) let mk_annot_list parse_state annot_lst pos = let range = get_annot_range parse_state pos in let sexp = List (List.rev (List.rev_map Annot.get_sexp annot_lst)) in Annot.List (range, annot_lst, sexp) let init_annot_pstate () = { Annot.positions = []; stack = [] } MK_PARSER( string, String.length, parse_str_annot, str.[pos], state.pstack.Annot.stack, state.pstack.Annot.stack <- pstack, add_annot_pos state pos;,add_annot_pos1 state pos;, mk_annot_atom state pbuf_str pos, mk_annot_list state sexp_lst pos, init_annot_pstate (), `Annot ) (* Partial parsing from bigstrings *) (* NOTE: this is really an awful duplication of the code for parsing strings, but since OCaml does not inline higher-order functions known at compile, other solutions would sacrifice a lot of efficiency. *) MK_PARSER( bigstring, Array1.dim, parse_bigstring, str.{pos}, state.pstack, state.pstack <- pstack, ,, Atom pbuf_str, List sexp_lst, [], `Sexp ) MK_PARSER( bigstring, Array1.dim, parse_bigstring_annot, str.{pos}, state.pstack.Annot.stack, state.pstack.Annot.stack <- pstack, add_annot_pos state pos;,add_annot_pos1 state pos;, mk_annot_atom state pbuf_str pos, mk_annot_list state sexp_lst pos, init_annot_pstate (), `Annot ) (* Input functions *) let mk_this_parse ?parse_pos my_parse = (); fun ~pos ~len str -> let parse_pos = match parse_pos with | None -> Parse_pos.create ~buf_pos:pos () | Some parse_pos -> parse_pos.Parse_pos.buf_pos <- pos; parse_pos in my_parse ?parse_pos:(Some parse_pos) ?len:(Some len) str let gen_input_sexp my_parse ?parse_pos ic = let buf = String.create 1 in let rec loop this_parse = let c = input_char ic in buf.[0] <- c; match this_parse ~pos:0 ~len:1 buf with | Done (sexp, _) -> sexp | Cont (_, this_parse) -> loop this_parse in loop (mk_this_parse ?parse_pos my_parse) let input_sexp ?parse_pos ic = gen_input_sexp parse ?parse_pos ic let gen_input_rev_sexps my_parse ?parse_pos ?(buf = String.create 8192) ic = let rev_sexps_ref = ref [] in let buf_len = String.length buf in let rec loop this_parse ~pos ~len ~cont_state = if len > 0 then match this_parse ~pos ~len buf with | Done (sexp, ({ Parse_pos.buf_pos; _ } as parse_pos)) -> rev_sexps_ref := sexp :: !rev_sexps_ref; let n_parsed = buf_pos - pos in let this_parse = mk_this_parse ~parse_pos my_parse in let cont_state = Cont_state.Parsing_whitespace in if n_parsed = len then let new_len = input ic buf 0 buf_len in loop this_parse ~pos:0 ~len:new_len ~cont_state else loop this_parse ~pos:buf_pos ~len:(len - n_parsed) ~cont_state | Cont (cont_state, this_parse) -> loop this_parse ~pos:0 ~len:(input ic buf 0 buf_len) ~cont_state else if cont_state = Cont_state.Parsing_whitespace then !rev_sexps_ref else failwith ( "Sexplib.Sexp.input_rev_sexps: reached EOF while in state " ^ Cont_state.to_string cont_state) in let len = input ic buf 0 buf_len in let this_parse = mk_this_parse ?parse_pos my_parse in loop this_parse ~pos:0 ~len ~cont_state:Cont_state.Parsing_whitespace let input_rev_sexps ?parse_pos ?buf ic = gen_input_rev_sexps parse ?parse_pos ?buf ic let input_sexps ?parse_pos ?buf ic = List.rev (input_rev_sexps ?parse_pos ?buf ic) (* of_string and of_bigstring *) let of_string_bigstring loc this_parse ws_buf get_len get_sub str = match this_parse str with | Done (_, { Parse_pos.buf_pos; _ }) when buf_pos <> get_len str -> let prefix_len = min (get_len str - buf_pos) 20 in let prefix = get_sub str buf_pos prefix_len in let msg = sprintf "Sexplib.Sexp.%s: S-expression followed by data at position %d: %S..." loc buf_pos prefix in failwith msg | Done (sexp, _) -> sexp | Cont (_, this_parse) -> (* When parsing atoms, the incremental parser cannot tell whether it is at the end until it hits whitespace. We therefore feed it one space to determine whether it is finished. *) match this_parse ~pos:0 ~len:1 ws_buf with | Done (sexp, _) -> sexp | Cont (cont_state, _) -> let cont_state_str = Cont_state.to_string cont_state in failwith ( sprintf "Sexplib.Sexp.%s: incomplete S-expression while in state %s: %s" loc cont_state_str (get_sub str 0 (get_len str))) let of_string str = of_string_bigstring "of_string" parse " " String.length String.sub str let get_bstr_sub_str bstr pos len = let str = String.create len in for i = 0 to len - 1 do str.[i] <- bstr.{pos + i} done; str let bstr_ws_buf = Array1.create char c_layout 1 let () = bstr_ws_buf.{0} <- ' ' let of_bigstring bstr = of_string_bigstring "of_bigstring" parse_bigstring bstr_ws_buf Array1.dim get_bstr_sub_str bstr (* Loading *) let gen_load_rev_sexps input_rev_sexps ?buf file = let ic = open_in file in try let sexps = input_rev_sexps ?parse_pos:None ?buf ic in close_in ic; sexps with exc -> close_in_noerr ic; raise exc let load_rev_sexps ?buf file = gen_load_rev_sexps input_rev_sexps ?buf file let load_sexps ?buf file = List.rev (load_rev_sexps ?buf file) let gen_load_sexp_loc = "Sexplib.Sexp.gen_load_sexp" let gen_load_sexp my_parse ?(strict = true) ?(buf = String.create 8192) file = let buf_len = String.length buf in let ic = open_in file in let rec loop this_parse ~cont_state = let len = input ic buf 0 buf_len in if len = 0 then failwith ( sprintf "%s: EOF in %s while in state %s" gen_load_sexp_loc file (Cont_state.to_string cont_state)) else match this_parse ~pos:0 ~len buf with | Done (sexp, ({ Parse_pos.buf_pos; _ } as parse_pos)) when strict -> let rec strict_loop this_parse ~pos ~len = match this_parse ~pos ~len buf with | Done _ -> failwith ( sprintf "%s: more than one S-expression in file %s" gen_load_sexp_loc file) | Cont (cont_state, this_parse) -> let len = input ic buf 0 buf_len in if len > 0 then strict_loop this_parse ~pos:0 ~len else if cont_state = Cont_state.Parsing_whitespace then sexp else failwith ( sprintf "%s: %s in state %s loading file %s" gen_load_sexp_loc "additional incomplete data" (Cont_state.to_string cont_state) file) in let this_parse = mk_this_parse ~parse_pos my_parse in strict_loop this_parse ~pos:buf_pos ~len:(len - buf_pos) | Done (sexp, _) -> sexp | Cont (cont_state, this_parse) -> loop this_parse ~cont_state in try let sexp = loop (mk_this_parse my_parse) ~cont_state:Cont_state.Parsing_whitespace in close_in ic; sexp with exc -> close_in_noerr ic; raise exc let load_sexp ?strict ?buf file = gen_load_sexp parse ?strict ?buf file module Annotated = struct include Annot let parse = parse_str_annot let parse_bigstring = parse_bigstring_annot let input_rev_sexps ?parse_pos ?buf ic = gen_input_rev_sexps parse ?parse_pos ?buf ic let input_sexp ?parse_pos ic = gen_input_sexp parse ?parse_pos ic let input_sexps ?parse_pos ?buf ic = List.rev (input_rev_sexps ?parse_pos ?buf ic) let of_string str = of_string_bigstring "Annotated.of_string" parse " " String.length String.sub str let of_bigstring bstr = of_string_bigstring "Annotated.of_bigstring" parse_bigstring bstr_ws_buf Array1.dim get_bstr_sub_str bstr let load_rev_sexps ?buf file = gen_load_rev_sexps input_rev_sexps ?buf file let load_sexps ?buf file = List.rev (load_rev_sexps ?buf file) let load_sexp ?strict ?buf file = gen_load_sexp parse ?strict ?buf file let conv f annot_sexp = let sexp = get_sexp annot_sexp in try `Result (f sexp) with Of_sexp_error (exc, bad_sexp) as e -> match find_sexp annot_sexp bad_sexp with | None -> raise e | Some bad_annot_sexp -> `Error (exc, bad_annot_sexp) let get_conv_exn ~file ~exc annot_sexp = let range = get_range annot_sexp in let { start_pos = { line; col; offset = _ }; end_pos = _ } = range in let loc = sprintf "%s:%d:%d" file line col in Of_sexp_error (Annot.Conv_exn (loc, exc), get_sexp annot_sexp) end let load_sexp_conv ?(strict = true) ?(buf = String.create 8192) file f = let sexp = load_sexp ~strict ~buf file in try `Result (f sexp) with Of_sexp_error _ -> Annotated.conv f (Annotated.load_sexp ~strict ~buf file) let raise_conv_exn ~file = function | `Result res -> res | `Error (exc, annot_sexp) -> raise (Annotated.get_conv_exn ~file ~exc annot_sexp) let load_sexp_conv_exn ?strict ?buf file f = raise_conv_exn ~file (load_sexp_conv ?strict ?buf file f) let load_sexps_conv ?(buf = String.create 8192) file f = let rev_sexps = load_rev_sexps ~buf file in try List.rev_map (fun sexp -> `Result (f sexp)) rev_sexps with Of_sexp_error _ as e -> match Annotated.load_rev_sexps ~buf file with | [] -> (* File is now empty - perhaps it was a temporary file handle? *) raise e | rev_annot_sexps -> List.rev_map (fun annot_sexp -> Annotated.conv f annot_sexp) rev_annot_sexps let load_sexps_conv_exn ?(buf = String.create 8192) file f = let rev_sexps = load_rev_sexps ~buf file in try List.rev_map f rev_sexps with Of_sexp_error _ as e -> match Annotated.load_rev_sexps ~buf file with | [] -> (* File is now empty - perhaps it was a temporary file handle? *) raise e | rev_annot_sexps -> List.rev_map (fun annot_sexp -> raise_conv_exn ~file (Annotated.conv f annot_sexp)) rev_annot_sexps let gen_of_string_conv of_string annot_of_string str f = let sexp = of_string str in try `Result (f sexp) with Of_sexp_error _ -> Annotated.conv f (annot_of_string str) let of_string_conv str f = gen_of_string_conv of_string Annotated.of_string str f let of_bigstring_conv bstr f = gen_of_string_conv of_bigstring Annotated.of_bigstring bstr f module Of_string_conv_exn = struct type t = { exc : exn; sexp : Type.t; sub_sexp : Type.t } exception E of t end let gen_of_string_conv_exn of_string str f = let sexp = of_string str in try f sexp with Of_sexp_error (exc, sub_sexp) -> raise (Of_string_conv_exn.E { Of_string_conv_exn.exc; sexp; sub_sexp }) let of_string_conv_exn str f = gen_of_string_conv_exn of_string str f let of_bigstring_conv_exn bstr f = gen_of_string_conv_exn of_bigstring bstr f (* Utilities for automated type conversions *) let unit = List [] external sexp_of_t : t -> t = "%identity" external t_of_sexp : t -> t = "%identity" (* Utilities for conversion error handling *) type found = [ `Found | `Pos of int * found ] type search_result = [ `Not_found | found ] let rec search_physical sexp ~contained = if sexp == contained then `Found else match sexp with | Atom _ -> `Not_found | List lst -> let rec loop i = function | [] -> `Not_found | h :: t -> let res = search_physical h ~contained in match res with | `Not_found -> loop (i + 1) t | #found as found -> `Pos (i, found) in loop 0 lst let rec subst_found sexp ~subst = function | `Found -> subst | `Pos (pos, found) -> match sexp with | Atom _ -> failwith "Sexplib.Sexp.subst_found: atom when position requested" | List lst -> let rec loop acc pos = function | [] -> failwith "Sexplib.Sexp.subst_found: short list when position requested" | h :: t when pos <> 0 -> loop (h :: acc) (pos - 1) t | h :: t -> List (List.rev_append acc (subst_found h ~subst found :: t)) in loop [] pos lst sexplib-113.33.03/src/sexp.ml000066400000000000000000000000671271035576100156050ustar00rootroot00000000000000include Pre_sexp module With_layout = Sexp_with_layout sexplib-113.33.03/src/sexp.mli000066400000000000000000000001201271035576100157440ustar00rootroot00000000000000(** Sexp: Module for handling S-expressions (I/O, etc.) *) include Sexp_intf.S sexplib-113.33.03/src/sexp_intf.ml000066400000000000000000000622421271035576100166300ustar00rootroot00000000000000(** Sexp_intf: interface specification for handling S-expressions (I/O, etc.) *) open Format open Bigarray module type S = sig (** Type of S-expressions *) type t = Type.t = Atom of string | List of t list (** Type of bigstrings *) type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t (** {6 Defaults} *) val default_indent : int ref (** [default_indent] reference to default indentation level for human-readable conversions. Initialisation value: 2. *) (** {6 S-expression size} *) val size : t -> int * int (** [size sexp] @return [(n_atoms, n_chars)], where [n_atoms] is the number of atoms in S-expression [sexp], and [n_chars] is the number of characters in the atoms of the S-expression. *) (** {6 Scan functions} *) val scan_sexp : ?buf : Buffer.t -> Lexing.lexbuf -> t (** [scan_sexp ?buf lexbuf] scans an S-expression from lex buffer [lexbuf] using the optional string buffer [buf] for storing intermediate strings. *) val scan_sexps : ?buf : Buffer.t -> Lexing.lexbuf -> t list (** [scan_sexps ?buf lexbuf] reads a list of whitespace separated S-expressions from lex buffer [lexbuf] using the optional string buffer [buf] for storing intermediate strings. *) val scan_rev_sexps : ?buf : Buffer.t -> Lexing.lexbuf -> t list (** [scan_rev_sexps ?buf lexbuf] same as {!scan_sexps}, but returns the reversed list and is slightly more efficient. *) val scan_sexp_opt : ?buf : Buffer.t -> Lexing.lexbuf -> t option (** [scan_sexp_opt ?buf lexbuf] is equivalent to [scan_sexp ?buf lexbuf] except that it returns [None] when the eof is reached. *) val scan_iter_sexps : ?buf : Buffer.t -> f : (t -> unit) -> Lexing.lexbuf -> unit (** [scan_iter_sexps ?buf ~f lexbuf] iterates over all whitespace separated S-expressions scanned from lex buffer [lexbuf] using function [f], and the optional string buffer [buf] for storing intermediate strings. *) val scan_fold_sexps : ?buf : Buffer.t -> f : ('a -> t -> 'a) -> init : 'a -> Lexing.lexbuf -> 'a (** [scan_fold_sexps ?buf ~f ~init lexbuf] folds over all whitespace separated S-expressions scanned from lex buffer [lexbuf] using function [f], initial state [init], and the optional string buffer [buf] for storing intermediate strings. *) val scan_sexps_conv : ?buf : Buffer.t -> f : (t -> 'a) -> Lexing.lexbuf -> 'a list (** [scan_sexps_conv ?buf ~f lexbuf] maps all whitespace separated S-expressions scanned from lex buffer [lexbuf] to some list using function [f], and the optional string buffer [buf] for storing intermediate strings. *) (** {6 Type and exception definitions for (partial) parsing} *) module Parse_pos : sig (** Position information after complete parse *) type t = Pre_sexp.Parse_pos.t = private { mutable text_line : int; (** Line position in parsed text *) mutable text_char : int; (** Character position in parsed text *) mutable global_offset : int; (** Global/logical offset *) mutable buf_pos : int; (** Read position in string buffer *) } val create : ?text_line : int -> ?text_char : int -> ?buf_pos : int -> ?global_offset : int -> unit -> t (** [create ?text_line ?text_char ?buf_pos ?global_offset ()] @return a parse position with the given parameters. @param text_line default = [1] @param text_char default = [0] @param global_offset default = [0] @param buf_pos default = [0] *) val with_buf_pos : t -> int -> t (** [with_buf_pos t pos] @return a copy of the parse position [t] where [buf_pos] is set to [pos]. *) end module Cont_state : sig (** State of parser continuations *) type t = Pre_sexp.Cont_state.t = | Parsing_whitespace | Parsing_atom | Parsing_list | Parsing_sexp_comment | Parsing_block_comment val to_string : t -> string (** [to_string cont_state] converts state of parser continuation [cont_state] to a string. *) end (** Type of result from calling {!Sexp.parse}. *) type ('a, 't) parse_result = ('a, 't) Pre_sexp.parse_result = | Done of 't * Parse_pos.t (** [Done (t, parse_pos)] finished parsing an S-expression. Current parse position is [parse_pos]. *) | Cont of Cont_state.t * ('a, 't) parse_fun (** [Cont (cont_state, parse_fun)] met the end of input before completely parsing an S-expression. The user has to call [parse_fun] to continue parsing the S-expression in another buffer. [cont_state] is the current parsing state of the continuation. NOTE: the continuation may only be called once and will raise [Failure] otherwise! *) (** Type of parsing functions with given offsets and lengths. *) and ('a, 't) parse_fun = pos : int -> len : int -> 'a -> ('a, 't) parse_result (** Module for parsing S-expressions annotated with location information *) module Annotated : sig (** Position information for annotated S-expressions *) type pos = Pre_sexp.Annotated.pos = { line : int; col : int; offset : int; } (** Range information for annotated S-expressions *) type range = Pre_sexp.Annotated.range = { start_pos : pos; end_pos : pos } (** S-expression annotated with location information *) type t = Pre_sexp.Annotated.t = | Atom of range * Type.t | List of range * t list * Type.t (** Type of conversion results of annotated S-expressions. *) type 'a conv = [ `Result of 'a | `Error of exn * t ] (** Exception associated with conversion errors. First argument describes the location, the second the reason. *) exception Conv_exn of string * exn (** Stack used by annotation parsers *) type stack = Pre_sexp.Annotated.stack = { mutable positions : pos list; mutable stack : t list list; } val get_sexp : t -> Type.t (** [get_sexp annot_sexp] @return S-expression associated with annotated S-expression [annot_sexp]. *) val get_range : t -> range (** [get_range annot_sexp] @return the range associated with annotated S-expression [annot_sexp]. *) val find_sexp : t -> Type.t -> t option (** [find_sexp annot_sexp sexp] @return [Some res] where [res] is the annotated S-expression that is physically equivalent to [sexp] in [annot_sexp], or [None] if there is no such S-expression. *) (** {6 Annotated (partial) parsing} *) val parse : ?parse_pos : Parse_pos.t -> ?len : int -> string -> (string, t) parse_result (** [parse ?parse_pos ?len str] same as {!parse}, but returns an S-expression annotated with location information. *) val parse_bigstring : ?parse_pos : Parse_pos.t -> ?len : int -> bigstring -> (bigstring, t) parse_result (** [parse_bigstring ?parse_pos ?len str] same as {!parse_bigstring}, but returns an S-expression annotated with location information. *) val input_sexp : ?parse_pos : Parse_pos.t -> in_channel -> t (** [input_sexp ?parse_pos ic] like {!input_sexp}, but returns an annotated S-expression instead. *) val input_sexps : ?parse_pos : Parse_pos.t -> ?buf : string -> in_channel -> t list (** [input_sexps ?parse_pos ?buf ic] like {!input_sexps}, but returns a list of annotated S-expressions. *) val input_rev_sexps : ?parse_pos : Parse_pos.t -> ?buf : string -> in_channel -> t list (** [input_sexps ?parse_pos ?buf ic] like {!input_rev_sexps}, but returns a list of annotated S-expressions. *) (** {6 Loading of annotated S-expressions} *) (** NOTE: these functions should only be used if an annotated S-expression is required. *) val load_sexp : ?strict : bool -> ?buf : string -> string -> t (** [load_sexp ?strict ?buf file] like {!load_sexp}, but returns an annotated S-expression. *) val load_sexps : ?buf : string -> string -> t list (** [load_sexps ?buf file] like {!load_sexps}, but returns a list of annotated S-expressions. *) val load_rev_sexps : ?buf : string -> string -> t list (** [load_rev_sexps ?buf file] like {!load_rev_sexps}, but returns a list of annotated S-expressions. *) (** {6 String and bigstring conversions} *) val of_string : string -> t (** [of_string str] same as {!of_string}, but returns an annotated S-expression. *) val of_bigstring : bigstring -> t (** [of_bigstring bstr] same as {!of_string}, but operates on bigstrings. *) (** Converters using annotations for determining error locations *) val conv : (Type.t -> 'a) -> t -> 'a conv (** [conv f annot_sexp] converts the S-expression associated with annotated S-expression [annot_sexp] using [f]. @return [`Result res] on success, or [`Error (exn, sub_annot_sexp)] otherwise, where [exn] is the exception associated with the conversion error, and [sub_annot_sexp] is the annotated S-expression on which conversion failed. *) val get_conv_exn : file : string -> exc : exn -> t -> exn (** [get_conv_exn ~file ~exc annot_sexp] @return the exception that would be raised for a given [file] and exception [exc] if conversion had failed on annotated S-expression [annot_sexp]. The format of the exception message is "file:line:col" *) end (** Type of state maintained during parsing *) type 't parse_state = 't Pre_sexp.parse_state = private { parse_pos : Parse_pos.t; (** Current parse position *) mutable pstack : 't; (** Stack of found S-expression lists *) pbuf : Buffer.t; (** Current atom buffer *) } (** Type of parse errors *) type parse_error = Pre_sexp.parse_error = { location : string; (** Function in which the parse failed *) err_msg : string; (** Reason why parsing failed *) parse_state : [ | `Sexp of t list list parse_state | `Annot of Annotated.stack parse_state ] (** State of parser *) } (** Exception raised during partial parsing *) exception Parse_error of parse_error (** {6 Unannotated (partial) parsing} *) val parse : ?parse_pos : Parse_pos.t -> ?len : int -> string -> (string, t) parse_result (** [parse ?parse_pos ?len str] (partially) parses an S-expression in string buffer [str] starting out with position information provided in [parse_pos] and reading at most [len] characters. To parse a single atom that is not delimited by whitespace it is necessary to call this function a second time with the returned continuation, and a dummy buffer that contains whitespace. [parse] starts parsing [str] at position [parse_pos.buf_pos]. Each subsequent [parse_fun] from a [Cont] uses the [buf] and [pos] that is supplied to it. The final [parse_fun] that returns [Done] mutates the [buf_pos] in the originally supplied [parse_pos], and then returns it. @param parse_pos default = [Parse_pos.create ()] @param len default = [String.length str - parse_pos.Parse_pos.buf_pos] *) val parse_bigstring : ?parse_pos : Parse_pos.t -> ?len : int -> bigstring -> (bigstring, t) parse_result (** [parse_bigstring ?parse_pos ?len str] same as {!parse}, but operates on bigstrings. *) val input_sexp : ?parse_pos : Parse_pos.t -> in_channel -> t (** [input_sexp ?parse_pos ic] parses an S-expression from input channel [ic] using initial position information in [parse_pos]. NOTE: this function is not as fast on files as {!Sexp.load_sexp}, and is also slightly slower than the scan-functions. But it is guaranteed that [input_sexp] is only going to read data parseable as an S-expression. Thus, subsequent input functions will see the data immediately following it. @param parse_pos default = [Parse_pos.create ()] *) val input_sexps : ?parse_pos : Parse_pos.t -> ?buf : string -> in_channel -> t list (** [input_sexps ?parse_pos ?buf ic] parses whitespace separated S-expressions from input channel [ic] until EOF is reached. Faster than the scan-functions. @param parse_pos default = [Parse_pos.create ()] *) val input_rev_sexps : ?parse_pos : Parse_pos.t -> ?buf : string -> in_channel -> t list (** [input_rev_sexps ?parse_pos ?buf ic] same as {!Sexp.input_sexps}, but returns a reversed list of S-expressions, which is slightly more efficient. *) (** {6 Loading of (converted) S-expressions} *) val load_sexp : ?strict : bool -> ?buf : string -> string -> t (** [load_sexp ?strict ?buf file] reads one S-expression from [file] using buffer [buf] for storing intermediate data. Faster than the scan-functions. @raise Parse_error if the S-expression is unparseable. @raise Failure if parsing reached the end of file before one S-expression could be read. @raise Failure if [strict] is true and there is more than one S-expression in the file. @param strict default = [true] *) val load_sexps : ?buf : string -> string -> t list (** [load_sexps ?buf file] reads a list of whitespace separated S-expressions from [file] using buffer [buf] for storing intermediate data. Faster than the scan-functions. @raise Parse_error if there is unparseable data in the file. @raise Failure if parsing reached the end of file before the last S-expression could be fully read. *) val load_rev_sexps : ?buf : string -> string -> t list (** [load_rev_sexps ?buf file] same as {!Sexp.load_sexps}, but returns a reversed list of S-expressions, which is slightly more efficient. *) val load_sexp_conv : ?strict : bool -> ?buf : string -> string -> (t -> 'a) -> 'a Annotated.conv (** [load_sexp_conv ?strict ?buf file f] like {!Sexp.load_sexp}, but performs a conversion on the fly using [f]. Performance is equivalent to executing {!Sexp.load_sexp} and performing conversion when there are no errors. In contrast to the plain S-expression loader, this function not only performs the conversion, it will give exact error ranges for conversion errors. @raise Parse_error if there is unparseable data in the file. @raise Failure if parsing reached the end of file before the last S-expression could be fully read. *) val load_sexp_conv_exn : ?strict : bool -> ?buf : string -> string -> (t -> 'a) -> 'a (** [load_sexp_conv_exn ?strict ?buf file f] like {!load_sexp_conv}, but returns the converted value or raises [Of_sexp_error] with exact location information in the case of a conversion error. *) val load_sexps_conv : ?buf : string -> string -> (t -> 'a) -> 'a Annotated.conv list (** [load_sexps_conv ?buf file f] like {!Sexp.load_sexps}, but performs a conversion on the fly using [f]. Performance is equivalent to executing {!Sexp.load_sexps} and performing conversion when there are no errors. In contrast to the plain S-expression loader, this function not only performs the conversion, it will give exact error ranges for conversion errors. @raise Parse_error if there is unparseable data in the file. @raise Failure if parsing reached the end of file before the last S-expression could be fully read. *) val load_sexps_conv_exn : ?buf : string -> string -> (t -> 'a) -> 'a list (** [load_sexps_conv_exn ?buf file f] like {!load_sexps_conv}, but returns the converted value or raises [Of_sexp_error] with exact location information in the case of a conversion error. *) (** {6 Output of S-expressions to I/O-channels} *) (** NOTE: for performance reasons these output functions may need to allocate large strings to write out huge S-expressions. This may cause problems on 32-bit platforms. If you think that you may need to write huge S-expressions on such platforms, you might want to use the pretty-printers that write to formatters instead (see further below). *) val output_hum : out_channel -> t -> unit (** [output_hum oc sexp] outputs S-expression [sexp] to output channel [oc] in human readable form. *) val output_hum_indent : int -> out_channel -> t -> unit (** [output_hum_indent indent oc sexp] outputs S-expression [sexp] to output channel [oc] in human readable form using indentation level [indent]. *) val output_mach : out_channel -> t -> unit (** [output_mach oc sexp] outputs S-expression [sexp] to output channel [oc] in machine readable (i.e. most compact) form. *) val output : out_channel -> t -> unit (** [output oc sexp] same as [output_mach]. *) (** {6 Output of S-expressions to file} *) (** All save-functions write to a temporary file before moving it into place to avoid intermittent garbling of existing files, which may cause problems for other processes that try to read. *) val save_hum : ?perm : int -> string -> t -> unit (** [save_hum ?perm file sexp] outputs S-expression [sexp] to [file] in human readable form. @param perm default = umask *) val save_mach : ?perm : int -> string -> t -> unit (** [save_mach ?perm file sexp] outputs S-expression [sexp] to [file] in machine readable (i.e. most compact) form. @param perm default = umask *) val save : ?perm : int -> string -> t -> unit (** [save ?perm file sexp] same as {!save_mach}. *) val save_sexps_hum : ?perm : int -> string -> t list -> unit (** [save_sexps_hum ?perm file sexps] outputs S-expression list [sexps] to [file] in human readable form, each sexp being followed by a newline. @param perm default = umask *) val save_sexps_mach : ?perm : int -> string -> t list -> unit (** [save_sexps_mach ?perm file sexps] outputs S-expression list [sexps] to [file] in machine readable form, each sexp being followed by a newline. @param perm default = umask *) val save_sexps : ?perm : int -> string -> t list -> unit (** [save_sexps ?perm file sexp] same as {!save_sexps_mach}. *) (** {6 Output of S-expressions to formatters} *) val pp_hum : formatter -> t -> unit (** [pp_hum ppf sexp] outputs S-expression [sexp] to formatter [ppf] in human readable form. *) val pp_hum_indent : int -> 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_mach : formatter -> t -> unit (** [pp_mach ppf sexp] outputs S-expression [sexp] to formatter [ppf] in machine readable (i.e. most compact) form. *) val pp : formatter -> t -> unit (** [pp ppf sexp] same as [pp_mach]. *) (** {6 String and bigstring conversions} *) (** Module encapsulating the exception raised by string converters when type conversions fail. *) module Of_string_conv_exn : sig type t = { exc : exn; sexp : Type.t; sub_sexp : Type.t } exception E of t end val of_string : string -> t (** [of_string str] converts string [str] to an S-expression. NOTE: trailing whitespace is considered an error, which may be overly strict for some applications. Either strip the string of trailing whitespace first, or, even cheaper, use {!parse} instead. *) val of_string_conv : string -> (t -> 'a) -> 'a Annotated.conv (** [of_string_conv str conv] like {!of_string}, but performs type conversion with [conv]. @return conversion result. *) val of_string_conv_exn : string -> (t -> 'a) -> 'a (** [of_string_conv_exn str conv] like {!of_string_conv}, but raises {!Of_string_conv_exn.E} if type conversion fails. @return converted value. *) val of_bigstring : bigstring -> t (** [of_bigstring bstr] same as {!of_string}, but operates on bigstrings. *) val of_bigstring_conv : bigstring -> (t -> 'a) -> 'a Annotated.conv (** [of_bigstring_conv bstr conv] like {!of_bigstring}, but performs type conversion with [conv]. @return conversion result. *) val of_bigstring_conv_exn : bigstring -> (t -> 'a) -> 'a (** [of_bigstring_conv_exn bstr conv] like {!of_bigstring_conv}, but raises {!Of_string_conv_exn.E} if type conversion fails. @return converted value. *) val to_string_hum : ?indent : int -> t -> string (** [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_mach : t -> string (** [to_string_mach sexp] converts S-expression [sexp] to a string in machine readable (i.e. most compact) form. *) val to_string : t -> string (** [to_string sexp] same as [to_string_mach]. *) (** {6 Buffer conversions} *) val to_buffer_hum : buf : Buffer.t -> ?indent : int -> t -> unit (** [to_buffer_hum ~buf ?indent sexp] outputs the S-expression [sexp] converted to a string in human readable form to buffer [buf]. @param indent default = [!default_indent] *) val to_buffer_mach : buf : Buffer.t -> t -> unit (** [to_buffer_mach ~buf sexp] outputs the S-expression [sexp] converted to a string in machine readable (i.e. most compact) form to buffer [buf]. *) val to_buffer : buf : Buffer.t -> t -> unit (** [to_buffer ~buf sexp] same as {!to_buffer_mach}. *) val to_buffer_gen : buf : 'buffer -> add_char : ('buffer -> char -> unit) -> add_string : ('buffer -> string -> unit) -> t -> unit (** [to_buffer_gen ~buf ~add_char ~add_string sexp] outputs the S-expression [sexp] converted to a string to buffer [buf] using the output functions [add_char] and [add_string]. *) (** {6 Utilities for automated type conversions} *) val unit : t (** [unit] the unit-value as expressed by an S-expression. *) val sexp_of_t : t -> t (** [sexp_of_t sexp] maps S-expressions which are part of a type with automated S-expression conversion to themselves. *) val t_of_sexp : t -> t (** [t_of_sexp sexp] maps S-expressions which are part of a type with automated S-expression conversion to themselves. *) (** {6 Utilities for conversion error handling} *) type found = [ `Found | `Pos of int * found ] (** Type of successful search results. [`Found] means that an S-expression was found at the immediate position, and [`Pos (pos, found)] indicates that it was found at position [pos] within a structure (= S-expression list) where [found] describes recursively where it was found in that structure. *) type search_result = [ `Not_found | found ] (** Type of search results. [`Not_found] means that an S-expression was not found within another S-expression. *) val search_physical : t -> contained : t -> search_result (** [search_physical sexp ~contained] @return the search result indicating whether, and if, where the S-expression [contained] was found within S-expression [sexp]. *) val subst_found : t -> subst : t -> found -> t (** [subst_found sexp ~subst found] @return the S-expression that results from substituting [subst] within S-expression [sexp] at the location described by [found]. *) (** S-expressions annotated with relative source positions and comments *) module With_layout : sig (* relative source positions *) type pos = Src_pos.Relative.t = { row : int; col : int } val sexp_of_pos : pos -> Type.t (** S-expressions annotated with relative source positions and comments *) type t = | Atom of pos * string * string option (* second is quoted representation *) | List of pos * t_or_comment list * pos (* positions of left and right parens *) and t_or_comment = | Sexp of t | Comment of comment and comment = | Plain_comment of pos * string (* line or block comment *) | Sexp_comment of pos * comment list * t (* position of #; *) val sexp_of_t : t -> Type.t val sexp_of_comment : comment -> Type.t val sexp_of_t_or_comment : t_or_comment -> Type.t module Forget : sig val t : t -> Type.t val t_or_comment : t_or_comment -> Type.t option val t_or_comments : t_or_comment list -> Type.t list end module Render : sig type asexp type 'a t (* monad for position-respecting asexp rendering *) val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t val sexp : asexp -> unit t (* assumes that positions in [asexp] are relative *) val run : (char -> unit) -> unit t -> unit end with type asexp := t_or_comment module Parser : sig type token val sexp : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> t_or_comment val sexp_opt : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> t_or_comment option val sexps : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> t_or_comment list val rev_sexps : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> t_or_comment list (* for debugging only, cannot be used otherwise anyway *) val sexps_abs : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Type_with_layout.Parsed.t_or_comment list end module Lexer : sig val main : ?buf:Buffer.t -> Lexing.lexbuf -> Parser.token end end end sexplib-113.33.03/src/sexp_with_layout.ml000066400000000000000000000127471271035576100202450ustar00rootroot00000000000000(* packaging of annotated sexp functions *) module List = struct let iter t ~f = List.iter f t let map t ~f = List.rev (List.rev_map f t) end include Type_with_layout type pos = Src_pos.Relative.t = { row : int; col : int } let sexp_of_pos = Src_pos.Relative.sexp_of_t module Lexer = struct let main = Lexer.main_with_layout end module Parser = Parser_with_layout module Render = struct module Rel_pos = Src_pos.Relative module Abs_pos = Src_pos.Absolute type last_atom = { immed_after : Abs_pos.t; unescaped : bool; } type state = { mutable row_shift : Rel_pos.t; mutable current : Abs_pos.t; mutable last_atom : last_atom option; } (* the point of [immed_after_last_atom] is to prevent (A B C) from rendering as (A BBC) after we replace B with BB *) type 'a t = (char -> unit) -> state -> 'a let return a _putc _st = a let bind m f putc st = f (m putc st) putc st let run putc m = m putc { row_shift = Rel_pos.zero; current = Abs_pos.origin; last_atom = None; } let emit_char putc st c = let {Abs_pos.col; row} = st.current in putc c; if c = '\n' then st.current <- {Abs_pos.row = 1 + row; col = 1} else st.current <- {Abs_pos.row; col = 1 + col} let emit_string putc st str = let n = String.length str in for i = 0 to n - 1 do emit_char putc st str.[i] done let emit_chars putc st c ~n = emit_string putc st (String.make n c) let advance putc ~anchor st ~by:delta ~unescaped_atom = let new_pos = Abs_pos.add (Abs_pos.add anchor delta) st.row_shift in let need_to_leave_room_between_two_unescaped_atoms_lest_they_become_one = unescaped_atom && begin match st.last_atom with | Some {immed_after; unescaped = prev_unescaped} -> new_pos = immed_after && prev_unescaped | None -> false end in let need_to_reposition = not (Abs_pos.geq new_pos st.current) || need_to_leave_room_between_two_unescaped_atoms_lest_they_become_one in let (row_delta, new_pos) = if need_to_reposition then begin (* repositioning heuristic: just move to the next fresh row *) let new_row = 1 + st.current.Abs_pos.row in let row_delta = new_row - new_pos.Abs_pos.row in (row_delta, {Abs_pos.row = new_row; col = new_pos.Abs_pos.col}) end else (0, new_pos) in begin (* advance to new_pos by emitting whitespace *) if new_pos.Abs_pos.row > st.current.Abs_pos.row then begin let n = (new_pos.Abs_pos.row - st.current.Abs_pos.row) in emit_chars putc st '\n' ~n end; if new_pos.Abs_pos.col > st.current.Abs_pos.col then begin let n = (new_pos.Abs_pos.col - st.current.Abs_pos.col) in emit_chars putc st ' ' ~n end; end; assert (new_pos = st.current); st.row_shift <- { st.row_shift with Rel_pos. row = st.row_shift.Rel_pos.row + row_delta; } let rec render_t putc ~anchor (st : state) t = match t with | Atom (delta, text, fmt_text) -> let fmt_text = match fmt_text with | None | Some "" -> Pre_sexp.mach_maybe_esc_str text | Some text -> text in let unescaped = fmt_text.[0] <> '"' in advance putc st ~by:delta ~anchor ~unescaped_atom:unescaped; emit_string putc st fmt_text; st.last_atom <- Some { immed_after = st.current; unescaped; }; | List (start_delta, tocs, end_delta) -> advance putc st ~by:start_delta ~anchor ~unescaped_atom:false; let child_anchor = Abs_pos.sub st.current st.row_shift in emit_char putc st '('; List.iter tocs ~f:(fun toc -> render_toc putc ~anchor:child_anchor st toc); advance putc st ~by:end_delta ~anchor ~unescaped_atom:false; emit_char putc st ')'; () and render_toc putc ~anchor st = function | Sexp t -> render_t putc ~anchor st t | Comment c -> render_c putc ~anchor st c and render_c putc ~anchor st = function | Plain_comment (delta, text) -> advance putc st ~by:delta ~anchor ~unescaped_atom:false; emit_string putc st text | Sexp_comment (delta, cs, t) -> advance putc st ~by:delta ~anchor ~unescaped_atom:false; emit_string putc st "#;"; List.iter cs ~f:(render_c putc ~anchor st); render_t putc ~anchor st t let render asexp putc st = render_toc putc ~anchor:Abs_pos.origin st asexp let sexp = render end module Forget = struct (* In cps to prevent non-tail recursion. The polymorphism in the signature ensures that each function returns only through the continuation. *) module Cps : sig val forget_t : t -> (Type.t -> 'r) -> 'r val forget_toc : t_or_comment -> (Type.t option -> 'r) -> 'r val forget_tocs : t_or_comment list -> (Type.t list -> 'r) -> 'r end = struct let rec forget_t t k = match t with | Atom (_, x, _) -> k (Type.Atom x) | List (_, tocs, _) -> forget_tocs tocs (fun xs -> k (Type.List xs)) and forget_tocs tocs k = match tocs with | [] -> k [] | toc :: tocs -> forget_toc toc (function | None -> forget_tocs tocs k | Some x -> forget_tocs tocs (fun xs -> k (x :: xs))) and forget_toc toc k = match toc with | Comment _ -> k None | Sexp t -> forget_t t (fun x -> k (Some x)) end let t x = Cps.forget_t x (fun y -> y) let t_or_comment x = Cps.forget_toc x (fun y -> y) let t_or_comments x = Cps.forget_tocs x (fun y -> y) end sexplib-113.33.03/src/src_pos.ml000066400000000000000000000020571271035576100162770ustar00rootroot00000000000000(* for lexing positions: - lnum starts from 1 - cnum starts from 0 - pos_bol is the position of the first character of the line for absolute pos: - row starts from 1 - col starts from 1 for relative pos, obviously 0 means same position *) (* operations that make sense for both absolute and relative positions *) module Pos = struct type t = { row : int; col : int } let sexp_of_t {row; col} = Type.Atom (Printf.sprintf "%d:%d" row col) let add t1 t2 = { row = t1.row + t2.row; col = t1.col + t2.col; } let sub t1 t2 = { row = t1.row - t2.row; col = t1.col - t2.col; } let compare {row = r1; col = c1} {row = r2; col = c2} = if r1 = r2 then c1 - c2 else r1 - r2 let geq t1 t2 = compare t1 t2 >= 0 end module Relative = struct include Pos let zero = {row = 0; col = 0} end module Absolute = struct include Pos let origin = {row = 1; col = 1} let of_lexing {Lexing.pos_lnum; pos_cnum; pos_bol; pos_fname = _ } = { row = pos_lnum; col = pos_cnum - pos_bol + 1; } let diff = sub end sexplib-113.33.03/src/src_pos.mli000066400000000000000000000010571271035576100164470ustar00rootroot00000000000000(** source positions, both relative and absolute *) module Relative : sig type t = { row : int; col : int } val sexp_of_t : t -> Type.t val zero : t val add : t -> t -> t val sub : t -> t -> t end module Absolute : sig type t = { row : int; col : int } val sexp_of_t : t -> Type.t val origin : t (* first row, first column *) val of_lexing : Lexing.position -> t val diff : t -> t -> Relative.t val add : t -> Relative.t -> t val sub : t -> Relative.t -> t (*val compare : t -> t -> int*) val geq : t -> t -> bool end sexplib-113.33.03/src/std.ml000066400000000000000000000026001271035576100154130ustar00rootroot00000000000000module Hashtbl = struct include Hashtbl let sexp_of_t = Conv.sexp_of_hashtbl let t_of_sexp = Conv.hashtbl_of_sexp end module Lazy = struct include Lazy let t_of_sexp = Conv.lazy_t_of_sexp let sexp_of_t = Conv.sexp_of_lazy_t end module Sexp_macro = Macro let sexp_of_unit = Conv.sexp_of_unit let unit_of_sexp = Conv.unit_of_sexp let sexp_of_bool = Conv.sexp_of_bool let bool_of_sexp = Conv.bool_of_sexp let sexp_of_string = Conv.sexp_of_string let string_of_sexp = Conv.string_of_sexp let sexp_of_char = Conv.sexp_of_char let char_of_sexp = Conv.char_of_sexp let sexp_of_int = Conv.sexp_of_int let int_of_sexp = Conv.int_of_sexp let sexp_of_float = Conv.sexp_of_float let float_of_sexp = Conv.float_of_sexp let sexp_of_int32 = Conv.sexp_of_int32 let int32_of_sexp = Conv.int32_of_sexp let sexp_of_int64 = Conv.sexp_of_int64 let int64_of_sexp = Conv.int64_of_sexp let sexp_of_nativeint = Conv.sexp_of_nativeint let nativeint_of_sexp = Conv.nativeint_of_sexp let sexp_of_ref = Conv.sexp_of_ref let ref_of_sexp = Conv.ref_of_sexp let sexp_of_lazy_t = Conv.sexp_of_lazy_t let lazy_t_of_sexp = Conv.lazy_t_of_sexp let sexp_of_option = Conv.sexp_of_option let option_of_sexp = Conv.option_of_sexp let sexp_of_list = Conv.sexp_of_list let list_of_sexp = Conv.list_of_sexp let sexp_of_array = Conv.sexp_of_array let array_of_sexp = Conv.array_of_sexp let sexp_of_exn = Conv.sexp_of_exn sexplib-113.33.03/src/type.ml000066400000000000000000000001061271035576100156010ustar00rootroot00000000000000(** Type of S-expressions *) type t = Atom of string | List of t list sexplib-113.33.03/src/type_with_layout.ml000066400000000000000000000056701271035576100202440ustar00rootroot00000000000000(** Type of annotated S-expressions *) module List = struct let map t ~f = List.rev (List.rev_map f t) end module Make (Pos : sig type t val sexp_of_t : t -> Type.t end) = struct module T = struct type t = | Atom of Pos.t * string * string option (* second is quoted representation *) | List of Pos.t * t_or_comment list * Pos.t (* positions of left and right parens *) and t_or_comment = | Sexp of t | Comment of comment and comment = | Plain_comment of Pos.t * string | Sexp_comment of Pos.t * comment list * t end include T module type S = sig include module type of T val sexp_of_t : t -> Type.t val sexp_of_comment : comment -> Type.t val sexp_of_t_or_comment : t_or_comment -> Type.t end module To_sexp : sig val of_t : t -> Type.t val of_comment : comment -> Type.t val of_t_or_comment : t_or_comment -> Type.t end = struct (* maybe we can actually use conv here, instead of inlining it *) let of_pos = Pos.sexp_of_t let of_string x = Type.Atom x let of_list of_a xs = Type.List (List.map ~f:of_a xs) let of_option of_a = function | Some x -> Type.List [of_a x] | None -> Type.List [] let rec of_t = function | Atom (v1, v2, v3) -> Type.List [Type.Atom "Atom"; of_pos v1; of_string v2; of_option of_string v3] | List (v1, v2, v3) -> Type.List [Type.Atom "List"; of_pos v1; of_list of_t_or_comment v2; of_pos v3] and of_t_or_comment = function | Sexp t -> Type.List [Type.Atom "Sexp"; of_t t] | Comment c -> Type.List [Type.Atom "Comment"; of_comment c] and of_comment = function | Plain_comment (v1, v2) -> Type.List [Type.Atom "Plain_comment"; of_pos v1; of_string v2] | Sexp_comment (v1, v2, v3) -> Type.List [Type.Atom "Sexp_comment"; of_pos v1; of_list of_comment v2; of_t v3] end let sexp_of_t = To_sexp.of_t let sexp_of_comment = To_sexp.of_comment let sexp_of_t_or_comment = To_sexp.of_t_or_comment end include Make (Src_pos.Relative) module Parsed = Make (Src_pos.Absolute) let relativize = let rel ~outer_p p = Src_pos.Absolute.diff p outer_p in let rec aux_t ~outer_p = function | Parsed.Atom (pos, s, sopt) -> Atom (rel pos ~outer_p, s, sopt) | Parsed.List (start_pos, tocs, end_pos) -> List ( rel start_pos ~outer_p , List.map tocs ~f:(fun toc -> aux_toc ~outer_p:start_pos toc) , rel end_pos ~outer_p ) and aux_toc ~outer_p = function | Parsed.Sexp t -> Sexp (aux_t t ~outer_p) | Parsed.Comment c -> Comment (aux_c c ~outer_p) and aux_c ~outer_p = function | Parsed.Plain_comment (pos, txt) -> Plain_comment (rel pos ~outer_p, txt) | Parsed.Sexp_comment (pos, cs, t) -> Sexp_comment ( rel pos ~outer_p , List.map cs ~f:(fun c -> aux_c ~outer_p c) , aux_t t ~outer_p ) in fun toc -> aux_toc toc ~outer_p:Src_pos.Absolute.origin sexplib-113.33.03/src/type_with_layout.mli000066400000000000000000000017671271035576100204200ustar00rootroot00000000000000(** S-expressions annotated with relative source positions and comments *) module Make (Pos : sig type t val sexp_of_t : t -> Type.t end) : sig module type S = sig (** S-expressions annotated with relative source positions and comments *) type t = | Atom of Pos.t * string * string option (* optional quoted representation *) | List of Pos.t * t_or_comment list * Pos.t (* left & right paren positions *) and t_or_comment = | Sexp of t | Comment of comment and comment = | Plain_comment of Pos.t * string (* line or block comment *) | Sexp_comment of Pos.t * comment list * t (* #; position *) val sexp_of_t : t -> Type.t val sexp_of_comment : comment -> Type.t val sexp_of_t_or_comment : t_or_comment -> Type.t end end module Parsed : Make(Src_pos.Absolute).S (** parsing produces absolute positions *) include Make(Src_pos.Relative).S (* the exposed type contains relative positions *) val relativize : Parsed.t_or_comment -> t_or_comment sexplib-113.33.03/test/000077500000000000000000000000001271035576100144615ustar00rootroot00000000000000sexplib-113.33.03/test/test_macros.ml000066400000000000000000000331261271035576100173430ustar00rootroot00000000000000open Sexplib open Sexplib.Conv open Printf module type Load = sig val load_sexp_conv_exn : string -> (Sexp.t -> 'a) -> 'a val load_sexps_conv : string -> (Sexp.t -> 'a) -> 'a Sexp.Annotated.conv list end exception E of [ `Expected of Sexp.t ] * [ `Got of Sexp.t ] [@@deriving sexp] let () = Printexc.register_printer (fun exc -> match Sexplib.Conv.sexp_of_exn_opt exc with | None -> None | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) let command_exn str = match Sys.command str with | 0 -> () | code -> failwith (sprintf "command %S exited with code %d" str code) module Make (Load : Load) = struct module Macro = struct end (* shadowing Macro to avoid mistakenly calling it instead of Load *) let test_id = ref 0 let id x = x let with_files files ~f = let time = Unix.time () in incr test_id; let dir = sprintf "%s/macros-test/macros-test-%f-%d" (Filename.get_temp_dir_name ()) time !test_id in List.iter (fun (file, contents) -> let file_dir = Filename.concat dir (Filename.dirname file) in command_exn ("mkdir -p " ^ file_dir); let out_channel = open_out (Filename.concat dir file) in output_string out_channel (contents ^ "\n"); close_out out_channel) files; let tear_down () = command_exn ("rm -rf -- " ^ dir); in try let v = f dir in tear_down (); v with e -> tear_down (); raise e let check files expected = with_files files ~f:(fun dir -> let actual = Load.load_sexp_conv_exn (Filename.concat dir "input.sexp") id in let expected = Sexp.of_string expected in if actual <> expected then raise (E (`Expected expected, `Got actual)) ) (* Not quite the same as [Str] functions because it reapplies itself, see the use below to eliminate "/./././...". *) let replace ~sub ~by str = let rec loop str i = if i + String.length sub < String.length str then if String.sub str i (String.length sub) = sub then let str = String.sub str 0 i ^ by ^ String.sub str (i + String.length sub) (String.length str - i - String.length sub) in loop str i else loop str (i + 1) else str in loop str 0 let contains str ~sub = Str.string_match (Str.regexp (sprintf ".*%s.*" (Str.quote sub))) str 0 let normalize str = try Sexp.to_string (Sexp.of_string str) with _ -> str type try_parse_string = string let sexp_of_try_parse_string str = try Sexp.of_string str with _ -> sexp_of_string str exception Wrong_error of exn * [ `Expected_to_contain of try_parse_string ] [@@deriving sexp] let check_error ?f ~expect files = with_files files ~f:(fun dir -> let file = Filename.concat dir "input.sexp" in let error_kind = try match f with | Some f -> ignore (Load.load_sexp_conv_exn file f); `No_error | None -> ignore (Load.load_sexp_conv_exn file id); `No_error with e -> `Error e in match error_kind with | `Error e -> List.iter (fun expect -> let expect = replace ~sub:"DIR" ~by:dir expect in let str = replace ~sub:"/./" ~by:"/" (Printexc.to_string e) in if not (contains (normalize str) ~sub:(normalize expect)) then raise (Wrong_error (e, `Expected_to_contain expect))) expect | `No_error -> failwith (sprintf "File %s expected to throw an exception, but loaded successfully." file)) let check_error_count ~f files ~expected_count = with_files files ~f:(fun dir -> let file = Filename.concat dir "input.sexp" in let results = Load.load_sexps_conv file f in let rec count = function | `Error _ :: xs -> 1 + count xs | `Result _ :: xs -> count xs | [] -> 0 in let actual_count = count results in if actual_count <> expected_count then failwith (sprintf "Expected %d errors, got %d." expected_count actual_count)) let%test_unit "simple" = check [ "input.sexp" , "(:include defs.sexp) ((field1 value1) (field2 ((:include include.sexp) 0004 0005)) (field3 (:concat a (:use f (x (:use x))))))" ; "defs.sexp" , "(:let x () y z) (:let f (x) (:concat (:use x) (:use x)))" ; "include.sexp" , "0001 0002 0003" ] "((field1 value1) (field2 (0001 0002 0003 0004 0005)) (field3 ayzyz))" let%test_unit "include chain with subdirectories" = check [ "input.sexp" , "(:include include/a.sexp)" ; "include/a.sexp" , "(:include b.sexp)" ; "include/b.sexp" , "(this is include/b)" ] "(this is include/b)" let%test_unit "hello world" = check [ "input.sexp" , "(:include defs.sexp) (:include template.sexp) (:use f (a (:use a)) (b (:use b)))" ; "defs.sexp" , "(:let a () hello) (:let b () \" world\")" ; "template.sexp" , "(:let f (a b) (:concat (:use a) (:use b)))" ] "\"hello world\"" let%test_unit "nested let" = check [ "input.sexp" , "(:let f (x) (:let g (y) (:use y) (:use y)) (:use g (y (:use x))) (:use g (y (:use x)))) (:concat (:use f (x x)))" ] "xxxx" let%test_unit "argument list scoping" = check [ "input.sexp" , "(:let a () a) (:let b () b) (:let f (b a) (:concat (:use b) (:use a))) (:use f (b (:use a)) (a (:use b)))" ] "ab" let%test_unit "empty argument" = check [ "input.sexp" , "(:let f (x) (:use x) bla) (:use f (x))" ] "bla" let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:let f (()) foo)" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:1:9 (Failure \"Error evaluating macros: Atom expected\")) ())"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:let f x foo)" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:1:8 (Failure \"Error evaluating macros: Atom list expected\")) x)"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:concat :use x)" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:1:9 (Failure \"Error evaluating macros: Unexpected :use\")) :use)"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:let f (x) (:use x)) (:use f (()))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:2:17 (Failure \"Error evaluating macros: Malformed argument\")) (()))"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:let f (x) (:use x)) (:use f (y x))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:2:9 (Failure \"Error evaluating macros: Formal args of f differ from supplied args, formal args are [x]\")) (:use f (y x)))"] let%test_unit _ = check_error [ "input.sexp" , "(:let f (a) body of f) (:use f (a a))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/input.sexp:1:0 (Failure \"Error evaluating macros: Unused variables: a\")) (:let f (a) body of f))"] let%test_unit _ = check_error [ "input.sexp" , "(:let f (a a) (:concat (:use a) (:use a))) (:use f (a foo) (a foo))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/input.sexp:1:0 (Failure \"Error evaluating macros: Duplicated let argument: a\")) (:let f (a a) (:concat (:use a) (:use a))))"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp) (:use f (x bla))" ; "include.sexp" , "(:let y () bla) (:let f (x) ((:use x) (:use y)))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:2:9 (Failure \"Error evaluating macros: Undeclared arguments in let: y\")) (:let f (x) ((:use x) (:use y))))"] let%test_unit _ = check_error [ "input.sexp" , "(:let x () x) (:include include.sexp)" ; "include.sexp" , "(:use x)" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:1:6 (Failure \"Error evaluating macros: Undefined variable (included files cannot reference variables from outside)\")) x)"] let%test_unit ":include can cause variable capture" = check [ "input.sexp" , "(:let x () 2) (:include include.sexp) (:use x)" ; "include.sexp" , "(:let x () 1)" ] "1" let%test_unit _ = check_error [ "input.sexp" , "(:concat (a b))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/input.sexp:1:0 (Failure \"Error evaluating macros: Malformed concat application: (:concat(a b))\")) (:concat (a b)))"] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp) (:use f (a ()))" ; "include.sexp" , "(:let f (a) (:concat (:use a)))" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:2:11 (Failure \"Error evaluating macros: Malformed concat application: (:concat())\")) (:concat (:use a)))"] let%test_unit "correct error location in a nested let" = check_error [ "input.sexp" , "(:let f () (:let g () (:let incorrect)) (:use g)) (:use f)" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/input.sexp:2:23 (Failure \"Error evaluating macros: Unexpected :let\")) :let)"] let%test_unit "correct location with chains of includes" = check_error [ "input.sexp" , "(:include a)" ; "a" , "(:include b)" ; "b" , "something invalid like :concat" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/b:1:23 (Failure \"Error evaluating macros: Unexpected :concat\")) :concat)"] let%test_unit _ = check_error [ "input.sexp" , "\n(:let f ())" ] ~expect:["(Sexplib.Conv.Of_sexp_error (Sexplib.Sexp.Annotated.Conv_exn DIR/input.sexp:2:0 (Failure \"Error evaluating macros: Empty let bodies not allowed\")) (:let f ()))"] let rec conv_error = function | Sexp.List [ Sexp.Atom "trigger"; Sexp.Atom "error" ] as t -> raise (Pre_sexp.Of_sexp_error (Exit, t)) | Sexp.Atom _ -> () | Sexp.List ts -> List.iter conv_error ts let%test_unit "error location for conversion errors" = check_error ~f:conv_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:let err () error) (foo bar (trigger (:use err)))" ] ~expect:["((Sexplib.Sexp.Annotated.Conv_exn DIR/include.sexp:2:18 \"Exit\") (trigger (:use err)) (expanded (trigger error)))"] let%test_unit "multiple conversion errors" = check_error_count ~f:conv_error ~expected_count:2 [ "input.sexp" , "(:include include.sexp) (:include include.sexp)" ; "include.sexp" , "(:let err () error) (foo bar (trigger (:use err)))" ] let%test_unit _ = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:include include.sexp)" ] ~expect:["Macro.Include_loop_detected(\"DIR/include.sexp\")"] (* The exact form of the error messages below will depend on whether we are using the sexplib or the async sexp reader, so we only match on relevant expression parts. *) (* what stops this loop is that the filenames become too long. We have to rewrite the error messages since the exact number of "./" in the path depends on the limit on path length. *) let%test_unit "sneaky include loop" = check_error [ "input.sexp" , "(:include include.sexp)" ; "include.sexp" , "(:include ././include.sexp)" ] ~expect:["DIR/include.sexp"; "File name too long"] let%test_unit "parsing error 1" = check_error [ "input.sexp" , "(:include include.sexp) ()" ; "include.sexp" , ")" ] ~expect:["DIR/include.sexp"; "unexpected character: ')'"] let%test_unit "parsing error 2" = check_error [ "input.sexp" , "(:include include.sexp) ()" ; "include.sexp" , "(" ] ~expect:["DIR/include.sexp"] end module M = Make (Macro) let%test_unit _ = match Macro.expand_local_macros [Sexp.of_string "(:use x)"] with | `Result _ -> assert false | `Error (e, _) -> let expected = "(Failure\"Error evaluating macros: Undefined variable\")" in if Sexp.to_string (sexp_of_exn e) <> expected then raise e ;; sexplib-113.33.03/test/test_macros.mli000066400000000000000000000003341271035576100175070ustar00rootroot00000000000000open Sexplib module type Load = sig val load_sexp_conv_exn : string -> (Sexp.t -> 'a) -> 'a val load_sexps_conv : string -> (Sexp.t -> 'a) -> 'a Sexp.Annotated.conv list end module Make (Load : Load) : sig end sexplib-113.33.03/test/test_sexp_with_layout.ml000066400000000000000000000033431271035576100214640ustar00rootroot00000000000000(* packaging of annotated sexp functions *) open Sexplib module M = Sexp.With_layout let%test_module "forget" = (module struct (* dummies *) let dumb_pos = {M.row = 0; col = 0} let dumb_comment = M.Plain_comment (dumb_pos, "comment") let atom x = M.Sexp (M.Atom (dumb_pos, x, None)) let list ts = M.Sexp (M.List (dumb_pos, ts, dumb_pos)) let comment = M.Comment dumb_comment let a1 = comment let a2 = atom "hello" let a3 = list [comment; atom "yo"; comment; atom "yo"; comment; atom "ma"; comment] let a4 = list [comment; a1; comment; a2; comment; a3; comment; a3] let a5 = list [comment; a1; comment; a2; comment; a3; comment; a4] let b2 = Sexp.Atom "hello" let b3 = Sexp.List [Sexp.Atom "yo"; Sexp.Atom "yo"; Sexp.Atom "ma"] let b4 = Sexp.List [b2; b3; b3] let b5 = Sexp.List [b2; b3; b4] let%test _ = M.Forget.t_or_comment a1 = None let%test _ = M.Forget.t_or_comment a2 = Some b2 let%test _ = M.Forget.t_or_comment a3 = Some b3 let%test _ = M.Forget.t_or_comment a4 = Some b4 let%test _ = M.Forget.t_or_comment a5 = Some b5 module Simple_forget = struct let rec t = function | M.Atom (_, x, _) -> Sexp.Atom x | M.List (_, ts, _) -> Sexp.List (t_or_comments ts) and t_or_comments = function | [] -> [] | t :: ts -> match t_or_comment t with | None -> t_or_comments ts | Some s -> s :: t_or_comments ts and t_or_comment = function | M.Sexp x -> Some (t x) | M.Comment _ -> None end let same_as_simple x = M.Forget.t_or_comment x = Simple_forget.t_or_comment x let%test _ = same_as_simple a1 let%test _ = same_as_simple a2 let%test _ = same_as_simple a3 let%test _ = same_as_simple a4 let%test _ = same_as_simple a5 end) sexplib-113.33.03/top/000077500000000000000000000000001271035576100143045ustar00rootroot00000000000000sexplib-113.33.03/top/sexplib_install_printers.ml000066400000000000000000000011271271035576100217610ustar00rootroot00000000000000let printers = [ "Sexplib.Sexp.pp_hum" ] let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = let lexbuf = Lexing.from_string str in let phrase = !Toploop.parse_toplevel_phrase lexbuf in Toploop.execute_phrase print_outcome err_formatter phrase let rec install_printers = function | [] -> true | printer :: printers -> let cmd = Printf.sprintf "#install_printer %s;;" printer in eval_string cmd && install_printers printers let () = if not (install_printers printers) then Format.eprintf "Problem installing Sexplib-printers@." sexplib-113.33.03/unix/000077500000000000000000000000001271035576100144655ustar00rootroot00000000000000sexplib-113.33.03/unix/lib/000077500000000000000000000000001271035576100152335ustar00rootroot00000000000000sexplib-113.33.03/unix/lib/sexplib_unix_conv.ml000066400000000000000000000013341271035576100213240ustar00rootroot00000000000000(** Exception sexp converters that are Unix-specific. Handles [Unix.Unix_error]. Write [let () = Sexplib_unix.Sexplib_unix_conv.linkme] in your program to ensure that the code in this module is run, i.e. the unix-specific exception converters are added. This is already done by [Core.Std], so any application that uses Core need not worry about this module at all. *) open Sexplib.Sexp open Sexplib.Conv let () = Exn_converter.add_auto ~finalise:false (Unix.Unix_error (Unix.E2BIG, "", "")) (function | Unix.Unix_error (err, loc, arg) -> let err_str = Unix.error_message err in List [Atom "Unix.Unix_error"; Atom err_str; Atom loc; Atom arg] | _ -> assert false) let linkme = () sexplib-113.33.03/vim/000077500000000000000000000000001271035576100142755ustar00rootroot00000000000000sexplib-113.33.03/vim/syntax/000077500000000000000000000000001271035576100156235ustar00rootroot00000000000000sexplib-113.33.03/vim/syntax/sexplib.vim000066400000000000000000000071301271035576100200070ustar00rootroot00000000000000" Vim syntax file " Language: S-expressions as used in Sexplib " Filenames: *.sexp " Maintainers: Markus Mottl " URL: http://www.ocaml.info/vim/syntax/sexplib.vim " Last Change: 2012 Jun 20 - Fixed a block comment highlighting bug (MM) " 2012 Apr 24 - Added support for new comment styles (MM) " 2009 Apr 02 - First release (MM) " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded if version < 600 syntax clear elseif exists("b:current_syntax") && b:current_syntax == "sexplib" finish endif " Sexplib is case sensitive. syn case match " Comments syn keyword sexplibTodo contained TODO FIXME XXX NOTE syn region sexplibBlockComment matchgroup=sexplibComment start="#|" matchgroup=sexplibComment end="|#" contains=ALLBUT,sexplibQuotedAtom,sexplibUnquotedAtom,sexplibEncl,sexplibComment syn match sexplibSexpComment "#;" skipwhite skipempty nextgroup=sexplibQuotedAtomComment,sexplibUnquotedAtomComment,sexplibListComment,sexplibComment syn region sexplibQuotedAtomComment start=+"+ skip=+\\\\\|\\"+ end=+"+ contained syn match sexplibUnquotedAtomComment /\([^;()" \t#|]\|#[^;()" \t|]\||[^;()" \t#]\)[^;()" \t]*/ contained syn region sexplibListComment matchgroup=sexplibComment start="(" matchgroup=sexplibComment end=")" contained contains=ALLBUT,sexplibEncl,sexplibString,sexplibQuotedAtom,sexplibUnquotedAtom,sexplibTodo,sexplibNumber,sexplibFloat syn match sexplibComment ";.*" contains=sexplibTodo " Atoms syn match sexplibUnquotedAtom /\([^;()" \t#|]\|#[^;()" \t|]\||[^;()" \t#]\)[^;()" \t]*/ syn region sexplibQuotedAtom start=+"+ skip=+\\\\\|\\"+ end=+"+ syn match sexplibNumber "\<-\=\d\(_\|\d\)*[l|L|n]\?\>" syn match sexplibNumber "\<-\=0[x|X]\(\x\|_\)\+[l|L|n]\?\>" syn match sexplibNumber "\<-\=0[o|O]\(\o\|_\)\+[l|L|n]\?\>" syn match sexplibNumber "\<-\=0[b|B]\([01]\|_\)\+[l|L|n]\?\>" syn match sexplibFloat "\<-\=\d\(_\|\d\)*\.\?\(_\|\d\)*\([eE][-+]\=\d\(_\|\d\)*\)\=\>" " Lists syn region sexplibEncl transparent matchgroup=sexplibEncl start="(" matchgroup=sexplibEncl end=")" contains=ALLBUT,sexplibParenErr " Errors syn match sexplibUnquotedAtomErr /\([^;()" \t#|]\|#[^;()" \t|]\||[^;()" \t#]\)[^;()" \t]*\(#|\||#\)[^;()" \t]*/ syn match sexplibParenErr ")" " Synchronization syn sync minlines=50 syn sync maxlines=500 " Define the default highlighting. " For version 5.7 and earlier: only when not done already " For version 5.8 and later: only when an item doesn't have highlighting yet if version >= 508 || !exists("did_sexplib_syntax_inits") if version < 508 let did_sexplib_syntax_inits = 1 command -nargs=+ HiLink hi link else command -nargs=+ HiLink hi def link endif HiLink sexplibParenErr Error HiLink sexplibUnquotedAtomErr Error HiLink sexplibComment Comment HiLink sexplibSexpComment Comment HiLink sexplibQuotedAtomComment Include HiLink sexplibUnquotedAtomComment Comment HiLink sexplibBlockComment Comment HiLink sexplibListComment Comment HiLink sexplibBoolean Boolean HiLink sexplibCharacter Character HiLink sexplibNumber Number HiLink sexplibFloat Float HiLink sexplibUnquotedAtom Identifier HiLink sexplibEncl Identifier HiLink sexplibQuotedAtom Keyword HiLink sexplibTodo Todo HiLink sexplibEncl Keyword delcommand HiLink endif let b:current_syntax = "sexplib" " vim: ts=8