pax_global_header00006660000000000000000000000064121353067320014514gustar00rootroot0000000000000052 comment=f91c9a9ff1cf4e1f54889e6edf6a933de86be17e sexplib-109.20.00/000077500000000000000000000000001213530673200134735ustar00rootroot00000000000000sexplib-109.20.00/.gitignore000066400000000000000000000001021213530673200154540ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte sexplib-109.20.00/CHANGES.txt000066400000000000000000000240331213530673200153060ustar00rootroot000000000000002012-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-109.20.00/COPYRIGHT.txt000066400000000000000000000007631213530673200156120ustar00rootroot00000000000000Most 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-109.20.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321213530673200165070ustar00rootroot00000000000000THIS 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-109.20.00/INSTALL.txt000066400000000000000000000017001213530673200153400ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 40eb37a06041e22318c42b18a11e90ab) *) This is the INSTALL file for the sexplib distribution. This package uses OASIS to generate its build system. See section OASIS for full information. Dependencies ============ In order to compile this package, you will need: * ocaml (>= 4.00.0) for all, test conv, test sexp, doc sexplib * findlib (>= 1.3.2) * type_conv (>= 109.20.00) for library pa_sexp_conv Installing ========== 1. Uncompress the source archive and go to the root of the package 2. Run 'ocaml setup.ml -configure' 3. Run 'ocaml setup.ml -build' 4. Run 'ocaml setup.ml -install' Uninstalling ============ 1. Go to the root of the package 2. Run 'ocaml setup.ml -uninstall' OASIS ===== OASIS is a program that generates a setup.ml file using a simple '_oasis' configuration file. The generated setup only depends on the standard OCaml installation: no additional library is required. (* OASIS_STOP *) sexplib-109.20.00/LICENSE-Tywith.txt000066400000000000000000000030101213530673200165760ustar00rootroot00000000000000--------------------------------------------------------------------------- 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-109.20.00/LICENSE.txt000066400000000000000000000261361213530673200153260ustar00rootroot00000000000000 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-109.20.00/Makefile000066400000000000000000000025111213530673200151320ustar00rootroot00000000000000# Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml sed '/^#/D' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) 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-109.20.00/README.md000066400000000000000000000442211213530673200147550ustar00rootroot00000000000000Sexplib - S-Expressions with Type Converters for OCaml ====================================================== --------------------------------------------------------------------------- What is Sexplib? ---------------- This [OCaml](http://www.ocaml.org) 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 data structures they define. The tight integration with the OCaml type system also allows for automatically verifying complex semantic properties when converting from S-expressions to OCaml values. Possible errors during automatic conversions from S-expressions to OCaml-values are reported in human-readable ways with exact location information. The library also offers functionality for extracting and replacing sub-expressions in S-expressions. Usage ----- Make sure you have installed the required `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 (`lib`) is fully documented, and HTML-documentation can be built from it on installation. The documentation for the latest release can also be found [online](http://mmottl.bitbucket.org/projects/sexplib/api/). 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 `syntax/pa_sexp_conv.ml` contains the extensions for the Camlp4-preprocessor. It adds the following three new constructs to the language: :::ocaml with sexp with sexp_of with of_sexp The first one implies the last two statements. When using these constructs right after a type definition, function definitions will be automatically generated which perform S-expression conversions. For example, consider the following type definition: :::ocaml 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. Converters for standard types (`int`, `list`, `Hashtbl.t`, etc.) become visible to the macro-generated code by opening the standard module before their first use in a type definition. Users will therefore usually want to place the following at the top of their files: :::ocaml open Sexplib.Std See the file `lib_test/conv_test.ml` for an example application. It also demonstrates how to extract and substitute sub-expressions. ### Compiling and linking To compile a file you will have to add preprocessing flags to the compiler invocation. For example for file `foo.ml`: :::sh ocamlc -pp "camlp4o -I {path to type_conv} \ -I {path to sexplib} pa_type_conv.cmo pa_sexp_conv.cmo" \ -I {path to sexplib} foo.ml If you are using [OCamlMakefile](http://bitbucket.org/mmottl/ocaml-makefile), just put the following line at the top of the file, assuming you have installed both `type_conv` and `sexplib` with ocamlfind. The comment must start at the beginning of the line, and you must not break lines (here broken for readability only): :::ocaml (*pp camlp4o -I `ocamlfind query type_conv` \ -I `ocamlfind query sexplib` \ pa_type_conv.cmo pa_sexp_conv.cmo *) In the linking stage you will only have to link with `sexplib`. E.g. when using `OCamlMakefile`, just add `sexplib` to the `PACKS`-variable. Users of the OCaml tool [findlib](http://projects.camlcity.org/projects/findlib.html) for compiling and linking OCaml files have an easier time: they just need to add `sexplib` to the list of packages to make S-expression functionality available. Adding `sexplib.syntax`, too, will make sure that files that use the type conversion feature will be preprocessed correctly. You may choose to place the macro `TYPE_CONV_PATH`, which takes a string argument, at the top of files to be preprocessed if you want to force a particular module path for error messages generated by `sexplib`. This may become necessary if modules are packed into a library at a later stage and if error messages generated by Sexplib need to refer to this location to help pinpoint the associated type. Syntax Specification of S-expressions ------------------------------------- ### 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 [OCaml-manual](http://www.ocaml.org/pub/docs/manual-ocaml) 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. A line comment is introduced using a semicolon, which comments out all text up to the end of the next newline character. The sequence "`%;`" introduces an S-expression comment. This means that the next S-expression, which must be syntactically correct and may be an atom (quoted or unquoted) or list, following this two-character sequence will be ignored. Whitespace or other comments between this sequence and the subsequent S-expression are ignored. Block comments are opened with "`#|`" and closed with "`|#`". They can be nested and require that double-quotes within the block balance and contain syntactically correct OCaml-strings, similar to quoted atoms. These OCaml-strings may contain comment characters without causing parsing problems. ### 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 :::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" |# |# ) ) ### Conversion of basic OCaml-values Basic OCaml-values like the unit-value, integers (in all representations), floats, strings, and booleans are represented in S-expression syntax the same way as in OCaml. Strings may also appear without quotes if this does not clash with the lexical conventions for S-expressions. ### Conversion of OCaml-tuples OCaml-tuples are simple lists of values in the same order as in the tuple. E.g. (OCaml representation followed by S-expression after arrow): :::ocaml (3.14, "foo", "bar bla", 27) <===> (3.14 foo "bar bla" 27) ### 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.: :::ocaml { 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.: :::ocaml type t = { x : int option; y : int sexp_option; } with sexp 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: :::ocaml { x = Some 1; y = Some 2; } <===> ( (x (some 1)) (y 2) ) And: :::ocaml { 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. More complex default values can be specified explicitly using several constructs, e.g.: :::ocaml let z_test v = v > 42 type t = { x : int with default(42); y : int with default(3), sexp_drop_default; z : int with default(3), sexp_drop_if(z_test); } with sexp The `default` record field extension above is supported by the underlying preprocessor library `type_conv` and specifies the intended default value for a record field in its argument. Sexplib will use this information to generate code which will set this record field to the default value if an S-expression omits this field. If a record is converted to an S-expression, record fields with default values will be emitted as usual. Specifying `sexp_drop_default` will add a test for polymorphic equality to the generated code such that a record field containing its default value will be suppressed in the resulting S-expression. This option requires the presence of a default value. `sexp_drop_if` on the other hand does not require a default. Its argument must be a function, which will receive the current record value. If the result of this function is `true`, then the record field will be suppressed in the resulting S-expression. The above extensions can be quite creatively used together with manifest types, functors, and first-class modules to make the emission of record fields or the definition of their default values configurable at runtime. ### 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: :::ocaml 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 data structures. ### 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, for example as in: :::ocaml type ab = [ `A | `B ] with sexp type cd = [ `C | `D ] with sexp type abcd = [ ab | cd ] with sexp ### Conversion of OCaml-lists and arrays OCaml-lists and arrays are straightforwardly represented as S-expression lists. ### Conversion of option types The option type is converted like ordinary polymorphic sum types, i.e.: :::ocaml 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: :::ocaml 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). 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. ### Conversion of polymorphic values There is nothing special about polymorphic values as long as there are conversion functions for the type parameters. E.g.: :::ocaml 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 data structure is indeed polymorphic and you want to convert it, you will have to supply the conversion functions for the type parameters at runtime. If you wanted to convert a value of type `'a t` as in the above example, you would have to write something like this: :::ocaml 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. ### Conversion of abstract data types If you want to convert an abstract data type to an S-expression, you will have to roll your own conversion functions, which should produce or accept values of type `Sexp.t`. If 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}`. It is possible to make use of internal representations, too, of course. In that case you may need to shadow the generated `*_of_sexp` function with a version that calls the generated one, but performs required semantic checks on the resulting value to guarantee that it does not violate properties of the abstract data type. For example: :::ocaml type pos_int = int with sexp let pos_int_of_sexp sexp = let n = pos_int_of_sexp sexp in if n >= 0 then n else raise (Of_sexp_error (Failure "pos_int: number not positive", sexp)) A nice perk of `sexplib` is that using the `Of_sexp_error`-exception will allow you to accurately pinpoint type errors in large S-expressions. The file loading functions described further below will exploit this feature. ### Conversion of hash tables Hash tables, which are abstract values in OCaml, are represented as association lists, i.e. lists of key-value pairs, e.g.: :::scheme ((foo 42) (bar 3)) Reading in the above S-expression as hash table 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 the OCaml-implementation of hash tables keeps duplicates. Bindings will be inserted into the hash table in the order of appearance. Therefore, the last binding of a key will be the "visible" one, the others are "hidden". See the OCaml-documentation on hash tables 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. ### 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. to hide large, unimportant parts of configurations. To prevent the preprocessor from generating calls to converters, simply apply the qualifier `sexp_opaque` as if it were a type constructor, e.g.: :::ocaml 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: :::ocaml (42, some_stuff) ===> (42 ) ### Conversion of exceptions S-expression converters for exceptions can be automatically registered using the "`with sexp`" macro, e.g.: :::ocaml 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 `sexp_of_exn`. User-defined conversion functions can be registered, too, by calling `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. 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. --------------------------------------------------------------------------- Contact Information and Contributing ------------------------------------ In the case of bugs, feature requests, contributions and similar, please contact the maintainers: * Jane Street Capital, LLC Up-to-date information should be available at: * * sexplib-109.20.00/THIRD-PARTY.txt000066400000000000000000000013601213530673200160030ustar00rootroot00000000000000The 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-109.20.00/_oasis000066400000000000000000000053421213530673200146770ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: sexplib Version: 109.20.00 Synopsis: sexplib - automated S-expression conversion Authors: Jane Street Capital LLC Copyrights: (C) 2005-2013 Jane Street Capital LLC Maintainers: Jane Street Capital LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/sexplib Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild, camlp4o Library sexplib Path: lib FindlibName: sexplib Pack: true Modules: Conv, Conv_error, Exn_magic, Path, Pre_sexp, Sexp, Sexp_intf, Sexp_with_layout, Src_pos, Std, Type, Type_with_layout, Parser, Parser_with_layout, Lexer BuildDepends: unix,bigarray,num XMETARequires: unix,bigarray,num Library pa_sexp_conv Path: syntax FindlibName: syntax FindlibParent: sexplib Modules: Pa_sexp_conv BuildDepends: camlp4.quotations, camlp4.extend, type_conv (>= 109.20.00) XMETAType: syntax XMETARequires: camlp4,type_conv,sexplib XMETADescription: Syntax extension for Sexplib Library sexplib_top Path: top FindlibName: top FindlibParent: sexplib Modules: Sexplib_install_printers XMETARequires: sexplib XMETADescription: Toplevel printers for S-expressions Executable sexp_test Path: lib_test MainIs: sexp_test.ml Build$: flag(tests) Install: false BuildDepends: sexplib Executable conv_test Path: lib_test MainIs: conv_test.ml Build$: flag(tests) Install: false BuildDepends: sexplib, sexplib.syntax Test sexp Run$: flag(tests) Command: $sexp_test < test.sexp WorkingDirectory: lib_test Test conv Run$: flag(tests) Command: $conv_test WorkingDirectory: lib_test Document "sexplib" Title: API reference for sexplib Type: ocamlbuild (0.3) BuildTools+: ocamldoc XOCamlbuildPath: lib XOCamlbuildLibraries: sexplib sexplib-109.20.00/_tags000066400000000000000000000047371213530673200145260ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 7e9eeb53326c246f58f9ff3c0f3f944e) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library sexplib "lib/sexplib.cmxs": use_sexplib "lib/conv.cmx": for-pack(Sexplib) "lib/conv_error.cmx": for-pack(Sexplib) "lib/exn_magic.cmx": for-pack(Sexplib) "lib/path.cmx": for-pack(Sexplib) "lib/pre_sexp.cmx": for-pack(Sexplib) "lib/sexp.cmx": for-pack(Sexplib) "lib/sexp_intf.cmx": for-pack(Sexplib) "lib/sexp_with_layout.cmx": for-pack(Sexplib) "lib/src_pos.cmx": for-pack(Sexplib) "lib/std.cmx": for-pack(Sexplib) "lib/type.cmx": for-pack(Sexplib) "lib/type_with_layout.cmx": for-pack(Sexplib) "lib/parser.cmx": for-pack(Sexplib) "lib/parser_with_layout.cmx": for-pack(Sexplib) "lib/lexer.cmx": for-pack(Sexplib) : pkg_unix : pkg_bigarray : pkg_num # Library pa_sexp_conv "syntax/pa_sexp_conv.cmxs": use_pa_sexp_conv : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv # Library sexplib_top "top/sexplib_top.cmxs": use_sexplib_top # Executable sexp_test "lib_test/sexp_test.byte": use_sexplib "lib_test/sexp_test.byte": pkg_unix "lib_test/sexp_test.byte": pkg_bigarray "lib_test/sexp_test.byte": pkg_num # Executable conv_test "lib_test/conv_test.byte": use_sexplib "lib_test/conv_test.byte": use_pa_sexp_conv "lib_test/conv_test.byte": pkg_camlp4.quotations "lib_test/conv_test.byte": pkg_camlp4.extend "lib_test/conv_test.byte": pkg_type_conv "lib_test/conv_test.byte": pkg_unix "lib_test/conv_test.byte": pkg_bigarray "lib_test/conv_test.byte": pkg_num : use_sexplib : use_pa_sexp_conv : pkg_camlp4.quotations : pkg_camlp4.extend : pkg_type_conv : pkg_unix : pkg_bigarray : pkg_num # OASIS_STOP : pp(cpp -undef -traditional -I/mnt/local/sda1/jdimino/git/sexplib/syntax) : syntax_camlp4o, pkg_type_conv.syntax : use_sexplib, pkg_unix, pkg_num, pkg_bigarray : syntax_camlp4o "top/sexplib_install_printers.ml": I(+compiler-libs) sexplib-109.20.00/configure000077500000000000000000000005541213530673200154060ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP sexplib-109.20.00/lib/000077500000000000000000000000001213530673200142415ustar00rootroot00000000000000sexplib-109.20.00/lib/META000066400000000000000000000016501213530673200147140ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b87c42e4e81fc5ffe0577b509a4de670) version = "109.20.00" description = "sexplib - automated S-expression conversion" requires = "unix bigarray num" archive(byte) = "sexplib.cma" archive(byte, plugin) = "sexplib.cma" archive(native) = "sexplib.cmxa" archive(native, plugin) = "sexplib.cmxs" exists_if = "sexplib.cma" package "top" ( version = "109.20.00" description = "Toplevel printers for S-expressions" requires = "sexplib" archive(byte) = "sexplib_top.cma" archive(byte, plugin) = "sexplib_top.cma" archive(native) = "sexplib_top.cmxa" archive(native, plugin) = "sexplib_top.cmxs" exists_if = "sexplib_top.cma" ) package "syntax" ( version = "109.20.00" description = "Syntax extension for Sexplib" requires = "camlp4 type_conv sexplib" archive(syntax, preprocessor) = "pa_sexp_conv.cma" archive(syntax, toploop) = "pa_sexp_conv.cma" exists_if = "pa_sexp_conv.cma" ) # OASIS_STOP sexplib-109.20.00/lib/conv.ml000066400000000000000000000551051213530673200155460ustar00rootroot00000000000000(* Utility Module for S-expression Conversions *) open Printf open Bigarray open Sexp 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 *) (* Some basic experiments indicate that %.20G is enough to round-trip a float through the sexp-converter, (although that was done long ago, and there's no real guarantee) *) let default_string_of_float = ref (fun n -> sprintf "%.20G" n) 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_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_num n = Atom (Num.string_of_num n) let sexp_of_ratio n = Atom (Ratio.string_of_ratio 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 Addrs = Map.Make (Int) type weak_repr = (Obj.t Weak.t * (exn -> Sexp.t)) Ids.t let exn_addr_map : (int * weak_repr) Addrs.t ref = ref Addrs.empty let get_exn_tag (exn : exn) = Obj.field (Obj.repr exn) 0 let get_exn_tag_str_addr exn_tag = (Obj.magic (Obj.field exn_tag 0) : int) let get_exn_str_addr exn = get_exn_tag_str_addr (get_exn_tag exn) let rec clean_up_handler id exn_tag = let old_exn_addr_map = !exn_addr_map in let addr = get_exn_tag_str_addr exn_tag in match try Some (Addrs.find addr old_exn_addr_map) with Not_found -> None with | Some (count, exn_handler_map) -> let new_exn_handler_map = Ids.remove id exn_handler_map in let new_exn_addr_map = if Ids.is_empty new_exn_handler_map then Addrs.remove addr old_exn_addr_map else Addrs.add addr (count - 1, new_exn_handler_map) old_exn_addr_map in (* This trick avoids mutexes and should be fairly efficient *) if !exn_addr_map != old_exn_addr_map then clean_up_handler id exn_tag else exn_addr_map := new_exn_addr_map | None -> () let fast_id_cnt = ref Int64.max_int exception Found_sexp of Sexp.t 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 let add_auto ?(finalise = true) exn sexp_of_exn = let exn_tag = get_exn_tag exn in let addr = get_exn_tag_str_addr exn_tag in let weak_tbl = Weak.create 1 in Weak.set weak_tbl 0 (Some exn_tag); let new_handler = weak_tbl, sexp_of_exn in let rec loop () = let id = !fast_id_cnt in let old_exn_addr_map = !exn_addr_map in let new_id = Int64.sub id Int64.one in let count, handler_map = try Addrs.find addr old_exn_addr_map with Not_found -> 0, Ids.empty in if count < !max_exn_tags then let new_handler_map = Ids.add id new_handler handler_map in let new_exn_handlers = Addrs.add addr (count + 1, new_handler_map) old_exn_addr_map in (* This trick avoids mutexes and should be fairly efficient *) if !fast_id_cnt != id || !exn_addr_map != old_exn_addr_map then loop () else begin exn_addr_map := new_exn_handlers; fast_id_cnt := new_id; if finalise then Gc.finalise (clean_up_handler id) exn_tag end in loop () let find_auto exn = let addr = get_exn_str_addr exn in match try Some (Addrs.find addr !exn_addr_map) with Not_found -> None with | None -> None | Some (_, exn_handler_map) -> let exn_tag = get_exn_tag exn in try let act _id (weak_tbl, sexp_of_exn) = match Weak.get weak_tbl 0 with | Some map_exn_tag when map_exn_tag == exn_tag -> raise (Found_sexp (sexp_of_exn exn)) | None | Some _ -> () in Ids.iter act exn_handler_map; None with Found_sexp sexp -> Some sexp 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) (* 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 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 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 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 ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp) let lazy_t_of_sexp a__of_sexp sexp = Lazy.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.create 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) = List [Atom name; Atom file; sexp_of_int line; sexp_of_int 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) );( 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) );( 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-109.20.00/lib/conv.mli000066400000000000000000000405501213530673200157150ustar00rootroot00000000000000(** 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_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_num : Num.num -> Sexp.t (** [sexp_of_num n] converts the value [n] of type [Num.num] 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_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 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 num_of_sexp : Sexp.t -> Num.num (** [num_of_sexp sexp] converts S-expression [sexp] to a value of type [Nat.num]. *) val ratio_of_sexp : Sexp.t -> Ratio.ratio (** [ratio_of_sexp sexp] converts S-expression [sexp] to a value of type [Nat.ratio]. *) 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 (** [set_max_exn_tags n] sets the maximum number of converters for exceptions with the same template to [n]. If already existing handlers exceed this number, they will remain at their current number until this number is reduced due to garbage collection. New handlers will not be added until [n] will not be exceeded. *) val get_max_exn_tags : unit -> int (** [set_max_exn_tags ()] return the maximum number of converters for exceptions with the same template. *) 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], unless the number of stored handlers for the given template exceeds [get_max_exn_tags ()], in which case the handler will never be called. When [sexp_of_exn] is called, the passed exception is guaranteed to match the template. 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-109.20.00/lib/conv_error.ml000066400000000000000000000071431213530673200167560ustar00rootroot00000000000000(* 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-109.20.00/lib/exn_magic.ml000066400000000000000000000156631213530673200165400ustar00rootroot00000000000000let 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 0) 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 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) (Obj.magic 0) 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-109.20.00/lib/exn_magic.mli000066400000000000000000000036221213530673200167010ustar00rootroot00000000000000val 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-109.20.00/lib/intro.txt000066400000000000000000000266041213530673200161450ustar00rootroot00000000000000@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-109.20.00/lib/lexer.mli000066400000000000000000000002301213530673200160560ustar00rootroot00000000000000val main : ?buf:Buffer.t -> Lexing.lexbuf -> Parser.token val main_with_layout : ?buf:Buffer.t -> Lexing.lexbuf -> Parser_with_layout.token sexplib-109.20.00/lib/lexer.mll000066400000000000000000000240411213530673200160670ustar00rootroot00000000000000{ (** 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-109.20.00/lib/parser.mly000066400000000000000000000026141213530673200162630ustar00rootroot00000000000000%{ (** 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-109.20.00/lib/parser_with_layout.mly000066400000000000000000000051751213530673200207200ustar00rootroot00000000000000%{ (** Parser: Grammar Specification for Parsing S-expressions *) (* compare to parser.mly *) (* *) (* C inside Ocaml comment to satisfy cr *) 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-109.20.00/lib/path.ml000066400000000000000000000126311213530673200155320ustar00rootroot00000000000000(* Path: Module for Substitutions within S-expressions *) open Format open Sexp 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-109.20.00/lib/path.mli000066400000000000000000000104671213530673200157100ustar00rootroot00000000000000(** 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-109.20.00/lib/pre_sexp.ml000066400000000000000000001241731213530673200164300ustar00rootroot00000000000000(* Sexp: Module for handling S-expressions (I/O, etc.) *) open Format open Bigarray 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 | c -> c <= ' ' || ix > 0 && loop (ix - 1) in loop (len - 1) let maybe_esc_str str = if must_escape str then let estr = String.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 else str let pp_maybe_esc_str ppf str = pp_print_string ppf (maybe_esc_str str) (* Output of S-expressions to formatters *) let rec pp_hum_indent indent ppf = function | Atom str -> pp_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' = 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 = Format.bprintf buf "%a@?" (pp_hum_indent indent) sexp let to_buffer_mach ~buf sexp = let rec loop may_need_space = function | Atom str -> let str' = 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' = 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 -> 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 -> 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 -> add_bump_pos state str ~max_pos ~pos c parse_atom \ \ 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 -> add_bump_pos state str ~max_pos ~pos c parse_quoted \ \ 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-109.20.00/lib/sexp.ml000066400000000000000000000000671213530673200155550ustar00rootroot00000000000000include Pre_sexp module With_layout = Sexp_with_layout sexplib-109.20.00/lib/sexp.mli000066400000000000000000000001201213530673200157140ustar00rootroot00000000000000(** Sexp: Module for handling S-expressions (I/O, etc.) *) include Sexp_intf.S sexplib-109.20.00/lib/sexp_intf.ml000066400000000000000000000623101213530673200165740ustar00rootroot00000000000000(** 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. *) external sexp_of_t : t -> t = "%identity" (** [sexp_of_t sexp] maps S-expressions which are part of a type with automated S-expression conversion to themselves. *) external t_of_sexp : t -> t = "%identity" (** [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-109.20.00/lib/sexp_with_layout.ml000066400000000000000000000127421213530673200202100ustar00rootroot00000000000000(* 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.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-109.20.00/lib/sexplib.mlpack000066400000000000000000000003361213530673200171020ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: c6efb9873451632b55286544e774412c) Conv Conv_error Exn_magic Path Pre_sexp Sexp Sexp_intf Sexp_with_layout Src_pos Std Type Type_with_layout Parser Parser_with_layout Lexer # OASIS_STOP sexplib-109.20.00/lib/sexplib.odocl000066400000000000000000000003361213530673200167330ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: c6efb9873451632b55286544e774412c) Conv Conv_error Exn_magic Path Pre_sexp Sexp Sexp_intf Sexp_with_layout Src_pos Std Type Type_with_layout Parser Parser_with_layout Lexer # OASIS_STOP sexplib-109.20.00/lib/src_pos.ml000066400000000000000000000020571213530673200162470ustar00rootroot00000000000000(* 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-109.20.00/lib/src_pos.mli000066400000000000000000000010571213530673200164170ustar00rootroot00000000000000(** 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-109.20.00/lib/std.ml000066400000000000000000000035211213530673200153660ustar00rootroot00000000000000module Hashtbl = struct include Hashtbl let sexp_of_t = Conv.sexp_of_hashtbl let t_of_sexp = Conv.hashtbl_of_sexp end module Big_int = struct include Big_int let sexp_of_big_int = Conv.sexp_of_big_int let big_int_of_sexp = Conv.big_int_of_sexp end module Nat = struct include Nat let sexp_of_nat = Conv.sexp_of_nat let nat_of_sexp = Conv.nat_of_sexp end module Num = struct include Num let sexp_of_num = Conv.sexp_of_num let num_of_sexp = Conv.num_of_sexp end module Ratio = struct include Ratio let sexp_of_ratio = Conv.sexp_of_ratio let ratio_of_sexp = Conv.ratio_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 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-109.20.00/lib/type.ml000066400000000000000000000001061213530673200155510ustar00rootroot00000000000000(** Type of S-expressions *) type t = Atom of string | List of t list sexplib-109.20.00/lib/type_with_layout.ml000066400000000000000000000056701213530673200202140ustar00rootroot00000000000000(** 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-109.20.00/lib/type_with_layout.mli000066400000000000000000000017671213530673200203700ustar00rootroot00000000000000(** 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-109.20.00/lib_test/000077500000000000000000000000001213530673200153005ustar00rootroot00000000000000sexplib-109.20.00/lib_test/conv_test.ml000066400000000000000000000103241213530673200176360ustar00rootroot00000000000000(** Conv_test: module for testing automated S-expression conversions and path substitutions *) open Format open Sexplib open Sexp open Conv module Exc_test : sig exception Test_exc of (string * int) with sexp end = struct exception Test_exc of (string * int) with sexp end (* Test each character. *) let check_string s = let s' = match (Sexp.of_string (Sexp.to_string (Sexp.Atom s))) with | Sexp.Atom s -> s | _ -> assert false in assert (s = s') let () = for i = 0 to 255 do check_string (String.make 1 (Char.chr i)) done (* Test user specified conversion *) type my_float = float let sexp_of_my_float n = Atom (sprintf "%.4f" n) let my_float_of_sexp = function | Atom str -> float_of_string str | _ -> failwith "my_float_of_sexp: atom expected" (* Test simple sum of products *) type foo = A | B of int * float with sexp (* Test polymorphic variants and deep module paths *) module M = struct module N = struct type ('a, 'b) variant = [ `X of ('a, 'b) variant | `Y of 'a * 'b ] with sexp type test = [ `Test ] with sexp end end type 'a variant = [ M.N.test | `V1 of [ `Z | ('a, string) M.N.variant ] option | `V2 ] with sexp (* Test empty types *) type empty with sexp type 'a function_field_with_labeled_argument = { f : x:'a -> 'a } with sexp (* Test non-regular types *) type 'a nonregular = Leaf of 'a | Branch of ('a * 'a) nonregular with sexp type ('a, 'b) nonregular_with_variant = Branch of ([ 'a list variant ], 'b) nonregular_with_variant with sexp (* Test variance annotations *) module type S = sig type +'a t with sexp end (* Test labeled arguments in functions *) type labeled = string -> foo : unit -> ?bar : int -> float -> float with sexp let f str ~foo:_ ?(bar = 3) n = float_of_string str +. n +. float bar let labeled_sexp : Sexp.t = sexp_of_labeled f let labeled : labeled lazy_t = lazy (labeled_of_sexp (labeled_sexp : Sexp.t)) type rec_labeled = { a : (foo : unit -> unit) } with sexp_of (* Test recursive types *) (* Test polymorphic record fields *) type 'x poly = { p : 'a 'b. 'a list; maybe_t : 'x t option; } (* Test records *) and 'a t = { x : foo; a : 'a variant; foo : int; bar : (my_float * string) list option; default_1 : int with default(1), sexp_drop_default; default_2 : int with default(2), sexp_drop_if((=) 2); sexp_option : int sexp_option; sexp_list : int sexp_list; sexp_bool : sexp_bool; poly : 'a poly; } with sexp type v = { t : int t } (* Test manifest types *) type u = v = { t : int t } with sexp (* Test types involving exceptions *) type exn_test = int * exn with sexp_of (* Test function types *) type fun_test = int -> unit with sexp_of open Path type does_sexp_array_type_check = { does_sexp_array_type_check_field : string sexp_array; } with sexp let main () = let make_t a = { x = B (42, 3.1); a = a; foo = 3; bar = Some [(3.1, "foo")]; default_1 = 1; default_2 = 2; sexp_option = None; sexp_list = []; sexp_bool = true; poly = { p = []; maybe_t = None; }; } in let v = `B (5, 5) in let v_sexp = <:sexp_of<[ `A | `B of int * int ] >> v in assert (<:of_sexp< [ `A | `B of int * int ] >> v_sexp = v); let u = { t = make_t (`V1 (Some (`X (`Y (7, "bla"))))) } in let u_sexp = sexp_of_u u in printf "Original: %a@\n@." pp u_sexp; let u' = u_of_sexp u_sexp in assert (u = u'); let foo_sexp = Sexp.of_string "A" in let _foo = foo_of_sexp foo_sexp in let path_str = ".[0].[1]" in let path = Path.parse path_str in let subst, el = subst_path u_sexp path in printf "Pos(%s): %a -> SUBST1@\n" path_str pp el; let dumb_sexp = subst (Atom "SUBST1") in printf "Pos(%s): %a@\n@\n" path_str pp dumb_sexp; let path_str = ".t.x.B[1]" in let path = Path.parse path_str in let subst, el = subst_path u_sexp path in printf "Record(%s): %a -> SUBST2@\n" path_str pp el; let u_sexp = subst (Atom "SUBST2") in printf "Record(%s): %a@\n@\n" path_str pp u_sexp; printf "SUCCESS!!!@." let () = try main (); raise (Exc_test.Test_exc ("expected exception", 42)) with | exc -> eprintf "Exception: %s@." (Sexp.to_string_hum (sexp_of_exn exc)) sexplib-109.20.00/lib_test/nonrec_test.ml000066400000000000000000000010251213530673200201530ustar00rootroot00000000000000open Sexplib open Conv type t = float with sexp module M : sig type t = float list with sexp end = struct type nonrec t = t list with sexp end type 'a u = 'a with sexp module M2 : sig type 'a u = 'a list with sexp end = struct type nonrec 'a u = 'a u list with sexp end type 'a v = 'a w and 'a w = A of 'a v with sexp type 'a v_ = 'a v with sexp type 'a w_ = 'a w with sexp module M3 : sig type 'a v = 'a w_ with sexp type 'a w = 'a v_ with sexp end = struct type nonrec 'a v = 'a w and 'a w = 'a v with sexp end sexplib-109.20.00/lib_test/pa_sexp_test.ml000066400000000000000000000107331213530673200203340ustar00rootroot00000000000000open Sexplib open Sexp open Conv let debug = ref false type ('a, 'b) variant2 = 'a with of_sexp type variant3 = [ `B | ([ `C ], int) variant2 ] with of_sexp let () = let not_deserializable = Atom "C" in try ignore (<:of_sexp< variant3 >> not_deserializable); failwith "Expected an exception about a silly type" with Conv.Of_sexp_error (exn, sexp) -> if !debug then ( let sexp1 = Conv.sexp_of_exn exn in Printf.printf "Conv_error.Of_sexp_error (%s, %s)\n%!" (Sexp.to_string sexp1) (Sexp.to_string sexp) ) (* this one would trigger a warning in 4.0 about unused rec if type_conv says that this definition is recursive *) type r = { r : int } with sexp module A = struct type nonrec r = { r : r } let _ (r : r) = r.r (* checking that the field is not rewritten *) end module No_unused_value_warnings : sig end = struct module No_warning : sig type t = [ `A ] with sexp end = struct type t = [ `A ] with sexp end module Empty = struct end module No_warning2(X : sig type t with sexp end) = struct end (* this one can't be handled (what if Empty was a functor, huh?) *) (* module No_warning3(X : sig type t with sexp end) = Empty *) module type S = sig type t = [ `A ] with sexp end module No_warning4 : S = struct type t = [ `A ] with sexp end module No_warning5 : S = ((struct type t = [ `A ] with sexp end : S) : S) module Nested_functors (M1 : sig type t with sexp end) (M2 : sig type t with sexp end) = struct end let () = let module M : sig type t with sexp end = struct type t with sexp end in () end module Default = struct type t = { a : int with default(2); } with sexp let () = assert (Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 }) let () = assert (Sexp.(List [List [Atom "a"; Atom "2"]]) = sexp_of_t { a = 2 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 }) let () = assert (t_of_sexp (Sexp.(List [])) = { a = 2 }) end module Type_alias = struct (* checking that the [as 'a] is supported and ignored in signatures, that it still exports the sexp_of_t__ when needed *) module B : sig type a = [ `A ] type t = ([`A] as 'a) constraint 'a = a with sexp end = struct type a = [ `A ] with sexp type t = [ `A ] with sexp end let () = assert (Sexp.to_string (B.sexp_of_t `A) = "A"); assert (`A = B.t_of_sexp (Sexp.of_string "A")); () module B2 = struct type t = [ B.t | `B ] with sexp end module C : sig type t = (int as 'a) with sexp end = struct type t = int with sexp end module D : sig type t = 'a constraint 'a = int with sexp end = struct type t = int with sexp end end module Drop_default = struct type t = { a : int with default(2), sexp_drop_default; } with sexp let () = assert (Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 }) let () = assert (Sexp.(List []) = sexp_of_t { a = 2 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 }) let () = assert (t_of_sexp (Sexp.(List [])) = { a = 2 }) end module Drop_if = struct type t = { a : int with default(2), sexp_drop_if(fun x -> x mod 2 = 0) } with sexp let () = assert (Sexp.(List [List [Atom "a"; Atom "1"]]) = sexp_of_t { a = 1 }) let () = assert (Sexp.(List []) = sexp_of_t { a = 2 }) let () = assert (Sexp.(List [List [Atom "a"; Atom "3"]]) = sexp_of_t { a = 3 }) let () = assert (Sexp.(List []) = sexp_of_t { a = 4 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "1"]])) = { a = 1 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "2"]])) = { a = 2 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "3"]])) = { a = 3 }) let () = assert (t_of_sexp (Sexp.(List [List [Atom "a"; Atom "4"]])) = { a = 4 }) let () = assert (t_of_sexp (Sexp.(List [])) = { a = 2 }) type u = { a : int with sexp_drop_if(fun x -> (* pa_type_conv used to drop parens altogether, causing type errors in the following code *) let pair = (x, 2) in match Some pair with | None -> true | Some (x, y) -> x = y ) } with sexp end module B = struct (* checking that there is no warning about 'unused rec' *) type r = { field : r -> unit } with sexp_of end sexplib-109.20.00/lib_test/parser_test.ml000066400000000000000000000242361213530673200201740ustar00rootroot00000000000000open Sexplib open Test_common (* TODO: assert that the positions are ok as well *) let sexp_of_layout_sexp = Sexp.With_layout.sexp_of_t_or_comment let sexps_of_layout_sexps l = List.map sexp_of_layout_sexp l let sexp_of_layout_sexps_or_something sexps_with_layout = match Sexp.With_layout.Forget.t_or_comments sexps_with_layout with | [s] -> s | [] | _ :: _ :: _ as sexps -> (* this is an error, but returning something is more effective for debug *) Sexp.List ( Sexp.List sexps :: Sexp.List (sexps_of_layout_sexps sexps_with_layout) :: [] ) let parsers = [ Sexp.of_string, "cont"; (fun s -> (* feeding the characters to the parse function one by one to make sure the cont_state machinery is working fine *) let pos = 0 in match Sexp.parse ~len:1 s with | Sexp.Done (t, _) -> t | Sexp.Cont (cont_state, parse_fun) -> let rec aux parse_fun pos = assert (pos < String.length s); match parse_fun ~pos ~len:1 s with | Sexp.Done (t, _) -> if pos + 1 = String.length s then t else failwith "Should have reached the end1" | Sexp.Cont (cont_state, parse_fun) -> aux_cont pos cont_state parse_fun and aux_cont pos cont_state parse_fun = if pos + 1 = String.length s then match cont_state with | Sexp.Cont_state.Parsing_atom -> begin match parse_fun ~pos:0 ~len:1 " " with | Sexp.Done (t, _) -> t | Sexp.Cont _ -> failwith "Should have reached the end2" end | Sexp.Cont_state.Parsing_sexp_comment | Sexp.Cont_state.Parsing_block_comment | Sexp.Cont_state.Parsing_whitespace -> failwith "incomplete" | Sexp.Cont_state.Parsing_list -> failwith "Should have reached the end3" else aux parse_fun (pos + 1) in aux_cont pos cont_state parse_fun ), "cont-incremental"; (fun s -> Sexp.scan_sexp (Lexing.from_string s)), "ocamllex"; (fun s -> Sexp.Annotated.get_sexp (Sexp.Annotated.of_string s)), "annot"; (fun s -> let sexps_with_layout = Sexp.With_layout.Parser.sexps Sexp.With_layout.Lexer.main (Lexing.from_string s) in sexp_of_layout_sexps_or_something sexps_with_layout ), "layout-sexps"; (fun s -> let parse = let lexbuf = Lexing.from_string s in fun () -> Sexp.With_layout.Parser.sexp_opt Sexp.With_layout.Lexer.main lexbuf in let rec aux acc = match parse () with | None -> List.rev acc | Some sexp -> aux (sexp :: acc) in sexp_of_layout_sexps_or_something (aux []) ), "layout-sexp-opt"; ] (* no idea why we can't read multiple sexps from a string directly *) let put_string_in_channel s f = let file, out_channel = Filename.open_temp_file "sexplib_test" "" in output_string out_channel s; close_out out_channel; let in_channel = open_in file in let v = try `Value (f in_channel) with exn -> `Exn exn in close_in in_channel; Sys.remove file; match v with | `Value v -> v | `Exn exn -> raise exn let list_parsers = [ (fun s -> Sexp.List (put_string_in_channel s Sexp.input_sexps)), "cont"; (fun s -> Sexp.List (Sexp.scan_sexps (Lexing.from_string s))), "ocamllex"; (fun s -> Sexp.List (Sexp.scan_sexps_conv ~f:(fun x -> x) (Lexing.from_string s))), "ocamllex_opt"; (fun s -> Sexp.List ( put_string_in_channel s (fun ch -> List.map Sexp.Annotated.get_sexp (Sexp.Annotated.input_sexps ch) ) )), "annot"; (fun s -> let sexps_with_layout = Sexp.With_layout.Parser.sexps Sexp.With_layout.Lexer.main (Lexing.from_string s) in let sexps = Sexp.With_layout.Forget.t_or_comments sexps_with_layout in Sexp.List sexps ), "layout-sexps"; ] let tests = ref 0 let failures = ref 0 let same_parse_tree ?no_following_sibling ?(use_list_parsers=false) loc string1 string2 = let context_wrappers = wrap_in_context ?no_following_sibling () in List.iter (fun context_wrapper -> let string1 = context_wrapper string1 in let string2 = context_wrapper string2 in List.iter (fun (parser_, parser_name) -> List.iter (fun (adapt_newline, newline_style) -> incr tests; try let string1 = adapt_newline string1 in let string2 = adapt_newline string2 in let tree1 = parser_ string1 in let tree2 = parser_ string2 in if tree1 <> tree2 then ( incr failures; Printf.printf "test failure at %s (%s, %s)\n string1: %S tree1: %s\n string2: %S tree2: %s\n%!" loc parser_name newline_style string1 (Sexp.to_string tree1) string2 (Sexp.to_string tree2) ) with e -> incr failures; Printf.printf "test failure at %s (%s, %s, %s) on %S vs %S\n%!" loc (Printexc.to_string e) parser_name newline_style string1 string2 ) newline_adapters ) (if use_list_parsers then list_parsers else parsers) ) context_wrappers let same_parse_trees ?no_following_sibling loc string1 string2 = same_parse_tree ?no_following_sibling ~use_list_parsers:true loc string1 string2 let parse_fail ?no_following_sibling ?(use_list_parsers=false) loc string f = let context_wrappers = wrap_in_context ?no_following_sibling () in List.iter (fun context_wrapper -> let string = context_wrapper string in List.iter (fun (parser_, parser_name) -> List.iter (fun (adapt_newline, newline_style) -> incr tests; try let string = adapt_newline string in let tree = parser_ string in incr failures; Printf.printf "test failure at %s (%s, %s): should have thrown an exception\nstring: %S tree: %s\n%!" loc parser_name newline_style string (Sexp.to_string tree) with e -> if not (f e) then ( incr failures; Printf.printf "test failure at %s (%s, %s, %s)\n%!" loc (Printexc.to_string e) parser_name newline_style ) ) newline_adapters ) (if use_list_parsers then list_parsers else parsers) ) context_wrappers let parse_fail_trees ?no_following_sibling loc string f = parse_fail ?no_following_sibling ~use_list_parsers:true loc string f #define _here_ \ (try assert false; exit 45 \ with Assert_failure (position, line, col) -> \ Printf.sprintf "%s:%d:%d" position line col) let grep pattern string = (* hopefully there is no need for escaping *) Sys.command ("echo '" ^ string ^ "' | grep -q '" ^ pattern ^ "'") = 0 let () = same_parse_tree _here_ "(a)" "(a;\n)"; (* single line comment in a list *) same_parse_tree _here_ ";\nb" "b"; (* single line comment at toplevel *) same_parse_tree _here_ ";;\nb" "b"; (* single line comment don't nest *) same_parse_tree _here_ ";\"\nb" "b"; (* single line comment ignore quotes *) same_parse_tree _here_ "(a#)" "(a#;\n)"; parse_fail _here_ "a#|" (function | Failure s -> grep "comment tokens in unquoted atom" s | Sexp.Parse_error {Sexp.location = "maybe_parse_bad_atom_hash"; err_msg=_; parse_state=_ } -> true | _ -> false); parse_fail _here_ "a|#" (function | Failure s -> grep "comment tokens in unquoted atom" s | Sexp.Parse_error {Sexp.location = "maybe_parse_bad_atom_pipe"; err_msg=_; parse_state=_ } -> true | _ -> false); parse_fail _here_ "##|" (function | Failure s -> grep "comment tokens in unquoted atom" s | Sexp.Parse_error {Sexp.location = "maybe_parse_bad_atom_hash"; err_msg=_; parse_state=_ } -> true | _ -> false); parse_fail _here_ "||#" (function | Failure s -> grep "comment tokens in unquoted atom" s | Sexp.Parse_error {Sexp.location = "maybe_parse_bad_atom_pipe"; err_msg=_; parse_state=_ } -> true | _ -> false); parse_fail _here_ "#|" (* not terminated *) (function | Failure s -> grep "incomplete" s || grep "unterminated" s | _ -> false); parse_fail _here_ "|#" (* not started *) (function | Failure s -> grep "illegal end of comment" s | Sexp.Parse_error {Sexp.location = "maybe_parse_close_comment"; err_msg=_; parse_state=_ } -> true | _ -> false); parse_fail _here_ ~no_following_sibling:true "#;" (* not followed *) (function | Sexp.Parse_error _ | Failure _ -> true | _ -> false); same_parse_tree _here_ "#;a b" "b"; (* sexp comment + atom *) same_parse_tree _here_ "#;((a)) b" "b"; (* sexp comment + list *) same_parse_tree _here_ "#;\"#;\" b" "b"; (* sexp comment + quoted atom *) same_parse_tree _here_ "#;a;comment\nb" "b"; (* sexp comment + single line commment *) same_parse_tree _here_ "#;#|aa)|#comment b" "b"; (* sexp comment + block commment *) same_parse_tree _here_ "#;a #;(a) #;\"asd\" b" "b"; (* consecutive sexp comment + atom *) same_parse_tree _here_ "(#;a #;(a) #;b)" "()"; (* consecutive sexp comment + nothing *) same_parse_tree _here_ "#; #; #; comment1 comment2 comment3 a" "a"; (* nested sexp comment *) same_parse_tree _here_ "#| ; |# ()" "()"; (* single line comment are not parsed inside of blocks *) same_parse_tree _here_ "#|#||#|#a" "a"; (* consecutive comment opening are not parsed as one invalid atom *) (* why do we need a freaking space at the end?? *) same_parse_trees _here_ "a #; b c " "a c "; (* base case, accepting lists *) same_parse_trees _here_ "#;#;a b c d " "c d "; (* leading comments work alright *) same_parse_trees _here_ "#;#;a b " " "; (* leading comments work alright *) same_parse_trees _here_ "plop #;#;a b " "plop "; (* trailing comments work alright *) same_parse_trees _here_ "#;b " " "; (* leading comments in front of nothing *) (* making sure that '|' is still accepted in literals *) same_parse_tree _here_ "(a|b)" "(\"a|b\")"; same_parse_tree _here_ "(a | b)" "(a \"|\" b)"; same_parse_tree _here_ "((a)|b)" "((a)\"|b\")"; same_parse_tree _here_ "(b|(a))" "(\"b|\"(a))"; same_parse_trees _here_ "a|b " "\"a|b\" "; same_parse_trees _here_ "(a)|b " "(a)\"|b\" "; same_parse_trees _here_ "b|(a)" "\"b|\"(a)"; if !failures <> 0 then ( Printf.printf "%d / %d tests failed\n%!" !failures !tests; exit 2 ) else ( match Sys.argv with | [| _ |] -> Printf.printf "Done %d tests\n%!" !tests | _ -> () ) sexplib-109.20.00/lib_test/printer_test.ml000066400000000000000000000143371213530673200203640ustar00rootroot00000000000000open Sexplib module With_layout = Sexp.With_layout open Test_common (* a hack to ignore these tests for now *) let care_about_windows_newlines = false let string_of_sexp_with_layout t = let b = Buffer.create 10 in With_layout.Render.run (Buffer.add_char b) (With_layout.Render.sexp t); Buffer.contents b let string_of_sexps_with_layout t_list = let open With_layout.Render in let b = Buffer.create 10 in let m = return () in let m = List.fold_left (fun m t -> bind m (fun () -> sexp t) ) m t_list in With_layout.Render.run (fun c -> Buffer.add_char b c) m; Buffer.contents b module Interactive_stuff = struct let display_from_lexbuf make_lexbuf = let lexbuf = make_lexbuf () in let sexps_abs = With_layout.Parser.sexps_abs With_layout.Lexer.main lexbuf in let s = String.concat "\n" ( List.map (fun t -> Sexp.to_string_hum (Type_with_layout.Parsed.sexp_of_t_or_comment t) ) sexps_abs ) in Printf.printf "With_layout.Parsed.t:\n%s\n\n%!" s; let lexbuf = make_lexbuf () in let sexps = With_layout.Parser.sexps With_layout.Lexer.main lexbuf in let s = String.concat "\n" ( List.map (fun t -> Sexp.to_string_hum (With_layout.sexp_of_t_or_comment t)) sexps ) in Printf.printf "With_layout.t:\n%s\n\n%!" s; let s = string_of_sexps_with_layout sexps in Printf.printf "rendered:<<\n%s\n>>\n%!" s let is_a_file s = try let ch = open_in s in close_in ch; true with Sys_error _ -> false end let failures = ref 0 let total = ref 0 let split_newlines s = let acc = ref [] in let b = Buffer.create 10 in let split () = acc := Buffer.contents b :: !acc; Buffer.clear b in for i = 0 to String.length s - 1 do if s.[i] = '\n' then split (); Buffer.add_char b s.[i] done; split (); List.rev !acc let rstrip s = let rec aux i = if i = 0 then "" else match s.[i - 1] with | ' ' | '\t' | '\n' | '\r' -> aux (i - 1) | _ -> String.sub s 0 i in aux (String.length s) let normalize_string s = (* removing the spacing at the end and removing the trailing whitespace on each line except the final carriage return if any so that \r\n in the input stays \r\n in the output *) let s = rstrip s in let l = split_newlines s in let l = List.map (fun s -> let ends_with_cr = s <> "" && s.[String.length s - 1] = '\r' in let s = rstrip s in if ends_with_cr && care_about_windows_newlines then s ^ "\r" else s ) l in String.concat "" l let test_printer () = let tests = [ (* basic things *) "a"; "a b"; "a b "; "\na \n b \n "; "(\na \n) () b \n "; (* single line comments *) ";\n"; ";() b \n "; "(;\n)"; "(a;\nb)"; (* block comments *) "#||#"; "#| ((a((|#"; (* block comments + random contents *) "a\"#|\"b"; (* quoted atom with block comment start *) "a \"|#\" b"; (* quoted atom with block comment end *) "a #|\"|#\" b|#"; (* block comment with quoted atom *) "a \n#|\"\n|#\" b|#\n"; (* block comment with quoted atom and newlines *) (* sexp comment *) "#;out in"; (* standard case *) "#;out#;out-as-well ;still out\n finally-in"; (* consecutive sexp comments *) "#;#;out out-as-well ;still out\n finally-in"; (* nested sexp comments *) "#;#;(\"out\" )out-as-well ;still out\n finally-in"; (* nested sexp comments that comment out more complicated expressions *) "#;;line comment1\n;line comment2\nout in"; ] in List.iter (fun test_str -> List.iter (fun wrapper -> List.iter (fun (newline_adapter, newline_style) -> incr total; let test_str = newline_adapter (wrapper test_str) in let lexbuf = Lexing.from_string test_str in let sexps_opt = try Some (With_layout.Parser.sexps With_layout.Lexer.main lexbuf) with e -> incr failures; let str = Printexc.to_string e in Printf.printf "Failed to parse %S (%s):\n %s\n%!" test_str newline_style str; None in match sexps_opt with | None -> () | Some sexps -> let printed_str_opt = try Some (string_of_sexps_with_layout sexps) with e -> incr failures; let str = Printexc.to_string e in Printf.printf "Failed to print %S (%s):\n %s\n %s\n%!" test_str newline_style (Sexp.to_string (Sexp.List (With_layout.Forget.t_or_comments sexps))) str; None in match printed_str_opt with | None -> () | Some printed_str -> (* trailing whitespace (at the end of lines or at the end of file) is not handled by the parser/printer, except when they are in a comment but that is annoying to check so stripping everything from both strings *) if normalize_string test_str <> normalize_string printed_str then ( incr failures; Printf.printf "Comparison failed %S (%s):\n\ \ got %S after parsing + printing\n\ \ test after normalization: %S\n\ \ printed after normalization: %S\n%!" test_str newline_style printed_str (normalize_string test_str) (normalize_string printed_str); ) ) newline_adapters ) (wrap_in_context ()) ) tests let () = match Array.to_list Sys.argv with | [] -> () | [_] -> (* no commmand line argument -> non interactive part *) test_printer (); if !failures <> 0 then ( Printf.printf "%d / %d tests failed\n%!" !failures !total; exit 2 ) | _ :: l -> (* command line argument -> take the arguments as files or sexps to be parsed *) List.iter (fun s -> let make_lexbuf = if Interactive_stuff.is_a_file s then (fun () -> let cin = open_in s in let lexbuf = Lexing.from_channel cin in Gc.finalise (fun cin -> close_in cin) cin; lexbuf ) else (fun () -> Lexing.from_string s) in Interactive_stuff.display_from_lexbuf make_lexbuf ) l sexplib-109.20.00/lib_test/sexp_test.ml000066400000000000000000000021141213530673200176460ustar00rootroot00000000000000(** Sexp_test: Module for Testing S-expression I/O. Example invocation: "sexp_test < test.sexp" *) open Format open Sexplib open Sexp (* let input_sexps ic = let lexbuf = Lexing.from_channel ic in scan_sexps lexbuf *) let () = let orig_sexps = input_sexps stdin in let hum_file = "/tmp/__hum.sexp" in let hum_oc = open_out hum_file in let hum_ppf = formatter_of_out_channel hum_oc in List.iter (fun sexp -> fprintf hum_ppf "%a@\n" Sexp.pp_hum sexp) orig_sexps; pp_print_flush hum_ppf (); close_out hum_oc; let mach_file = "/tmp/__mach.sexp" in let mach_oc = open_out mach_file in List.iter (fun sexp -> Printf.fprintf mach_oc "%a\n" Sexp.output_mach sexp) orig_sexps; close_out mach_oc; let hum_ic = open_in hum_file in let hum_sexps = input_sexps hum_ic in close_in hum_ic; assert (hum_sexps = orig_sexps); Sys.remove hum_file; let mach_ic = open_in mach_file in let mach_sexps = input_sexps mach_ic in close_in mach_ic; assert (mach_sexps = orig_sexps); Sys.remove mach_file; printf "Parsing S-expressions: SUCCESS!!!@." sexplib-109.20.00/lib_test/test.sexp000066400000000000000000000006561213530673200171670ustar00rootroot00000000000000(this is a list) (this is another list and (this is a nested list)) ( "\ This is a multi-line \ string with embedded newlines." "This string contains decimal \255, hex \xff codes, \ and other \\ \n escapes." A# # ## #x| ) ; Line comment #; ( S-expression comment ) #| #| Nested |# block comment "|#" |# #| "" |# #| ""|# #|"" |# #|""|# #| "asdf" "asdf" |# (something #| ; |# () "something else") sexplib-109.20.00/lib_test/test_common.ml000066400000000000000000000021121213530673200201550ustar00rootroot00000000000000open Sexplib let () = Printexc.register_printer (function | Sexp.Parse_error {Sexp.location; err_msg; parse_state=_ } -> Some ( Printf.sprintf "Sexp.parse_error {location = %S; err_msg = %S}" location err_msg ) | _ -> None ) let wrap_in_context ?(no_following_sibling=false) () = [ (fun a -> a); (fun a -> "(" ^ a ^ ")"); (* checking if the spacing around braces changes something *) (fun a -> "( " ^ a ^ ")"); (fun a -> "(" ^ a ^ " )"); (fun a -> "( " ^ a ^ " )"); (fun a -> "( ( ( " ^ a ^ " ) ) )"); ] @ ( if no_following_sibling then [] else [ (fun a -> "( something " ^ a ^ "\"something else\")"); (fun a -> "( \"something else\"" ^ a ^ " something )"); (fun a -> "((\"something else\")" ^ a ^ "(something))"); ] ) let explode s = let acc = ref [] in for i = String.length s - 1 downto 0 do acc := s.[i] :: !acc done; !acc let newline_adapters = [ (fun s -> s), "unix"; (fun s -> String.concat "" (List.map (function '\n' -> "\r\n" | c -> String.make 1 c) (explode s))), "windows"; ] sexplib-109.20.00/lib_test_ounit/000077500000000000000000000000001213530673200165165ustar00rootroot00000000000000sexplib-109.20.00/lib_test_ounit/test_sexp_with_layout.ml000066400000000000000000000032321213530673200235160ustar00rootroot00000000000000(* packaging of annotated sexp functions *) open Sexplib module M = Sexp.With_layout TEST_MODULE "forget" = 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] TEST = M.Forget.t_or_comment a1 = None TEST = M.Forget.t_or_comment a2 = Some b2 TEST = M.Forget.t_or_comment a3 = Some b3 TEST = M.Forget.t_or_comment a4 = Some b4 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 TEST = same_as_simple a1 TEST = same_as_simple a2 TEST = same_as_simple a3 TEST = same_as_simple a4 TEST = same_as_simple a5 end sexplib-109.20.00/myocamlbuild.ml000066400000000000000000000345751213530673200165240ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: f445332011b20e926cbe52b8fd37e91b) *) module OASISGettext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 117 "myocamlbuild.ml" module BaseEnvLight = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let split s ch = let x = ref [] in let rec go s = let pos = String.index s ch in x := (String.before s pos)::!x; go (String.after s (pos + 1)) in try go s with Not_found -> !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* this lists all supported packages *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") (* this is supposed to list available syntaxes, but I don't know how to do it. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] (* ocamlfind command *) let ocamlfind x = S[A"ocamlfind"; x] let dispatch = function | Before_options -> (* by using Before_options one let command line options have an higher priority *) (* on the contrary using After_options will guarantee to have the higher priority *) (* override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop" | After_rules -> (* When one link an OCaml library/binary/package, one should use -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) | _ -> () end module MyOCamlbuildBase = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 56 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [] -> ocaml_lib nm | nm, dir :: tl -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. *) dep ["link"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in flag tags & spec) t.flags | _ -> () let dispatch_default t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] end # 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("sexplib", ["lib"]); ("pa_sexp_conv", ["syntax"]); ("sexplib_top", ["top"]) ]; lib_c = []; flags = []; includes = [("lib_test", ["lib"; "syntax"])]; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; # 495 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | After_rules -> pflag ["ocaml"; "compile"] "I" (fun x -> S [A "-I"; A x]); flag ["ocamldep"; "ocaml"; "use_pa_sexp_conv"] (S [A "-ppopt"; P "syntax/pa_sexp_conv.cma"]); flag ["compile"; "ocaml"; "use_pa_sexp_conv"] (S [A "-ppopt"; P "syntax/pa_sexp_conv.cma"]) | _ -> () let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook) sexplib-109.20.00/setup.ml000066400000000000000000005142031213530673200151720ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 0f2d96e9ac0553c3e7c7ce1da1fa5979) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let args () = ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), (s_ " Run quietly"); "-info", Arg.Unit (fun () -> default := {!default with info = true}), (s_ " Display information message"); "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), (s_ " Output debug message")] end module OASISString = struct (* # 1 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do buf.[i] <- f s.[i] done; buf end module OASISUtils = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext module MapString = Map.Make(String) let map_string_of_assoc assoc = List.fold_left (fun acc (k, v) -> MapString.add k v acc) MapString.empty assoc module SetString = Set.Make(String) let set_string_add_list st lst = List.fold_left (fun acc e -> SetString.add e acc) st lst let set_string_of_list = set_string_add_list SetString.empty let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 71 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let version_0_3_or_after t = comparator_apply t (VGreaterEqual (string_of_version "0.3")) end module OASISLicense = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISTypes = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 102 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: string option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISUnixPath = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * library * group_t list) (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; lst in List.map (fun nm -> List.map (fun base_fn -> base_fn ^"."^ext) (find_module nm)) lst in (* The headers that should be compiled along *) let headers = if lib.lib_pack then [] else find_modules lib.lib_modules "cmi" in (* The .cmx that be compiled along *) let cmxs = let should_be_built = (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) type data = common_section * build_section * library type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children : tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, lib) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = Lazy.lazy_from_fun (fun () -> (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty) in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a,b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a,b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p,e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (if case_sensitive then file_exists_case else Sys.file_exists) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2142 "setup.ml" module BaseEnvLight = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let var_get name env = let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff in var_expand (MapString.find name env) let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2240 "setup.ml" module BaseContext = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext let args = args let default = default end module BaseMessage = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e : unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name,value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s : string = ocamlopt () in "true" with PropList.Not_set _ -> let _s : string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let (failed, n) = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t [||]; info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> "_oasis" in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 4480 "setup.ml" module InternalConfigurePlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s : string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISLibrary open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the flag \ '-add' of ocamlfind because the command line is too \ long. This flag is only available for findlib 1.3.2. \ Please upgrade findlib from %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize modul^".ml"]) :: acc with Not_found -> begin warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; acc end) acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, lib, children) -> files_of_library data_and_files (cs, bs, lib), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let (_, bs, _) = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let (cs, bs, exec) = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let (cs, doc) = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev;])) end # 5233 "setup.ml" module OCamlbuildCommon = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let ends_with nd fn = let nd_len = String.length nd in (String.length fn >= nd_len) && (String.sub fn (String.length fn - nd_len) nd_len) = nd in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cma" fn || ends_with ".cmxs" fn || ends_with ".cmxa" fn || ends_with (ext_lib ()) fn || ends_with (ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (f_ "No one of expected built files %s exists") (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in let cond_targets = (* Run the hook *) !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets)) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar let doc_build path pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix path; cs.cs_name^".docdir"; ] in run_ocamlbuild [index_html] argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean t pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 5558 "setup.ml" module CustomPlugin = struct (* # 21 "/home/ysulsky/local/opam-full/4.00.1/build/oasis.0.3.0/src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 5694 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build; test = [ ("sexp", CustomPlugin.Test.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$sexp_test", ["<"; "test.sexp"])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("conv", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$conv_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; doc = [("sexplib", OCamlbuildDocPlugin.doc_build "lib")]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("sexp", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$sexp_test", ["<"; "test.sexp"])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("conv", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$conv_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; clean_doc = [("sexplib", OCamlbuildDocPlugin.doc_clean "lib")]; distclean = []; distclean_test = [ ("sexp", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$sexp_test", ["<"; "test.sexp"])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("conv", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$conv_test", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = Some (OASISVersion.VGreaterEqual "1.3.2"); name = "sexplib"; version = "109.20.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0"; }); license_file = Some "LICENSE.txt"; copyrights = [ "(C) 2005-2013 Jane Street Capital LLC " ]; maintainers = ["Jane Street Capital LLC "]; authors = ["Jane Street Capital LLC "]; homepage = Some "https://github.com/janestreet/sexplib"; synopsis = "sexplib - automated S-expression conversion"; description = None; categories = []; conf_type = (`Configure, "internal", Some "0.3"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; build_type = (`Build, "ocamlbuild", Some "0.3"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; install_type = (`Install, "internal", Some "0.3"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; files_ab = []; sections = [ Library ({ cs_name = "sexplib"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("unix", None); FindlibPackage ("bigarray", None); FindlibPackage ("num", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = [ "Conv"; "Conv_error"; "Exn_magic"; "Path"; "Pre_sexp"; "Sexp"; "Sexp_intf"; "Sexp_with_layout"; "Src_pos"; "Std"; "Type"; "Type_with_layout"; "Parser"; "Parser_with_layout"; "Lexer" ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "sexplib"; lib_findlib_containers = []; }); Library ({ cs_name = "pa_sexp_conv"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4.quotations", None); FindlibPackage ("camlp4.extend", None); FindlibPackage ("type_conv", Some (OASISVersion.VGreaterEqual "109.20.00")) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = ["Pa_sexp_conv"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "sexplib"; lib_findlib_name = Some "syntax"; lib_findlib_containers = []; }); Library ({ cs_name = "sexplib_top"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "top"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { lib_modules = ["Sexplib_install_printers"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "sexplib"; lib_findlib_name = Some "top"; lib_findlib_containers = []; }); Executable ({ cs_name = "sexp_test"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib_test"; bs_compiled_object = Byte; bs_build_depends = [InternalLibrary "sexplib"]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = false; exec_main_is = "sexp_test.ml"; }); Executable ({ cs_name = "conv_test"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tests", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "lib_test"; bs_compiled_object = Byte; bs_build_depends = [ InternalLibrary "sexplib"; InternalLibrary "pa_sexp_conv" ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])]; }, {exec_custom = false; exec_main_is = "conv_test.ml"; }); Test ({ cs_name = "sexp"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); test_command = [ (OASISExpr.EBool true, ("$sexp_test", ["<"; "test.sexp"])) ]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; test_working_directory = Some "lib_test"; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "tests"), true) ]; test_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; }); Test ({ cs_name = "conv"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); test_command = [(OASISExpr.EBool true, ("$conv_test", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; test_working_directory = Some "lib_test"; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "tests"), true) ]; test_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; }); Doc ({ cs_name = "sexplib"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$docdir"; doc_title = "API reference for sexplib"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = []; doc_build_tools = [ ExternalTool "ocamlbuild"; ExternalTool "camlp4o"; ExternalTool "ocamldoc" ]; }) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; oasis_digest = Some ":\208\234\234\206xK\195b\004C\015\2405\145\191"; oasis_exec = None; oasis_setup_args = []; setup_update = false; };; let setup () = BaseSetup.setup setup_t;; # 6131 "setup.ml" (* OASIS_STOP *) let () = setup () sexplib-109.20.00/syntax/000077500000000000000000000000001213530673200150215ustar00rootroot00000000000000sexplib-109.20.00/syntax/pa_sexp_conv.ml000066400000000000000000001503141213530673200200430ustar00rootroot00000000000000(* Pa_sexp_conv: Preprocessing Module for Automated S-expression Conversions *) open StdLabels open MoreLabels open Printf open Camlp4 open PreCast open Syntax module Gen = Pa_type_conv.Gen (* Utility functions *) let mk_rev_bindings loc fps = let coll (i, bindings, patts, vars) fp = let name = "v" ^ string_of_int i in let var_expr = <:expr@loc< $lid:name$ >> in let expr = match fp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ $var_expr$ >> | `Match matchings -> <:expr@loc< match $var_expr$ with [ $matchings$ ] >> in let patt = <:patt@loc< $lid:name$ >> in let bindings = <:binding@loc< $patt$ = $expr$ and $bindings$ >> in i - 1, bindings, patt :: patts, var_expr :: vars in let n = List.length fps in let _, bindings, patts, expr = List.fold_left ~f:coll ~init:(n, Ast.BiNil loc, [], []) fps in bindings, patts, expr let mk_full_type loc type_name tps = let coll_args tp _param = <:ctyp@loc< $tp$ _ >> in List.fold_left ~f:coll_args ~init:<:ctyp@loc< $lid:type_name$ >> tps ;; let sexp_type_is_recursive type_name tp = Gen.type_is_recursive type_name tp ~short_circuit:(function | <:ctyp< sexp_opaque $_$ >> -> Some false | _ -> None) let mk_bindings loc fps = mk_rev_bindings loc (List.rev fps) let unroll_cnv_fp loc var = function | `Fun fun_expr -> <:expr@loc< $fun_expr$ $var$ >> | `Match matchings -> <:expr@loc< match $var$ with [ $matchings$ ] >> let unroll_fun_matches loc fp1 fp2 = match fp1, fp2 with | `Fun fun_expr1, `Fun fun_expr2 -> <:expr@loc< $fun_expr1$ $fun_expr2$ >> | `Fun fun_expr, `Match matching -> <:expr@loc< $fun_expr$ (fun [ $matching$ ]) >> | _ -> assert false (* impossible *) let rec sig_of_tds cnv = function | Ast.TyDcl (loc, type_name, tps, rhs, cl) -> cnv loc type_name tps rhs cl | Ast.TyAnd (loc, tp1, tp2) -> <:sig_item@loc< $sig_of_tds cnv tp1$; $sig_of_tds cnv tp2$ >> | _ -> assert false (* impossible *) let type_app base_type types = List.fold_left types ~init:base_type ~f:(fun acc typ -> let loc = Ast.loc_of_ctyp typ in <:ctyp@loc< $acc$ $typ$ >>) ;; (* Generates the quantified type [ ! 'a .. 'z . (make_mono_type t ('a .. 'z)) ], or [None] if there are no type parameters. A quantified type annotation is required for of_sexp and to_sexp functions for non-regular types, such as [ type t 'a = [ A of 'a | B of t 'a 'a ] ]. *) let mk_poly_type make_mono_type loc type_name type_params = let type_params = List.map type_params ~f:Gen.drop_variance_annotations in match type_params with | [] -> None | first :: rest -> let unquantified_type = make_mono_type <:ctyp@loc< $lid:type_name$ >> type_params in let loc = Ast.loc_of_ctyp unquantified_type in (* It's confusing that you need an application between the '!' and the '.'. I would have expected a list. *) Some <:ctyp@loc< ! $type_app first rest$ . $unquantified_type$ >> (* Generators for S-expressions *) (* Generates the signature for type conversion to S-expressions *) module Sig_generate_sexp_of = struct let rec sig_of_td__loop acc = function | [] -> let loc = Ast.loc_of_ctyp acc in <:ctyp@loc< $acc$ -> Sexplib.Sexp.t >> | tp :: tps -> let tp = Gen.drop_variance_annotations tp in let loc = Ast.loc_of_ctyp tp in let sexp_of = sig_of_td__loop <:ctyp@loc< $acc$ $tp$ >> tps in <:ctyp@loc< ( $tp$ -> Sexplib.Sexp.t ) -> $sexp_of$ >> let sig_of_td loc type_name tps _rhs _cl = let sexp_of = sig_of_td__loop <:ctyp@loc< $lid:type_name$ >> tps in <:sig_item@loc< value $lid: "sexp_of_" ^ type_name$ : $sexp_of$ >> let mk_sig _rec tds = <:sig_item< $sig_of_tds sig_of_td tds$ >> let () = Pa_type_conv.add_sig_generator ~delayed:true "sexp_of" mk_sig let mk_sig_exn _rec = function | <:ctyp@loc< $uid:_$ >> | <:ctyp@loc< $uid:_$ of $_$ >> -> <:sig_item@loc< >> | tp -> Gen.error tp ~fn:"mk_sig_exn" ~msg:"unknown type" let () = Pa_type_conv.add_sig_generator ~delayed:true ~is_exn:true "sexp" mk_sig_exn end (* Generates the signature for type conversion from S-expressions *) module Sig_generate_of_sexp = struct let rec is_polymorphic_variant = function | <:ctyp< ($ty$ as $_$) >> -> is_polymorphic_variant ty | <:ctyp< private $tp$ >> -> is_polymorphic_variant tp | <:ctyp< ( $tup:_$ ) >> | <:ctyp< $_$ -> $_$ >> | <:ctyp< { $_$ } >> | <:ctyp< [ $_$ ] >> -> `Surely_not | <:ctyp< [< $_$ ] >> | <:ctyp< [> $_$ ] >> | <:ctyp< [= $_$ ] >> -> `Definitely | <:ctyp< '$_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $id:_$ >> | <:ctyp< >> -> `Maybe | <:ctyp< $tp1$ == $tp2$ >> -> begin match is_polymorphic_variant tp1 with | (`Surely_not | `Definitely) as res -> res | `Maybe -> is_polymorphic_variant tp2 end | tp -> Gen.unknown_type tp "Sig_generate_of_sexp.is_polymorphic_variant" let rec sig_of_td__loop acc = function | [] -> let loc = Ast.loc_of_ctyp acc in <:ctyp@loc< Sexplib.Sexp.t -> $acc$ >> | tp :: tps -> let tp = Gen.drop_variance_annotations tp in let loc = Ast.loc_of_ctyp tp in let of_sexp = sig_of_td__loop <:ctyp@loc< $acc$ $tp$ >> tps in <:ctyp@loc< ( Sexplib.Sexp.t -> $tp$ ) -> $of_sexp$ >> let sig_of_td with_poly loc type_name tps rhs _cl = let of_sexp = sig_of_td__loop <:ctyp@loc< $lid:type_name$ >> tps in let of_sexp_item = <:sig_item@loc< value $lid: type_name ^ "_of_sexp"$ : $of_sexp$; >> in match with_poly, is_polymorphic_variant rhs with | true, `Surely_not -> Gen.error rhs ~fn:"Sig_generate_of_sexp.sig_of_td" ~msg:"sexp_poly annotation \ but type is surely not a polymorphic variant" | false, (`Surely_not | `Maybe) -> of_sexp_item | (true | false), `Definitely | true, `Maybe -> <:sig_item@loc< $of_sexp_item$; value $lid: "__" ^ type_name ^ "_of_sexp__"$ : $of_sexp$; >> let mk_sig with_poly _rec tds = <:sig_item< $sig_of_tds (sig_of_td with_poly) tds$ >> let () = Pa_type_conv.add_sig_generator ~delayed:true "of_sexp" (mk_sig false) let () = Pa_type_conv.add_sig_generator ~delayed:true "of_sexp_poly" (mk_sig true) end (* Generates the signature for type conversion to S-expressions *) module Sig_generate = struct let () = Pa_type_conv.add_sig_set "sexp" ~set:["sexp_of"; "of_sexp"] let () = Pa_type_conv.add_sig_set "sexp_poly" ~set:["sexp_of"; "of_sexp_poly"] end (* Generator for converters of OCaml-values to S-expressions *) module Generate_sexp_of = struct (* Handling of record defaults *) type record_field_handler = [ `keep | `drop_default | `drop_if of Ast.expr ] let record_field_handlers : (Loc.t, record_field_handler) Hashtbl.t = Hashtbl.create 0 let get_record_field_handler loc = try Hashtbl.find record_field_handlers loc with Not_found -> `keep let check_record_field_handler loc = if Hashtbl.mem record_field_handlers loc then Loc.raise loc (Failure "sexp record field handler defined twice") let () = Pa_type_conv.add_record_field_generator "sexp_drop_default" (fun tp -> let loc = Ast.loc_of_ctyp tp in check_record_field_handler loc; Hashtbl.replace record_field_handlers ~key:loc ~data:`drop_default) let () = Pa_type_conv.add_record_field_generator_with_arg "sexp_drop_if" Syntax.expr (fun expr_opt tp -> let loc = Ast.loc_of_ctyp tp in check_record_field_handler loc; let test = match expr_opt with | Some expr -> expr | None -> Loc.raise loc (Failure "could not parse expression") in Hashtbl.replace record_field_handlers ~key:loc ~data:(`drop_if test)) (* Make abstract calls *) let mk_abst_call loc tn rev_path = <:expr@loc< $id:Gen.ident_of_rev_path loc (("sexp_of_" ^ tn) :: rev_path)$ >> (* Conversion of type paths *) let sexp_of_path_fun loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call loc tn rev_path | [] -> assert false (* impossible *) (* Conversion of types *) let rec sexp_of_type = function | <:ctyp@loc< _ >> -> `Fun <:expr@loc< fun _ -> Sexp.Atom "_" >> | <:ctyp@loc< sexp_opaque $_$ >> -> `Fun <:expr@loc< Sexplib.Conv.sexp_of_opaque >> | <:ctyp@loc< $tp1$ $tp2$ >> -> `Fun (sexp_of_appl_fun loc tp1 tp2) | <:ctyp< ( $tup:tp$ ) >> -> sexp_of_tuple tp | <:ctyp@loc< '$parm$ >> -> `Fun <:expr@loc< $lid:"_of_" ^ parm$ >> | <:ctyp@loc< $id:id$ >> -> `Fun (sexp_of_path_fun loc id) | <:ctyp@loc< $_$ -> $_$ >> -> `Fun <:expr@loc< fun _f -> Sexplib.Conv.sexp_of_fun Pervasives.ignore >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> sexp_of_variant row_fields | <:ctyp< ! $parms$ . $poly_tp$ >> -> sexp_of_poly parms poly_tp | tp -> Gen.unknown_type tp "sexp_of_type" (* Conversion of polymorphic types *) and sexp_of_appl_fun loc tp1 tp2 = match sexp_of_type tp1, sexp_of_type tp2 with | `Fun fun_expr1, `Fun fun_expr2 -> <:expr@loc< $fun_expr1$ $fun_expr2$ >> | `Fun fun_expr, `Match matching -> <:expr@loc< $fun_expr$ (fun [ $matching$ ]) >> | _ -> assert false (* impossible *) (* Conversion of tuples *) and sexp_of_tuple tp = let loc = Ast.loc_of_ctyp tp in let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tp []) in let bindings, patts, vars = mk_bindings loc fps in let in_expr = <:expr@loc< Sexplib.Sexp.List $Gen.mk_expr_lst loc vars$ >> in let expr = <:expr@loc< let $bindings$ in $in_expr$ >> in `Match <:match_case@loc< ( $tup:Ast.paCom_of_list patts$ ) -> $expr$ >> (* Conversion of variant types *) and mk_cnv_expr tp = let loc = Ast.loc_of_ctyp tp in match sexp_of_type tp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> and sexp_of_variant row_fields = let rec loop = function | <:ctyp@loc< $tp1$ | $tp2$ >> -> <:match_case@loc< $loop tp1$ | $loop tp2$ >> | <:ctyp@loc< `$cnstr$ >> -> <:match_case@loc< `$cnstr$ -> Sexplib.Sexp.Atom $str:cnstr$ >> | <:ctyp@loc< `$cnstr$ of sexp_list $tp$>> -> let cnv_expr = match sexp_of_type tp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun el -> match el with [ $matchings$ ] >> in <:match_case@loc< `$cnstr$ l -> Sexplib.Sexp.List [ Sexplib.Sexp.Atom $str:cnstr$ :: Sexplib.Conv.list_map $cnv_expr$ l] >> | <:ctyp@loc< `$cnstr$ of $tps$ >> -> let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tps []) in let bindings, patts, vars = mk_bindings loc fps in let cnstr_expr = <:expr@loc< Sexplib.Sexp.Atom $str:cnstr$ >> in let expr = <:expr@loc< let $bindings$ in Sexplib.Sexp.List $Gen.mk_expr_lst loc (cnstr_expr :: vars)$ >> in <:match_case@loc< `$cnstr$ $Ast.paSem_of_list patts$ -> $expr$ >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> loop row_fields | <:ctyp@loc< $tp1$ $tp2$ >> -> let id_path = Gen.get_appl_path loc tp1 in let call = sexp_of_appl_fun loc tp1 tp2 in <:match_case@loc< #$id_path$ as v -> $call$ v >> | <:ctyp@loc< $id:id$ >> | <:ctyp@loc< #$id:id$ >> -> let call = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call loc tn rev_path | [] -> assert false (* impossible *) in <:match_case@loc< #$id$ as v -> $call$ v >> | tp -> Gen.unknown_type tp "sexp_of_variant" in `Match (loop row_fields) (* Polymorphic record fields *) and sexp_of_poly parms tp = let loc = Ast.loc_of_ctyp tp in let bindings = let mk_binding parm = <:binding@loc< $lid:"_of_" ^ parm$ = Sexplib.Conv.sexp_of_opaque >> in List.map ~f:mk_binding (Gen.ty_var_list_of_ctyp parms []) in match sexp_of_type tp with | `Fun fun_expr -> `Fun <:expr@loc< let $list:bindings$ in $fun_expr$ >> | `Match matchings -> `Match <:match_case@loc< arg -> let $list:bindings$ in match arg with [ $matchings$ ] >> (* Conversion of sum types *) let rec branch_sum = function | <:ctyp@loc< $tp1$ | $tp2$ >> -> <:match_case@loc< $branch_sum tp1$ | $branch_sum tp2$ >> | <:ctyp@loc< $uid:cnstr$ >> -> <:match_case@loc< $uid:cnstr$ -> Sexplib.Sexp.Atom $str:cnstr$ >> | <:ctyp@loc< $uid:cnstr$ of sexp_list $tp$>> -> let cnv_expr = match sexp_of_type tp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun el -> match el with [ $matchings$ ] >> in <:match_case@loc< $uid:cnstr$ l -> Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:cnstr$ :: Sexplib.Conv.list_map $cnv_expr$ l] >> | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tps []) in let cnstr_expr = <:expr@loc< Sexplib.Sexp.Atom $str:cnstr$ >> in let bindings, patts, vars = mk_bindings loc fps in let patt = match patts with | [patt] -> patt | _ -> <:patt@loc< ( $tup:Ast.paCom_of_list patts$ ) >> in <:match_case@loc< $uid:cnstr$ $patt$ -> let $bindings$ in Sexplib.Sexp.List $Gen.mk_expr_lst loc (cnstr_expr :: vars)$ >> | <:ctyp< $_$ : $_$ >> as tp -> Gen.error tp ~fn:"branch_sum" ~msg:"GADTs are not supported by sexplib" | tp -> Gen.unknown_type tp "branch_sum" let sexp_of_sum alts = `Match (branch_sum alts) (* Conversion of record types *) let mk_rec_patt loc patt name = let p = <:patt@loc< $lid:name$ = $lid:"v_" ^ name$ >> in <:patt@loc< $patt$; $p$ >> let sexp_of_record_field patt expr name tp ?sexp_of is_empty_expr = let loc = Ast.loc_of_ctyp tp in let patt = mk_rec_patt loc patt name in let cnv_expr = match sexp_of_type tp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun el -> match el with [ $matchings$ ] >> in let cnv_expr = match sexp_of with | None -> cnv_expr | Some sexp_of -> <:expr@loc< $sexp_of$ $cnv_expr$ >> in let expr = let v_name = <:expr@loc< $lid: "v_" ^ name$ >> in <:expr@loc< let bnds = if $is_empty_expr loc v_name$ then bnds else let arg = $cnv_expr$ $v_name$ in let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] in [ bnd :: bnds ] in $expr$ >> in patt, expr let sexp_of_default_field patt expr name tp ?sexp_of default = sexp_of_record_field patt expr name tp ?sexp_of (fun loc expr -> <:expr@loc< Pervasives.(=) $default$ $expr$ >>) let sexp_of_record flds_ctyp = let flds = Ast.list_of_ctyp flds_ctyp [] in let list_empty_expr loc lst = <:expr@loc< match $lst$ with [ [] -> True | _ -> False ] >> in let array_empty_expr loc arr = <:expr@loc< match $arr$ with [ [||] -> True | _ -> False ] >> in let coll (patt, expr) = function | <:ctyp@loc< $lid:name$ : mutable sexp_option $tp$ >> | <:ctyp@loc< $lid:name$ : sexp_option $tp$ >> -> let patt = mk_rec_patt loc patt name in let vname = <:expr@loc< v >> in let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in let expr = <:expr@loc< let bnds = match $lid:"v_" ^ name$ with [ None -> bnds | Some v -> let arg = $cnv_expr$ in let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] in [ bnd :: bnds ] ] in $expr$ >> in patt, expr | <:ctyp@loc< $lid:name$ : mutable sexp_bool >> | <:ctyp@loc< $lid:name$ : sexp_bool >> -> let patt = mk_rec_patt loc patt name in let expr = <:expr@loc< let bnds = if $lid:"v_" ^ name$ then let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$] in [ bnd :: bnds ] else bnds in $expr$ >> in patt, expr | <:ctyp@loc< $lid:name$ : mutable sexp_list $tp$ >> | <:ctyp@loc< $lid:name$ : sexp_list $tp$ >> -> sexp_of_record_field patt expr name tp ~sexp_of:<:expr@loc< sexp_of_list >> list_empty_expr | <:ctyp@loc< $lid:name$ : mutable sexp_array $tp$ >> | <:ctyp@loc< $lid:name$ : sexp_array $tp$ >> -> sexp_of_record_field patt expr name tp ~sexp_of:<:expr@loc< sexp_of_array >> array_empty_expr | <:ctyp@loc< $lid:name$ : mutable $tp$ >> | <:ctyp@loc< $lid:name$ : $tp$ >> -> let opt_default = Pa_type_conv.Gen.find_record_default loc in let field_handler = get_record_field_handler loc in begin match opt_default, field_handler with | None, `drop_default -> Loc.raise loc (Failure "no default to drop") | _, `drop_if test -> sexp_of_record_field patt expr name tp (fun loc expr -> <:expr@loc< $test$ $expr$>>) | Some default, `drop_default -> sexp_of_default_field patt expr name tp default | _, `keep -> let patt = mk_rec_patt loc patt name in let vname = <:expr@loc< $lid:"v_" ^ name$ >> in let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in let expr = <:expr@loc< let arg = $cnv_expr$ in let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] in let bnds = [ bnd :: bnds ] in $expr$ >> in patt, expr end | _ -> assert false (* impossible *) in let loc = Ast.loc_of_ctyp flds_ctyp in let init_expr = <:expr@loc< Sexplib.Sexp.List bnds >> in let patt, expr = List.fold_left ~f:coll ~init:(<:patt@loc<>>, init_expr) flds in `Match <:match_case@loc< { $patt$ } -> let bnds = [] in $expr$ >> (* Empty type *) let sexp_of_nil loc = `Fun <:expr@loc< fun _v -> assert False >> (* Generate code from type definitions *) let sexp_of_td loc type_name tps rhs = let body = let rec loop tp = Gen.switch_tp_def tp ~alias:(fun (_ : Loc.t) tp -> sexp_of_type tp) ~sum:(fun (_ : Loc.t) tp -> sexp_of_sum tp) ~record:(fun (_ : Loc.t) tp -> sexp_of_record tp) ~variants:(fun (_ : Loc.t) tp -> sexp_of_variant tp) ~mani:(fun (_ : Loc.t) _tp1 tp2 -> loop tp2) ~nil:sexp_of_nil in match loop rhs with | `Fun fun_expr -> (* Prevent violation of value restriction and problems with recursive types by eta-expanding function definitions *) <:expr@loc< fun [ v -> $fun_expr$ v ] >> | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> in let patts = List.map tps ~f:(fun ty -> <:patt@loc< $lid:"_of_" ^ Gen.get_tparam_id ty$>>) in let body = Gen.abstract loc patts body in let body = match mk_poly_type Sig_generate_sexp_of.sig_of_td__loop loc type_name tps with | None -> body | Some typ -> <:expr@loc< ( $body$ : $typ$ ) >> in <:binding@loc< $lid:"sexp_of_" ^ type_name$ = $body$ >> let rec sexp_of_tds = function | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> sexp_of_td loc type_name tps rhs | Ast.TyAnd (loc, tp1, tp2) -> <:binding@loc< $sexp_of_tds tp1$ and $sexp_of_tds tp2$ >> | _ -> assert false (* impossible *) let sexp_of rec_ tds = let binding, recursive, loc = match tds with | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> sexp_of_td loc type_name tps rhs, rec_ && sexp_type_is_recursive type_name rhs, loc | Ast.TyAnd (loc, _, _) as tds -> sexp_of_tds tds, rec_, loc | _ -> assert false (* impossible *) in if recursive then <:str_item@loc< value rec $binding$ >> else <:str_item@loc< value $binding$ >> (* Add code generator to the set of known generators *) let () = Pa_type_conv.add_generator "sexp_of" sexp_of let sexp_of_exn _rec tp = let get_full_cnstr cnstr = Pa_type_conv.get_conv_path () ^ "." ^ cnstr in let expr = match tp with | <:ctyp@loc< $uid:cnstr$ >> -> <:expr@loc< Sexplib.Exn_magic.register $uid:cnstr$ $str:get_full_cnstr cnstr$ >> | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> let ctyps = Ast.list_of_ctyp tps [] in let fps = List.map ~f:sexp_of_type ctyps in let sexp_converters = List.map fps ~f:(function | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >>) in let _, patts, vars = mk_bindings loc fps in let register_name = sprintf "register%d" (List.length fps) in let make_exc = let var_args = match vars with | [var] -> var | _ -> <:expr@loc< $tup:Ast.exCom_of_list vars$ >> in Gen.abstract loc patts <:expr@loc< $uid:cnstr$ $var_args$ >> in let call = let partial = <:expr@loc< Sexplib.Exn_magic.$lid:register_name$ $make_exc$ $str:get_full_cnstr cnstr$ >> in Gen.apply loc partial sexp_converters in <:expr@loc< $call$ >> | tp -> Gen.unknown_type tp "sexp_of_exn" in let loc = Ast.loc_of_ctyp tp in <:str_item@loc< value () = $expr$ >> let () = Pa_type_conv.add_generator ~is_exn:true "sexp" sexp_of_exn end (* Generator for converters of S-expressions to OCaml-values *) module Generate_of_sexp = struct let mk_abst_call loc tn ?(internal = false) rev_path = let tns = tn ^ "_of_sexp" in let tns_suff = if internal then "__" ^ tns ^ "__" else tns in <:expr@loc< $id:Gen.ident_of_rev_path loc (tns_suff :: rev_path)$ >> (* Utility functions for polymorphic variants *) (* Handle backtracking when variants do not match *) let handle_no_variant_match loc expr = <:match_case@loc< Sexplib.Conv_error.No_variant_match _ -> $expr$ >> let is_wildcard = function [_] -> true | _ -> false (* Generate code depending on whether to generate a match for the last case of matching a variant *) let handle_variant_match_last loc match_last matches = if match_last || is_wildcard matches then match matches with | <:match_case< $_$ -> $expr$ >> :: _ -> expr | _ -> assert false (* impossible *) else <:expr@loc< match atom with [ $list:matches$ ] >> (* Generate code for matching malformed S-expressions *) let mk_variant_other_matches loc rev_els call = let coll_structs acc (loc, cnstr) = <:match_case@loc< $str:cnstr$ -> Sexplib.Conv_error.$lid:call$ _tp_loc _sexp >> :: acc in let exc_no_variant_match = <:match_case@loc< _ -> Sexplib.Conv_error.no_variant_match _tp_loc _sexp >> in List.fold_left ~f:coll_structs ~init:[exc_no_variant_match] rev_els (* Split the row fields of a variant type into lists of atomic variants, structured variants, atomic variants + included variant types, and structured variants + included variant types. *) let rec split_row_field (atoms, structs, ainhs, sinhs as acc) = function | <:ctyp@loc< `$cnstr$ >> -> let tpl = loc, cnstr in ( tpl :: atoms, structs, `A tpl :: ainhs, sinhs ) | <:ctyp@loc< `$cnstr$ of $tps$ >> -> ( atoms, (loc, cnstr) :: structs, ainhs, `S (loc, cnstr, tps) :: sinhs ) | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> List.fold_left ~f:split_row_field ~init:acc (Ast.list_of_ctyp row_fields []) | <:ctyp< $_$ $_$ >> | (<:ctyp< $id:_$ >> | <:ctyp< #$id:_$ >>) as inh -> let iinh = `I inh in ( atoms, structs, iinh :: ainhs, iinh :: sinhs ) | tp -> Gen.unknown_type tp "split_row_field" (* Conversion of type paths *) let path_of_sexp_fun loc id = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call loc tn rev_path | [] -> assert false (* no empty paths *) (* Conversion of types *) let rec type_of_sexp = function | <:ctyp@loc< sexp_opaque $_$ >> -> `Fun <:expr@loc< Sexplib.Conv.opaque_of_sexp >> | <:ctyp@loc< sexp_option >> -> `Fun <:expr@loc< fun a_of_sexp v -> Some (a_of_sexp v) >> | <:ctyp@loc< sexp_list >> -> `Fun <:expr@loc< fun a_of_sexp v -> Sexplib.Conv.list_of_sexp a_of_sexp v >> | <:ctyp@loc< sexp_array >> -> `Fun <:expr@loc< fun a_of_sexp v -> Sexplib.Conv.array_of_sexp a_of_sexp v >> | <:ctyp@loc< $tp1$ $tp2$ >> -> let fp1 = type_of_sexp tp1 in let fp2 = type_of_sexp tp2 in `Fun (unroll_fun_matches loc fp1 fp2) | <:ctyp< ( $tup:tp$ ) >> -> tuple_of_sexp tp | <:ctyp@loc< '$parm$ >> -> `Fun <:expr@loc< $lid:"_of_" ^ parm$ >> | <:ctyp@loc< $id:id$ >> -> `Fun (path_of_sexp_fun loc id) | <:ctyp@loc< $_$ -> $_$ >> -> `Fun <:expr@loc< Sexplib.Conv.fun_of_sexp >> | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> | <:ctyp< [= $row_fields$ ] >> -> variant_of_sexp ?full_type:None row_fields | <:ctyp< ! $parms$ . $poly_tp$ >> -> poly_of_sexp parms poly_tp | tp -> Gen.unknown_type tp "type_of_sexp" (* Conversion of tuples *) and tuple_of_sexp tps = let fps = List.map ~f:type_of_sexp (Ast.list_of_ctyp tps []) in let loc = Ast.loc_of_ctyp tps in let bindings, patts, vars = mk_bindings loc fps in let n = string_of_int (List.length fps) in `Match <:match_case@loc< Sexplib.Sexp.List $Gen.mk_patt_lst loc patts$ -> let $bindings$ in ( $tup:Ast.exCom_of_list vars$ ) | sexp -> Sexplib.Conv_error.tuple_of_size_n_expected _tp_loc $int:n$ sexp >> (* Generate internal call *) and mk_internal_call = function | <:ctyp@loc< $id:id$ >> | <:ctyp@loc< #$id:id$ >> -> let call = match Gen.get_rev_id_path id [] with | tn :: rev_path -> mk_abst_call loc tn ~internal:true rev_path | [] -> assert false (* impossible *) in call | <:ctyp@loc< $tp1$ $tp2$ >> -> let fp1 = `Fun (mk_internal_call tp1) in let fp2 = type_of_sexp tp2 in unroll_fun_matches loc fp1 fp2 | _ -> assert false (* impossible *) (* Generate code for matching included variant types *) and handle_variant_inh full_type match_last other_matches inh = let loc = Ast.loc_of_ctyp inh in let fun_expr = mk_internal_call inh in let match_exc = handle_no_variant_match loc ( handle_variant_match_last loc match_last other_matches) in let new_other_matches = [ <:match_case@loc< _ -> try ($fun_expr$ _sexp :> $full_type$) with [ $match_exc$ ] >> ] in new_other_matches, true (* Generate code for matching atomic variants *) and mk_variant_match_atom loc full_type rev_atoms_inhs rev_structs = let coll (other_matches, match_last) = function | `A (loc, cnstr) -> let new_match = <:match_case@loc< $str:cnstr$ -> `$cnstr$ >> in new_match :: other_matches, false | `I inh -> handle_variant_inh full_type match_last other_matches inh in let other_matches = mk_variant_other_matches loc rev_structs "ptag_takes_args" in let match_atoms_inhs, match_last = List.fold_left ~f:coll ~init:(other_matches, false) rev_atoms_inhs in handle_variant_match_last loc match_last match_atoms_inhs (* Variant conversions *) (* Match arguments of constructors (variants or sum types) *) and mk_cnstr_args_match ~is_variant cnstr tps = let loc = Ast.loc_of_ctyp tps in let cnstr vars_expr = if is_variant then <:expr@loc< `$cnstr$ $vars_expr$ >> else <:expr@loc< $uid:cnstr$ $vars_expr$ >> in match tps with | <:ctyp@loc< sexp_list $tp$ >> -> let cnv = match type_of_sexp tp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> | `Match matchings -> <:expr@loc< fun el -> match el with [ $matchings$ ] >> in cnstr <:expr@loc< Sexplib.Conv.list_map ($cnv$) sexp_args >> | _ -> let fps = List.map ~f:type_of_sexp (Ast.list_of_ctyp tps []) in let bindings, patts, vars = mk_bindings loc fps in let good_arg_match = let vars_expr = match vars with | [var_expr] -> var_expr | _ -> <:expr@loc< ( $tup:Ast.exCom_of_list vars$ ) >> in cnstr vars_expr in let handle_exc = if is_variant then "ptag_incorrect_n_args" else "stag_incorrect_n_args" in <:expr@loc< match sexp_args with [ $Gen.mk_patt_lst loc patts$ -> let $bindings$ in $good_arg_match$ | _ -> Sexplib.Conv_error.$lid:handle_exc$ _tp_loc _tag _sexp ] >> (* Generate code for matching structured variants *) and mk_variant_match_struct loc full_type rev_structs_inhs rev_atoms = let has_structs_ref = ref false in let coll (other_matches, match_last) = function | `S (loc, cnstr, tps) -> has_structs_ref := true; let expr = mk_cnstr_args_match ~is_variant:true cnstr tps in let new_match = <:match_case@loc< ($str:cnstr$ as _tag) -> $expr$ >> in new_match :: other_matches, false | `I inh -> handle_variant_inh full_type match_last other_matches inh in let other_matches = mk_variant_other_matches loc rev_atoms "ptag_no_args" in let match_structs_inhs, match_last = List.fold_left ~f:coll ~init:(other_matches, false) rev_structs_inhs in ( handle_variant_match_last loc match_last match_structs_inhs, !has_structs_ref ) (* Generate code for handling atomic and structured variants (i.e. not included variant types) *) and handle_variant_tag loc full_type row_fields = let rev_atoms, rev_structs, rev_atoms_inhs, rev_structs_inhs = List.fold_left ~f:split_row_field ~init:([], [], [], []) row_fields in let match_struct, has_structs = mk_variant_match_struct loc full_type rev_structs_inhs rev_atoms in let maybe_sexp_args_patt = if has_structs then <:patt@loc< sexp_args >> else <:patt@loc< _ >> in <:match_case@loc< Sexplib.Sexp.Atom atom as _sexp -> $mk_variant_match_atom loc full_type rev_atoms_inhs rev_structs$ | Sexplib.Sexp.List [Sexplib.Sexp.Atom atom :: $maybe_sexp_args_patt$] as _sexp -> $match_struct$ | Sexplib.Sexp.List [Sexplib.Sexp.List _ :: _] as sexp -> Sexplib.Conv_error.nested_list_invalid_poly_var _tp_loc sexp | Sexplib.Sexp.List [] as sexp -> Sexplib.Conv_error.empty_list_invalid_poly_var _tp_loc sexp >> (* Generate matching code for variants *) and variant_of_sexp ?full_type row_tp = let rec replace_params_with_underscores = function | <:ctyp@loc< $a$ $_$ >> -> <:ctyp@loc< $replace_params_with_underscores a$ _ >> | x -> x in let loc = Ast.loc_of_ctyp row_tp in let row_fields = Ast.list_of_ctyp row_tp [] in let row_tp = Ast.tyOr_of_list (List.map row_fields ~f:replace_params_with_underscores) in let is_contained, full_type = match full_type with | None -> true, <:ctyp@loc< [= $row_tp$ ] >> | Some full_type -> false, full_type in let top_match = match row_fields with | (<:ctyp< $id:_$ >> | <:ctyp< $_$ $_$ >>) as inh :: rest -> let rec loop inh row_fields = let call = <:expr@loc< ( $mk_internal_call inh$ sexp :> $full_type$ ) >> in match row_fields with | [] -> call | h :: t -> let expr = match h with | <:ctyp< $id:_$ >> | <:ctyp< $_$ $_$ >> -> loop h t | _ -> let rftag_matches = handle_variant_tag loc full_type row_fields in <:expr@loc< match sexp with [ $rftag_matches$ ] >> in <:expr@loc< try $call$ with [ $handle_no_variant_match loc expr$ ] >> in <:match_case@loc< sexp -> $loop inh rest$ >> | _ :: _ -> handle_variant_tag loc full_type row_fields | [] -> assert false (* impossible *) in if is_contained then `Fun <:expr@loc< fun sexp -> try match sexp with [ $top_match$ ] with [ Sexplib.Conv_error.No_variant_match (_tp_loc, sexp) -> Sexplib.Conv_error.no_matching_variant_found _tp_loc sexp ] >> else `Match top_match and poly_of_sexp parms tp = let loc = Ast.loc_of_ctyp tp in let bindings = let mk_binding parm = <:binding@loc< $lid:"_of_" ^ parm$ = fun sexp -> Sexplib.Conv_error.record_poly_field_value _tp_loc sexp >> in List.map ~f:mk_binding (Gen.ty_var_list_of_ctyp parms []) in match type_of_sexp tp with | `Fun fun_expr -> `Fun <:expr@loc< let $list:bindings$ in $fun_expr$ >> | `Match matchings -> `Match <:match_case@loc< arg -> let $list:bindings$ in match arg with [ $matchings$ ] >> (* Sum type conversions *) (* Generate matching code for well-formed S-expressions wrt. sum types *) let rec mk_good_sum_matches = function | <:ctyp@loc< $uid:cnstr$ >> -> let lccnstr = String.uncapitalize cnstr in <:match_case@loc< Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) -> $uid:cnstr$ >> | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> let lccnstr = String.uncapitalize cnstr in <:match_case@loc< (Sexplib.Sexp.List [Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$ as _tag) :: sexp_args] as _sexp) -> $mk_cnstr_args_match ~is_variant:false cnstr tps$ >> | <:ctyp@loc< $tp1$ | $tp2$ >> -> <:match_case@loc< $mk_good_sum_matches tp1$ | $mk_good_sum_matches tp2$ >> | _ -> assert false (* impossible *) (* Generate matching code for malformed S-expressions with good tags wrt. sum types *) let rec mk_bad_sum_matches = function | <:ctyp@loc< $uid:cnstr$ >> -> let lccnstr = String.uncapitalize cnstr in <:match_case@loc< Sexplib.Sexp.List [Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) :: _] as sexp -> Sexplib.Conv_error.stag_no_args _tp_loc sexp >> | <:ctyp@loc< $uid:cnstr$ of $_$ >> -> let lccnstr = String.uncapitalize cnstr in <:match_case@loc< Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) as sexp -> Sexplib.Conv_error.stag_takes_args _tp_loc sexp >> | <:ctyp@loc< $tp1$ | $tp2$ >> -> <:match_case@loc< $mk_bad_sum_matches tp1$ | $mk_bad_sum_matches tp2$ >> | _ -> assert false (* impossible *) (* Generate matching code for sum types *) let sum_of_sexp alts = let loc = Ast.loc_of_ctyp alts in `Match <:match_case@loc< $mk_good_sum_matches alts$ | $mk_bad_sum_matches alts$ | Sexplib.Sexp.List [Sexplib.Sexp.List _ :: _] as sexp -> Sexplib.Conv_error.nested_list_invalid_sum _tp_loc sexp | Sexplib.Sexp.List [] as sexp -> Sexplib.Conv_error.empty_list_invalid_sum _tp_loc sexp | sexp -> Sexplib.Conv_error.unexpected_stag _tp_loc sexp >> (* Record conversions *) (* Generate code for extracting record fields *) let mk_extract_fields tp = let rec loop no_args args = function | <:ctyp< $tp1$; $tp2$ >> -> let no_args, args = loop no_args args tp2 in loop no_args args tp1 | <:ctyp@loc< $lid:nm$ : mutable sexp_bool >> | <:ctyp@loc< $lid:nm$ : sexp_bool>> -> let no_args = <:match_case@loc< $str:nm$ -> if $lid:nm ^ "_field"$.val then duplicates.val := [ field_name :: duplicates.val ] else $lid:nm ^ "_field"$.val := True | $no_args$ >> in no_args, args | <:ctyp@loc< $lid:nm$ : mutable sexp_option $tp$ >> | <:ctyp@loc< $lid:nm$ : sexp_option $tp$ >> | <:ctyp@loc< $lid:nm$ : mutable $tp$ >> | <:ctyp@loc< $lid:nm$ : $tp$ >> -> let unrolled = unroll_cnv_fp loc <:expr@loc< _field_sexp >> (type_of_sexp tp) in let args = <:match_case@loc< $str:nm$ -> match $lid:nm ^ "_field"$.val with [ None -> let fvalue = $unrolled$ in $lid:nm ^ "_field"$.val := Some fvalue | Some _ -> duplicates.val := [ field_name :: duplicates.val ] ] | $args$ >> in no_args, args | _ -> assert false (* impossible *) in let handle_extra = let loc = Ast.loc_of_ctyp tp in <:match_case@loc< _ -> if Sexplib.Conv.record_check_extra_fields.val then extra.val := [ field_name :: extra.val ] else () >> in loop handle_extra handle_extra tp (* Generate code for handling the result of matching record fields *) let mk_handle_record_match_result has_poly flds = let has_nonopt_fields = ref false in let res_tpls, bi_lst, good_patts = let rec loop (res_tpls, bi_lst, good_patts as acc) = function | <:ctyp@loc< $lid:nm$ : $tp$ >> -> let fld = <:expr@loc< $lid:nm ^ "_field"$.val >> in let mk_default loc = bi_lst, <:patt@loc< $lid:nm ^ "_value"$ >> :: good_patts in let new_bi_lst, new_good_patts = match tp with | <:ctyp@loc< sexp_bool >> | <:ctyp@loc< mutable sexp_bool >> | <:ctyp@loc< sexp_option $_$ >> | <:ctyp@loc< mutable sexp_option $_$ >> | <:ctyp@loc< sexp_list $_$ >> | <:ctyp@loc< mutable sexp_list $_$ >> | <:ctyp@loc< sexp_array $_$ >> | <:ctyp@loc< mutable sexp_array $_$ >> -> mk_default loc | <:ctyp@loc< $_$ >> -> match Pa_type_conv.Gen.find_record_default loc with | Some _ -> mk_default loc | None -> has_nonopt_fields := true; ( <:expr@loc< (Pervasives.(=) $fld$ None, $str:nm$) >> :: bi_lst, <:patt@loc< Some $lid:nm ^ "_value"$ >> :: good_patts ) in ( <:expr@loc< $fld$ >> :: res_tpls, new_bi_lst, new_good_patts ) | <:ctyp< $tp1$; $tp2$ >> -> loop (loop acc tp2) tp1 | _ -> assert false (* impossible *) in loop ([], [], []) flds in let loc = Ast.loc_of_ctyp flds in let match_good_expr = if has_poly then let rec loop acc = function | <:ctyp< $tp1$; $tp2$ >> -> loop (loop acc tp2) tp1 | <:ctyp@loc< $lid:nm$ : $_$ >> -> <:expr@loc< $lid:nm ^ "_value"$ >> :: acc | _ -> assert false (* impossible *) in match loop [] flds with | [match_good_expr] -> match_good_expr | match_good_exprs -> <:expr@loc< $tup:Ast.exCom_of_list match_good_exprs$ >> else let rec loop = function | <:ctyp@loc< $tp1$; $tp2$ >> -> <:rec_binding@loc< $loop tp1$; $loop tp2$ >> | <:ctyp@loc< $lid:nm$ : mutable sexp_list $_$ >> | <:ctyp@loc< $lid:nm$ : sexp_list $_$ >> -> <:rec_binding@loc< $lid:nm$ = match $lid:nm ^ "_value"$ with [ None -> [] | Some v -> v ] >> | <:ctyp@loc< $lid:nm$ : mutable sexp_array $_$ >> | <:ctyp@loc< $lid:nm$ : sexp_array $_$ >> -> <:rec_binding@loc< $lid:nm$ = match $lid:nm ^ "_value"$ with [ None -> [||] | Some v -> v ] >> | <:ctyp@loc< $lid:nm$ : mutable $_$ >> | <:ctyp@loc< $lid:nm$ : $_$ >> -> begin match Pa_type_conv.Gen.find_record_default loc with | None -> <:rec_binding@loc< $lid:nm$ = $lid:nm ^ "_value"$ >> | Some default -> <:rec_binding@loc< $lid:nm$ = match $lid:nm ^ "_value"$ with [ None -> $default$ | Some v -> v ] >> end | _ -> assert false (* impossible *) in <:expr@loc< { $loop flds$ } >> in let expr, patt = match res_tpls, good_patts with | [res_expr], [res_patt] -> res_expr, res_patt | _ -> <:expr@loc< $tup:Ast.exCom_of_list res_tpls$ >>, <:patt@loc< $tup:Ast.paCom_of_list good_patts$ >> in if !has_nonopt_fields then <:expr@loc< match $expr$ with [ $patt$ -> $match_good_expr$ | _ -> Sexplib.Conv_error.record_undefined_elements _tp_loc sexp $Gen.mk_expr_lst loc bi_lst$ ] >> else <:expr@loc< match $expr$ with [ $patt$ -> $match_good_expr$ ] >> (* Generate code for converting record fields *) let mk_cnv_fields has_poly flds = let field_refs = let rec loop = function | <:ctyp@loc< $tp1$; $tp2$ >> -> <:binding@loc< $loop tp1$ and $loop tp2$ >> | <:ctyp@loc< $lid:nm$ : sexp_bool >> -> <:binding@loc< $lid:nm ^ "_field"$ = ref False >> | <:ctyp@loc< $lid:nm$ : $_$ >> -> <:binding@loc< $lid:nm ^ "_field"$ = ref None >> | _ -> assert false (* impossible *) in loop flds in let mc_no_args_fields, mc_fields_with_args = mk_extract_fields flds in let loc = Ast.loc_of_ctyp flds in <:expr@loc< let $field_refs$ and duplicates = ref [] and extra = ref [] in let rec iter = fun [ [ Sexplib.Sexp.List [(Sexplib.Sexp.Atom field_name); _field_sexp] :: tail ] -> do { match field_name with [ $mc_fields_with_args$ ]; iter tail } | [Sexplib.Sexp.List [(Sexplib.Sexp.Atom field_name)] :: tail] -> do { match field_name with [ $mc_no_args_fields$ ]; iter tail } | [((Sexplib.Sexp.Atom _ | Sexplib.Sexp.List _) as sexp) :: _] -> Sexplib.Conv_error.record_only_pairs_expected _tp_loc sexp | [] -> () ] in do { iter field_sexps; if Pervasives.(<>) duplicates.val [] then Sexplib.Conv_error.record_duplicate_fields _tp_loc duplicates.val sexp else if Pervasives.(<>) extra.val [] then Sexplib.Conv_error.record_extra_fields _tp_loc extra.val sexp else $mk_handle_record_match_result has_poly flds$ } >> let rec is_poly = function | <:ctyp< $_$ : ! $_$ . $_$ >> -> true | <:ctyp< $flds1$; $flds2$ >> -> is_poly flds1 || is_poly flds2 | _ -> false (* Generate matching code for records *) let record_of_sexp flds = let loc = Ast.loc_of_ctyp flds in let handle_fields = let has_poly = is_poly flds in let cnv_fields = mk_cnv_fields has_poly flds in if has_poly then let is_singleton_ref = ref true in let patt = let rec loop = function | <:ctyp@loc< $tp1$; $tp2$ >> -> is_singleton_ref := false; <:patt@loc< $loop tp1$, $loop tp2$ >> | <:ctyp@loc< $lid:nm$ : $_$ >> -> <:patt@loc< $lid:nm$ >> | _ -> assert false (* impossible *) in let patt = loop flds in if !is_singleton_ref then patt else <:patt@loc< $tup:patt$ >> in let record_def = let rec loop = function | <:ctyp@loc< $tp1$; $tp2$ >> -> <:rec_binding@loc< $loop tp1$; $loop tp2$ >> | <:ctyp@loc< $lid:nm$ : $_$ >> -> <:rec_binding@loc< $lid:nm$ = $lid:nm$ >> | _ -> assert false (* impossible *) in loop flds in <:expr@loc< let $patt$ = $cnv_fields$ in { $record_def$ } >> else cnv_fields in `Match <:match_case@loc< Sexplib.Sexp.List field_sexps as sexp -> $handle_fields$ | Sexplib.Sexp.Atom _ as sexp -> Sexplib.Conv_error.record_list_instead_atom _tp_loc sexp >> (* Empty type *) let nil_of_sexp loc = `Fun <:expr@loc< fun sexp -> Sexplib.Conv_error.empty_type _tp_loc sexp >> (* Generate code from type definitions *) let td_of_sexp loc type_name tps rhs = let alias_ref = ref `Not_an_alias in let handle_alias tp = alias_ref := (match tp with | <:ctyp< '$_$ >> -> `Alias `Type_var | _ -> `Alias `Type_constructor); type_of_sexp tp in let full_type = mk_full_type loc type_name tps in let is_variant_ref = ref false in let handle_variant row_fields = is_variant_ref := true; variant_of_sexp ~full_type row_fields in let body = let rec loop tp = Gen.switch_tp_def tp ~alias:(fun (_ : Loc.t) tp -> handle_alias tp) ~sum:(fun (_ : Loc.t) tp -> sum_of_sexp tp) ~record:(fun (_ : Loc.t) tp -> record_of_sexp tp) ~variants:(fun (_ : Loc.t) tp -> handle_variant tp) ~mani:(fun (_ : Loc.t) _tp1 tp2 -> loop tp2) ~nil:nil_of_sexp in match loop rhs with | `Fun fun_expr -> (* Prevent violation of value restriction and problems with recursive types by eta-expanding function definitions *) <:expr@loc< fun [ t -> $fun_expr$ t ] >> | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> in let external_name = type_name ^ "_of_sexp" in let internal_name = "__" ^ type_name ^ "_of_sexp__" in let arg_patts, arg_exprs = List.split ( List.map ~f:(function tp -> let name = "_of_" ^ Gen.get_tparam_id tp in <:patt@loc< $lid:name$ >>, <:expr@loc< $lid:name$ >> ) tps) in let with_poly_call = match !alias_ref with | `Not_an_alias | `Alias `Type_constructor -> false | `Alias `Type_var -> true in let internal_fun_body = let full_type_name = sprintf "%s.%s" (Pa_type_conv.get_conv_path ()) type_name in if with_poly_call then (* special case for type definitions whose bodies are type variables, like: type ('a, 'b) t = 'a because - they can used in polymorphic variants: [ ([`A], int) t | `B ] - the way sexplib works, it cannot handle backtracking in these cases, (because we only receive as parameter sexp_of_'a but not __sexp_of_'a__ presumably) so it is better to emit an error rather than do something weird *) Gen.abstract loc arg_patts <:expr@loc< fun sexp -> Sexplib.Conv_error.silly_type $str:full_type_name$ sexp >> else <:expr@loc< let _tp_loc = $str:full_type_name$ in $Gen.abstract loc arg_patts body$ >> in let pre_external_fun_body = let internal_call = let internal_expr = <:expr@loc< $lid:internal_name$ >> in <:expr@loc< $Gen.apply loc internal_expr arg_exprs$ sexp >> in let no_variant_match_mc = <:match_case@loc< Sexplib.Conv_error.No_variant_match (_tp_loc, sexp) -> Sexplib.Conv_error.no_matching_variant_found _tp_loc sexp >> in if with_poly_call then <:expr@loc< try $body$ sexp with [ $no_variant_match_mc$ ] >> (* Type alias may refer to variant, therefore same handling here! *) else if !is_variant_ref || !alias_ref = `Alias `Type_constructor then <:expr@loc< try $internal_call$ with [ $no_variant_match_mc$ ] >> else internal_call in let external_fun_body = Gen.abstract loc arg_patts <:expr@loc< fun sexp -> ($pre_external_fun_body$) >> in let type_of_of_sexp = mk_poly_type Sig_generate_of_sexp.sig_of_td__loop loc type_name tps in let maybe_annotate expr = match type_of_of_sexp with | None -> expr | Some typ -> <:expr@loc< ( $expr$ : $typ$ ) >> in let internal_fun_body = maybe_annotate internal_fun_body in let external_fun_body = maybe_annotate external_fun_body in let internal_binding = <:binding@loc< $lid:internal_name$ = $internal_fun_body$ >> in let external_binding = <:binding@loc< $lid:external_name$ = $external_fun_body$ >> in internal_binding, external_binding let rec tds_of_sexp acc = function | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> td_of_sexp loc type_name tps rhs :: acc | Ast.TyAnd (_, tp1, tp2) -> tds_of_sexp (tds_of_sexp acc tp2) tp1 | _ -> assert false (* impossible *) (* Generate code from type definitions *) let of_sexp rec_ = function | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> let internal_binding, external_binding = td_of_sexp loc type_name tps rhs in let is_recursive = rec_ && sexp_type_is_recursive type_name rhs in if is_recursive then <:str_item@loc< value rec $internal_binding$ and $external_binding$; >> else <:str_item@loc< value $internal_binding$; value $external_binding$; >> | Ast.TyAnd (loc, _, _) as tds -> let two_bindings = tds_of_sexp [] tds in let bindings = List.map ~f:(fun (b1, b2) -> <:binding@loc< $b1$ and $b2$ >>) two_bindings in if rec_ then <:str_item@loc< value rec $list:bindings$; >> else <:str_item@loc< value $list:bindings$; >> | _ -> assert false (* impossible *) (* Add code generator to the set of known generators *) let () = Pa_type_conv.add_generator "of_sexp" of_sexp end module Quotations = struct let of_sexp_quote loc _loc_name_opt cnt_str = Pa_type_conv.set_conv_path_if_not_set loc; let ctyp = Gram.parse_string ctyp_quot loc cnt_str in let fp = Generate_of_sexp.type_of_sexp ctyp in let body = match fp with | `Fun fun_expr -> <:expr@loc< $fun_expr$ sexp >> | `Match matchings -> <:expr@loc< match sexp with [$matchings$] >> in let full_type_name = sprintf "%s line %i: %s" (Pa_type_conv.get_conv_path ()) (Loc.start_line loc) cnt_str in <:expr@loc< fun [ sexp -> let _tp_loc = $str:full_type_name$ in $body$ ] >> let () = Quotation.add "of_sexp" Quotation.DynAst.expr_tag of_sexp_quote let sexp_of_quote loc _loc_name_opt cnt_str = Pa_type_conv.set_conv_path_if_not_set loc; let ctyp = Gram.parse_string ctyp_quot loc cnt_str in Generate_sexp_of.mk_cnv_expr ctyp let () = Quotation.add "sexp_of" Quotation.DynAst.expr_tag sexp_of_quote end (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *) let () = Pa_type_conv.add_str_set "sexp" ~set:["of_sexp"; "sexp_of"] sexplib-109.20.00/syntax/pa_sexp_conv.mli000066400000000000000000000001211213530673200202020ustar00rootroot00000000000000(** Pa_sexp_conv: Preprocessing Module for Automated S-expression Conversions *) sexplib-109.20.00/syntax/pa_sexp_conv.mllib000066400000000000000000000001411213530673200205220ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 5969c59e3896ac685b501cdfd34e8ea3) Pa_sexp_conv # OASIS_STOP sexplib-109.20.00/top/000077500000000000000000000000001213530673200142755ustar00rootroot00000000000000sexplib-109.20.00/top/sexplib_install_printers.ml000066400000000000000000000011271213530673200217520ustar00rootroot00000000000000let 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-109.20.00/top/sexplib_top.mllib000066400000000000000000000001551213530673200176470ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 7a19a4d35cff890b2e24c5eb532a6d68) Sexplib_install_printers # OASIS_STOP sexplib-109.20.00/vim/000077500000000000000000000000001213530673200142665ustar00rootroot00000000000000sexplib-109.20.00/vim/syntax/000077500000000000000000000000001213530673200156145ustar00rootroot00000000000000sexplib-109.20.00/vim/syntax/sexplib.vim000066400000000000000000000071301213530673200200000ustar00rootroot00000000000000" 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