pax_global_header00006660000000000000000000000064125646110250014514gustar00rootroot0000000000000052 comment=f086747b305a572ae1e17e3bbc2709b7fff20114 core_extended-113.00.00/000077500000000000000000000000001256461102500146265ustar00rootroot00000000000000core_extended-113.00.00/.gitignore000066400000000000000000000001361256461102500166160ustar00rootroot00000000000000_build/ /setup.data /setup.log /*.exe /*.docdir /*.native /*.byte src/config.h src/config.mlh core_extended-113.00.00/CHANGES.md000066400000000000000000000134761256461102500162330ustar00rootroot00000000000000## 113.00.00 - Added to `Interval_map` a more complete set of operations. - Removed `Core_extended.Sexp.filter_record`, which has been superseded by `Core.Std.Sexp.of_sexp_allow_extra_fields`. - Added to `Interval_map` an `Interval` module, with the type of intervals used in an interval map. - In `Color_print`, added `sprintf` functions, and changed formatting to compose properly. ## 112.35.00 - Removed the `Stats_reporting` module. - Renamed `Quickcheck` module to `Quickcheck_deprecated`. It's replaced by Janecheck, which for now is a separate library in the core_extended package, but will soon be merged into core. - Moved the `Selector` module to its own library. This is for internal reasons related for code review; it is included as a library within the core_extended package for now, but may move to another home in the future. - Added `Extended_unix.terminal_width : int Lazy.t`. - Added `Interval_map` module. - Added to `Sendmail.send` additional optional arguments: `?message_id:string`, `?in_reply_to:string`. ## 112.24.00 - Added to `Shell.set_defaults` a `?preserve_euid:bool` argument, which causes `Shell` to use `bash -p`. - Removed `Array.Access_control`, now that there is `Core.Std.Array.Permissioned`. - Removed `Fast_int_div`. ## 112.17.00 - Added functions to `Low_level_debug` to get a sexp or string representation of any type. This could be handy when debugging polymorphic code. - Renamed `String.is_substring` to `is_substring_deprecated`. Use `Core.String.is_substring` instead. - Fixed a bug in `Bin_io_utils.save`. - Made `Unix.Mac_address` match `Hashable.S`. ## 112.06.00 - Sped up `String.is_substring` by replacing the OCaml implementation with a call to libc `memmem`. `memmem` runs in 20% of the time, incurs minimal GC pressure, is portable among UNIXen that we target, AND it's clearer than the ML version. - Made `Float_ref` support `bin_io` and `sexp`. - Removed `gettid`, which is now available in `Core.Unix`. - Added `Fast_int_div` module, which speeds up integer division by a fixed divisor. - Moved `Sexp.of_sexp_allow_extra_fields` to core_kernel. ## 112.01.00 - Added `Float_ref` module, which is like `float ref` but faster for sets due to bypassing the write barrier. Benchmark results on Sandy Bridge: | [float\_ref.ml:] float ref set | 2\_886.94ns | 8.00w | | | [float\_ref.ml:] Float\_ref.set | 355.76ns | 6.00w | | | [float\_ref.ml:] float ref get | 415.52ns | 6.00w | | | [float\_ref.ml:] Float_ref.get | 416.19ns | 6.00w | | - Added `Bin_io_utils.Wrapped.t`, which defines an `'a t with bin_io` that supports size-prefixed serialization and deserialization. `Wrapped` has two useful submodules, `Opaque` and `Ignored`, for efficient handling of size-prefixed bin-io values in cases where serialization can be bypassed. See the comments in the module for more details. ## 111.28.00 - Implemented `Int.gcd` using binary GCD in C, for improved performance. - Added `Bin_io_utils.Serialized`, which stores a value in memory as its bin-io representation. Writing such a value just blits the value. - Moved `Text_block` from `Core_extended` into `Textutils`. - Added modules `Hashtbl2` and `Hashtbl2_pair`. ## 111.25.00 - Moved `Quickcheck` from `core`. - Added [Int.gcd]. ## 111.17.00 - Added some functions to `Splay_tree`: * `length` * `keys` * `data` * `to_alist` * `delete_{after,before}` * `map` * `map_range` * `split`. ## 111.13.00 - Moved `Patience_diff` out of `Core_extended` into its own library. ## 111.11.00 - For `Flang`, added ordering to fields, and added `abs`, `min`, and `max` to the language. - Removed `Loggers` module. ## 111.03.00 - Added `Set_lang`, a DSL for sets with constants, union, intersection, and difference. - In `Process`, use `epoll` rather than `select` when possible, This prevents errors when selecting on file descriptors numbered greater than `FD_SETSIZE` (1024). - Removed `Syslog` module. There is now `Unix.Syslog` in core instead; the APIs are not compatible, but they are similar. ## 109.58.00 - Cleaned up the `Stats_reporting` module ## 109.55.00 - Added `Service_command.acquire_lock_exn`, for acquiring a service's lock. ## 109.53.00 - Fixed `Flang` and `Olang` to round-trip via sexps, i.e. `(t_of_sexp (sexp_of_t t)) = t`. ## 109.52.00 - Removed `Sexp.load_sexp_with_includes`; one should use the new `Sexplib.Macro` functions. - Added `Blang`-like languages `Flang` and `Olang`. * `Flang` -- terms over a field. * `Olang` -- predicates over an ordered set. ## 109.45.00 - Fixed `Core_extended.Sys.groups` to use `Unix.Group.getbygid` rather than `Unix.Group.getbygid_exn`. This handles when a group is deleted and its gid remains in the cache, which causes `Unix.Group.getbygid_exn` to fail because the gid no longer resolves to a group. ## 109.40.00 - Added `Stats_reporting.Delta`, for recording deltas of values. ## 109.36.00 - In `Sexp` module, added ability to expand and compress bash-like brace wildcards. ## 109.35.00 - Added stable versions of types contained in the `Selector` module. ## 109.34.00 - Improved `Sexp.Diff`. Labeled arguments, put them in the right order (old before new), and rework the code to follow the same convention, and produce the output where deletions precede insertions. ## 109.28.00 - In `Shell` functions, made the amount of captured stderr/stdout configurable. ## 109.27.00 - In module `Sexp`, changed and renamed `load_includes_in_sexp`. From: ```ocaml val load_includes_in_sexp : ?max_depth:int -> Sexp.t -> Sexp.t ``` to: ```ocaml val load_sexp_with_includes: ?max_depth:int -> ?buf:string -> string -> Sexp.t ``` - Added function `Sexp.Diff.to_string`. - Previously the only option was to print to `Out_channel`. core_extended-113.00.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321256461102500176420ustar00rootroot00000000000000THIS 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. core_extended-113.00.00/INSTALL.txt000066400000000000000000000030031256461102500164710ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 25587b5ae4f4b0ec953b4fdbed5c1e8c) *) This is the INSTALL file for the core_extended 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 test_runner * findlib (>= 1.3.2) * bin_prot for library core_extended, library selector_lib * comparelib for library core_extended * core for library core_extended, library selector_lib, executable core_hello * custom_printf for library core_extended * fieldslib for library core_extended * pa_bench for library core_extended * pa_ounit for library core_extended * pa_pipebang for library core_extended * pa_test for library core_extended * textutils for library core_extended * re2 for library core_extended, library selector_lib * sexplib for library core_extended, library selector_lib * sexplib_num for library core_extended * oUnit (>= 1.1.0) for executable test_runner 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 *) core_extended-113.00.00/LICENSE.txt000066400000000000000000000261361256461102500164610ustar00rootroot00000000000000 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. core_extended-113.00.00/Makefile000066400000000000000000000025121256461102500162660ustar00rootroot00000000000000# 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 grep -v '^#' 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 core_extended-113.00.00/THIRD-PARTY.txt000066400000000000000000000013601256461102500171360ustar00rootroot00000000000000The 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. core_extended-113.00.00/_oasis000066400000000000000000000177621256461102500160430ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: core_extended Version: 113.00.00 Synopsis: Jane Street Capital's standard library overlay Authors: Jane Street Group, LLC Copyrights: (C) 2008-2013 Jane Street Group LLC Maintainers: Jane Street Group, LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/core_extended Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild, camlp4o Description: The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. Flag linux Description: Enable linux specific extensions Default$: flag(linux_possible) Flag "posix-timers" Description: Enable POSIX timers Default$: flag(posix_timers_possible) PreConfCommand: config/detect.sh PostConfCommand: config/discover.sh $ocamlc src/config.mlh src/config.h PreDistCleanCommand: $rm src/config.mlh src/config.h Library core_extended Path: src FindlibName: core_extended Pack: true Modules: Alternating_primary_backup_assignment, Atomic_edit, Bin_io_utils, Bitarray, Cache, Cbuffer, Color_print, Crit_bit, Csv_writer, Deprecated_bench, Deprecated_command, Deprecated_fcommand, Deprecated_service_command, Documented_match_statement, English, Environment, Exception_check, Extended_array, Extended_common, Extended_exn, Extended_filename, Extended_float, Extended_gc, Extended_hashtbl, Extended_int, Extended_int32, Extended_int63, Extended_int64, Extended_linux, Extended_list, Extended_list__LCS, Extended_list__multimerge, Extended_memo, Extended_monad, Extended_nativeint, Extended_option, Extended_result, Extended_sexp, Extended_string, Extended_sys, Extended_thread, Extended_time, Extended_unix, Extra_fields, Fd_leak_check, Find, Flang, Float_ref, Fold_map, Generic, Hashtbl2, Hashtbl2_pair, Interval_map, Interval_map_intf, Invariant, Invocation, Iter, Lazy_list, Lazy_m, Lazy_sequence, Left_boundary, Linebuf, List_zipper, Logger, Low_level_debug, Malloc, Multi_map, Net_utils, Number, Olang, Packed_array, Packed_map, Posix_clock, Pp, Printc, Process, Procfs, Prod_or_test, Quickcheck_deprecated, Random_selection, Readline, Readline__input_char, Readline__input_loop, Runtime_blockout_detector, Rw_mutex, Sampler, Search_foo, Semaphore, Sendmail, Service_command, Set_lang, Set_lang_intf, Shell, Shell__core, Shell__line_buffer, Sntp, Splay_tree, Std, String_zipper, Sys_utils, Tcp, Timed_function, Trie, Unix_utils, Update_queue CSources: extended_int_stubs.c, extended_linux_stubs.c, extended_unix_stubs.c, fork_exec.c, fork_exec.h, linebuf_stubs.c, low_level_debug_stubs.c, malloc_stubs.c, posix_clock_stubs.c, config.h CCOpt+: -Isrc BuildDepends: bigarray, bin_prot, bin_prot.syntax, comparelib.syntax, core, custom_printf, custom_printf.syntax, fieldslib, fieldslib.syntax, pa_bench.syntax, pa_ounit, pa_ounit.syntax, pa_pipebang, pa_test, pa_test.syntax, textutils, re2, sexplib, sexplib.syntax, sexplib_num, unix, threads XMETARequires: bigarray, bin_prot, core, custom_printf, fieldslib, oUnit, pa_bench, pa_ounit, pa_test, re2, sexplib, sexplib_num, textutils, threads unix, Library selector_lib Path: selector/src FindlibParent: core_extended FindlibName: selector Pack: true Modules: Selector BuildDepends: bin_prot.syntax, core, re2, sexplib.syntax, threads XMETARequires: bin_prot, core, re2, sexplib, threads Executable core_extended_hello Path: test MainIs: core_extended_hello.ml Build$: flag(tests) Custom: true CompiledObject: best Install: false BuildDepends: core_extended Executable core_hello Path: test MainIs: core_hello.ml Build$: flag(tests) Custom: true CompiledObject: best Install: false BuildDepends: core,threads Executable test_runner Path: test MainIs: test_runner.ml Build$: flag(tests) Custom: true CompiledObject: best Install: false BuildDepends: core_extended,oUnit (>= 1.1.0),threads Test test_runner Run$: flag(tests) Command: $test_runner --core-hello $core_hello --core-extended-hello $core_extended_hello WorkingDirectory: test TestTools: core_hello,core_extended_hello core_extended-113.00.00/_tags000066400000000000000000000472171256461102500156610ustar00rootroot00000000000000 : pa_ounit_lib(core_extended) <{,janecheck{,_kernel}/}{src,test}/*.ml{,i}> : syntax_camlp4o : ugly_hack_to_workaround_ocamlbuild_nightmare "src/console.ml" : mlh, package(camlp4.macro) "src/core_command.ml" : mlh, package(camlp4.macro) "src/extended_linux.ml" : mlh, package(camlp4.macro) "src/malloc.ml" : mlh, package(camlp4.macro) "src/posix_clock.ml" : mlh, package(camlp4.macro) "test/test.ml" : mlh, package(camlp4.macro) # OASIS_START # DO NOT EDIT (digest: dc0f02145345cf5fb0e68402df263fcc) # 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 true: annot, bin_annot <**/.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 core_extended "src/core_extended.cmxs": use_core_extended "src/alternating_primary_backup_assignment.cmx": for-pack(Core_extended) "src/atomic_edit.cmx": for-pack(Core_extended) "src/bin_io_utils.cmx": for-pack(Core_extended) "src/bitarray.cmx": for-pack(Core_extended) "src/cache.cmx": for-pack(Core_extended) "src/cbuffer.cmx": for-pack(Core_extended) "src/color_print.cmx": for-pack(Core_extended) "src/crit_bit.cmx": for-pack(Core_extended) "src/csv_writer.cmx": for-pack(Core_extended) "src/deprecated_bench.cmx": for-pack(Core_extended) "src/deprecated_command.cmx": for-pack(Core_extended) "src/deprecated_fcommand.cmx": for-pack(Core_extended) "src/deprecated_service_command.cmx": for-pack(Core_extended) "src/documented_match_statement.cmx": for-pack(Core_extended) "src/english.cmx": for-pack(Core_extended) "src/environment.cmx": for-pack(Core_extended) "src/exception_check.cmx": for-pack(Core_extended) "src/extended_array.cmx": for-pack(Core_extended) "src/extended_common.cmx": for-pack(Core_extended) "src/extended_exn.cmx": for-pack(Core_extended) "src/extended_filename.cmx": for-pack(Core_extended) "src/extended_float.cmx": for-pack(Core_extended) "src/extended_gc.cmx": for-pack(Core_extended) "src/extended_hashtbl.cmx": for-pack(Core_extended) "src/extended_int.cmx": for-pack(Core_extended) "src/extended_int32.cmx": for-pack(Core_extended) "src/extended_int63.cmx": for-pack(Core_extended) "src/extended_int64.cmx": for-pack(Core_extended) "src/extended_linux.cmx": for-pack(Core_extended) "src/extended_list.cmx": for-pack(Core_extended) "src/extended_list__LCS.cmx": for-pack(Core_extended) "src/extended_list__multimerge.cmx": for-pack(Core_extended) "src/extended_memo.cmx": for-pack(Core_extended) "src/extended_monad.cmx": for-pack(Core_extended) "src/extended_nativeint.cmx": for-pack(Core_extended) "src/extended_option.cmx": for-pack(Core_extended) "src/extended_result.cmx": for-pack(Core_extended) "src/extended_sexp.cmx": for-pack(Core_extended) "src/extended_string.cmx": for-pack(Core_extended) "src/extended_sys.cmx": for-pack(Core_extended) "src/extended_thread.cmx": for-pack(Core_extended) "src/extended_time.cmx": for-pack(Core_extended) "src/extended_unix.cmx": for-pack(Core_extended) "src/extra_fields.cmx": for-pack(Core_extended) "src/fd_leak_check.cmx": for-pack(Core_extended) "src/find.cmx": for-pack(Core_extended) "src/flang.cmx": for-pack(Core_extended) "src/float_ref.cmx": for-pack(Core_extended) "src/fold_map.cmx": for-pack(Core_extended) "src/generic.cmx": for-pack(Core_extended) "src/hashtbl2.cmx": for-pack(Core_extended) "src/hashtbl2_pair.cmx": for-pack(Core_extended) "src/interval_map.cmx": for-pack(Core_extended) "src/interval_map_intf.cmx": for-pack(Core_extended) "src/invariant.cmx": for-pack(Core_extended) "src/invocation.cmx": for-pack(Core_extended) "src/iter.cmx": for-pack(Core_extended) "src/lazy_list.cmx": for-pack(Core_extended) "src/lazy_m.cmx": for-pack(Core_extended) "src/lazy_sequence.cmx": for-pack(Core_extended) "src/left_boundary.cmx": for-pack(Core_extended) "src/linebuf.cmx": for-pack(Core_extended) "src/list_zipper.cmx": for-pack(Core_extended) "src/logger.cmx": for-pack(Core_extended) "src/low_level_debug.cmx": for-pack(Core_extended) "src/malloc.cmx": for-pack(Core_extended) "src/multi_map.cmx": for-pack(Core_extended) "src/net_utils.cmx": for-pack(Core_extended) "src/number.cmx": for-pack(Core_extended) "src/olang.cmx": for-pack(Core_extended) "src/packed_array.cmx": for-pack(Core_extended) "src/packed_map.cmx": for-pack(Core_extended) "src/posix_clock.cmx": for-pack(Core_extended) "src/pp.cmx": for-pack(Core_extended) "src/printc.cmx": for-pack(Core_extended) "src/process.cmx": for-pack(Core_extended) "src/procfs.cmx": for-pack(Core_extended) "src/prod_or_test.cmx": for-pack(Core_extended) "src/quickcheck_deprecated.cmx": for-pack(Core_extended) "src/random_selection.cmx": for-pack(Core_extended) "src/readline.cmx": for-pack(Core_extended) "src/readline__input_char.cmx": for-pack(Core_extended) "src/readline__input_loop.cmx": for-pack(Core_extended) "src/runtime_blockout_detector.cmx": for-pack(Core_extended) "src/rw_mutex.cmx": for-pack(Core_extended) "src/sampler.cmx": for-pack(Core_extended) "src/search_foo.cmx": for-pack(Core_extended) "src/semaphore.cmx": for-pack(Core_extended) "src/sendmail.cmx": for-pack(Core_extended) "src/service_command.cmx": for-pack(Core_extended) "src/set_lang.cmx": for-pack(Core_extended) "src/set_lang_intf.cmx": for-pack(Core_extended) "src/shell.cmx": for-pack(Core_extended) "src/shell__core.cmx": for-pack(Core_extended) "src/shell__line_buffer.cmx": for-pack(Core_extended) "src/sntp.cmx": for-pack(Core_extended) "src/splay_tree.cmx": for-pack(Core_extended) "src/std.cmx": for-pack(Core_extended) "src/string_zipper.cmx": for-pack(Core_extended) "src/sys_utils.cmx": for-pack(Core_extended) "src/tcp.cmx": for-pack(Core_extended) "src/timed_function.cmx": for-pack(Core_extended) "src/trie.cmx": for-pack(Core_extended) "src/unix_utils.cmx": for-pack(Core_extended) "src/update_queue.cmx": for-pack(Core_extended) : oasis_library_core_extended_ccopt "src/extended_int_stubs.c": oasis_library_core_extended_ccopt "src/extended_linux_stubs.c": oasis_library_core_extended_ccopt "src/extended_unix_stubs.c": oasis_library_core_extended_ccopt "src/fork_exec.c": oasis_library_core_extended_ccopt "src/linebuf_stubs.c": oasis_library_core_extended_ccopt "src/low_level_debug_stubs.c": oasis_library_core_extended_ccopt "src/malloc_stubs.c": oasis_library_core_extended_ccopt "src/posix_clock_stubs.c": oasis_library_core_extended_ccopt : use_libcore_extended_stubs : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(core) : package(custom_printf) : package(custom_printf.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(re2) : package(sexplib) : package(sexplib.syntax) : package(sexplib_num) : package(textutils) : package(threads) : package(unix) "src/extended_int_stubs.c": package(bigarray) "src/extended_int_stubs.c": package(bin_prot) "src/extended_int_stubs.c": package(bin_prot.syntax) "src/extended_int_stubs.c": package(comparelib.syntax) "src/extended_int_stubs.c": package(core) "src/extended_int_stubs.c": package(custom_printf) "src/extended_int_stubs.c": package(custom_printf.syntax) "src/extended_int_stubs.c": package(fieldslib) "src/extended_int_stubs.c": package(fieldslib.syntax) "src/extended_int_stubs.c": package(pa_bench.syntax) "src/extended_int_stubs.c": package(pa_ounit) "src/extended_int_stubs.c": package(pa_ounit.syntax) "src/extended_int_stubs.c": package(pa_pipebang) "src/extended_int_stubs.c": package(pa_test) "src/extended_int_stubs.c": package(pa_test.syntax) "src/extended_int_stubs.c": package(re2) "src/extended_int_stubs.c": package(sexplib) "src/extended_int_stubs.c": package(sexplib.syntax) "src/extended_int_stubs.c": package(sexplib_num) "src/extended_int_stubs.c": package(textutils) "src/extended_int_stubs.c": package(threads) "src/extended_int_stubs.c": package(unix) "src/extended_linux_stubs.c": package(bigarray) "src/extended_linux_stubs.c": package(bin_prot) "src/extended_linux_stubs.c": package(bin_prot.syntax) "src/extended_linux_stubs.c": package(comparelib.syntax) "src/extended_linux_stubs.c": package(core) "src/extended_linux_stubs.c": package(custom_printf) "src/extended_linux_stubs.c": package(custom_printf.syntax) "src/extended_linux_stubs.c": package(fieldslib) "src/extended_linux_stubs.c": package(fieldslib.syntax) "src/extended_linux_stubs.c": package(pa_bench.syntax) "src/extended_linux_stubs.c": package(pa_ounit) "src/extended_linux_stubs.c": package(pa_ounit.syntax) "src/extended_linux_stubs.c": package(pa_pipebang) "src/extended_linux_stubs.c": package(pa_test) "src/extended_linux_stubs.c": package(pa_test.syntax) "src/extended_linux_stubs.c": package(re2) "src/extended_linux_stubs.c": package(sexplib) "src/extended_linux_stubs.c": package(sexplib.syntax) "src/extended_linux_stubs.c": package(sexplib_num) "src/extended_linux_stubs.c": package(textutils) "src/extended_linux_stubs.c": package(threads) "src/extended_linux_stubs.c": package(unix) "src/extended_unix_stubs.c": package(bigarray) "src/extended_unix_stubs.c": package(bin_prot) "src/extended_unix_stubs.c": package(bin_prot.syntax) "src/extended_unix_stubs.c": package(comparelib.syntax) "src/extended_unix_stubs.c": package(core) "src/extended_unix_stubs.c": package(custom_printf) "src/extended_unix_stubs.c": package(custom_printf.syntax) "src/extended_unix_stubs.c": package(fieldslib) "src/extended_unix_stubs.c": package(fieldslib.syntax) "src/extended_unix_stubs.c": package(pa_bench.syntax) "src/extended_unix_stubs.c": package(pa_ounit) "src/extended_unix_stubs.c": package(pa_ounit.syntax) "src/extended_unix_stubs.c": package(pa_pipebang) "src/extended_unix_stubs.c": package(pa_test) "src/extended_unix_stubs.c": package(pa_test.syntax) "src/extended_unix_stubs.c": package(re2) "src/extended_unix_stubs.c": package(sexplib) "src/extended_unix_stubs.c": package(sexplib.syntax) "src/extended_unix_stubs.c": package(sexplib_num) "src/extended_unix_stubs.c": package(textutils) "src/extended_unix_stubs.c": package(threads) "src/extended_unix_stubs.c": package(unix) "src/fork_exec.c": package(bigarray) "src/fork_exec.c": package(bin_prot) "src/fork_exec.c": package(bin_prot.syntax) "src/fork_exec.c": package(comparelib.syntax) "src/fork_exec.c": package(core) "src/fork_exec.c": package(custom_printf) "src/fork_exec.c": package(custom_printf.syntax) "src/fork_exec.c": package(fieldslib) "src/fork_exec.c": package(fieldslib.syntax) "src/fork_exec.c": package(pa_bench.syntax) "src/fork_exec.c": package(pa_ounit) "src/fork_exec.c": package(pa_ounit.syntax) "src/fork_exec.c": package(pa_pipebang) "src/fork_exec.c": package(pa_test) "src/fork_exec.c": package(pa_test.syntax) "src/fork_exec.c": package(re2) "src/fork_exec.c": package(sexplib) "src/fork_exec.c": package(sexplib.syntax) "src/fork_exec.c": package(sexplib_num) "src/fork_exec.c": package(textutils) "src/fork_exec.c": package(threads) "src/fork_exec.c": package(unix) "src/linebuf_stubs.c": package(bigarray) "src/linebuf_stubs.c": package(bin_prot) "src/linebuf_stubs.c": package(bin_prot.syntax) "src/linebuf_stubs.c": package(comparelib.syntax) "src/linebuf_stubs.c": package(core) "src/linebuf_stubs.c": package(custom_printf) "src/linebuf_stubs.c": package(custom_printf.syntax) "src/linebuf_stubs.c": package(fieldslib) "src/linebuf_stubs.c": package(fieldslib.syntax) "src/linebuf_stubs.c": package(pa_bench.syntax) "src/linebuf_stubs.c": package(pa_ounit) "src/linebuf_stubs.c": package(pa_ounit.syntax) "src/linebuf_stubs.c": package(pa_pipebang) "src/linebuf_stubs.c": package(pa_test) "src/linebuf_stubs.c": package(pa_test.syntax) "src/linebuf_stubs.c": package(re2) "src/linebuf_stubs.c": package(sexplib) "src/linebuf_stubs.c": package(sexplib.syntax) "src/linebuf_stubs.c": package(sexplib_num) "src/linebuf_stubs.c": package(textutils) "src/linebuf_stubs.c": package(threads) "src/linebuf_stubs.c": package(unix) "src/low_level_debug_stubs.c": package(bigarray) "src/low_level_debug_stubs.c": package(bin_prot) "src/low_level_debug_stubs.c": package(bin_prot.syntax) "src/low_level_debug_stubs.c": package(comparelib.syntax) "src/low_level_debug_stubs.c": package(core) "src/low_level_debug_stubs.c": package(custom_printf) "src/low_level_debug_stubs.c": package(custom_printf.syntax) "src/low_level_debug_stubs.c": package(fieldslib) "src/low_level_debug_stubs.c": package(fieldslib.syntax) "src/low_level_debug_stubs.c": package(pa_bench.syntax) "src/low_level_debug_stubs.c": package(pa_ounit) "src/low_level_debug_stubs.c": package(pa_ounit.syntax) "src/low_level_debug_stubs.c": package(pa_pipebang) "src/low_level_debug_stubs.c": package(pa_test) "src/low_level_debug_stubs.c": package(pa_test.syntax) "src/low_level_debug_stubs.c": package(re2) "src/low_level_debug_stubs.c": package(sexplib) "src/low_level_debug_stubs.c": package(sexplib.syntax) "src/low_level_debug_stubs.c": package(sexplib_num) "src/low_level_debug_stubs.c": package(textutils) "src/low_level_debug_stubs.c": package(threads) "src/low_level_debug_stubs.c": package(unix) "src/malloc_stubs.c": package(bigarray) "src/malloc_stubs.c": package(bin_prot) "src/malloc_stubs.c": package(bin_prot.syntax) "src/malloc_stubs.c": package(comparelib.syntax) "src/malloc_stubs.c": package(core) "src/malloc_stubs.c": package(custom_printf) "src/malloc_stubs.c": package(custom_printf.syntax) "src/malloc_stubs.c": package(fieldslib) "src/malloc_stubs.c": package(fieldslib.syntax) "src/malloc_stubs.c": package(pa_bench.syntax) "src/malloc_stubs.c": package(pa_ounit) "src/malloc_stubs.c": package(pa_ounit.syntax) "src/malloc_stubs.c": package(pa_pipebang) "src/malloc_stubs.c": package(pa_test) "src/malloc_stubs.c": package(pa_test.syntax) "src/malloc_stubs.c": package(re2) "src/malloc_stubs.c": package(sexplib) "src/malloc_stubs.c": package(sexplib.syntax) "src/malloc_stubs.c": package(sexplib_num) "src/malloc_stubs.c": package(textutils) "src/malloc_stubs.c": package(threads) "src/malloc_stubs.c": package(unix) "src/posix_clock_stubs.c": package(bigarray) "src/posix_clock_stubs.c": package(bin_prot) "src/posix_clock_stubs.c": package(bin_prot.syntax) "src/posix_clock_stubs.c": package(comparelib.syntax) "src/posix_clock_stubs.c": package(core) "src/posix_clock_stubs.c": package(custom_printf) "src/posix_clock_stubs.c": package(custom_printf.syntax) "src/posix_clock_stubs.c": package(fieldslib) "src/posix_clock_stubs.c": package(fieldslib.syntax) "src/posix_clock_stubs.c": package(pa_bench.syntax) "src/posix_clock_stubs.c": package(pa_ounit) "src/posix_clock_stubs.c": package(pa_ounit.syntax) "src/posix_clock_stubs.c": package(pa_pipebang) "src/posix_clock_stubs.c": package(pa_test) "src/posix_clock_stubs.c": package(pa_test.syntax) "src/posix_clock_stubs.c": package(re2) "src/posix_clock_stubs.c": package(sexplib) "src/posix_clock_stubs.c": package(sexplib.syntax) "src/posix_clock_stubs.c": package(sexplib_num) "src/posix_clock_stubs.c": package(textutils) "src/posix_clock_stubs.c": package(threads) "src/posix_clock_stubs.c": package(unix) # Library selector_lib "selector/src/selector_lib.cmxs": use_selector_lib "selector/src/selector.cmx": for-pack(Selector_lib) : package(bin_prot.syntax) : package(core) : package(re2) : package(sexplib.syntax) : package(threads) # Executable core_extended_hello : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(core) : package(custom_printf) : package(custom_printf.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(re2) : package(sexplib) : package(sexplib.syntax) : package(sexplib_num) : package(textutils) : package(threads) : package(unix) : use_core_extended : custom # Executable core_hello : package(core) : package(threads) : custom # Executable test_runner : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(core) : package(custom_printf) : package(custom_printf.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(oUnit) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(re2) : package(sexplib) : package(sexplib.syntax) : package(sexplib_num) : package(textutils) : package(threads) : package(unix) : use_core_extended : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(core) : package(custom_printf) : package(custom_printf.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(oUnit) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(re2) : package(sexplib) : package(sexplib.syntax) : package(sexplib_num) : package(textutils) : package(threads) : package(unix) : use_core_extended : custom # OASIS_STOP core_extended-113.00.00/config/000077500000000000000000000000001256461102500160735ustar00rootroot00000000000000core_extended-113.00.00/config/detect.sh000077500000000000000000000013131256461102500177000ustar00rootroot00000000000000#!/bin/sh # Detect supported features and put the result in setup.data set -e if uname | grep -q -i linux; then linux_possible=true else linux_possible=false fi ptimer=`getconf _POSIX_TIMERS || echo undefined` case $ptimer in undefined) posix_timers_possible=false ;; *) if [ $ptimer -ge 200111 ]; then posix_timers_possible=true else posix_timers_possible=false fi ;; esac if [ -e setup.data ]; then sed '/^\(linux\|posix_timers\)_possible=/d' setup.data > setup.data.new mv setup.data.new setup.data fi cat >> setup.data <&2 exit 2 fi OCAMLC="$1" ML_OUTFILE="$2" C_OUTFILE="$3" shift 3 if [ ! -e setup.data ]; then echo "setup.data missing, run ./configure first." exit 2 fi OCAML_CFLAGS= . ./setup.data [ "$linux" = true ] && OCAML_CFLAGS="$OCAML_CFLAGS -ccopt -DLINUX_EXT" [ "$posix_timers" = true ] && OCAML_CFLAGS="$OCAML_CFLAGS -ccopt -DPOSIX_TIMERS" MAKEFILE_CONFIG=`ocamlc -where`/Makefile.config if [ ! -e $MAKEFILE_CONFIG ]; then echo "Makefile.config missing in ocaml standard library path." echo 2 fi ARCH=`cat $MAKEFILE_CONFIG | grep '^ARCH=' | cut -d= -f2` SRC=config/test.c OUT=config/test.out trap "rm -f $OUT" EXIT $OCAMLC -ccopt -E $OCAML_CFLAGS -c $SRC | grep '^"OUT:[^"]*"$' | sed 's/"OUT:\([^"]*\)"/\1/' | tee > $OUT echo "DEFINE ARCH_$ARCH" >> $OUT if [ "$ARCH" = amd64 ]; then echo "DEFINE ARCH_x86_64" >> $OUT fi case "`ocamlc -version`" in 4*) echo "DEFINE OCAML_4" >> $OUT esac mv "$OUT" "$ML_OUTFILE" { sentinel="CORE_`basename "$C_OUTFILE" | tr a-z. A-Z_`" cat < "$C_OUTFILE" core_extended-113.00.00/config/test.c000066400000000000000000000034251256461102500172220ustar00rootroot00000000000000/* This file is just preprocessed. Lines of the form "OUT:XXX" are kept and replaced by XXX in the output to produce lib/config.mlh. */ #include #include #include #include #include #if defined(LINUX_EXT) "OUT:DEFINE LINUX_EXT" #else # warning "cpp test --defined(LINUX_EXT)-- was false" # warning "Feature LINUX_EXT will not be availlable" #endif #if defined(POSIX_TIMERS) "OUT:DEFINE POSIX_TIMERS" #else # warning "cpp test --defined(POSIX_TIMERS)-- was false" # warning "Feature POSIX_TIMERS will not be availlable" #endif #if defined(RLIMIT_NICE) "OUT:DEFINE RLIMIT_NICE" #else # warning "cpp test --defined(RLIMIT_NICE)-- was false" # warning "Feature RLIMIT_NICE will not be availlable" #endif /* Defined in */ #if defined(ARCH_SIXTYFOUR) "OUT:DEFINE ARCH_SIXTYFOUR" #endif #if defined MSG_NOSIGNAL "OUT:DEFINE MSG_NOSIGNAL" #else # warning "cpp test --defined MSG_NOSIGNAL-- was false" # warning "Bigstring.(unsafe_|really_)?send(to)?(_noblocking)?_no_sigpipe will not be availlable" #endif #if defined(_POSIX_TIMEOUTS) && (_POSIX_TIMEOUTS > 0) "OUT:DEFINE MUTEX_TIMED_LOCK" #else # warning "cpp test --defined(_POSIX_TIMEOUTS) && (_POSIX_TIMEOUTS > 0)-- was false" # warning "Feature MUTEX_TIMED_LOCK will not be availlable" #endif #if defined(_POSIX_SYNCHRONIZED_IO) && _POSIX_SYNCHRONIZED_IO > 0 "OUT:DEFINE FDATASYNC" #else # warning "cpp test --defined(_POSIX_SYNCHRONIZED_IO) && _POSIX_SYNCHRONIZED_IO > 0-- was false" # warning "Feature FDATASYNC will not be availlable" #endif #if defined(_POSIX_THREAD_CPUTIME) "OUT:DEFINE THREAD_CPUTIME" #else # warning "cpp test --defined(_POSIX_THREAD_CPUTIME)-- was false" # warning "Feature THREAD_CPUTIME will not be availlable" #endif core_extended-113.00.00/configure000077500000000000000000000005531256461102500165400ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 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 core_extended-113.00.00/example/000077500000000000000000000000001256461102500162615ustar00rootroot00000000000000core_extended-113.00.00/example/color_print/000077500000000000000000000000001256461102500206135ustar00rootroot00000000000000core_extended-113.00.00/example/color_print/test_colors.ml000066400000000000000000000046731256461102500235170ustar00rootroot00000000000000open Core.Std open Core_extended.Std let () = printf "Printing lots of ansi color and formatting to test Color_print module\n"; printf "Color cube:\n"; let i = ref 0 in for r = 0 to 5 do for g = 0 to 5 do for b = 0 to 5 do let floatify x = Float.of_int x /. 5. in let r = floatify r in let g = floatify g in let b = floatify b in if !i mod 3 = 0 then Color_print.rgbprintf ~r ~g ~b "%s" "X" else if !i mod 3 = 1 then printf "%s" (Color_print.rgb_sprintf ~r ~g ~b "%s" "X") else printf "%s" (Color_print.rgb ~r ~g ~b "X"); incr i; done; printf "\n"; done; printf "\n"; done; printf "Grayscale:\n"; for x = 0 to 23 do let floatify x = Float.of_int x /. 23. in let x = floatify x in Color_print.grayprintf ~brightness:x "X"; done; printf "\n"; printf "\n"; printf "Mixing formats and overriding:\n"; printf "%s\n" ( Color_print.magenta_sprintf "%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s" (Color_print.red "red") ("magenta") (Color_print.bold "boldmagenta") (Color_print.bold (Color_print.bold "boldmagenta")) (Color_print.bold (Color_print.underline "underlineboldmagenta")) (Color_print.bold (Color_print.inverse "inverseboldmagenta")) (Color_print.inverse (Color_print.underline "underlineinversemagenta")) (Color_print.inverse (Color_print.blue "inverseblue")) (Color_print.inverse ~override:true (Color_print.blue "inverseblue")) (Color_print.green (Color_print.blue "blue")) (Color_print.green ~override:true (Color_print.blue "green")) ); printf "%s\n" ( Color_print.magenta_sprintf ~override:true "%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s" (Color_print.red "magenta") ("magenta") (Color_print.bold "boldmagenta") (Color_print.bold (Color_print.bold "boldmagenta")) (Color_print.bold (Color_print.underline "underlineboldmagenta")) (Color_print.bold (Color_print.inverse "inverseboldmagenta")) (Color_print.inverse (Color_print.underline "underlineinversemagenta")) (Color_print.inverse (Color_print.blue "inversemagenta")) (Color_print.inverse ~override:true (Color_print.blue "inversemagenta")) (Color_print.green (Color_print.blue "magenta")) (Color_print.green ~override:true (Color_print.blue "magenta")) ); printf "%s\n" (Color_print.normal (Color_print.red (Color_print.bold "normal"))); () ;; core_extended-113.00.00/example/quotactl/000077500000000000000000000000001256461102500201155ustar00rootroot00000000000000core_extended-113.00.00/example/quotactl/quotactl.ml000066400000000000000000000110001256461102500222730ustar00rootroot00000000000000open Core.Std module Quota = Core_extended.Std.Unix.Quota let id_kind_and_lookup = function | `User -> "user", fun name -> (Unix.Passwd.getbyname_exn name).Unix.Passwd.uid | `Group -> "group", fun name -> (Unix.Group.getbyname_exn name).Unix.Group.gid module Query = struct let make_named_command user_or_group = let id_kind, lookup_id = id_kind_and_lookup user_or_group in id_kind, Command.basic ~summary:(sprintf "Query a %s's quota" id_kind) Command.Spec.( (step (fun f v -> f ~id:(lookup_id v)) +> anon (String.uppercase id_kind %: string)) +> anon ("DEVICE" %: file) ) (fun ~id device () -> let bytes_limit, bytes_usage, inodes_limit, inodes_usage = Or_error.ok_exn (Quota.query user_or_group ~id ~path:device) in printf "== Usage ==\n"; printf " - Bytes : %s\n" (Int63.to_string (bytes_usage : Quota.bytes Quota.usage :> Int63.t)); printf " - Inodes : %s\n" (Int63.to_string (inodes_usage : Quota.inodes Quota.usage :> Int63.t)); printf "== Limits ==\n"; printf " - Bytes : %s\n" (Sexp.to_string (<:sexp_of< Quota.bytes Quota.limit >> bytes_limit)); printf " - Inodes : %s\n" (Sexp.to_string (<:sexp_of< Quota.inodes Quota.limit >> inodes_limit))) let named_command = "query", Command.group ~summary:"Query quotas" [ make_named_command `User; make_named_command `Group ] end module Modify = struct let make_named_command user_or_group = let id_kind, lookup_id = id_kind_and_lookup user_or_group in id_kind, Command.basic ~summary:(sprintf "Modify a %s's quota" id_kind) Command.Spec.( let make_nullable_arg_type ~zero parse = Arg_type.create (function | "" | "0" -> None | s when String.lowercase s = "none" -> None | s -> let x = parse s in if x = zero then None else Some x) in let bytes = make_nullable_arg_type ~zero:(Quota.bytes Int63.zero) (fun s -> s |! Byte_units.of_string |! Byte_units.bytes |! Int63.of_float |! Quota.bytes) in let inodes = make_nullable_arg_type ~zero:(Quota.inodes Int63.zero) (fun s -> Quota.inodes (Int63.of_string s)) in let grace = make_nullable_arg_type ~zero:Time.epoch (fun s -> try Time.of_string s with exn -> try Time.add (Time.now ()) (Time.Span.of_string s) with _ -> raise exn) in (step (fun f v -> f ~id:(lookup_id v)) +> anon (String.uppercase id_kind %: string)) +> flag "-bytes-soft" (optional bytes) ~doc:"byte usage soft limit" +> flag "-bytes-hard" (optional bytes) ~doc:"byte usage hard limit" +> flag "-bytes-grace" (optional grace) ~doc:"byte usage grace period" +> flag "-inodes-soft" (optional inodes) ~doc:"inode usage soft limit" +> flag "-inodes-hard" (optional inodes) ~doc:"inode usage hard limit" +> flag "-inodes-grace" (optional grace) ~doc:"inode usage grace period" +> anon ("DEVICE" %: file) ) (fun ~id bsoft bhard bgrace isoft ihard igrace device () -> let bytes_limit, _bytes_usage, inodes_limit, _inodes_usage = Or_error.ok_exn (Quota.query user_or_group ~id ~path:device) in let update_limit limit soft hard grace = let optional_update field update = match field with | None -> Fn.id | Some v -> fun l -> update l v in List.fold ~init:limit ~f:(fun acc update -> update acc) [ optional_update soft (fun acc soft -> {acc with Quota.soft}); optional_update hard (fun acc hard -> {acc with Quota.hard}); optional_update grace (fun acc grace -> {acc with Quota.grace}); ] in let bytes_limit = update_limit bytes_limit bsoft bhard bgrace in let inodes_limit = update_limit inodes_limit isoft ihard igrace in Or_error.ok_exn (Quota.set user_or_group ~id ~path:device bytes_limit inodes_limit)) let named_command = "modify", Command.group ~summary:"Modify quotas" [ make_named_command `User; make_named_command `Group ] end let command = Command.group ~summary:"Set/query quotas" [ Query.named_command; Modify.named_command; ] let () = Exn.handle_uncaught ~exit:true (fun () -> Command.run command) core_extended-113.00.00/myocamlbuild.ml000066400000000000000000000455241256461102500176530ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: a6b1dfc733794e68a885243f612e86c4) *) module OASISGettext = struct (* # 22 "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 (* # 22 "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 # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "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 type conf = { no_automatic_syntax: bool; } (* 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 exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_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"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* 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"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "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 (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string 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\n" 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, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> 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; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) 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. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; 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 let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("core_extended", ["src"], []); ("selector_lib", ["selector/src"], []) ]; lib_c = [("core_extended", "src", ["src/fork_exec.h"; "src/config.h"])]; flags = [ (["oasis_library_core_extended_ccopt"; "compile"], [(OASISExpr.EBool true, S [A "-ccopt"; A "-Isrc"])]) ]; includes = [("test", ["src"])] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 630 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | After_rules -> dep ["ocaml"; "ocamldep"; "mlh"] ["src/config.mlh"]; flag ["mlh"; "ocaml"; "ocamldep"] (S[A"-ppopt"; A"-Isrc/"]); flag ["mlh"; "ocaml"; "compile"] (S[A"-ppopt"; A"-Isrc/"]); flag ["mlh"; "ocaml"; "doc"] (S[A"-ppopt"; A"-Isrc/"]); flag ["c"; "compile"] & S[A"-I"; A"src"; A"-package"; A"core"; A"-thread"]; List.iter (fun tag -> pflag ["ocaml"; tag] "pa_ounit_lib" (fun s -> S[A"-ppopt"; A"-pa-ounit-lib"; A"-ppopt"; A s])) ["ocamldep"; "compile"; "doc"]; let hack = "ugly_hack_to_workaround_ocamlbuild_nightmare" in mark_tag_used hack; dep [hack] [hack]; let lib_kernel_mods = [ "generator" ; "observer" ; "jck" ; "janecheck_intf" ; "std" ] in let add_exts l exts = List.concat (List.map (fun fn -> let fn = "janecheck_kernel/src/" ^ fn in List.map (fun ext -> fn ^ ext) exts) l) in rule hack ~prod:hack ~deps:(add_exts lib_kernel_mods [".cmx"; ".cmi"; ".cmo"]) (fun _ _ -> let to_remove = add_exts lib_kernel_mods [ ".cmx" ; ".cmi" ; ".cmo" ; ".ml" ; ".mli" ; ".ml.depends" ; ".mli.depends" ; ".o" ] in Seq [ Seq (List.map rm_f to_remove) ; Echo ([], hack) ]) | _ -> () let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook) core_extended-113.00.00/selector/000077500000000000000000000000001256461102500164465ustar00rootroot00000000000000core_extended-113.00.00/selector/src/000077500000000000000000000000001256461102500172355ustar00rootroot00000000000000core_extended-113.00.00/selector/src/selector.ml000066400000000000000000000122741256461102500214150ustar00rootroot00000000000000module Stable = struct open Core.Stable open Sexplib.Type module Date_selector = struct module V1 = struct type t = | GT of Date.V1.t | LT of Date.V1.t | Between of Date.V1.t * Date.V1.t | On of Date.V1.t with bin_io, sexp let t_of_sexp sexp = let module Date = Core.Std.Date in match sexp with | Atom _ as d -> On (Date.t_of_sexp d) | List [Atom ">"; Atom _ as d] -> GT (Date.t_of_sexp d) | List [Atom ">="; Atom _ as d] -> GT (Date.add_days (Date.t_of_sexp d) (-1)) | List [Atom "<"; Atom _ as d] -> LT (Date.t_of_sexp d) | List [Atom "<="; Atom _ as d] -> LT (Date.add_days (Date.t_of_sexp d) (1)) | List [Atom _ as d1; Atom "><"; Atom _ as d2] | List [Atom "><"; Atom _ as d1; Atom _ as d2] | List [Atom _ as d1; Atom _ as d2] -> (* The basic cases (GT, LT etc.) are being matched here, since they are lists of two atoms. Here the check whether the first atom is a date is done with try-with. *) begin try Between ((Date.t_of_sexp d1), (Date.t_of_sexp d2)) with _ -> t_of_sexp sexp end | _ -> t_of_sexp sexp end module Current = V1 end module String_selector = struct module Regexp = struct module V1 = struct module T = struct (* This type is stable in spite of using the Re2's non-stable type because bin_io and sexp conversion functions are explicitly defined below. *) type t = string * Re2.Std.Re2.t let to_string (s, _) = s let of_regexp s = s, Re2.Std.Re2.create_exn s let of_string s = of_regexp s end include T include Core.Std.Binable.Of_stringable(T) let t_of_sexp sexp = let open Core.Std in let fail () = of_sexp_error "expected string bounded with / on both sides" sexp in match sexp with | List _ -> of_sexp_error "expected Atom" sexp | Atom s -> if String.length s < 2 then fail () else if s.[0] = '/' && s.[String.length s - 1] = '/' then let s = String.sub s ~pos:1 ~len:(String.length s - 2) in of_regexp s else fail () let sexp_of_t (s, _) = Sexp.Atom ("/" ^ s ^ "/") end module Current = V1 end module V1 = struct type t = | Equal of string list | Matches of Regexp.V1.t list | Mixed of [ `Regexp of Regexp.V1.t | `Literal of string ] list with bin_io, sexp let t_of_sexp sexp = let parse_atom a = match a with | List _ -> assert false | Atom s -> if String.length s >= 1 && s.[0] = '/' then `Regexp (Regexp.V1.t_of_sexp a) else `Literal s in try match sexp with | Atom _ as a -> begin match parse_atom a with | `Regexp r -> Matches [r] | `Literal s -> Equal [s] end | List l -> Mixed (Core.Std.List.map l ~f:(fun sexp -> match sexp with | List _ -> Core.Std.of_sexp_error "expected Atom" sexp | Atom _ as a -> parse_atom a)) with | e -> try t_of_sexp sexp with _ -> raise e end module Current = V1 end module String_list_selector = struct module V1 = struct type t = string list with bin_io, sexp let t_of_sexp sexp = match sexp with | Sexp.Atom s -> [s] | _ -> t_of_sexp sexp end module Current = V1 end end open Core.Std module type Selector = sig type selector type value val eval : selector -> value -> bool end module Date_selector = struct include Stable.Date_selector.Current type selector = t type value = Date.t let eval t d = match t with | GT gtd -> Date.(>) d gtd | LT ltd -> Date.(<) d ltd | Between (d1, d2) -> Date.(>=) d d1 && Date.(<=) d d2 | On ond -> Date.(=) d ond end module String_selector = struct module Regexp : sig type t = Stable.String_selector.Regexp.Current.t with bin_io, sexp val of_regexp : string -> t val to_string : t -> string val matches : t -> string -> bool val to_regexp : t -> Re2.Std.Re2.t end = struct include Stable.String_selector.Regexp.Current let to_regexp (_, p) = p let matches (_, rex) s = Re2.Std.Re2.matches rex s end include Stable.String_selector.Current type selector = t type value = String.t let eval t s = match t with | Equal el -> Option.is_some (List.find el ~f:(fun e -> e = s)) | Matches ml -> Option.is_some (List.find ml ~f:(fun rex -> Regexp.matches rex s)) | Mixed ml -> Option.is_some (List.find ml ~f:(function | `Regexp rex -> Regexp.matches rex s | `Literal l -> l = s)) end module String_list_selector = struct include Stable.String_list_selector.Current type selector = t type value = string let eval t s = match List.find t ~f:(fun m -> m = s) with | None -> false | Some _ -> true end core_extended-113.00.00/selector/src/selector.mli000066400000000000000000000046501256461102500215650ustar00rootroot00000000000000open Core.Std (* Implements types to be used in selection languages using Blang. The many nested types serve partially as documentation, but mostly to ease the creation of custom sexp parsers to reduce the amount of noise in config files. While any amount of magic may be embedded in the sexp parsers exposed below, the following magic will be available: - constructors that take lists can be written as atoms for singletons - specific notes as detailed below *) module type Selector = sig type selector type value val eval : selector -> value -> bool end module Date_selector : sig (* >, <, and = are allowed in place of GT, LT, and On. In addition >< can be used in place of Between and can be used infix (e.g. (date1 >< date2)). In addition, the special cases of on and between can be written as simply "date" and "(date1 date2)" *) type t = | GT of Date.t | LT of Date.t | Between of Date.t * Date.t | On of Date.t with bin_io, sexp include Selector with type selector = t and type value = Date.t end (* regular expressions must be bounded with a '/' on both ends and this is used to automagically produce the correct type when parsing sexps, so that you can write any of the following: /.*foo/ foo (foo bar) (foo /bar[0-9]/) *) module String_selector : sig module Regexp : sig type t with bin_io, sexp val of_regexp : string -> t val matches : t -> string -> bool val to_string : t -> string val to_regexp : t -> Re2.Std.Re2.t end type t = | Equal of string list | Matches of Regexp.t list | Mixed of [ `Regexp of Regexp.t | `Literal of string ] list with bin_io, sexp include Selector with type selector = t and type value = String.t end module String_list_selector : sig type t = string list with bin_io, sexp include Selector with type selector = t and type value = string end module Stable : sig open Core.Stable module Date_selector : sig module V1 : sig type t = Date_selector.t with sexp, bin_io end end module String_selector : sig module Regexp : sig module V1 : sig type t = String_selector.Regexp.t with sexp, bin_io end end module V1 : sig type t = String_selector.t with bin_io, sexp end end module String_list_selector : sig module V1 : sig type t = String_list_selector.t with sexp, bin_io end end end core_extended-113.00.00/selector/src/selector_lib.mldylib000066400000000000000000000001411256461102500232550ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 1609e94a4941254300e46c66653572ab) Selector_lib # OASIS_STOP core_extended-113.00.00/selector/src/selector_lib.mllib000066400000000000000000000001411256461102500227200ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 1609e94a4941254300e46c66653572ab) Selector_lib # OASIS_STOP core_extended-113.00.00/selector/src/selector_lib.mlpack000066400000000000000000000001351256461102500230730ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0c3cd33e7bf626da4897316a7158a7a4) Selector # OASIS_STOP core_extended-113.00.00/setup.ml000066400000000000000000005772571256461102500163470ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 733ec4a45894267a884f30540030ce52) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "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 (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) 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 fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-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"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "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 = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) 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) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl 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 (* # 22 "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 (* # 78 "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 (* # 22 "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 (* # 22 "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 version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) 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 rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "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 (* # 22 "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 OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "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 (* # 115 "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 object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } 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 | Object of common_section * build_section * object_ | 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 | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; 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: OASISText.t 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; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "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 (* # 22 "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 (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, 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) | Object (_, bs, obj) -> Object (cs, bs, obj) | 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" | `Object -> "object" | `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 (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "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 (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs 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 bs 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 bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") 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"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: 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) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.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 of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] 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 | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) 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, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end 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 (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "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 (* # 22 "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 (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) 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 else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") 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 # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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 (* # 22 "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" | "Cygwin" -> ".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 (* # 22 "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 (* # 22 "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 (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | 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") | BObj -> (f_ "object %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 let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.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 ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "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 (* # 22 "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 _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "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 OASISFeatures.package_test OASISFeatures.flag_tests pkg && 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 (* # 22 "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 OASISFeatures.package_test OASISFeatures.flag_docs pkg && 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 (* # 22 "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 let arg_rest = ref [] 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"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); 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 _ | Object _ | 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 default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn 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 default_oasis_fn 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 # 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "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; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" 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 (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib 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 obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) 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 let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (String.capitalize modul ^ sufx) :: (String.uncapitalize modul ^ sufx) :: accu end sufx [] 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 begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ 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 and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) 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, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), 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 # 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list 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 (tests ()) then ["-tag"; "tests"] 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 (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args 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 tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(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 | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %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 _ | Object _ | 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 (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) 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 (* # 22 "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 type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) 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 run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6651 "setup.ml" module CustomPlugin = struct (* # 22 "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 # 6799 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = [ ("test_runner", CustomPlugin.Test.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$test_runner", [ "--core-hello"; "$core_hello"; "--core-extended-hello"; "$core_extended_hello" ])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; doc = []; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("test_runner", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$test_runner", [ "--core-hello"; "$core_hello"; "--core-extended-hello"; "$core_extended_hello" ])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; clean_doc = []; distclean = []; distclean_test = [ ("test_runner", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$test_runner", [ "--core-hello"; "$core_hello"; "--core-extended-hello"; "$core_extended_hello" ])) ]; 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"); alpha_features = []; beta_features = []; name = "core_extended"; version = "113.00.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0" }); license_file = Some "LICENSE.txt"; copyrights = [ "(C) 2008-2013 Jane Street Group LLC " ]; maintainers = ["Jane Street Group"; "LLC "]; authors = ["Jane Street Group"; "LLC "]; homepage = Some "https://github.com/janestreet/core_extended"; synopsis = "Jane Street Capital's standard library overlay"; description = Some [ OASISText.Para "The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, Some (("config/detect.sh", [])))]; post_command = [ (OASISExpr.EBool true, Some (("config/discover.sh", ["$ocamlc"; "src/config.mlh"; "src/config.h"]))) ] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); 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, Some (("$rm", ["src/config.mlh"; "src/config.h"]))) ]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = []; sections = [ Flag ({ cs_name = "linux"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Enable linux specific extensions"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "linux_possible", true) ] }); Flag ({ cs_name = "posix-timers"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Enable POSIX timers"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "posix_timers_possible", true) ] }); Library ({ cs_name = "core_extended"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("bigarray", None); FindlibPackage ("bin_prot", None); FindlibPackage ("bin_prot.syntax", None); FindlibPackage ("comparelib.syntax", None); FindlibPackage ("core", None); FindlibPackage ("custom_printf", None); FindlibPackage ("custom_printf.syntax", None); FindlibPackage ("fieldslib", None); FindlibPackage ("fieldslib.syntax", None); FindlibPackage ("pa_bench.syntax", None); FindlibPackage ("pa_ounit", None); FindlibPackage ("pa_ounit.syntax", None); FindlibPackage ("pa_pipebang", None); FindlibPackage ("pa_test", None); FindlibPackage ("pa_test.syntax", None); FindlibPackage ("textutils", None); FindlibPackage ("re2", None); FindlibPackage ("sexplib", None); FindlibPackage ("sexplib.syntax", None); FindlibPackage ("sexplib_num", None); FindlibPackage ("unix", None); FindlibPackage ("threads", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = [ "extended_int_stubs.c"; "extended_linux_stubs.c"; "extended_unix_stubs.c"; "fork_exec.c"; "fork_exec.h"; "linebuf_stubs.c"; "low_level_debug_stubs.c"; "malloc_stubs.c"; "posix_clock_stubs.c"; "config.h" ]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, ["-Isrc"])]; 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 = [ "Alternating_primary_backup_assignment"; "Atomic_edit"; "Bin_io_utils"; "Bitarray"; "Cache"; "Cbuffer"; "Color_print"; "Crit_bit"; "Csv_writer"; "Deprecated_bench"; "Deprecated_command"; "Deprecated_fcommand"; "Deprecated_service_command"; "Documented_match_statement"; "English"; "Environment"; "Exception_check"; "Extended_array"; "Extended_common"; "Extended_exn"; "Extended_filename"; "Extended_float"; "Extended_gc"; "Extended_hashtbl"; "Extended_int"; "Extended_int32"; "Extended_int63"; "Extended_int64"; "Extended_linux"; "Extended_list"; "Extended_list__LCS"; "Extended_list__multimerge"; "Extended_memo"; "Extended_monad"; "Extended_nativeint"; "Extended_option"; "Extended_result"; "Extended_sexp"; "Extended_string"; "Extended_sys"; "Extended_thread"; "Extended_time"; "Extended_unix"; "Extra_fields"; "Fd_leak_check"; "Find"; "Flang"; "Float_ref"; "Fold_map"; "Generic"; "Hashtbl2"; "Hashtbl2_pair"; "Interval_map"; "Interval_map_intf"; "Invariant"; "Invocation"; "Iter"; "Lazy_list"; "Lazy_m"; "Lazy_sequence"; "Left_boundary"; "Linebuf"; "List_zipper"; "Logger"; "Low_level_debug"; "Malloc"; "Multi_map"; "Net_utils"; "Number"; "Olang"; "Packed_array"; "Packed_map"; "Posix_clock"; "Pp"; "Printc"; "Process"; "Procfs"; "Prod_or_test"; "Quickcheck_deprecated"; "Random_selection"; "Readline"; "Readline__input_char"; "Readline__input_loop"; "Runtime_blockout_detector"; "Rw_mutex"; "Sampler"; "Search_foo"; "Semaphore"; "Sendmail"; "Service_command"; "Set_lang"; "Set_lang_intf"; "Shell"; "Shell__core"; "Shell__line_buffer"; "Sntp"; "Splay_tree"; "Std"; "String_zipper"; "Sys_utils"; "Tcp"; "Timed_function"; "Trie"; "Unix_utils"; "Update_queue" ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "core_extended"; lib_findlib_containers = [] }); Library ({ cs_name = "selector_lib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "selector/src"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("bin_prot.syntax", None); FindlibPackage ("core", None); FindlibPackage ("re2", None); FindlibPackage ("sexplib.syntax", None); FindlibPackage ("threads", 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 = ["Selector"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = Some "core_extended"; lib_findlib_name = Some "selector"; lib_findlib_containers = [] }); Executable ({ cs_name = "core_extended_hello"; 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 = "test"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "core_extended"]; 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 = true; exec_main_is = "core_extended_hello.ml" }); Executable ({ cs_name = "core_hello"; 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 = "test"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("core", None); FindlibPackage ("threads", 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, [])] }, {exec_custom = true; exec_main_is = "core_hello.ml"}); Executable ({ cs_name = "test_runner"; 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 = "test"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "core_extended"; FindlibPackage ("oUnit", Some (OASISVersion.VGreaterEqual "1.1.0")); FindlibPackage ("threads", 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, [])] }, {exec_custom = true; exec_main_is = "test_runner.ml"}); Test ({ cs_name = "test_runner"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [ (OASISExpr.EBool true, ("$test_runner", [ "--core-hello"; "$core_hello"; "--core-extended-hello"; "$core_extended_hello" ])) ]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = Some "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"; InternalExecutable "core_hello"; InternalExecutable "core_extended_hello" ] }) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "\247\216~\145J\183\150\127\031\173\004\208\215#\129\006"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7358 "setup.ml" (* OASIS_STOP *) let () = setup () core_extended-113.00.00/src/000077500000000000000000000000001256461102500154155ustar00rootroot00000000000000core_extended-113.00.00/src/META000066400000000000000000000015401256461102500160660ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 90daab87fb8e81f1bc8dad28e512a001) version = "113.00.00" description = "Jane Street Capital's standard library overlay" requires = "bigarray bin_prot core custom_printf fieldslib oUnit pa_bench pa_ounit pa_test re2 sexplib sexplib_num textutils threads unix " archive(byte) = "core_extended.cma" archive(byte, plugin) = "core_extended.cma" archive(native) = "core_extended.cmxa" archive(native, plugin) = "core_extended.cmxs" exists_if = "core_extended.cma" package "selector" ( version = "113.00.00" description = "Jane Street Capital's standard library overlay" requires = "bin_prot core re2 sexplib threads" archive(byte) = "selector_lib.cma" archive(byte, plugin) = "selector_lib.cma" archive(native) = "selector_lib.cmxa" archive(native, plugin) = "selector_lib.cmxs" exists_if = "selector_lib.cma" ) # OASIS_STOP core_extended-113.00.00/src/Makefile000066400000000000000000000047621256461102500170660ustar00rootroot00000000000000OCAMLMAKEFILE = ../OCamlMakefile #ifeq ($(shell uname -s), Linux) # LINUX_EXT_STUBS_C = linux_ext_stubs.c # LINUX_EXT_ML = linux_ext.mli linux_ext.ml # CLIBS += rt #endif SOURCES = \ pp.mli \ pp.ml \ extended_unix.mli \ extended_unix.ml \ extended_string.mli \ extended_string.ml \ extended_sexp.mli \ extended_sexp.ml \ extended_result.mli \ extended_result.ml \ extended_option.mli \ extended_option.ml \ extended_list.mli \ extended_list.ml \ extended_linux.mli \ extended_linux.ml \ extended_gc.mli \ extended_gc.ml \ extended_float.mli \ extended_float.ml \ extended_filename.mli \ extended_filename.ml \ extended_exn.mli \ extended_exn.ml \ extended_array.mli \ extended_array.ml \ exception_check.mli \ exception_check.ml \ exception_sys.mli \ exception_sys.ml \ vector.mli \ vector.ml \ unix_utils.mli \ unix_utils.ml \ union_find.mli \ union_find.ml \ syslog.mli \ syslog.ml \ process.mli \ process.ml \ shell.mli \ shell.ml \ extended_common.mli \ extended_common.ml \ sendmail.mli \ sendmail.ml \ semaphore.mli \ semaphore.ml \ rw_mutex.mli \ rw_mutex.ml \ rmap.mli \ rmap.ml \ res_array.mli \ res_array.ml \ readline.mli \ readline.ml \ prompt.mli \ prompt.ml \ procfs.mli \ procfs.ml \ net_utils.mli \ net_utils.ml \ malloc.mli \ malloc.ml \ lru.mli \ lru.ml \ log.mli \ log.ml \ loggers.mli \ loggers.ml \ logger.mli \ logger.ml \ iter.mli \ iter.ml \ int_set.mli \ int_set.ml \ hashtree.mli \ hashtree.ml \ function.mli \ function.ml \ fold_table.mli \ fold_map.mli \ fold_map.ml \ find.mli \ find.ml \ escaping.mli \ escaping.ml \ dispatch_arg.mli \ dispatch_arg.ml \ container_extended.ml \ command.mli \ command.ml \ cbuffer.mli \ cbuffer.ml \ std.ml \ extended_linux_stubs.c extended_unix_stubs.c malloc_stubs.c extended_sys_stubs.c syslog_stubs.c LIB_PACK_NAME = core_extended INCDIRS = +camlp4 . OCAMLFLAGS = -for-pack Core_extended -annot CFLAGS = \ -pipe -g -fPIC -O2 -fomit-frame-pointer \ -Wall -pedantic -Wextra -Wunused -Wno-long-long PACKS = res sexplib bin_prot fieldslib core pcre RESULT = core_extended THREADS = yes ANNOTATE = true all: byte-code-library native-code-library LIBINSTALL_FILES = \ core_extended.cmi core_extended.cma core_extended.cmxa core_extended.a libcore_extended_stubs.a dllcore_extended_stubs.so install: libinstall uninstall: libuninstall clean:: clean-doc -include $(OCAMLMAKEFILE) core_extended-113.00.00/src/alternating_primary_backup_assignment.ml000066400000000000000000000004271256461102500256020ustar00rootroot00000000000000open Core.Std type 'a t = { primary : 'a; backup : 'a } let baseline = Time.to_date Time.epoch ~zone:Time.Zone.utc let select date ~slot1:a ~slot2:b = let n = Date.diff baseline date in if n % 2 = 0 then {primary = a; backup = b} else {primary = b; backup = a} core_extended-113.00.00/src/alternating_primary_backup_assignment.mli000066400000000000000000000007511256461102500257530ustar00rootroot00000000000000open Core.Std (** role assignment for systems with a primary and backup instances that switch roles daily for ease of deploying new versions. *) (* Note: most weekends are happily two days long, so that primary and backup are properly swapped between Friday and Monday. This breaks down on three-day weekends, but one shouldn't deploy leading into one of those anyway. *) type 'a t = { primary : 'a; backup : 'a } val select : Date.t -> slot1:'a -> slot2:'a -> 'a t core_extended-113.00.00/src/atomic_edit.ml000066400000000000000000000033111256461102500202260ustar00rootroot00000000000000open Core.Std type return_type = | Ok | Changed of string * string | Abort type file_state = { path : string; stat : Unix.stats; } let record_state filepath = { path = filepath; stat = Unix.stat filepath; } (* the peer is an unlocked shadow copy of the master which will then atomically replace the master if the user function completes ok and the master has not changed since the peer was created *) let peer_name master_state = Filename.temp_file ~perm:master_state.stat.Unix.st_perm ~in_dir:(Filename.dirname master_state.path) (Filename.basename master_state.path) ("." ^ Pid.to_string (Unix.getpid ())) let copy_master master_state = let peer_path = peer_name master_state in Shell.cp ~overwrite:true ~perm:0o0644 (master_state.path) (peer_path); peer_path let replace_master master_state peer_path = let update_file = (master_state.path ^ ".update") in protectx (Unix.openfile update_file ~mode:[Unix.O_WRONLY;Unix.O_EXCL;Unix.O_CREAT] ~perm:0o0644) ~f:(fun _ -> if master_state.stat.Unix.st_mtime <> (Unix.stat(master_state.path)).Unix.st_mtime then Changed ( (sprintf "%s changed while you were editing %s" master_state.path peer_path) , peer_path) else ( Unix.rename ~src:peer_path ~dst:master_state.path; Ok ) ) ~finally:(fun fd -> Unix.close fd; Unix.unlink update_file) let atomic_edit ~f master_path = let master_state = record_state master_path in let peer_path = copy_master master_state in match (f (peer_path)) with | `Ok -> replace_master master_state peer_path | `Abort -> Abort core_extended-113.00.00/src/atomic_edit.mli000066400000000000000000000016221256461102500204020ustar00rootroot00000000000000(** Atomically edit a file without long-term locking See documentation for the function [atomic_edit] *) (** the return value of [atomic_edit] *) type return_type = | Ok | Changed of string * string | Abort (** [atomic_edit ~f filepath] edit [filepath] by making a unique copy (peer) that can be openly changed without holding any locks on the original. When the function returns, a short term exclusive lock is held while overwriting the original with the edited copy. If the mtime of the original is changed since the copy was made, the replacement is aborted (indicating another [atomic_edit] was first to update the file, or some other process) and Changed is returned with a tuple [(warning message * terd file)]. The terd file contains the edits and might be used to diff or re-edit. *) val atomic_edit : f:(string -> [ `Ok | `Abort ] ) -> string -> return_type core_extended-113.00.00/src/bin_io_utils.ml000066400000000000000000000213431256461102500204310ustar00rootroot00000000000000open Core.Std let load ?pos ?len file bin_read_t = let failwith s = failwith ("Core_extended.Bin_io_utils.load: " ^ s) in let pos = match pos with | None -> Int64.zero | Some pos when pos < Int64.zero -> failwith "pos < 0" | Some pos -> pos in let bstr = In_channel.with_file file ~f:(fun ic -> let file_size = In_channel.length ic in let len64 = match len with | None when pos > file_size -> failwith "pos > file size" | None -> Int64.(-) file_size pos | Some len64 when len64 < Int64.zero -> failwith "len < 0" | Some len64 when Int64.(+) pos len64 > file_size -> failwith "pos + len < file size" | Some len64 -> len64 in let len = match Int64.to_int len64 with | None -> failwith "len exceeds maximum integer" | Some len -> len in let bstr = Bigstring.create len in Bigstring.really_input ic bstr; bstr) in let pos_ref = ref 0 in let v = bin_read_t bstr ~pos_ref in if !pos_ref <> Bigstring.length bstr then failwith "garbage after data" else v let save ?header ?perm file bin_writer_t v = let bstr = Bin_prot.Utils.bin_dump ?header bin_writer_t v in let tmp_name, oc = let in_dir, basename = Filename.split file in Filename.open_temp_file ~in_dir basename "tmp" in try Bigstring.really_output oc bstr; Out_channel.close oc; let perm = match perm with | Some perm -> perm | None -> let umask = Unix.umask 0 in ignore (Unix.umask umask); umask lxor 0o666 in if perm <> 0o600 then Unix.chmod tmp_name ~perm; Sys.rename tmp_name file with e -> close_out_noerr oc; raise e let end_char = '\n' let escape_char = '\\' let escaped_end_char = 'n' let to_line bin_t v = let bstr = Bin_prot.Utils.bin_dump bin_t.Bin_prot.Type_class.writer v ~header:false in let len = Bigstring.length bstr in let escaped_bstr = Bigstring.create (2 * len + 1) in let end_pos = ref 0 in let write char = escaped_bstr.{!end_pos} <- char; incr end_pos in for i = 0 to len - 1 do if bstr.{i} = end_char then begin write escape_char; write escaped_end_char; end else if bstr.{i} = escape_char then begin write escape_char; write escape_char end else write bstr.{i} done; write end_char; Bigstring.sub escaped_bstr ~pos:0 ~len:!end_pos let of_line s bin_t = let len = String.length s in let bstr = Bigstring.create len in let bstr_pos = ref 0 in let write char = bstr.{!bstr_pos} <- char; incr bstr_pos in let rec loop s_pos = if s_pos < len then if s.[s_pos] <> escape_char then begin write s.[s_pos]; loop (s_pos + 1) end else let next = s.[s_pos+1] in if next = escape_char then write escape_char else if next = escaped_end_char then write end_char else failwith "bug in write_robust or read_robust"; loop (s_pos + 2) in loop 0; bin_t.Bin_prot.Type_class.reader.Bin_prot.Type_class.read (Bigstring.sub_shared bstr ~pos:0 ~len:!bstr_pos) ~pos_ref:(ref 0) module Serialized = struct type 'a t = string let create { Bin_prot.Type_class. size; write } a = let size = size a in let buf = Bigstring.create size in let written = write buf ~pos:0 a in assert (size = written); Bigstring.to_string buf ;; let value t { Bin_prot.Type_class. read; vtag_read = _ } = let pos_ref = ref 0 in read (Bigstring.of_string t) ~pos_ref let bin_size_t t = String.length t let bin_write_t = fun buf ~pos t -> let len = String.length t in Bigstring.From_string.blit ~src:t ~src_pos:0 ~dst:buf ~dst_pos:pos ~len; pos + len let bin_read_t_with_value bin_read_a = fun buf ~pos_ref -> let pos = !pos_ref in let a = bin_read_a buf ~pos_ref in let len = !pos_ref - pos in let t = Bigstring.To_string.sub buf ~pos ~len in (t, a) let bin_read_t bin_read_a = fun buf ~pos_ref -> fst (bin_read_t_with_value bin_read_a buf ~pos_ref) let __bin_read_t__ _ = (* this should only be called when [t] is a polymorphic variant (it is not) *) fun _ ~pos_ref:_ -> assert false let bin_writer_t (_ : 'a Bin_prot.Type_class.writer) = { Bin_prot.Type_class.size = bin_size_t ; write = bin_write_t } let bin_reader_t { Bin_prot.Type_class. read = bin_read_a; vtag_read } = { Bin_prot.Type_class.read = bin_read_t bin_read_a ; vtag_read = __bin_read_t__ vtag_read } let bin_reader_t_with_value { Bin_prot.Type_class. read = bin_read_a; vtag_read } = { Bin_prot.Type_class.read = bin_read_t_with_value bin_read_a ; vtag_read = __bin_read_t__ vtag_read } let bin_writer_t_with_value (_ : 'a Bin_prot.Type_class.writer) = { Bin_prot.Type_class.size = (fun x -> bin_size_t (fst x)) ; write = (fun buf ~pos t -> bin_write_t buf ~pos (fst t)) } let bin_t { Bin_prot.Type_class. writer = bin_writer_a; reader = bin_reader_a } = { Bin_prot.Type_class. writer = bin_writer_t bin_writer_a ; reader = bin_reader_t bin_reader_a } let bin_t_with_value { Bin_prot.Type_class. writer = bin_writer_a; reader = bin_reader_a } = { Bin_prot.Type_class.writer = bin_writer_t_with_value bin_writer_a ; reader = bin_reader_t_with_value bin_reader_a } module Make (B : Binable) = struct type t = string let create bt = create B.bin_writer_t bt let value t = value t B.bin_reader_t let bin_size_t = bin_size_t let bin_write_t = bin_write_t let bin_read_t = bin_read_t B.bin_read_t let __bin_read_t__ = __bin_read_t__ B.__bin_read_t__ let bin_writer_t = bin_writer_t B.bin_writer_t let bin_reader_t = bin_reader_t B.bin_reader_t let bin_t = bin_t B.bin_t let bin_reader_t_with_value = bin_reader_t_with_value B.bin_reader_t let bin_t_with_value = bin_t_with_value B.bin_t end let bin_size_t _ = bin_size_t let bin_write_t _ = bin_write_t TEST_MODULE = struct module Make_test (B : sig type t with bin_io, sexp_of, compare val values_and_sizes : (t * int) list end) = struct module Serialized_t = Make (B) TEST_UNIT "roundtrip" = List.iter B.values_and_sizes ~f:(fun (value, _size) -> let t = Serialized_t.create value in <:test_result> ~expect:value (Serialized_t.value t)) ;; TEST_UNIT "serialized writer matches writer" = List.iter B.values_and_sizes ~f:(fun (value, _size) -> let t = Serialized_t.create value in let expect = Bin_prot.Utils.bin_dump B.bin_writer_t value |> Bigstring.to_string in let buffer = Bin_prot.Utils.bin_dump Serialized_t.bin_writer_t t |> Bigstring.to_string in <:test_result> ~expect buffer) ;; TEST_UNIT "serialized reader matches reader" = List.iter B.values_and_sizes ~f:(fun (value, _size) -> let buffer = Bin_prot.Utils.bin_dump B.bin_writer_t value in let t = Serialized_t.bin_read_t buffer ~pos_ref:(ref 0) in <:test_result> ~expect:value (Serialized_t.value t)) ;; TEST_UNIT "bin_size_t" = List.iter B.values_and_sizes ~f:(fun (value, size) -> let t = Serialized_t.create value in <:test_result> ~expect:(value, size) (value, (Serialized_t.bin_size_t t))) end module Test_int = Make_test (struct include Int let values_and_sizes = [ 5, 1 ; 255, 3 ; 1024, 3 ] end) module Test_string = Make_test (struct include String let values_and_sizes = [ "foo", 4 ; "foo bar", 8 ] end) module Variant = struct type t = | A of int | B of string | C with sexp, bin_io, compare end module Test_variant = Make_test (struct include Variant let values_and_sizes = [ A 5, 2 ; B "foo bar buz", 13 ; C, 1 ] end) module Record = struct type t = { name : string ; age : int } with sexp, bin_io, compare end module Test_record = Make_test (struct include Record let values_and_sizes = [ { name = "Drew"; age = 26 }, 6 ] end) module Polymorphic_variant = struct type t = [ `A of int | `B of string | `C ] with sexp, bin_io, compare end module Test_polymorphic_variant = Make_test (struct include Polymorphic_variant let values_and_sizes = [ `A 6, 5 ; `B "foo bar guz", 16 ; `C, 4 ] end) end end core_extended-113.00.00/src/bin_io_utils.mli000066400000000000000000000042301256461102500205760ustar00rootroot00000000000000open Core.Std val load : ?pos : Int64.t -> ?len : Int64.t -> string -> 'a Bin_prot.Read.reader -> 'a val save : ?header : bool -> ?perm : Unix.file_perm -> string -> 'a Bin_prot.Type_class.writer -> 'a -> unit (* converts the value to a string with a newline at the end and no other newlines *) val to_line : 'a Bin_prot.Type_class.t -> 'a -> Bigstring.t (* reads a string with no newlines (which must be the output of [to_line] without the trailing newline) and converts it to a value *) val of_line : string -> 'a Bin_prot.Type_class.t -> 'a module Serialized : sig (** A container for storing an ['a] as a bin-io buffer. The advantages of storing a value as an ['a t] rather than an ['a] are: - it will take up less space - serializing ['a t] is faster (it's just a blit) and it has the same bin-io representation as ['a]. However, every time you need to access ['a] itself you need to call [value], which requires deserializing. ['a t] is safe in the sense that you cannot construct an ['a t] that doesn't store a valid ['a]. When deserializing an ['a], this requires actually constructing ['a]. If you'd like access to the ['a] that's constructed during deserialization, see the [bin_reader_t_with_value] below. *) type 'a t with bin_io val create : 'a Bin_prot.Type_class.writer -> 'a -> 'a t val value : 'a t -> 'a Bin_prot.Type_class.reader -> 'a (** Deserializing requires actually constructing an ['a], so this reader gives you access to that ['a], rather than just throwing it away. This is useful because you often might want to do something like indexing ['a t] by inspecting ['a] at the time that you read it. *) val bin_reader_t_with_value : 'a Bin_prot.Type_class.reader -> ('a t * 'a) Bin_prot.Type_class.reader val bin_t_with_value : 'a Bin_prot.Type_class.t -> ('a t * 'a) Bin_prot.Type_class.t module Make (B : Binable) : sig type t with bin_io val create : B.t -> t val value : t -> B.t val bin_reader_t_with_value : (t * B.t) Bin_prot.Type_class.reader val bin_t_with_value : (t * B.t) Bin_prot.Type_class.t end end core_extended-113.00.00/src/bitarray.ml000066400000000000000000000034721256461102500175720ustar00rootroot00000000000000open Core.Std (* a single 63 bit chunk of the array, bounds checking is left to the main module. We can only use 62 bits, because of the sign bit *) module Int63_chunk : sig type t val empty : t val get : t -> int -> bool val set : t -> int -> bool -> t end = struct open Int63 type t = Int63.t let empty = zero let get t i = bit_and t (shift_left one i) > zero let set t i v = if v then bit_or t (shift_left one i) else bit_and t (bit_xor minus_one (shift_left one i)) end type t = { data: Int63_chunk.t Array.t; length: int } (* We can't use the sign bit, so we only get to use 62 bits *) let bits_per_bucket = 62 let create sz = if sz < 0 || sz > (Array.max_length * bits_per_bucket) then invalid_argf "invalid size" (); { data = Array.create ~len:(1 + (sz / bits_per_bucket)) Int63_chunk.empty; length = sz } ;; let bucket i = i / bits_per_bucket let index i = i mod bits_per_bucket let bounds_check t i = if i < 0 || i >= t.length then invalid_argf "Bitarray: out of bounds" (); ;; let get t i = bounds_check t i; Int63_chunk.get t.data.(bucket i) (index i) ;; let set t i v = bounds_check t i; let bucket = bucket i in t.data.(bucket) <- Int63_chunk.set t.data.(bucket) (index i) v ;; let clear t = Array.fill t.data ~pos:0 ~len:(Array.length t.data) Int63_chunk.empty ;; let fold = let rec loop t n ~init ~f = if n < t.length then loop t (n + 1) ~init:(f init (get t n)) ~f else init in fun t ~init ~f -> loop t 0 ~init ~f ;; let iter t ~f = fold t ~init:() ~f:(fun _ v -> f v) let sexp_of_t t = Array.sexp_of_t Bool.sexp_of_t (Array.init t.length ~f:(fun i -> get t i)) ;; let t_of_sexp sexp = let a = Array.t_of_sexp Bool.t_of_sexp sexp in let t = create (Array.length a) in Array.iteri a ~f:(fun i v -> set t i v); t ;; core_extended-113.00.00/src/bitarray.mli000066400000000000000000000021711256461102500177360ustar00rootroot00000000000000(** This module implements efficient and compact arrays of boolean values. It stores its values in the bits of an integer, using multiple integers to allow for arrays larger than the machine word size. All operations are on immediates (no caml_modify), and are quite simple. Hence this data structure should be more efficient than an array of bools. *) type t include Core.Std.Sexpable with type t := t (** [create size] size must be less than ((word size - 2) * max array length) *) val create : int -> t (** [get t pos] get the value in position [pos], raises Invalid_argument if the position is out of bounds. *) val get : t -> int -> bool (** [set t pos] set the value in position [pos], raises Invalid_argument if the position is out of bounds. *) val set : t -> int -> bool -> unit (** [clear t] set the contents of every element to false O(n / (word_size - 2)) *) val clear : t -> unit (** [fold t ~init ~f] Fold over the array as in [Array.fold] *) val fold : t -> init:'a -> f:('a -> bool -> 'a) -> 'a (** [iter t ~f] Iterate over the array as in [Array.iter] *) val iter : t -> f:(bool -> unit) -> unit core_extended-113.00.00/src/cache.ml000066400000000000000000000145711256461102500170220ustar00rootroot00000000000000open Core.Std (* *) module type Strategy = sig type 'a t type 'a with_init_args val cps_create : f:(_ t -> 'b) -> 'b with_init_args val touch : 'a t -> 'a -> 'a list val remove : 'a t -> 'a -> unit val clear : 'a t -> unit end module Memoized = struct type 'a t = ('a,exn) Result.t let return : 'a t -> 'a = function | Result.Ok x -> x | Result.Error e -> raise e let create ~f arg = try Result.Ok (f arg) with | Sys.Break as e -> raise e | e -> Result.Error e end module type Store = sig type ('k,'v) t type 'a with_init_args val cps_create : f:((_,_) t -> 'b) -> 'b with_init_args val clear : (_,_) t -> unit val replace : ('k,'v) t -> key:'k -> data:'v -> unit val find : ('k,'v) t -> 'k -> 'v option val data : (_,'v) t -> 'v list val remove : ('k,_) t -> 'k -> unit end module type S = sig type ('a, 'b) t type 'a with_init_args type ('a,'b) memo = ('a, ('b, exn) Result.t) t val find : ('k,'v) t -> 'k -> 'v option val add : ('k,'v) t -> key:'k -> data:'v -> unit val remove : ('k,_) t -> 'k -> unit val clear : (_,_) t -> unit val create : destruct:('v -> unit) option -> ('k,'v) t with_init_args val call_with_cache : cache:('a,'b) memo -> ('a -> 'b) -> 'a -> 'b val memoize : ?destruct:('b -> unit) -> ('a -> 'b) -> (('a,'b) memo * ('a -> 'b)) with_init_args end module Make(Strat:Strategy) (Store:Store) : S with type 'a with_init_args = ('a Store.with_init_args Strat.with_init_args) = struct type 'a with_init_args = ('a Store.with_init_args Strat.with_init_args) type ('k,'v) t = { destruct : ('v -> unit) option; (** Function to be called on removal of values from the store *) strat : 'k Strat.t; store : ('k,'v) Store.t (** The actual key value store*) } type ('a,'b) memo = ('a, ('b, exn) Result.t) t let clear_from_store cache key = match Store.find cache.store key with | None -> failwith "Cache.Make: strategy wants to remove a key which \ isn't in the store" | Some v -> Option.call ~f:cache.destruct v; Store.remove cache.store key let touch_key cache key = List.iter (Strat.touch cache.strat key) ~f:(fun k -> clear_from_store cache k) let find cache k = let res = Store.find cache.store k in if Option.is_some res then touch_key cache k; res let add cache ~key ~data = touch_key cache key; Store.replace cache.store ~key ~data let remove cache key = Option.iter (Store.find cache.store key) ~f:(fun v -> Strat.remove cache.strat key; Option.call ~f:cache.destruct v; Store.remove cache.store key) let clear cache = Option.iter cache.destruct ~f:(fun destruct -> List.iter (Store.data cache.store) ~f:destruct); Strat.clear cache.strat; Store.clear cache.store let create ~destruct = Strat.cps_create ~f:(fun strat -> Store.cps_create ~f:(fun store -> {strat = strat; destruct = destruct; store = store})) let call_with_cache ~cache f arg = match find cache arg with | Some v -> Memoized.return v | None -> touch_key cache arg; let rval = Memoized.create ~f arg in Store.replace cache.store ~key:arg ~data:rval; Memoized.return rval let memoize ?destruct f = Strat.cps_create ~f:(fun strat -> Store.cps_create ~f:(fun store -> let destruct = Option.map destruct ~f:(fun f -> Result.iter ~f) in let cache = {strat = strat; destruct = destruct; store = store} in let memd_f arg = call_with_cache ~cache f arg in cache,memd_f)) end module Strategy = struct module Lru = struct type 'a t = { (* sorted in order of descending recency *) list: 'a Doubly_linked.t; (* allows fast lookup in the list above *) table: ('a, 'a Doubly_linked.Elt.t) Hashtbl.t; mutable maxsize: int; mutable size: int; } type 'a with_init_args = int -> 'a let kill_extra lru = let extra = ref [] in while lru.size > lru.maxsize do let key = Option.value_exn (Doubly_linked.remove_last lru.list) in Hashtbl.remove lru.table key; (* remove from table *) lru.size <- lru.size - 1; (* reduce size by 1 *) extra := key :: !extra done; !extra let touch lru x = let el = Doubly_linked.insert_first lru.list x in match Hashtbl.find lru.table x with | Some old_el -> Doubly_linked.remove lru.list old_el; Hashtbl.set lru.table ~key:x ~data:el; [] | None -> Hashtbl.set lru.table ~key:x ~data:el; lru.size <- lru.size + 1; kill_extra lru let remove lru x = Option.iter (Hashtbl.find lru.table x) ~f:(fun el -> Doubly_linked.remove lru.list el; Hashtbl.remove lru.table x) let create maxsize = { list = Doubly_linked.create (); table = Hashtbl.Poly.create () ~size:100; maxsize = maxsize; size = 0; } let cps_create ~f maxsize = f (create maxsize) let clear lru = lru.size <- 0; Hashtbl.clear lru.table; Doubly_linked.clear lru.list end module Keep_all = struct type 'a t = unit type 'a with_init_args = 'a let cps_create ~f = f () let touch () _ = [] let remove () _ = () let clear () = () end end module Store = struct module Table = struct include Hashtbl type 'a with_init_args = 'a let cps_create ~f = f (Hashtbl.Poly.create () ~size:16) end end module Keep_all = Make(Strategy.Keep_all)(Store.Table) module Lru = Make(Strategy.Lru)(Store.Table) let keep_one ?(destruct=ignore) f = let v = ref None in (); fun x -> match !v with | Some (x',y) when x' = x -> Memoized.return y | _ -> Option.iter !v ~f:(fun (_,y) -> Result.iter ~f:destruct y); v := None; let res = Memoized.create ~f x in v := Some (x,res); Memoized.return res let memoize ?destruct ?(expire=`Keep_all) f = match expire with | `Lru size -> snd (Lru.memoize ?destruct f size) | `Keep_all -> snd (Keep_all.memoize ?destruct f) | `Keep_one -> keep_one ?destruct f let unit f = let l = Lazy.from_fun f in (fun () -> Lazy.force l) core_extended-113.00.00/src/cache.mli000066400000000000000000000127211256461102500171660ustar00rootroot00000000000000(** Generic caching library *) open Core.Std (** [memoize ~destruct ~expire f] memoizes the results of [f]. @param expire Strategy used to prune out values from the cache - [`Keep_one]: only keeps the last result around - [`Keep_all]: (the default value) never delete any values from the cache - [`Lru n]: keep [n] values in the cache and them removes the least recently used @param destruct function called on every value we remove from the cache *) val memoize : ?destruct : ('b -> unit) -> ?expire:[ `Lru of int | `Keep_all | `Keep_one ] -> ('a -> 'b) -> ('a -> 'b) (** Returns memoized version of any function with argument unit. In effect this builds a lazy value.*) val unit : (unit -> 'a) -> (unit -> 'a) (** {1 Exposed cache } These modules implement memoization and give you access to the cache. This, for instance, enables you to flush it. *) (** Least recently used caching *) module Lru : sig type ('k,'v) t type ('a,'b) memo = ('a, ('b, exn) Result.t) t val find : ('k, 'v) t -> 'k -> 'v option val add : ('k, 'v) t -> key:'k -> data:'v -> unit val remove : ('k,_) t -> 'k -> unit val clear : (_,_) t -> unit val create : destruct:('v -> unit) option -> int -> ('k,'v) t val call_with_cache : cache:('a,'b) memo -> ('a -> 'b) -> 'a -> 'b val memoize : ?destruct:('b -> unit) -> ('a -> 'b) -> int -> ('a,'b) memo * ('a -> 'b) end (** Full caching (never flushes out values automatically ) *) module Keep_all : sig type ('k,'v) t type ('a,'b) memo = ('a, ('b, exn) Result.t) t val find : ('k, 'v) t -> 'k -> 'v option val add : ('k, 'v) t -> key:'k -> data:'v -> unit val remove : ('k,_) t -> 'k -> unit val clear : (_,_) t -> unit val create : destruct:('v -> unit) option -> ('k,'v) t val call_with_cache : cache:('a,'b) memo -> ('a -> 'b) -> 'a -> 'b val memoize : ?destruct:('b -> unit) -> ('a -> 'b) -> ('a,'b) memo * ('a -> 'b) end (** {1 Generic caching} This enables you to implement your own caching strategy and store. Generic caching is based on separating the replacement policie and the store and tying them together with [Make]. *) (** Replacement policy This dictates when elements will droped from the cache. *) module type Strategy = sig type 'a t (** This type is used to specify the signature of [cps_create]. For instance if [cps_create] takes two arguments of types [x] and [y]: {[ type 'a with_init_args : x -> y -> 'a ]} *) type 'a with_init_args (** [cps_create ~f ] is given in CPS form to enable chaining. (i.e. instead of directly returning a value it applies f to this value). *) val cps_create : f:(_ t -> 'b) -> 'b with_init_args (** Marks an element as "fresh". Returns a list of elements to be dropped from the store. *) val touch : 'a t -> 'a -> 'a list (** Informs the strategy that an element was removed from the store. *) val remove : 'a t -> 'a -> unit (** Inform the strategy that all the elements where dropped from the store. *) val clear : 'a t -> unit end (** Caching store A [Store] is the backend used to store the values in a cache. A store is a key/value associative table. *) module type Store = sig (** A key value store. *) type ('k, 'v) t type 'a with_init_args (** [cps_create] is given in CPS form to enable chaining. see {!Cache.Strategy.cps_create} for more information. *) val cps_create : f:((_,_) t -> 'b) -> 'b with_init_args (** Remove all the values from the store. *) val clear : ('k, 'v) t -> unit (** [replace store ~key ~data] associated the [data] to [key]; remove any previously existing binding. *) val replace : ('k, 'v) t -> key:'k -> data:'v -> unit (** [find store key] returns the value associated to [key] in [store]. *) val find : ('k, 'v) t -> 'k -> 'v option (** [data store] returns all values in [store]. *) val data : (_,'v) t -> 'v list (** [remove store key] removes the binding for [key] in [store]. *) val remove : ('k, 'v) t -> 'k -> unit end (** The output signature of the functor {!Cache.Make} *) module type S = sig (** A key value cache*) type ('k,'v) t (** Used to specify the type of the {!create} and {!memoize} function. This describes the arguments required to initialise the caching strategy and the store. For instance if the store doesn't take any argument (eg.: {!Store.Table}) and the strategy takes an [int] (eg.: {!Strategy.Lru}) this type will be: {[ type 'a with_init_args = int -> 'a ]} *) type 'a with_init_args type ('a,'b) memo = ('a, ('b, exn) Result.t) t val find : ('k, 'v) t -> 'k -> 'v option val add : ('k, 'v) t -> key:'k -> data:'v -> unit val remove : ('k,_) t -> 'k -> unit val clear : (_,_) t -> unit val create : destruct:('v -> unit) option -> ('k,'v) t with_init_args val call_with_cache : cache:('a,'b) memo -> ('a -> 'b) -> 'a -> 'b val memoize : ?destruct:('b -> unit) -> ('a -> 'b) -> (('a,'b) memo * ('a -> 'b)) with_init_args end (** Predefined strategies *) module Strategy : sig (** Least recently used. *) module Lru : Strategy with type 'a with_init_args = int -> 'a (** Keep all the values*) module Keep_all : Strategy with type 'a with_init_args = 'a end (** Predefined stores *) module Store : sig module Table : Store with type 'a with_init_args = 'a end module Make (Strat : Strategy) (Store : Store) : S with type 'a with_init_args = ('a Store.with_init_args Strat.with_init_args) core_extended-113.00.00/src/cbuffer.ml000066400000000000000000000135541256461102500173730ustar00rootroot00000000000000open Core.Std type 'a t = { mutable data: 'a array; (** base of circular buffer *) mutable start: int; (** first position at which data is found *) mutable length: int; (** number of elements in buffer *) never_shrink: bool; (** whether to refrain from shrinking the buffer *) dummy: 'a; (** value used to pack into newly allocated arrays *) } with sexp let create ?(never_shrink=false) dummy length = { data = Array.create ~len:(Int.max 10 length) dummy; start = 0; length = 0; never_shrink = never_shrink; dummy = dummy; } let length buf = buf.length let phys_length buf = Array.length buf.data let is_full buf = buf.length >= Array.length buf.data let check_index fname buf i = if i < 0 || i >= buf.length then invalid_arg (Printf.sprintf "Cbuffer.%s: index %i is not between 0 and %d" fname i (buf.length - 1)) let get buf i = check_index "get" buf i; buf.data.((buf.start + i) mod phys_length buf) let set buf i v = check_index "set" buf i; buf.data.((buf.start + i) mod phys_length buf) <- v let copy_data ~src ~dst start length = if start + length <= Array.length src then Array.blit ~src ~dst ~src_pos:start ~dst_pos:0 ~len:length else let length1 = Array.length src - start in let length2 = length - length1 in Array.blit ~src ~dst ~src_pos:start ~dst_pos:0 ~len:length1; Array.blit ~src ~dst ~src_pos:0 ~dst_pos:length1 ~len:length2 (* [swap_array buf len] copies the contents of [buf] to a new array of length [len] and places that new data into the buffer *) let swap_array buf new_length = let newdata = Array.create ~len:new_length buf.dummy in copy_data ~src:buf.data ~dst:newdata buf.start buf.length; buf.data <- newdata; buf.start <- 0 (** double the size of the buffer *) let expand buf = swap_array buf (phys_length buf * 2) (** half the size of the buffer *) let shrink buf = if buf.length > phys_length buf / 2 then invalid_arg (Printf.sprintf "Cbuffer.shrink: buffer is too big (%d > %d)" buf.length (phys_length buf / 2)) else swap_array buf (phys_length buf / 2) let to_array buf = let ar = Array.create ~len:buf.length buf.dummy in copy_data ~src:buf.data ~dst:ar buf.start buf.length; ar let add buf v = if is_full buf then expand buf; if buf.start = 0 then buf.start <- phys_length buf - 1 else buf.start <- buf.start - 1; buf.data.(buf.start) <- v; buf.length <- buf.length + 1 let drop_from buf i = check_index "drop_from" buf i; for j = i to buf.length - 1 do set buf j buf.dummy done; buf.length <- i; if not buf.never_shrink && buf.length < phys_length buf / 4 then shrink buf let drop_last buf = drop_from buf (buf.length - 1) (****** not well code-reviewed from here down ******) let iter buf ~f = for i = 0 to (length buf) - 1 do f i (get buf i); done let iterr buf ~f = for i = (length buf) - 1 downto 0 do f i (get buf i); done let of_array arr = let len = Array.length arr in if len = 0 then invalid_arg "Cbuffer.of_array: empty array argument"; let buf = create arr.(0) len in (* we do not have access to buf.data here -- reimplement blit! *) (* Array.blit ~src:arr ~dst:buf.data ~src_pos:0 ~dst_pos:0 ~len; *) for i = len - 1 downto 0 do add buf arr.(i) done; buf let rec cb_compare ~f ~b1 ~b2 ~s1 ~s2 ~n = if n = 0 then true else if (length b1) - s1 < n || (length b2) - s2 < n then false else if f (get b1 s1) (get b2 s2) then cb_compare ~f ~b1 ~b2 ~s1:(s1+1) ~s2:(s2+1) ~n:(n-1) else false TEST_MODULE "compare" = struct let cb1 = of_array [|0;1;2;3;4|] let cb2 = of_array [|0;1;2;2;2|] TEST "yes" = cb_compare ~f:(=) ~b1:cb1 ~b2:cb2 ~s1:0 ~s2:0 ~n:3 TEST "no1" = not (cb_compare ~f:(=) ~b1:cb1 ~b2:cb2 ~s1:0 ~s2:0 ~n:4) TEST "no2"= not (cb_compare ~f:(=) ~b1:cb1 ~b2:cb2 ~s1:1 ~s2:0 ~n:3) end let drop_old ?(cmp = compare) ?free ~f ~cutoff buf = (* should be ?(f=ident), but then ocaml thinks that f is 'a -> 'a *) let len = length buf in let last = ref len in while !last > 0 && cmp (f (get buf (!last - 1))) cutoff <= 0 do decr last; Option.iter free ~f:(fun f -> f (get buf !last)); done; if !last < len then drop_from buf !last; len - !last (* number of objects dropped *) (* This is a bit of a hacky test module because it's a straightforward copy of the one that was in lib_test *) TEST_MODULE = struct TEST_MODULE "mapping" = struct let cb = of_array [|0;1;2;3;4|] let bu = Buffer.create 10 let out n x = Printf.bprintf bu "(%d %d)" n x let () = iter cb ~f:out TEST "map" = Buffer.contents bu = "(0 0)(1 1)(2 2)(3 3)(4 4)" let () = Buffer.clear bu let () = iterr cb ~f:out TEST "mapr" = Buffer.contents bu = "(4 4)(3 3)(2 2)(1 1)(0 0)" end TEST_MODULE "drop_old" = struct let cb = of_array [|4;3;2;1;0|] let list = ref [] let free obj = list := obj::!list TEST "ret-1" = drop_old ~cutoff:(-1) ~free cb ~f:ident = 0 TEST "buf-1" = to_array cb = [|4;3;2;1;0|] TEST "free-1" = !list = [] TEST "ret0" = drop_old ~cutoff:0 ~free cb ~f:ident = 1 TEST "buf0" = to_array cb = [|4;3;2;1|] TEST "free0" = !list = [0] TEST "ret1" = drop_old ~cutoff:1 ~free cb ~f:ident = 1 TEST "buf1" = to_array cb = [|4;3;2|] TEST "free1" = !list = [1;0] TEST "ret2" = drop_old ~cutoff:2 ~free cb ~f:ident = 1 TEST "buf2" = to_array cb = [|4;3|] TEST "free2" = !list = [2;1;0] TEST "ret3" = drop_old ~cutoff:3 ~free cb ~f:ident = 1 TEST "buf3" = to_array cb = [|4|] TEST "free3" = !list = [3;2;1;0] TEST "ret4" = drop_old ~cutoff:4 ~free cb ~f:ident = 1 TEST "buf4" = to_array cb = [||] TEST "free4" = !list = [4;3;2;1;0] end TEST_MODULE "drop_old2" = struct let cb = of_array [|4;3;2;1;0|] TEST "ret5" = drop_old ~cutoff:5 cb ~f:ident = 5 TEST "buf5" = to_array cb = [||] end end core_extended-113.00.00/src/cbuffer.mli000066400000000000000000000042471256461102500175430ustar00rootroot00000000000000(** Circular buffers. THIS LIBRARY WILL BE DELETED IN FAVOUR OF DEQUEUE AT SOME POINT IN THE FUTURE *) type 'a t = { mutable data : 'a array; (* base of circular buffer *) mutable start : int; (* first position at which data is found *) mutable length : int; (* number of elements in buffer *) never_shrink : bool; (* whether to refrain from shrinking the buffer *) dummy : 'a; (* value used to pack into newly allocated arrays *) } with sexp val create : ?never_shrink:bool -> 'a -> Core.Std.Int.t -> 'a t val length : 'a t -> int val phys_length : 'a t -> int val is_full : 'a t -> bool val check_index : string -> 'a t -> int -> unit val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit (** copies data from one array to another. This assumes that the destination array is large enough to accommodate the data *) val copy_data : src:'a Core.Std.Array.t -> dst:'a Core.Std.Array.t -> int -> int -> unit (** [swap_array buf len] copies the contents of [buf] to a new array of length [len] and places that new data into the buffer *) val swap_array : 'a t -> int -> unit (** double the size of the buffer *) val expand : 'a t -> unit (** half the size of the buffer *) val shrink : 'a t -> unit val to_array : 'a t -> 'a Core.Std.Array.t val add : 'a t -> 'a -> unit val drop_from : 'a t -> int -> unit val drop_last : 'a t -> unit (** [iter buf ~f] calls func on each buffer element starting with 0 like this: (func pos element) *) val iter : 'a t -> f:(int -> 'a -> unit) -> unit (** [iterr buf ~f] calls func on each buffer element starting with end like this: (func pos element) *) val iterr : 'a t -> f:(int -> 'a -> unit) -> unit (** initialize Cbuffer from array *) val of_array : 'a Core.Std.Array.t -> 'a t (** compare two buffer fragments *) val cb_compare : f:('a -> 'b -> bool) -> b1:'a t -> b2:'b t -> s1:int -> s2:int -> n:int -> bool (** drop stuff from the end. equivalent to while cutoff > f (get buf (length buf - 1)) do drop_last buf; done but calls drop just once *) val drop_old : ?cmp:('a -> 'a -> int) -> ?free:('b -> unit) -> f:('b -> 'a) -> cutoff:'a -> 'b t -> int core_extended-113.00.00/src/color_print.ml000066400000000000000000000147011256461102500203040ustar00rootroot00000000000000open Core.Std let ansi_regexp = Memo.unit (fun () -> Re2.Std.Re2.create_exn "\027\\[.*?m") let ansi_capture_regexp = Memo.unit (fun () -> Re2.Std.Re2.create_exn "(\027\\[.*?m)") let normal_capture_regexp = Memo.unit (fun () -> Re2.Std.Re2.create_exn "(\027\\[0m)") let normal str = Re2.Std.Re2.rewrite_exn (ansi_regexp ()) ~template:"" str let add_after_ansi str ~code = Re2.Std.Re2.rewrite_exn (ansi_capture_regexp ()) ~template:("\\1" ^ code) str let add_after_normal str ~code = Re2.Std.Re2.rewrite_exn (normal_capture_regexp ()) ~template:("\\1" ^ code) str let ansi_code ~code = "\027[" ^ code ^ "m" let normal_code = ansi_code ~code:"0" let bold_code = ansi_code ~code:"1" let underline_code = ansi_code ~code:"4" let red_code = ansi_code ~code:"31" let green_code = ansi_code ~code:"32" let yellow_code = ansi_code ~code:"33" let blue_code = ansi_code ~code:"34" let magenta_code = ansi_code ~code:"35" let cyan_code = ansi_code ~code:"36" let inverse_code = ansi_code ~code:"7" let float_to_int x ~max = if x <= 0. then 0 else if x >= 1. then max else Float.iround_exn ~dir:`Nearest (x *. Float.of_int max) let gray_code ~brightness = let brightness = float_to_int brightness ~max:23 in ansi_code ~code:("38;5;" ^ Int.to_string (brightness + 232)) let rgbint_code ~r ~g ~b = ansi_code ~code:("38;5;" ^ Int.to_string (16 + r*36 + g*6 + b)) let rgb_code ~r ~g ~b = let r = float_to_int r ~max:5 in let g = float_to_int g ~max:5 in let b = float_to_int b ~max:5 in rgbint_code ~r ~g ~b type color = [ | `Black | `Gray | `Light_gray | `White | `Dark_red | `Red | `Pink | `Light_pink | `Orange | `Amber | `Dark_yellow | `Gold | `Yellow | `Khaki | `Wheat | `Chartreuse | `Green_yellow | `Dark_green | `Green | `Light_green | `Bright_green | `Spring_green | `Medium_spring_green | `Dark_cyan | `Sea_green | `Cyan | `Turquoise | `Pale_turquoise | `Dodger_blue | `Deep_sky_blue | `Dark_blue | `Blue | `Light_slate_blue | `Light_steel_blue | `Blue_violet | `Violet | `Dark_magenta | `Purple | `Magenta | `Orchid | `Plum | `Rose | `Deep_pink ] with sexp, bin_io let color_code ~(color:color) = let (r,g,b) = match (color:color) with | `Black -> (0,0,0) | `Gray -> (2,2,2) | `Light_gray -> (3,3,3) | `White -> (5,5,5) | `Dark_red -> (2,0,0) | `Red -> (5,0,0) | `Pink -> (5,2,2) | `Light_pink -> (5,3,3) | `Orange -> (5,2,0) | `Amber -> (5,3,0) | `Dark_yellow -> (2,2,0) | `Gold -> (3,3,0) | `Yellow -> (5,5,0) | `Khaki -> (5,5,2) | `Wheat -> (5,5,3) | `Chartreuse -> (2,5,0) | `Green_yellow -> (3,5,0) | `Dark_green -> (0,2,0) | `Green -> (0,5,0) | `Light_green -> (2,5,2) | `Bright_green -> (3,5,3) | `Spring_green -> (0,5,2) | `Medium_spring_green -> (0,5,3) | `Dark_cyan -> (0,2,2) | `Sea_green -> (0,3,3) | `Cyan -> (0,5,5) | `Turquoise -> (2,5,5) | `Pale_turquoise -> (3,5,5) | `Dodger_blue -> (0,2,5) | `Deep_sky_blue -> (0,3,5) | `Dark_blue -> (0,0,2) | `Blue -> (0,0,5) | `Light_slate_blue -> (2,2,5) | `Light_steel_blue -> (3,3,5) | `Blue_violet -> (2,0,5) | `Violet -> (3,0,5) | `Dark_magenta -> (2,0,2) | `Purple -> (3,0,3) | `Magenta -> (5,0,5) | `Orchid -> (5,2,5) | `Plum -> (5,3,5) | `Rose -> (5,0,2) | `Deep_pink -> (5,0,3) in rgbint_code ~r ~g ~b let wrap ?(override=false) str ~code = code ^ (if override then add_after_ansi str ~code else add_after_normal str ~code) ^ normal_code let bold ?override str = wrap ?override str ~code:bold_code let underline ?override str = wrap ?override str ~code:underline_code let red ?override str = wrap ?override str ~code:red_code let green ?override str = wrap ?override str ~code:green_code let yellow ?override str = wrap ?override str ~code:yellow_code let blue ?override str = wrap ?override str ~code:blue_code let magenta ?override str = wrap ?override str ~code:magenta_code let cyan ?override str = wrap ?override str ~code:cyan_code let inverse ?override str = wrap ?override str ~code:inverse_code let gray ?override str ~brightness = wrap ?override str ~code:(gray_code ~brightness) let rgb ?override str ~r ~g ~b = wrap ?override str ~code:(rgb_code ~r ~g ~b) let color ?override str ~color = wrap ?override str ~code:(color_code ~color) (* Note that this always flushes after the terminating normal_code. This is probably not necessary, but it helps ensure that the code that turns off the special formatting actually does get output *) let wrap_print ~code fmt = Printf.kfprintf (fun oc -> fprintf oc "%s%!" normal_code) stdout ("%s" ^^ fmt) code let boldprintf fmt = wrap_print ~code:bold_code fmt let underlineprintf fmt = wrap_print ~code:underline_code fmt let inverseprintf fmt = wrap_print ~code:inverse_code fmt let redprintf fmt = wrap_print ~code:red_code fmt let yellowprintf fmt = wrap_print ~code:yellow_code fmt let greenprintf fmt = wrap_print ~code:green_code fmt let blueprintf fmt = wrap_print ~code:blue_code fmt let magentaprintf fmt = wrap_print ~code:magenta_code fmt let cyanprintf fmt = wrap_print ~code:cyan_code fmt let grayprintf ~brightness fmt = wrap_print ~code:(gray_code ~brightness) fmt let rgbprintf ~r ~g ~b fmt = wrap_print ~code:(rgb_code ~r ~g ~b) fmt let colorprintf ~color fmt = wrap_print ~code:(color_code ~color) fmt let wrap_sprint ?override ~code fmt = Printf.ksprintf (fun str -> wrap ?override str ~code) fmt let bold_sprintf ?override fmt = wrap_sprint ?override ~code:bold_code fmt let underline_sprintf ?override fmt = wrap_sprint ?override ~code:underline_code fmt let inverse_sprintf ?override fmt = wrap_sprint ?override ~code:inverse_code fmt let red_sprintf ?override fmt = wrap_sprint ?override ~code:red_code fmt let yellow_sprintf ?override fmt = wrap_sprint ?override ~code:yellow_code fmt let green_sprintf ?override fmt = wrap_sprint ?override ~code:green_code fmt let blue_sprintf ?override fmt = wrap_sprint ?override ~code:blue_code fmt let magenta_sprintf ?override fmt = wrap_sprint ?override ~code:magenta_code fmt let cyan_sprintf ?override fmt = wrap_sprint ?override ~code:cyan_code fmt let gray_sprintf ?override ~brightness fmt = wrap_sprint ?override ~code:(gray_code ~brightness) fmt let rgb_sprintf ?override ~r ~g ~b fmt = wrap_sprint ?override ~code:(rgb_code ~r ~g ~b) fmt let color_sprintf ?override ~color fmt = wrap_sprint ?override ~code:(color_code ~color) fmt core_extended-113.00.00/src/color_print.mli000066400000000000000000000076451256461102500204660ustar00rootroot00000000000000(* Ansi colored printing module *) open Core.Std (* Remove all special formatting and colors from string *) val normal: string -> string (* Turn strings various colors or add formatting. Orthogonal formatting settings should generally compose. For example, bold+red is possible. When settings conflict, if [override] is true, will attempt to modify the existing string to override the conflicting setting. Otherwise by default will preserve the existing formatting and only visibly apply the new setting to nonconflicting parts of the string. *) val bold : ?override:bool -> string -> string val underline : ?override:bool -> string -> string val inverse : ?override:bool -> string -> string val red : ?override:bool -> string -> string val yellow : ?override:bool -> string -> string val green : ?override:bool -> string -> string val blue : ?override:bool -> string -> string val magenta : ?override:bool -> string -> string val cyan : ?override:bool -> string -> string (* floats should be in [0,1], assumes 256 color terminal. If your terminal isn't displaying 256 colors, there's a good chance it still supports 256 colors, and you might be able to get it by something like "export TERM=xterm-256color" *) val gray: ?override:bool -> string -> brightness:float -> string val rgb: ?override:bool -> string -> r:float -> g:float -> b:float -> string type color = [ (* Roughly sorted in order of hue *) | `Black | `Gray | `Light_gray | `White | `Dark_red | `Red | `Pink | `Light_pink | `Orange | `Amber | `Dark_yellow | `Gold | `Yellow | `Khaki | `Wheat | `Chartreuse | `Green_yellow | `Dark_green | `Green | `Light_green | `Bright_green | `Spring_green | `Medium_spring_green | `Dark_cyan | `Sea_green | `Cyan | `Turquoise | `Pale_turquoise | `Dodger_blue | `Deep_sky_blue | `Dark_blue | `Blue | `Light_slate_blue | `Light_steel_blue | `Blue_violet | `Violet | `Dark_magenta | `Purple | `Magenta | `Orchid | `Plum | `Rose | `Deep_pink ] with sexp, bin_io val color: ?override:bool -> string -> color:color -> string (* sprintf - Convenience functions. *) val bold_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val underline_sprintf: ?override:bool -> ('a, unit, string, string) format4 -> 'a val inverse_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val red_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val yellow_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val green_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val blue_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val magenta_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val cyan_sprintf : ?override:bool -> ('a, unit, string, string) format4 -> 'a val gray_sprintf : ?override:bool -> brightness:float -> ('a, unit, string, string) format4 -> 'a val rgb_sprintf : ?override:bool -> r:float -> g:float -> b:float -> ('a, unit, string, string) format4 -> 'a val color_sprintf: ?override:bool -> color:color -> ('a, unit, string, string) format4 -> 'a (* Formatted printf. *) val boldprintf : ('a, out_channel, unit) format -> 'a val underlineprintf: ('a, out_channel, unit) format -> 'a val inverseprintf : ('a, out_channel, unit) format -> 'a val redprintf : ('a, out_channel, unit) format -> 'a val yellowprintf : ('a, out_channel, unit) format -> 'a val greenprintf : ('a, out_channel, unit) format -> 'a val blueprintf : ('a, out_channel, unit) format -> 'a val magentaprintf : ('a, out_channel, unit) format -> 'a val cyanprintf : ('a, out_channel, unit) format -> 'a val grayprintf : brightness:float -> ('a, out_channel, unit) format -> 'a val rgbprintf : r:float -> g:float -> b:float -> ('a, out_channel, unit) format -> 'a val colorprintf: color:color -> ('a, out_channel, unit) format -> 'a core_extended-113.00.00/src/core_extended.mldylib000066400000000000000000000001421256461102500216000ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: cb9a61d38bca3c5f7b66e6714f968a02) Core_extended # OASIS_STOP core_extended-113.00.00/src/core_extended.mllib000066400000000000000000000001421256461102500212430ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: cb9a61d38bca3c5f7b66e6714f968a02) Core_extended # OASIS_STOP core_extended-113.00.00/src/core_extended.mlpack000066400000000000000000000026271256461102500214250ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d75003295a06dc5326a875b463ae91de) Alternating_primary_backup_assignment Atomic_edit Bin_io_utils Bitarray Cache Cbuffer Color_print Crit_bit Csv_writer Deprecated_bench Deprecated_command Deprecated_fcommand Deprecated_service_command Documented_match_statement English Environment Exception_check Extended_array Extended_common Extended_exn Extended_filename Extended_float Extended_gc Extended_hashtbl Extended_int Extended_int32 Extended_int63 Extended_int64 Extended_linux Extended_list Extended_list__LCS Extended_list__multimerge Extended_memo Extended_monad Extended_nativeint Extended_option Extended_result Extended_sexp Extended_string Extended_sys Extended_thread Extended_time Extended_unix Extra_fields Fd_leak_check Find Flang Float_ref Fold_map Generic Hashtbl2 Hashtbl2_pair Interval_map Interval_map_intf Invariant Invocation Iter Lazy_list Lazy_m Lazy_sequence Left_boundary Linebuf List_zipper Logger Low_level_debug Malloc Multi_map Net_utils Number Olang Packed_array Packed_map Posix_clock Pp Printc Process Procfs Prod_or_test Quickcheck_deprecated Random_selection Readline Readline__input_char Readline__input_loop Runtime_blockout_detector Rw_mutex Sampler Search_foo Semaphore Sendmail Service_command Set_lang Set_lang_intf Shell Shell__core Shell__line_buffer Sntp Splay_tree Std String_zipper Sys_utils Tcp Timed_function Trie Unix_utils Update_queue # OASIS_STOP core_extended-113.00.00/src/crit_bit.ml000066400000000000000000000176601256461102500175600ustar00rootroot00000000000000open Core.Std module type S = sig type key type 'data t val empty : 'data t val mem : 'data t -> key -> bool val find : 'data t -> key -> 'data option val add : 'data t -> key:key -> data:'data -> 'data t val remove : 'data t -> key -> 'data t val iter : 'data t -> f:(key:key -> data:'data -> unit) -> unit val map : 'data t -> f:('data -> 'b) -> 'b t val fold : 'data t -> init:'b -> f:(key:key -> data:'data -> 'b -> 'b) -> 'b end module type Bit_indexable = sig type t = string (* return the byte at the given position in the data structure t. [get] must never raise an exception and must return 0 for all bytes past the end of the structure *) val get : t -> int -> int val length : t -> int end module Crit_bit (B : Bit_indexable) : (S with type key = B.t) = struct let get = B.get module Node = struct module Inner = struct type 'node t = { byte_pos : int; bit_mask : int; left : 'node; right : 'node; } end type 'a t = | Inner of 'a t Inner.t | Edge of B.t * 'a end type key = B.t type 'a t = 'a Node.t option let empty = None let rec best_mem t s = match t with | Node.Edge (k,v) -> (k,v) | Node.Inner node -> if get s node.Node.Inner.byte_pos land node.Node.Inner.bit_mask = 0 then best_mem node.Node.Inner.left s else best_mem node.Node.Inner.right s ;; (* returns 0 or 1, indicating direction *) (*let dir_test ~bit_mask c = ((c lor bit_mask) + 1) lsr 8*) let go_left ~bit_mask c = c land bit_mask = 0 let find t k = match t with | None -> None | Some t -> let (k',v) = best_mem t k in if k = k' then Some v else None ;; let mem t s = Option.is_some (find t s) let find_most_significant_bit i = if i land 0b10000000 > 0 then 0b10000000 else if i land 0b01000000 > 0 then 0b01000000 else if i land 0b00100000 > 0 then 0b00100000 else if i land 0b00010000 > 0 then 0b00010000 else if i land 0b00001000 > 0 then 0b00001000 else if i land 0b00000100 > 0 then 0b00000100 else if i land 0b00000010 > 0 then 0b00000010 else 0b00000001 ;; (* [find_crit_bit] returns a partially filled inner node containing the byte position and bit mask of the crit_bit difference between base and s *) let find_crit_bit ~base ~key ~data = let b_length = B.length base in let k_length = B.length key in let rec loop byte_pos = if byte_pos = b_length && byte_pos = k_length then None else begin let k_byte = get key byte_pos in let b_byte = get base byte_pos in if b_byte <> k_byte then let bit_mask = find_most_significant_bit (b_byte lxor k_byte) in let edge = Node.Edge (key, data) in let make_node n = Node.Inner (if go_left ~bit_mask b_byte then {Node.Inner. byte_pos; bit_mask; left = n; right = edge } else {Node.Inner. byte_pos; bit_mask; left = edge; right = n }) in Some (byte_pos, bit_mask, make_node) else loop (byte_pos + 1) end in loop 0 ;; let add t ~key ~data = match t with | None -> Some (Node.Edge (key, data)) | Some node -> let base,_ = best_mem node key in match find_crit_bit ~base ~key ~data with | None -> t | Some (byte_pos, bit_mask, make_node) -> let rec loop node = match node with | Node.Edge _ -> make_node node | Node.Inner inner -> let next_byte_pos = inner.Node.Inner.byte_pos in let next_bit_mask = inner.Node.Inner.bit_mask in if (byte_pos > next_byte_pos) || (next_byte_pos = byte_pos && next_bit_mask > bit_mask) then begin if go_left ~bit_mask:inner.Node.Inner.bit_mask (get key inner.Node.Inner.byte_pos) then Node.Inner {inner with Node.Inner.left = loop inner.Node.Inner.left} else Node.Inner {inner with Node.Inner.right = loop inner.Node.Inner.right} end else make_node node in Some (loop node) ;; let remove t key = match t with | None -> None | Some node -> let rec loop node = match node with | Node.Edge (k,_) -> if k = key then None else raise Not_found | Node.Inner inner -> if go_left ~bit_mask:inner.Node.Inner.bit_mask (get key inner.Node.Inner.byte_pos) then begin match loop inner.Node.Inner.left with | None -> Some inner.Node.Inner.right | Some n -> Some (Node.Inner {inner with Node.Inner.left = n}) end else begin match loop inner.Node.Inner.right with | None -> Some inner.Node.Inner.left | Some n -> Some (Node.Inner {inner with Node.Inner.right = n}) end in try loop node with | Not_found -> t ;; let fold t ~init ~f = match t with | None -> init | Some node -> let rec loop acc node = match node with | Node.Edge (key,data) -> f ~key ~data init | Node.Inner inner -> loop (loop acc inner.Node.Inner.left) inner.Node.Inner.right in loop init node ;; let iter t ~f = fold t ~init:() ~f:(fun ~key ~data () -> f ~key ~data) let map t ~f = match t with | None -> None | Some node -> let rec loop node = match node with | Node.Edge (key,data) -> Node.Edge (key, f data) | Node.Inner inner -> let left = loop inner.Node.Inner.left in let right = loop inner.Node.Inner.right in Node.Inner {Node.Inner. byte_pos = inner.Node.Inner.byte_pos; bit_mask = inner.Node.Inner.bit_mask; left; right; } in Some (loop node) ;; end include (Crit_bit (struct type t = string let get s pos = try int_of_char s.[pos] with | _ -> 0 ;; let length = String.length end)) module Test = struct let random_data () = let length = Random.int 60 + 1 in let s = String.create length in for i = 0 to length - 1 do s.[i] <- Char.of_int_exn (Random.int (126 - 47) + 47) done; Some s ;; let existing_data map = let data = Array.of_list (Map.keys map) in if Array.length data > 0 then Some (data.(Random.int (Array.length data))) else None ;; let random_action map = match Random.int 4 with | 0 -> `Insert (random_data ()) | 1 -> `Insert (existing_data map) | 2 -> `Delete (random_data ()) | 3 -> `Delete (existing_data map) | _ -> assert false ;; let test () = Random.init 769_305; let rec loop base_map crit_bit n = if n = 0 then () else begin match random_action base_map with | `Delete None | `Insert None -> loop base_map crit_bit n | `Insert (Some key) -> let base_map = Map.add base_map ~key ~data:() in let crit_bit = add crit_bit ~key ~data:() in if (Map.find base_map key <> find crit_bit key) then failwithf "insertion of '%s' failed" key (); loop base_map crit_bit (n - 1) | `Delete (Some key) -> let base_map = Map.remove base_map key in let crit_bit = remove crit_bit key in if (Map.find base_map key <> find crit_bit key) then failwithf "deletion of '%s' failed (%b, %b)" key (Map.mem base_map key) (mem crit_bit key) (); loop base_map crit_bit (n - 1) end in try loop String.Map.empty empty 100_000; true with | _e -> false ;; TEST = test () end core_extended-113.00.00/src/crit_bit.mli000066400000000000000000000006061256461102500177210ustar00rootroot00000000000000type 'data t val empty : 'data t val find : 'data t -> string -> 'data option val add : 'data t -> key:string -> data:'data -> 'data t val remove : 'data t -> string -> 'data t val iter : 'data t -> f:(key:string -> data:'data -> unit) -> unit val map : 'data t -> f:('data -> 'b) -> 'b t val fold : 'data t -> init:'b -> f:(key:string -> data:'data -> 'b -> 'b) -> 'b core_extended-113.00.00/src/csv_writer.ml000066400000000000000000000120361256461102500201400ustar00rootroot00000000000000open Core.Std (** * * The standard string transformations are split in two: * - one to get the length of the result (can work on substring) * - another one to perform the action (with string blit semmantic) * * Common arguments * * -> to figure out how to escape/print quote and separators. * -> to operate on substrings : pos len * -> to perform string transformations: all the blit arguments * *) (** Field handling *) let rec quote_blit_loop ~quote ~src ~dst ~src_pos ~dst_pos src_end = if src_pos = src_end then dst_pos else match src.[src_pos] with | c when c = quote -> dst.[dst_pos] <- quote; dst.[dst_pos + 1] <- quote; quote_blit_loop ~quote ~src ~dst ~src_pos:(src_pos + 1) ~dst_pos:(dst_pos + 2) src_end | c -> dst.[dst_pos] <- c; quote_blit_loop ~quote ~src ~dst ~src_pos:(src_pos + 1) ~dst_pos:(dst_pos + 1) src_end let quote_blit ~quote ~src ~dst ~src_pos ~dst_pos ~len = quote_blit_loop ~quote ~src ~dst ~src_pos ~dst_pos (src_pos + len) (** Find the length of a quoted field... *) let rec quote_len_loop ~quote ~sep ~pos ~end_pos ~should_escape s acc = if pos = end_pos then if should_escape then Some acc else None else match s.[pos] with | c when c = quote -> quote_len_loop s ~quote ~sep ~pos:(pos + 1) ~end_pos ~should_escape:true (acc + 1) | c when c = sep -> quote_len_loop s ~quote ~sep ~pos:(pos + 1) ~end_pos ~should_escape:true acc | '\n' -> quote_len_loop s ~quote ~sep ~pos:(pos + 1) ~end_pos ~should_escape:true acc | _ -> quote_len_loop s ~quote ~sep ~pos:(pos + 1) ~end_pos ~should_escape acc let quote_len ~quote ~sep ~pos ~len s = if len = 0 then None else let trailling_ws = s.[pos]=' ' || s.[pos]= '\t' || s.[pos + len -1] = ' ' || s.[pos + len -1] = '\t' in quote_len_loop s ~quote ~sep ~pos ~end_pos:(len + pos) ~should_escape:trailling_ws len (** Line handling *) let rec line_spec_loop ~quote ~sep esc_acc size = function | [] when esc_acc = [] -> [],0 | [] -> List.rev esc_acc,(size -1) (* We overshot our count by one comma*) | h::t -> let len = String.length h in begin match quote_len h ~quote ~sep ~len ~pos:0 with | None -> line_spec_loop ~quote ~sep ((false,h)::esc_acc) (size + len + 1) t | Some qlen -> line_spec_loop ~quote ~sep ((true,h)::esc_acc) (size + qlen + 3) t end let field_blit ~quote ~dst ~pos = function | true,h -> dst.[pos] <- quote; let len = String.length h in let qpos = quote_blit ~quote ~src:h ~src_pos:0 ~dst ~dst_pos:(pos+1) ~len in dst.[qpos] <- quote; qpos + 1 | false,h -> let len = String.length h in String.blit ~dst_pos:pos ~src_pos:0 ~dst ~src:h ~len; pos + len (** Tables *) let rec line_blit_loop ~quote ~sep ~dst ~pos = function | [] -> pos | [v] -> field_blit ~quote:'"' ~dst ~pos v | v::((_::_) as t) -> let pos = field_blit ~quote:'"' ~dst ~pos v in dst.[pos] <- sep; line_blit_loop ~quote ~sep ~dst ~pos:(pos + 1) t let rec output_lines_loop ~quote ~sep ~buff oc = function | [] -> () | h::t -> let spec,len = line_spec_loop ~quote ~sep [] 0 h in let buff = if String.length buff < len then String.create (2*len) else buff in ignore (line_blit_loop ~quote ~sep ~dst:buff ~pos:0 spec:int); output oc buff 0 len; output_string oc "\r\n"; output_lines_loop ~quote ~sep ~buff oc t let line_to_string ?(quote='"') ?(sep=',') l = let spec,len = line_spec_loop ~quote ~sep [] 0 l in let res = String.create len in ignore (line_blit_loop ~quote ~sep ~dst:res ~pos:0 spec:int); res let maybe_escape_field ?(quote='"') ?(sep=',') s = let len = String.length s in match quote_len s ~quote ~sep ~len ~pos:0 with | None -> s | Some qlen -> let res = String.create (qlen+2) in res.[0] <- quote; res.[qlen+1] <- quote; ignore (quote_blit ~quote ~src:s ~src_pos:0 ~dst:res ~dst_pos:1 ~len :int); res let escape_field ?(quote='"') s = let len = String.length s in match quote_len s ~quote ~sep:',' ~len ~pos:0 with | None -> let res = String.create (len+2) in res.[0] <- quote; res.[len+1] <- quote; String.blit ~src_pos:0 ~dst_pos:1 ~len ~src:s ~dst:res; res | Some qlen -> let res = String.create (qlen+2) in res.[0] <- quote; res.[qlen+1] <- quote; ignore (quote_blit ~quote ~src:s ~src_pos:0 ~dst:res ~dst_pos:1 ~len :int); res let output_lines ?(quote='"') ?(sep=',') oc l = output_lines_loop ~quote ~sep ~buff:(String.create 256) oc l core_extended-113.00.00/src/csv_writer.mli000066400000000000000000000026371256461102500203170ustar00rootroot00000000000000(** * Compliant simple CSV writter. * * This library is designed to deal with proper CSV (no quotes allowed in the * middle of the fields...). It is fast and flexible: by splitting most * writing functions in two parts one that gives the length of the string to * write and another that writes the result in a subpart of another string we * avoid unnecessary string creations. *) (** Prints a valid csv file to a given channel (note that line are ended "\r\n") *) val output_lines : ?quote:char -> ?sep:char -> out_channel -> string list list -> unit (** Convert one CSV line to a string. *) val line_to_string : ?quote:char -> ?sep:char -> string list -> string (** Escape the a CSV field if need be.*) val maybe_escape_field : ?quote:char -> ?sep:char -> string -> string (** Escape a CSV (even if doesn't have any characters that require escaping).*) val escape_field : ?quote:char -> string -> string (** {3 Low-level } *) (** Get the escaped length of one quoted field (without the quotes). Returns None if the field doesn't need to be escaped. *) val quote_len: quote:char -> sep:char -> pos:int -> len:int -> string -> int option (** Copy and escapes the content of a field over from one string to another. This does not put the quotes in.*) val quote_blit: quote:char -> src:string -> dst:string -> src_pos:int -> dst_pos:int -> len :int -> int core_extended-113.00.00/src/deprecated_bench.ml000066400000000000000000000326361256461102500212200ustar00rootroot00000000000000(** DEPRECATED: use the base/bench library instead *) open Core.Std open Textutils.Std module Int63_arithmetic : sig type t = Int63.t val ( - ) : t -> t -> t val ( / ) : t -> t -> t end = Int63 module Test = struct type t = { name : string option; size : int; f : unit -> unit; } ;; let create ?name ?(size = 1) f = { name; size; f } let name t = t.name let size t = t.size end module Result = struct module Stat = struct type t = { run_cycles : int; compactions : int; minor_allocated : int; major_allocated : int; promoted : int; } let empty = { run_cycles = 0; compactions = 0; minor_allocated = 0; major_allocated = 0; promoted = 0; } let (+) a b = { run_cycles = a.run_cycles + b.run_cycles; compactions = a.compactions + b.compactions; minor_allocated = a.minor_allocated + b.minor_allocated; major_allocated = a.major_allocated + b.major_allocated; promoted = a.promoted + b.promoted; } let min a b = { run_cycles = Int.min a.run_cycles b.run_cycles; compactions = Int.min a.compactions b.compactions; minor_allocated = Int.min a.minor_allocated b.minor_allocated; major_allocated = Int.min a.major_allocated b.major_allocated; promoted = Int.min a.promoted b.promoted; } let max a b = { run_cycles = Int.max a.run_cycles b.run_cycles; compactions = Int.max a.compactions b.compactions; minor_allocated = Int.max a.minor_allocated b.minor_allocated; major_allocated = Int.max a.major_allocated b.major_allocated; promoted = Int.max a.promoted b.promoted; } end type t = string option * int * Stat.t array let mean arr = let sum = Array.fold arr ~f:Stat.(+) ~init:Stat.empty in let n = Array.length arr in { Stat. run_cycles = sum.Stat.run_cycles / n; compactions = sum.Stat.compactions / n; minor_allocated = sum.Stat.minor_allocated / n; major_allocated = sum.Stat.major_allocated / n; promoted = sum.Stat.promoted / n; } let min arr = Array.fold arr ~f:Stat.min ~init:arr.(0) let max arr = Array.fold arr ~f:Stat.max ~init:arr.(0) let compactions_occurred arr = (max arr).Stat.compactions > 0 let minor_allocated_varied arr = (max arr).Stat.minor_allocated <> (min arr).Stat.minor_allocated let major_allocated_varied arr = (max arr).Stat.major_allocated <> (min arr).Stat.major_allocated end (* printing functions *) let make_name (name_opt, _size, _results) = match name_opt with | Some name -> name | None -> "" ;; let make_size (_name_opt, size, _results) = Int.to_string size ;; let make_minor_allocated (_name_opt, _size, results) = Int.to_string (Result.mean results).Result.Stat.minor_allocated ;; let make_major_allocated (_name_opt, _size, results) = Int.to_string (Result.mean results).Result.Stat.major_allocated ;; let make_promoted (_name_opt, _size, results) = Int.to_string (Result.mean results).Result.Stat.promoted ;; let make_cycles (_name_opt, _size, results) = Int_conversions.insert_underscores (Int.to_string (Result.mean results).Result.Stat.run_cycles) ;; let make_norm_cycles (_name_opt, size, results) = if size > 0 then let mean_cycles = (Result.mean results).Result.Stat.run_cycles in Int_conversions.insert_underscores (Int.to_string (mean_cycles / size)) else "" ;; let make_nanos (_name_opt, size, results) = let module Tsc_span = Time_stamp_counter.Span in if size <= 0 then "" else let mean_cycles = (Result.mean results).Result.Stat.run_cycles in let nanos = Float.to_int (Time.Span.to_ns (Tsc_span.to_time_span (Tsc_span.of_int_exn (mean_cycles / size)))) in Int_conversions.insert_underscores (Int.to_string nanos) ;; let make_warn (_name_opt, _size, results) = let twenty = 20 in let maybe_string s predicate = if predicate then s else "" in let mean_run = (Result.mean results).Result.Stat.run_cycles in let min_run = (Result.min results).Result.Stat.run_cycles in let max_run = (Result.max results).Result.Stat.run_cycles in maybe_string "m" ((mean_run - min_run) > mean_run / twenty) ^ maybe_string "M" ((max_run - mean_run) > mean_run / twenty) ^ maybe_string "c" (Result.compactions_occurred results) ^ maybe_string "a" (Result.minor_allocated_varied results) ^ maybe_string "A" (Result.major_allocated_varied results) ;; type column = [ `Name | `Input_size | `Cycles | `Normalized_cycles | `Nanos | `Allocated | `Warnings ] with sexp, compare module CMap = Map.Make (struct type t = column with sexp let compare = compare_column end) let default_columns = [ `If_not_empty `Name; `Normalized_cycles; `If_not_empty `Warnings ] module Warning_set = Set.Make (struct type t = Char.t with sexp (* Case-insensitive compare, lowercase first in case of equality. *) let compare a b = match a, b with | ('a' .. 'z' | 'A' .. 'Z'), ('a' .. 'z' | 'A' .. 'Z') -> begin let a' = Char.lowercase a in let b' = Char.lowercase b in match Char.compare a' b' with | 0 -> Int.neg (Char.compare a b) | d -> d end | _ -> Char.compare a b end) let print ?(limit_width_to=72) ?(columns=default_columns) ?display data = let left, right = Ascii_table.Align.(left, right) in (* Map displayed columns to `If_not_empty or `Yes. *) let displayed = List.fold columns ~init:CMap.empty ~f:(fun cmap column -> match column with | `If_not_empty c -> CMap.add cmap ~key:c ~data:`If_not_empty | #column as c -> CMap.add cmap ~key:c ~data:`Yes) in let col tag name make align = Ascii_table.Column.create name make ~align ~show:(Option.value (CMap.find displayed tag) ~default:`No) in let columns = [ col `Name "Name" make_name left ; col `Input_size "Input size" make_size right; col `Cycles "Cycles" make_cycles right; col `Normalized_cycles "Normalized cycles" make_norm_cycles right; col `Nanos "Time (ns)" make_nanos right; col `Allocated "Allocated (minor)" make_minor_allocated right; col `Allocated "Allocated (major)" make_major_allocated right; col `Allocated "Promoted" make_promoted right; col `Warnings "Warnings" make_warn right; ] in Ascii_table.output ?display ~oc:stdout ~limit_width_to columns data; (* Print the meaning of warnings. *) if CMap.mem displayed `Warnings then begin (* Collect used warnings. *) let warnings = List.fold_left data ~init:Warning_set.empty ~f:(fun cset x -> let warn = make_warn x in String.fold warn ~init:cset ~f:Warning_set.add) in if not (Warning_set.is_empty warnings) then begin print_string "\nWarnings:\n"; Warning_set.iter warnings ~f:(fun c -> let msg = match c with | 'm' -> "the minimum run time was less than 80% of the mean" | 'M' -> "the maximum run time was more than 120% of the mean" | 'c' -> "GC compactions occurred during testing" | 'a' -> "the number of minor words allocated was not the same in all tests" | 'A' -> "the number of major words allocated was not the same in all tests" | _ -> "???" in Printf.printf "%c: %s\n" c msg) end end ;; (* end printing functions *) let stabilize_gc () = let rec loop failsafe last_heap_live_words = if failsafe <= 0 then failwith "unable to stabilize the number of live words in the major heap"; Gc.compact (); let stat = Gc.stat () in if stat.Gc.Stat.live_words <> last_heap_live_words then loop (failsafe - 1) stat.Gc.Stat.live_words in loop 10 0 ;; let full_major_cost ~now () = let count = 10 in let s = now () in for _i = 1 to count do Gc.full_major (); done; let e = now () in Int63_arithmetic.((e - s) / Int63.of_int count) let find_run_size ~now ~rdtscp ~mean_cycles f = let rec loop samples = let s = now () in let sc = rdtscp () in for _i = 1 to samples do f (); done; let ec = rdtscp () in let e = now () in (* we need enough samples so that the mean_cycles is < 1% of the cost of the run and we also demand that the total run take at least .01 seconds *) if mean_cycles * 100 > (Posix_clock.Time_stamp_counter.diff ec sc) || Int63.Replace_polymorphic_compare.(Int63_arithmetic.(e - s) < Int63.of_int 1_000_000) then loop (Int.( * ) samples 2) else samples in loop 1 ;; let gc_minor_allocated gc_stat_s gc_stat_e = Int.of_float (gc_stat_e.Gc.Stat.minor_words -. gc_stat_s.Gc.Stat.minor_words) ;; let gc_major_allocated gc_stat_s gc_stat_e = Int.of_float (gc_stat_e.Gc.Stat.major_words -. gc_stat_s.Gc.Stat.major_words) ;; let gc_promoted gc_stat_s gc_stat_e = Int.of_float (gc_stat_e.Gc.Stat.promoted_words -. gc_stat_s.Gc.Stat.promoted_words) ;; let run_once ~f ~mean_cycles ~rdtscp = let stat_s = Gc.quick_stat () in f (); (* call f once to warm up the cache *) let cycles_now = rdtscp () in f (); let cycles_after = rdtscp () in let stat_e = Gc.quick_stat () in {Result.Stat. run_cycles = ((Posix_clock.Time_stamp_counter.diff cycles_after cycles_now) - mean_cycles); compactions = stat_e.Gc.Stat.compactions - stat_s.Gc.Stat.compactions; minor_allocated = gc_minor_allocated stat_s stat_e; major_allocated = gc_major_allocated stat_s stat_e; promoted = gc_promoted stat_s stat_e; } let time_cycles ~rdtscp = let rec loop n lst = match n with | 0 -> lst | n -> let start = rdtscp () in let after = rdtscp () in loop (n-1) ((Posix_clock.Time_stamp_counter.diff after start)::lst) in let times = loop 100000 [] in (List.fold_left ~f:(+) ~init:0 times) / (List.length times) let bench_basic = let open Core.Std.Result.Monad_infix in (Ok Posix_clock.Time_stamp_counter.rdtsc) >>= fun rdtscp -> Posix_clock.gettime >>= fun gettime -> Posix_clock.mean_gettime_cost >>= fun mean_gettime_cost -> Posix_clock.min_interval >>| fun min_interval -> fun ~verbosity ~gc_prefs ~no_compactions ~clock ~trials test -> let print_high s = match verbosity with | `High -> printf s | `Low | `Mid -> Printf.ifprintf stdout s in let print_mid s = match verbosity with | `High | `Mid -> printf s | `Low -> Printf.ifprintf stdout s in print_mid "\n===== running test: %s ======\n%!" (Option.value ~default:"(NO NAME)" test.Test.name); let old_gc = Gc.get () in Option.iter gc_prefs ~f:Gc.set; let measurement_clock = match clock with | `Wall -> Posix_clock.Monotonic | `Cpu -> Posix_clock.Process_cpu in let now () = gettime measurement_clock in let mean_cycles = time_cycles ~rdtscp in print_high "cost of running rdtscp: %d cycles\n%!" mean_cycles; if no_compactions then Gc.set { (Gc.get ()) with Gc.Control.max_overhead = 1_000_000 }; (* calculate how long it takes us to get a time measurement for the current thread *) let gettime_cost = mean_gettime_cost ~measure:measurement_clock ~using:Posix_clock.Monotonic in print_high "calculating cost of timing measurement: %s ns\n%!" (Int63.to_string gettime_cost); let gettime_min_interval = min_interval measurement_clock in print_high "calculating minimal measurable interval: %s ns\n%!" (Int63.to_string gettime_min_interval); (* find the number of samples of f needed before gettime cost is < 1% of the total *) print_high "determining number of trials: %!"; let run_count = match trials with | `Auto -> find_run_size ~now ~mean_cycles ~rdtscp test.Test.f | `Num n -> n in print_high "%d\n%!" run_count; let runs = Array.create ~len:run_count Result.Stat.empty in print_high "stabilizing GC: %!"; stabilize_gc (); print_high "done\n%!"; let full_major_cost = full_major_cost ~now () in print_high "calculating the cost of a full major sweep: %s ns\n%!" (Int63.to_string full_major_cost); for i = 0 to run_count - 1 do runs.(i) <- run_once ~f:test.Test.f ~mean_cycles ~rdtscp; print_mid "\r(%d / %d)%!" (i + 1) (run_count) done; print_mid "\n%!"; (* keep f from being gc'd by calling f () again *) if run_count > 1 then (* It makes no sense to run multiple times slow functions *) test.Test.f (); Gc.set old_gc; runs type 'a with_benchmark_flags = ?verbosity:[ `High | `Mid | `Low ] -> ?gc_prefs:Gc.Control.t -> ?no_compactions:bool -> ?trials:[ `Auto | `Num of int ] -> ?clock:[`Wall | `Cpu] -> 'a type 'a with_print_flags = ?limit_width_to:int -> ?columns:[ column | `If_not_empty of column ] list -> ?display:Ascii_table.Display.t -> 'a let bench_raw ?(verbosity=`Low) ?gc_prefs ?(no_compactions=false) ?(trials=`Auto) ?(clock=`Wall) tests = let bench_basic = Or_error.ok_exn bench_basic in List.map tests ~f:(fun test -> test.Test.name, test.Test.size, bench_basic ~verbosity ~gc_prefs ~no_compactions ~clock ~trials test) ;; let bench ?limit_width_to ?columns ?display ?verbosity ?gc_prefs ?no_compactions ?trials ?clock tests = print ?limit_width_to ?columns ?display (bench_raw ?verbosity ?gc_prefs ?no_compactions ?trials ?clock tests) ;; core_extended-113.00.00/src/deprecated_bench.mli000066400000000000000000000071701256461102500213640ustar00rootroot00000000000000(** DEPRECATED: use the base/bench library instead *) open Core.Std open Textutils (** Simple example: open Core.Std module Bench = Core_extended.Bench let main () = Bench.bench [Bench.Test.create ~name:"test" (fun () -> ignore (Time.now ()))] ;; let () = main () *) module Test : sig type t val create : ?name:string -> ?size:int -> (unit -> unit) -> t val name : t -> string option val size : t -> int end module Result : sig module Stat : sig type t = { run_cycles : int; compactions : int; minor_allocated : int; major_allocated : int; promoted : int; } val empty : t end type t = string option * int * Stat.t array val mean : Stat.t array -> Stat.t val min : Stat.t array -> Stat.t val max : Stat.t array -> Stat.t val compactions_occurred : Stat.t array -> bool end (** verbosity (default low): If low, only prints results. If mid, additionally prints time estimates and a status line. If high, additionally prints information at each step of benchmarking. gc_prefs: can be used to set custom GC settings during benchmarking (they will be reverted when the function returns) no_compactions (default false): disables compactions during benchmarking, reverted when the function returns. Takes precedence over gc_prefs. trials (default `Auto): runs this many trials for each sample. If `Auto, bench will automatically determine the number of trials to run based on how long it takes to run one trial. It will run enough trials n so that the mean cost of calling rdtscp is less than one percent of n, and it takes more than 0.01 seconds. clock (default wall): controls time measurement method. Wall includes waiting on I/O and when the process is suspended/descheduled; cpu only counts time spent on computations. *) type 'a with_benchmark_flags = ?verbosity:[ `High | `Mid | `Low ] -> ?gc_prefs:Gc.Control.t -> ?no_compactions:bool -> ?trials:[ `Auto | `Num of int ] -> ?clock:[`Wall | `Cpu ] -> 'a type column = [ `Name | `Input_size | `Cycles | `Normalized_cycles | `Nanos | `Allocated | `Warnings ] (**The "Name" and "Input size" columns of the printed table reflect the values passed to Test.create. The "Normalized" column is [run_time / input_size]. "Stdev" reports the standard deviation for the "Run time" column. "Allocated" reports the average number of allocated words through the benchmarks. "Warnings" may contain single characters indicating various things: 'm' indicates the minimum run time was less than 80% of the mean 'M' indicates the maximum run time was more than 120% of the mean 'c' indicates GC compactions occurred during testing 'a' indicates the number of words allocated was not the same in all tests [limit_with_to] defaults to 72. [columns]: select which columns to display. [`If_not_empty c] means print the column only if at least one cell contains something. It defaults to: [\[`If_not_empty `Name; `Normalized_cycles; `If_not_empty `Warnings\]]. *) type 'a with_print_flags = ?limit_width_to:int -> ?columns:[ column | `If_not_empty of column ] list -> ?display:Ascii_table.Display.t -> 'a val bench : (Test.t list -> unit) with_benchmark_flags with_print_flags (** [bench_raw] returns a list documenting the runtimes rather than printing to stdout. These can be fed to print for results identical to calling bench. *) val bench_raw : (Test.t list -> Result.t list) with_benchmark_flags val print : (Result.t list -> unit) with_print_flags core_extended-113.00.00/src/deprecated_command.ml000066400000000000000000001377221256461102500215610ustar00rootroot00000000000000(** DEPRECATED: use Core.Std.Command instead *) open Core.Std open Textutils.Std open Printf exception Invalid_arguments of string list with sexp (* compare command names, so that "help" is the last one *) let subcommand_cmp a c = let is_help_cmd = function | s when String.is_prefix s ~prefix:"help" -> 1 | _ -> 0 in let is_help_cmd_diff = (is_help_cmd a) - (is_help_cmd c) in if is_help_cmd_diff = 0 then String.compare a c else is_help_cmd_diff let subcommand_cmp_fst (a, _) (c, _) = subcommand_cmp a c (* simple module for formatting two columns *) module Columns = struct type t = (string * string) list let align (pairs : t) = match pairs with | [] -> [] | (x, _) :: xs -> let left_col_len : int = List.fold_left (List.map ~f:(fun (a,_) -> String.length a) xs) ~f:(fun acc x -> max acc x) ~init:(String.length x) in let max_width = match Console.width () with | `Not_a_tty | `Not_available -> 80 | `Cols cols -> cols in List.concat (List.map pairs ~f:(fun (cmd,desc) -> let desc_line_len = max 30 (max_width - 4 - left_col_len) in let desch,descl = match Extended_string.line_break desc ~len:desc_line_len with | h :: t -> (h, t) | [] -> assert false in let head = sprintf "%-*s %s" left_col_len cmd desch in let tail = List.map descl ~f:(fun s -> sprintf "%-*s %s" left_col_len " " s) in head :: tail)) let sort_align pairs = align (List.sort pairs ~cmp:subcommand_cmp_fst) end module Help_page = struct let render ~summary ~usage ~readme ~choice_type ~choices = sprintf "\n%s\n\n %s\n%s%s" summary usage (match readme with None -> "" | Some s -> sprintf "\n%s\n" (s ())) (if choices = [] then "" else sprintf "\n === %s ===\n\n%s\n" choice_type (List.fold choices ~init:"" ~f:(fun acc x -> acc ^ " " ^ x ^ "\n"))) end let partial_match (tbl:(string,'a) Hashtbl.t) (subcmd:string) : [`Exact of (string * 'a) | `Partial of (string * 'a) | `None | `Ambiguous of (string * 'a) list ] = match Hashtbl.find tbl subcmd with | Some v -> `Exact (subcmd, v) | None -> (* No full match, try for a partial match *) let possible_res = Hashtbl.fold tbl ~init:[] ~f:(fun ~key ~data acc -> if String.is_prefix key ~prefix:subcmd then (key, data) :: acc else acc) in match possible_res with | [kv] -> `Partial kv | [] -> `None | l -> `Ambiguous l let assert_no_underscores s = if String.exists s ~f:(fun c -> c = '_') then failwithf "%s contains an underscore. Use a dash instead." s (); module Flag : sig (** type of flags to a command with accumulator type ['a] *) type 'a t val name : _ t -> string (** Template for flag-creation functions *) type ('a, 'b) create = string -> ?aliases:string list -> ?full_flag_required:bool -> 'b -> doc:string -> 'a t val of_arg : Arg.t -> unit t (** {6 Flag handling without an accumulator} *) val noarg : (unit, unit -> unit) create val string : (unit, string -> unit) create val int : (unit, int -> unit) create val float : (unit, float -> unit) create val bool : (unit, bool -> unit) create val gen : (string -> 'gen) -> (unit, 'gen -> unit) create val set_string : (unit, string ref) create val set_string_opt : (unit, string option ref) create val set_int : (unit, int ref) create val set_int_opt : (unit, int option ref) create val set_float : (unit, float ref) create val set_float_opt : (unit, float option ref) create val set_date : (unit, Date.t ref) create val set_date_opt : (unit, Date.t option ref) create val set : (unit, bool ref) create val clear : (unit, bool ref) create val set_gen : (string -> 'gen) -> (unit, 'gen ref) create val set_gen_opt : (string -> 'gen) -> (unit, 'gen option ref) create (** {6 flag handling meant for use with immutable accumulator} *) val noarg_acc : ('a, 'a -> 'a) create val string_acc : ('a, 'a -> string -> 'a) create val int_acc : ('a, 'a -> int -> 'a) create val bool_acc : ('a, 'a -> bool -> 'a) create val float_acc : ('a, 'a -> float -> 'a) create (** [rest f]: a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val date_acc : ('a, 'a -> Date.t -> 'a) create val rest_acc : ('a, 'a -> string list -> 'a) create val gen_acc : (string -> 'gen) -> ('a, 'a -> 'gen -> 'a) create (** {6 flag handling meant for use with mutable accumulator} *) val noarg_mut : ('a, 'a -> unit) create val arg_mut : ('a, 'a -> string -> unit) create val string_mut : ('a, 'a -> string -> unit) create val int_mut : ('a, 'a -> int -> unit) create val bool_mut : ('a, 'a -> bool -> unit) create val float_mut : ('a, 'a -> float -> unit) create val date_mut : ('a, 'a -> Date.t -> unit) create (** [rest f]: a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val rest_mut : ('a, 'a -> string list -> unit) create val gen_mut : (string -> 'gen) -> ('a, 'a -> 'gen -> unit) create (** {2 Deprecated } This is the old deprecated interface to Flag *) module Action : sig (** ['accum]-mutating action to perform when processing a flag *) type 'accum t = | Noarg of ('accum -> 'accum) | Arg of ('accum -> string -> 'accum) | Rest of ('accum -> string list -> 'accum) (** an action for a flag that takes no additional argument *) val noarg : ('accum -> unit) -> 'accum t (** an action for a flag that takes an additional string argument *) val arg : ('accum -> string -> unit) -> 'accum t (** [rest f]: an action for a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val rest : ('accum -> string list -> unit) -> 'accum t (** [rest f]: an action for a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) (** an action for a flag that takes an additional int argument *) val int : ('accum -> int -> unit) -> 'accum t (** an action for a flag that takes an additional bool argument *) val bool : ('accum -> bool -> unit) -> 'accum t (** an action for a flag that takes an additional float argument *) val float : ('accum -> float -> unit) -> 'accum t end val create : ?aliases:string list -> ?full_flag_required:bool -> name:string -> doc:string -> 'a Action.t -> 'a t (** [lift t ~project] transforms a flag with accumulator type ['a] into a flag with a more informative accumulator type ['b] provided that [project x] returns a pair consisting of 1. a ['a]-value extracted from the ['b]-value [x], and 2. a function for rebuilding a modified ['b]-value from the modified ['a]-value resulting from processing the flag. The intended use pattern for [lift] is when ['b] is a record type with a field [foo] of type ['a] and [project] is [fun r -> (r.foo, (fun foo' -> { r with foo = foo' }))] *) val lift : 'a t -> project:('b -> 'a * ('a -> 'b)) -> 'b t val lift_unit : unit t -> 'any t val lookup : 'a t list -> string -> 'a Action.t option module Poly : sig type 'a flag type t = { flag : 'a. unit -> 'a flag } val instantiate : t -> 'a flag end with type 'a flag := 'a t val to_spec : ('accum -> 'accum) ref -> 'accum t -> ('c, 'c) Command.Spec.t val to_spec_unit : unit t -> ('c, 'c) Command.Spec.t val to_spec_units : unit t list -> ('c, 'c) Command.Spec.t end = struct module Action' = struct type 'a t = | Noarg of ('a -> 'a) | Arg of ('a -> string -> 'a) | Rest of ('a -> string list -> 'a) let noarg f = Noarg f let arg f = Arg f let rest f = Rest f let int f = Arg (fun x s -> f x (Int.of_string s)) let bool f = Arg (fun x s -> f x (Bool.of_string s)) let float f = Arg (fun x s -> f x (Float.of_string s)) let date f = Arg (fun x s -> f x (Date.of_string s)) let gen of_string f = Arg (fun x s -> f x (of_string s)) (* [project] extracts a record field together with a rebuilding function [inject] to fill in the remaining fields after modifying the field. *) let lift t ~project = match t with | Noarg g -> Noarg (fun r -> let (f, inject) = project r in inject (g f)) | Arg g -> Arg (fun r x -> let (f, inject) = project r in inject (g f x)) | Rest g -> Rest (fun r xs -> let (f, inject) = project r in inject (g f xs)) end (* Action is a deprecated interface, that we here gussy up to be usable on the outside. Action' is the primary interface here. *) module Action = struct type 'a t = 'a Action'.t = | Noarg of ('a -> 'a) | Arg of ('a -> string -> 'a) | Rest of ('a -> string list -> 'a) let cvt x a = a (fun acc v -> x acc v; acc) let noarg x = Action'.noarg (fun acc -> x acc; acc) let arg x = cvt x Action'.arg let rest x = cvt x Action'.rest let int x = cvt x Action'.int let bool x = cvt x Action'.bool let float x = cvt x Action'.float end type 'a t = { name : string; spec : 'a Action.t; doc : string; aliases : string list; full_flag_required : bool; } type 'a flag = 'a t let lift t ~project = { t with spec = Action'.lift t.spec ~project } let lift_unit t = let project t = (), fun _ -> t in lift t ~project let create ?(aliases=[]) ?(full_flag_required=false) ~name ~doc spec = assert_no_underscores name; { name = name; spec = spec; doc = doc; aliases = aliases; full_flag_required = full_flag_required; } let name v = v.name let lookup ts = let alist = List.concat_map ts ~f:(fun t -> List.map (t.name :: t.aliases) ~f:(fun v -> (v, t))) in match String.Table.of_alist alist with | `Duplicate_key flag -> failwithf "multiple specifications for flag %s" flag () | `Ok tbl -> (fun flag -> match partial_match tbl flag with | `Exact (_, v) | `Partial (_, ({full_flag_required = false; name=_; spec=_; doc=_; aliases=_ } as v)) -> Some v.spec | `Partial (_, ({full_flag_required = true; name=_; spec=_; doc=_; aliases=_ } as v)) -> eprintf "Note: cannot abbreviate flag \"%s\".\n%!" v.name; None | `Ambiguous l -> eprintf "Note: flag \"%s\" is an ambiguous prefix: %s\n%!" flag (String.concat ~sep:", " (List.map ~f:fst l)); None | `None -> None) ;; (* The creation functions are listed below *) type ('a,'b) create = string -> ?aliases:string list -> ?full_flag_required:bool -> 'b -> doc:string -> 'a t (* takes a mutable-style handling function, and returns one that has an interface like an immutable-style handling function *) let unmut handle = (fun acc arg -> handle acc arg; acc) ;; let of_action fix_handle action_fn = (fun name ?aliases ?full_flag_required handle ~doc -> create ?aliases ?full_flag_required ~name ~doc (action_fn (fix_handle handle))) ;; let noarg_mut x = of_action (fun h x -> h x; x) Action'.noarg x let arg_mut x = of_action unmut Action'.arg x let string_mut x = of_action unmut Action'.arg x let int_mut x = of_action unmut Action'.int x let bool_mut x = of_action unmut Action'.bool x let float_mut x = of_action unmut Action'.float x let date_mut x = of_action unmut Action'.date x let rest_mut x = of_action unmut Action'.rest x let gen_mut os x = of_action unmut (Action'.gen os) x let noarg_acc x = of_action Fn.id Action'.noarg x let string_acc x = of_action Fn.id Action'.arg x let int_acc x = of_action Fn.id Action'.int x let bool_acc x = of_action Fn.id Action'.bool x let float_acc x = of_action Fn.id Action'.float x let date_acc x = of_action Fn.id Action'.date x let rest_acc x = of_action Fn.id Action'.rest x let gen_acc os x = of_action Fn.id (Action'.gen os) x let unref ref = (fun () x -> ref := x) let unref_opt ref = (fun () x -> ref := Some x) let unclos f = (fun () x -> f x) let set x = of_action (fun ref () -> ref := true) Action.noarg x let clear x = of_action (fun ref () -> ref := false) Action.noarg x let noarg x = of_action Fn.id Action'.noarg x let string x = of_action unclos Action'.arg x let int x = of_action unclos Action'.int x let bool x = of_action unclos Action'.bool x let float x = of_action unclos Action'.float x let gen os x = of_action unclos (Action'.gen os) x let set_string x = of_action unref Action'.arg x let set_string_opt x = of_action unref_opt Action'.arg x let set_int x = of_action unref Action'.int x let set_int_opt x = of_action unref_opt Action'.int x let set_float x = of_action unref Action'.float x let set_float_opt x = of_action unref_opt Action'.float x let set_date x = of_action unref Action'.date x let set_date_opt x = of_action unref_opt Action'.date x let set_gen os x = of_action unref (Action'.gen os) x let set_gen_opt os x = of_action unref_opt (Action'.gen os) x let of_arg (key, spec, doc) = let key = String.tr ~target:'_' ~replacement:'-' key in match spec with | Arg.Unit f -> noarg key ~doc f | Arg.Bool f -> bool key ~doc f | Arg.String f -> string key ~doc f | Arg.Int f -> int key ~doc f | Arg.Float f -> float key ~doc f | Arg.Set rf -> set key ~doc rf | Arg.Clear rf -> clear key ~doc rf | Arg.Set_string rf -> set_string key ~doc rf | Arg.Set_int rf -> set_int key ~doc rf | Arg.Set_float rf -> set_float key ~doc rf | Arg.Tuple _ -> failwith "Flag.of_arg: Arg.Tuple not supported" | Arg.Symbol _ -> failwith "Flag.of_arg: Arg.Symbol not supported" | Arg.Rest _ -> failwith "Flag.of_arg: Arg.Rest not supported" module Poly = struct type t = { flag : 'a. unit -> 'a flag } let instantiate t = t.flag () end module Deprecated_spec = Command.Deprecated.Spec let to_spec flag_env_updates {name; aliases; doc; spec; full_flag_required=_ } = let add_env_update new_env_update = let old_env_update = !flag_env_updates in flag_env_updates := (fun env -> new_env_update (old_env_update env)) in Command.Spec.( let drop () = step (fun m _ -> m) in match spec with | Action.Noarg update -> drop () +> flag name ~aliases ~doc (Deprecated_spec.no_arg ~hook:(fun () -> add_env_update update)) | Action.Arg update -> drop () +> flag name ~aliases ~doc (listed (Arg_type.create (fun s -> add_env_update (fun env -> update env s); s))) | Action.Rest update -> drop () +> flag name ~aliases ~doc (Deprecated_spec.escape ~hook:(fun ss -> add_env_update (fun env -> update env ss))) ) let to_spec_unit {name; aliases; doc; spec; full_flag_required=_ } = Command.Spec.( let drop () = step (fun m _ -> m) in match spec with | Action.Noarg update -> drop () +> flag name ~aliases ~doc (Deprecated_spec.no_arg ~hook:update) | Action.Arg update -> drop () +> flag name ~aliases ~doc (listed (Arg_type.create (update ()))) | Action.Rest update -> drop () +> flag name ~aliases ~doc (Deprecated_spec.escape ~hook:(update ())) ) let to_spec_units flags = Command.Spec.( List.fold ~f:(fun acc flag -> acc ++ to_spec_unit flag) ~init:(step ident) flags ) end module Shared_flags = struct type 'a t = { flags : unit Flag.t list; get : unit -> 'a; } end module Autocomplete_ = struct type t = string list -> string list module Bash_action = struct type t = [ `Alias | `Arrayvar | `Binding | `Builtin | `Command | `Directory | `Disabled | `Enabled | `Export | `File | `Function | `Group | `Helptopic | `Hostname | `Job | `Keyword | `Running | `Service | `Setopt | `Shopt | `Signal | `Stopped | `User | `Variable ] with sexp let to_string action = sexp_of_t action |! Sexp.to_string |! String.lowercase end let escape_for_bash string = let len = String.length string in let buffer = Buffer.create len in for i = 0 to len - 1 do begin match string.[i] with | '|' | '&' | ';' | '(' | ')' | '<' | '>' | ' ' | '\t' -> Buffer.add_char buffer '\\'; | _ -> () end; Buffer.add_char buffer string.[i]; done; Buffer.contents buffer let bash = let create_command_line action key = let options = match action with | `Directory -> " -S/ " | _ -> " " in "compgen" ^ options ^ " -A " ^ Bash_action.to_string action ^ " " ^ key in let single_command action key = let command_line = create_command_line action key in try Shell.run_full "/bin/bash" ["-c"; command_line] with | _exn -> "" in let command actions key = let actions = if List.exists actions ~f:((=) `File) && not (List.exists actions ~f:((=) `Directory)) then `Directory :: actions else actions in List.map ~f:(fun action -> single_command action key) actions |! String.concat ~sep:"\n" in fun actions command_line -> let result = match List.rev command_line with | [] -> command actions "" | key :: _ -> command actions key in String.split ~on:'\n' result |! List.map ~f:escape_for_bash ;; end let maybe_dashify ~allow_underscores = if not allow_underscores then (fun s -> s) else (fun s -> String.mapi s ~f:(fun i c -> if i = 0 || c <> '_' then c else '-' )) let is_help_flag = function | ("--help" | "-help" | "help" | "h" | "?" | "-?") -> true | _ -> false type group = { summary : string; readme : (unit -> string) option; subcommands : t String.Table.t; } and t = | Core of Command.t * (string list -> string list) option (* autocomplete *) | Group of group let group ~summary ?readme alist = List.iter alist ~f:(fun (name, _) -> assert_no_underscores name); match String.Table.of_alist alist with | `Ok subcommands -> Group { summary; readme; subcommands } | `Duplicate_key name -> failwith ("multiple subcommands named " ^ name) let summary = function | Core (base, _) -> Command.Deprecated.summary base | Group grp -> grp.summary let help ~cmd t = match t with | Core _ -> (* This will be dealt with by the Core.Std.Command internally this function is only called from within dispatch. during a call to dispatch, if we get to a point where our command is a Core (and would thus get into this branch), we call Core.Std.Command.Deprecated.run, which punts the entire functionality over to Core.Std.Command *) assert false | Group grp -> let alist = ("help [-r]", "explain a given subcommand (perhaps recursively)") :: List.map ~f:(fun (cmd, t) -> (cmd, summary t)) (Hashtbl.to_alist grp.subcommands) in Help_page.render ~summary:grp.summary ~readme:grp.readme ~usage:(cmd ^ " SUBCOMMAND") ~choice_type:"available subcommands" ~choices:(Columns.sort_align alist) ;; let help_help ~cmd subcommands = let choices = List.sort ~cmp:subcommand_cmp subcommands in Help_page.render ~summary:("explain " ^ cmd ^ " or one of its subcommands, perhaps recursively") ~readme:None ~usage:(cmd ^ " help [-r[ecursive] [-flags] [-expand-dots]] [SUBCOMMAND]\n" ^ " " ^ cmd ^ " -? [SUBCOMMAND]\n" ^ " " ^ cmd ^ " -?? [SUBCOMMAND] # (shortcut for -help -r) \n" ^ " " ^ cmd ^ " -??? [SUBCOMMAND] # (shortcut for -help -r -flags)") ~choice_type:"available subcommands" ~choices ;; (* Implements the "help -r" feature *) let help_recursive ~cmd ~with_flags ~expand_dots t = let rec help_recursive_rec ~cmd t s = let new_s = s ^ (if expand_dots then cmd else ".") ^ " " in match t with | Core (t, _) -> Command.Deprecated.help_recursive ~cmd ~with_flags ~expand_dots t s | Group grp -> (s ^ cmd, grp.summary) :: List.concat_map (List.sort ~cmp:subcommand_cmp_fst (Hashtbl.to_alist grp.subcommands)) ~f:(fun (cmd', t) -> help_recursive_rec ~cmd:cmd' t new_s) in let alist = help_recursive_rec ~cmd t "" in let choices = Columns.align alist in match t with | Core _ -> (* help_recursive is only called from within dispatch if we ever get to a Core variant (which would cause us to be in this branch), we would have gone into the | Core branch of dispatch, which would punt responsibility over to Core.Std.Command *) assert false | Group grp -> Help_page.render ~summary:grp.summary ~readme:grp.readme ~usage:(cmd ^ " SUBCOMMAND") ~choice_type:("available subcommands" ^ if with_flags then " and flags" else "") ~choices (* These refs are populated by run_internal. *) let expanded_argv_head_rev = ref [] let expanded_argv_tail = ref [] (* This exception is raised if we try to read expanded argv before calling run_internal *) exception Expanded_argv_not_yet_initialized with sexp let get_expanded_argv () = let expanded_argv = List.rev_map_append !expanded_argv_head_rev !expanded_argv_tail ~f:(fun x->x) in if expanded_argv = [] then raise Expanded_argv_not_yet_initialized else expanded_argv ;; let get_expanded_cmdline () = String.concat ~sep:" " (get_expanded_argv ()) module Autocomplete = struct let bash_autocomplete_function = let fname = sprintf "_jsautocom_%s" (Pid.to_string (Unix.getpid ())) in sprintf "%s () { COMPREPLY=() LENV=\"\" i=0; for e in \"${COMP_WORDS[@]}\"; do LENV=\"$LENV COMMAND_COMP_WORDS_${i}=\\\"$e\\\"\"; (( i++ )); done; CC=\"eval COMMAND_COMP_CWORD=\"${COMP_CWORD}\" COMMAND_COMP_POINT=\"${COMP_POINT}\" \ $LENV ${COMP_WORDS}\" matching_options=`$CC` eval ${matching_options} return 0 } complete -F %s %s" fname fname Sys.argv.(0) let output_bash_function () = print_endline bash_autocomplete_function; () include Autocomplete_ let print_list strings = let options = List.filter ~f:((<>) "") strings in let arr = Array.of_list options in Array.iteri arr ~f:(fun i contents -> printf "COMPREPLY[%i]='%s'; " (i + 1) contents) let get_environment_numeric environment = match Sys.getenv environment with | Some word -> if word = "" then 0 else int_of_string word | None -> assert false let current_word () = get_environment_numeric "COMMAND_COMP_CWORD" let current_point () = get_environment_numeric "COMMAND_COMP_POINT" - String.length Sys.argv.(0) let external_completion ~autocomplete ~key ~command_line = let completion_line = match autocomplete with | None -> Autocomplete_.bash [`File] [key] | Some f -> f command_line in print_list completion_line let filter_matching_prefixes_and_print ~autocomplete ~key ~command_line strings = match List.filter strings ~f:(String.is_prefix ~prefix:key) with | [] -> external_completion ~autocomplete ~key ~command_line | lst -> print_list lst let rec autocomplete t command_line = match t with | Core (base, autocomplete) -> let flags = Command.Deprecated.get_flag_names base in (match List.rev command_line with | [] -> print_list flags | key :: _ -> if key = "" || key.[0] <> '-' then external_completion ~autocomplete ~key ~command_line else filter_matching_prefixes_and_print ~autocomplete ~key ~command_line flags) | Group grp -> match command_line with | [key] -> Hashtbl.keys grp.subcommands |! filter_matching_prefixes_and_print ~autocomplete:None ~key ~command_line | [] -> (* We are at the root and all the options are requested *) Hashtbl.keys grp.subcommands |! print_list | key :: argv -> match Hashtbl.find grp.subcommands key with | None -> () | Some t -> autocomplete t argv let rec truncate_command_line ~current_word ~current_point command_line = (* Printf.fprintf stderr "Word: %d, Point: %d" current_word current_point; *) if current_word = 1 then begin match command_line with | h :: _ -> let current_point = (* We might be off due to the spaces ... is there a better way? *) min (String.length h) (max 0 current_point) in [String.sub h ~pos:0 ~len:current_point] | [] -> [""] end else begin assert (current_word > 0); match command_line with | h :: command_line -> let len = String.length h in let current_word = pred current_word in let current_point = current_point - (len + 1) in h :: truncate_command_line ~current_word ~current_point command_line | [] -> [] end let autocomplete t command_line = let current_word = current_word () in let current_point = current_point () in let command_line = truncate_command_line ~current_word ~current_point command_line in autocomplete t command_line (* We clear the setting of environment variable associated with command-line completion so that subprocesses don't see them. *) let getenv_and_clear var = let value = Sys.getenv var in if is_some value then Unix.unsetenv var; value ;; let rec execution_mode' index = match getenv_and_clear ("COMMAND_COMP_WORDS_" ^ string_of_int index) with | None -> [] | Some command -> command :: execution_mode' (index + 1) ;; let execution_mode () = match getenv_and_clear "COMMAND_OUTPUT_INSTALLATION_BASH" with | Some _ -> `print_bash_autocomplete_function | None -> let command_list = execution_mode' 0 in match command_list with | [] -> `run_main | _ :: partial_command_line -> `doing_auto_completion partial_command_line ;; end let of_core_command t = Core (t, None) let create ?autocomplete ?readme ~summary ~usage_arg ~init ~flags ~final main = let c = Command.basic ~summary ?readme Command.Spec.( let flag_env_updates = ref Fn.id in let flags = List.fold flags ~init:(step Fn.id) ~f:(fun flags t -> let flag = Flag.to_spec flag_env_updates t in flags ++ flag) in flags ++ step (fun m anons help -> let env = init () in let env = !flag_env_updates env in let argv = final env anons in fun () -> try m argv with Invalid_arguments lines -> printf "Invalid arguments: %s\n\n" (String.concat ~sep:" " lines); print_endline (Lazy.force help); exit 1 ) +> anon (Command.Deprecated.Spec.ad_hoc ~usage_arg) +> help ) main in Core (c, autocomplete) let create0 ?autocomplete ?readme ~summary ~usage_arg ~init ~flags ~final main = let final accum anonargs = match anonargs with | [] -> final accum | _ :: _ as lst -> printf "Error: expected 0 anonymous arguments, got %i\n%!" (List.length lst); exit 1 in create ?autocomplete ?readme ~summary ~usage_arg ~init ~flags ~final main let create_no_accum ?autocomplete ?readme ~summary ~usage_arg ~flags ~final main = let init () = () in let final _ anonargs = final anonargs in create ?autocomplete ?readme ~summary ~usage_arg ~init ~flags ~final main let create_no_accum0 ?autocomplete ?readme ~summary ~usage_arg ~flags main = let init () = () in let final _ = () in create0 ?autocomplete ?readme ~summary ~usage_arg ~init ~flags ~final main module Version = struct type command = t type t = { command : command; flags : unit Flag.t list; } let print_version ?(version = Command.Deprecated.version) () = print_endline version let print_build_info ?(build_info = Command.Deprecated.build_info) () = print_endline build_info let poly_flags ?version ?build_info () = [ { Flag.Poly.flag = fun () -> Flag.noarg_acc "-version" (fun _ -> print_version ?version (); exit 0) ~doc:" Print the version of this build and exit" }; { Flag.Poly.flag = fun () -> Flag.noarg_acc "-build-info" (fun _ -> print_build_info ?build_info (); exit 0) ~doc:" Print build info as sexp and exit" }; ] let flags ?version ?build_info () = List.map ~f:Flag.Poly.instantiate (poly_flags ?version ?build_info ()) let command ?version ?build_info () = let summary = "Print version information" in let usage_arg = "[-version | -build-info]" in let init () = () in let flags = flags ?version ?build_info () in let final () _anons = () in let main () = eprintf "(no option given - printing version)\n%!"; print_version ?version (); exit 0 in create ~summary ~usage_arg ~init ~flags ~final main let add ?version ?build_info unversioned = let command = match unversioned with | Core _ -> failwith "You have used a Core.Std.Command in a Command basic stub. \ Please convert fully to Core.Std.Command" | Group grp -> group ~summary:grp.summary (("version", command ?version ?build_info ()) :: String.Table.to_alist grp.subcommands) in { command; flags = flags ?version ?build_info () } end let run_internal versioned ~allow_unknown_flags:_ ~allow_underscores ~cmd ~argv ?post_parse = let maybe_dashify = maybe_dashify ~allow_underscores in expanded_argv_head_rev := [cmd]; expanded_argv_tail := argv; let rec loop t ~is_help ~is_help_rec ~is_help_rec_flags ~is_expand_dots cmd argv = let update_expanded_argv l1 l2 = expanded_argv_head_rev := l1 @ !expanded_argv_head_rev; expanded_argv_tail := l2 in let post_parse_call ~is_ok = match post_parse with | None -> () | Some f -> let status_code = match is_ok, is_help with | false, _ -> `Error | true, true -> `Help | true, false -> `Ok in f status_code (get_expanded_argv ()) in match t with | Core (t, _) -> fun () -> Command.Deprecated.run t ~cmd ~args:argv ~is_help ~is_help_rec ~is_help_rec_flags ~is_expand_dots | Group grp -> let execute_group (subcmd, rest) = match partial_match grp.subcommands (maybe_dashify subcmd) with | `Exact (full_subcmd, t) | `Partial (full_subcmd, t) -> update_expanded_argv [full_subcmd] rest; loop t ~is_help ~is_help_rec ~is_help_rec_flags ~is_expand_dots (cmd ^ " " ^ full_subcmd) rest | `Ambiguous l -> post_parse_call ~is_ok:false; eprintf "%s\n%s%!" (sprintf "subcommand %s is an ambiguous prefix: %s" subcmd (String.concat ~sep:", " (List.map ~f:fst l))) (help ~cmd t); exit 1 | `None -> post_parse_call ~is_ok:false; eprintf "%s\n%s%!" ("unknown subcommand " ^ subcmd ^ " for command " ^ cmd) (help ~cmd t); exit 1 in match argv with | [] -> post_parse_call ~is_ok:is_help; (fun () -> if is_help then (printf "%s" ( if is_help_rec then help_recursive ~cmd ~with_flags:is_help_rec_flags ~expand_dots:is_expand_dots t else help ~cmd t); exit 0) else (eprintf "%s%!" (help ~cmd t); eprintf ("\n\nA subcommand for %s is required\n%!") cmd; exit 1)) | arg :: rest -> begin match Flag.lookup versioned.Version.flags (maybe_dashify arg) with | None -> () | Some (Flag.Action.Rest _ | Flag.Action.Arg _) -> assert false | Some (Flag.Action.Noarg f) -> f () end; match arg,rest with | ( "??" | "-??" ), rest -> update_expanded_argv ["-recursive";"-help"] rest; loop t ~is_help:true ~is_help_rec:true ~is_help_rec_flags ~is_expand_dots cmd rest | ( "???" | "-???" ), rest -> update_expanded_argv ["-flags";"-recursive";"-help"] rest; loop t ~is_help:true ~is_help_rec:true ~is_help_rec_flags:true ~is_expand_dots cmd rest | flag, rest when is_help_flag flag -> update_expanded_argv ["-help"] rest; if is_help then begin post_parse_call ~is_ok:true; (fun () -> printf "%s" (help_help ~cmd (Hashtbl.keys grp.subcommands)); exit 0) end else loop t ~is_help:true ~is_help_rec ~is_help_rec_flags ~is_expand_dots cmd rest | ("-r" | "-recursive"), rest when is_help -> update_expanded_argv ["-recursive"] rest; loop t ~is_help ~is_help_rec:true ~is_help_rec_flags ~is_expand_dots cmd rest | "-flags", rest when is_help -> update_expanded_argv ["-flags"] rest; loop t ~is_help ~is_help_rec ~is_help_rec_flags:true ~is_expand_dots cmd rest | "-expand-dots", rest when is_help -> update_expanded_argv ["-expand-dots"] rest; loop t ~is_help ~is_help_rec ~is_help_rec_flags ~is_expand_dots:true cmd rest | subcmd, rest -> execute_group (subcmd, rest) in loop versioned.Version.command ~is_help:false ~is_help_rec:false ~is_help_rec_flags:false ~is_expand_dots:false cmd argv ;; (* The #! protocol for stand-alone scripts groups together all embedded flags as one. If the first line of a #! script reads #! /path/to/my/command -flag1 -flag2 -flag3 and then we call the script as > script arg1 arg2 then the argument vector passed to /path/to/my/command will be ["-flag1 -flag2 -flag3"; "arg1"; "arg2"] So we need to pull apart the first argument into three. Likely, this will only happen when the first argument is a flag (starts with '-') and contains a space. *) let hash_bang_expand_arg = function | (first :: rest) as same -> if String.is_prefix first ~prefix:"-" then String.split first ~on:' ' @ rest else same | other -> other ;; type 'a with_run_flags = ?version:string -> ?build_info:string (* Defaults to [Sys.argv]. *) -> ?argv:string list (* if true, unknown flags will be passed to the anon command handler *) -> ?allow_unknown_flags:bool (* if true, "-multi_arg_flag", will be handled the same as "-multi-arg-flag". If false, an exception will be raised. The default is true. *) -> ?allow_underscores:bool (* set to [true] when we expect the command to run as the result of calling a #! interpreter script. *) -> ?hash_bang_expand:bool -> ?post_parse:([ `Ok | `Error | `Help ] -> string list -> unit) -> t -> 'a let run : unit with_run_flags = fun ?version ?build_info ?argv ?(allow_unknown_flags=false) ?(allow_underscores=true) ?(hash_bang_expand=false) ?post_parse t -> match t with | Core (c, _) -> Command.run ?version ?build_info ?argv c | Group _ as t -> let t = Version.add ?version ?build_info t in match Autocomplete.execution_mode () with | `print_bash_autocomplete_function -> Autocomplete.output_bash_function (); exit 0 | `doing_auto_completion partial_command_line -> Autocomplete.autocomplete t.Version.command partial_command_line; exit 0 | `run_main -> let argv = Option.value argv ~default:(Array.to_list Sys.argv) in match argv with | [] -> failwith "no command name passed in" (* I think this is impossible *) | cmd :: argv -> let cmd = Filename.basename cmd in let argv = if hash_bang_expand then hash_bang_expand_arg argv else argv in run_internal t ~allow_unknown_flags ~allow_underscores ~cmd ~argv ?post_parse () ;; module Annotated_field = struct type t = { field_name : string; flag_name : string; doc : string; value : [ | `Optional of string option | `Default of string | `Specified of string option | `List of string list (* [`Switch v] is for boolean fields with default value [v] where passing the flag (with no arguments) sets it to [not v] *) | `Switch of bool ] } type accum = t list ref module F = Fieldslib.Field let with_names name field ~doc ~value = { field_name = F.name field; flag_name = Option.value name ~default:(F.name field); doc = doc; value = value; } let required ?name t_list ~doc field = let t = with_names name field ~doc:(doc ^ " (required)") ~value:(`Specified None) in t :: t_list ;; let default ?name default to_string t_list ~doc field = let default_s = to_string default in let t = with_names name field ~doc:(sprintf "%s (default=%s)" doc default_s) ~value:(`Default default_s) in t :: t_list ;; let optional ?name ?(suppress_word_optional=false) t_list ~doc field = let t = with_names name field ~doc:(doc ^ (if suppress_word_optional then "" else " (optional)")) ~value:(`Optional None) in t :: t_list ;; let set ?name t_list ~doc field = let t = with_names name field ~doc:(doc ^ " (default=false)") ~value:(`Switch false) in t :: t_list ;; let clear ?name t_list ~doc field = let t = with_names name field ~doc:(doc ^ " (default=true)") ~value:(`Switch true) in t :: t_list ;; let list ?name t_list ~doc field = let t = with_names name field ~doc ~value:(`List []) in t :: t_list ;; let init t_list = ref t_list let alter_value t_list ~name ~f = match List.find t_list ~f:(fun t -> t.flag_name = name) with | None -> t_list | Some t -> let new_t = {t with value = f t.value} in new_t :: List.filter t_list ~f:(fun t -> t.flag_name <> name) ;; let to_flag t = let err_specified_more_than_once () = failwithf "%s specified more than once" t.flag_name () in let create flag_creator handler = let name = "-" ^ String.tr ~target:'_' ~replacement:'-' t.flag_name in flag_creator name ?aliases:None ?full_flag_required:None handler ~doc:t.doc in match t.value with | `Switch default -> create Flag.noarg_mut (fun accum -> accum := alter_value !accum ~name:t.flag_name ~f:(function | `Switch _ -> `Specified (Some (string_of_bool (not default))) | _ -> err_specified_more_than_once ())) | `Specified None -> create Flag.arg_mut (fun accum s -> accum := alter_value !accum ~name:t.flag_name ~f:(function | `Specified None -> `Specified (Some s) | _ -> err_specified_more_than_once ())) | `Optional None -> create Flag.arg_mut (fun accum s -> accum := alter_value !accum ~name:t.flag_name ~f:(function | `Optional None -> `Specified (Some s) | _ -> err_specified_more_than_once ())) | `Default _ -> create Flag.arg_mut (fun accum s -> accum := alter_value !accum ~name:t.flag_name ~f:(function | `Default _ -> `Specified (Some s) | _ -> err_specified_more_than_once ())) | `List [] -> create Flag.arg_mut (fun accum s -> accum := alter_value !accum ~name:t.flag_name ~f:(function | `List l -> `List (s :: l) | _ -> assert false )) | `Optional (Some _) | `Specified (Some _) | `List (_ :: _) -> failwith "did you call to_flag more than once?" ;; let get accum of_string field = let field_name = F.name field in let err_unspecified () = failwithf "%s not specified" field_name () in match List.find !accum ~f:(fun t -> t.field_name = field_name) with | None -> err_unspecified () | Some t -> begin match t.value with | `Switch b -> of_string (Bool.to_string b) | `Specified (Some s) | `Default s -> of_string s | `Optional None -> of_string "None" | `Optional (Some s) -> of_string ("Some " ^ s) | `Specified None -> err_unspecified () | `List _ -> failwith "use get_list" end ;; let get_opt accum of_string field = let field_name = F.name field in let err_unspecified () = failwithf "%s not specified" field_name () in match List.find !accum ~f:(fun t -> t.field_name = field_name) with | None -> err_unspecified () | Some t -> begin match t.value with | `Optional x | `Specified x -> Option.map x ~f:of_string | _ -> invalid_arg "Annotated_field.get_opt" end ;; let get_list accum of_string field = let field_name = F.name field in let err_unspecified () = failwithf "%s not specified" field_name () in match List.find !accum ~f:(fun t -> t.field_name = field_name) with | None -> err_unspecified () | Some t -> begin match t.value with | `List x -> List.map x ~f:of_string | _ -> invalid_arg "Annotated_field.get_list" end ;; end module Flags_ext = struct type 'a setter = | No_arg of 'a | Arg of (string -> 'a) let is_no_arg = function No_arg _ -> true | _ -> false type ('a, 'flag) t = { flag : 'flag; get : unit -> 'a; is_set : unit -> bool; } let flag t = t.flag let get t = t.get () let is_set t = t.is_set () (* ******************************************************** *) (* Flags that can occur at most once *) let create_internal ~default ~name ~doc setter = let name = "-" ^ name in if default = None && is_no_arg setter then failwithf "Flags_ext: Flag %s is a no_arg flag without a default (doesn't make sense)" name (); let acc = ref None in let flag = let fail () = failwithf "Flag %s should only be specified once" name () in match setter with | No_arg final -> Flag.noarg name ~doc (fun () -> match !acc with | None -> acc := Some final | Some _ -> fail ()) | Arg of_string -> Flag.string name ~doc (fun str -> match !acc with | None -> acc := Some (of_string str) | Some _ -> fail ()) in let get () = match default with | Some default -> Option.value !acc ~default | None -> Option.value_exn ~message:(sprintf "Required argument %s was not specified" name) (!acc) in { flag = flag; get = get; is_set = fun () -> is_some !acc; } let create ?default ~name ~doc setter = let (default, doc) = match default with | None -> None , sprintf "%s (required)" doc | Some (v, to_string) -> Some v, if is_no_arg setter then doc (* corresponds to set or clear *) else sprintf "%s (default=%s)" doc (to_string v) in create_internal ~default ~name ~doc setter let create_optional ~name ~doc setter = let doc = sprintf "%s (optional)" doc in (* optional arguments have a default of None *) let default = Some None in let setter = match setter with | No_arg final -> No_arg (Some final) | Arg of_string -> Arg (fun s-> Some (of_string s)) in create_internal ~default ~name ~doc setter let create_rest ?(name="--") ~doc () = let x = ref None in let flag = Flag.rest_acc name ~doc (fun () s's -> x := Some s's ) in { flag; get = (fun () -> !x); is_set = (fun () -> Option.is_some !x) } (* ************************************************************************** *) (* Repeatable flags *) let create_many ?(at_least_one=false) ~name ~doc setter = let name = "-" ^ name in let doc = sprintf "%s (%d or more)" doc (if at_least_one then 1 else 0) in let acc = ref [] in let flag = match setter with | Arg of_string -> Flag.string name ~doc (fun str -> acc := (of_string str) :: !acc) (* This case only really makes sense when [x] is [()]. *) | No_arg x -> Flag.noarg name ~doc (fun () -> acc := x :: !acc) in let get () = if at_least_one && !acc = [] then failwithf "Flag %s must be specified at least once" name (); !acc in { flag = flag; get = get; is_set = fun () -> not (List.is_empty !acc); } (* ******************************************************** *) (* Choice (1 of n) flags that can occur atmost once *) let create_choice_internal ?default spec_list = let acc = ref None in let names = List.map spec_list ~f:(fun (name, _, _) -> name) in let names_string = String.concat ~sep:"," names in let make_flag (name, doc, setter) = match setter with | No_arg v -> Flag.noarg name ~doc (fun () -> match !acc with | Some _ -> failwithf "Only one of %s can be specified." names_string (); | None -> acc := Some v) | Arg of_string -> Flag.string name ~doc (fun str -> match !acc with | Some _ -> failwithf "Only one of %s can be specified." names_string (); | None -> acc := Some (of_string str)) in let flags = List.map spec_list ~f:make_flag in let get () = match (!acc, default) with | Some v, _ -> v | None , Some v -> v | None , None -> failwithf "At least one of %s must be specified" names_string () in { flag = flags; get = get; is_set = fun () -> is_some !acc; } let foreach ls ~f = let rec loop = function | [] -> [] | [x] -> [f x ~first:false ~last:true] | x :: xs -> f x ~first:false ~last:false :: loop xs in let loop0 = function | [] -> [] | [x] -> [f x ~first:true ~last:true] | (x :: xs) -> f x ~first:true ~last:false :: loop xs in loop0 ls let make_choice_indicator_string first last = match (first, last) with | true , _ -> "" | false, false -> "(OR) " | false, true -> "(OR) " let create_choice ?default spec_list = let (default, spec_list) = match default with | Some (v, to_string) -> (Some v, foreach spec_list ~f:(fun (name, doc, setter) ~first ~last -> let (arg, desc) = String.lsplit2_exn doc ~on:' ' in let doc = sprintf "%s %s%s (default=%s)" arg (make_choice_indicator_string first last) desc (to_string v) in ("-" ^ name, doc, setter))) | None -> (None, foreach spec_list ~f:(fun (name, doc, setter) ~first ~last -> let (arg, desc) = String.lsplit2_exn doc ~on:' ' in let doc = sprintf "%s %s%s" arg (make_choice_indicator_string first last) desc in ("-" ^ name, doc, setter))) in create_choice_internal ?default spec_list let create_choice_optional spec_list = let spec_list = foreach spec_list ~f:(fun (name, doc, setter) ~first ~last -> let (arg, desc) = String.lsplit2_exn doc ~on:' ' in let doc = sprintf "%s %s%s (optional)" arg (make_choice_indicator_string first last) desc in let setter = match setter with | Arg of_string -> Arg (fun s -> Some (of_string s)) | No_arg v -> No_arg (Some v) in ("-" ^ name, doc, setter)) in create_choice_internal ~default:None spec_list let create_set ~name ~doc = create ~default:(false,string_of_bool) ~name ~doc (No_arg true) end module Helpers = struct exception Found_anonymous_arguments with sexp let no_anons c anons = match anons with | [] -> c | _ -> Printf.eprintf "No anonymous arguments expected\n%!"; raise Found_anonymous_arguments ;; end core_extended-113.00.00/src/deprecated_command.mli000066400000000000000000000355321256461102500217260ustar00rootroot00000000000000(** DEPRECATED: use Core.Std.Command instead *) (** command-line parsing with hierarchical sub-commands *) open Core.Std exception Invalid_arguments of string list module Flag : sig (** type of flags to a command with accumulator type ['a] *) type 'a t val name : _ t -> string (** Template for flag-creation functions *) type ('a, 'b) create = string -> ?aliases:string list -> ?full_flag_required:bool -> ('b) -> doc:string -> 'a t val of_arg : Arg.t -> unit t (** {6 Flag handling without an accumulator} *) val noarg : (unit, unit -> unit) create val string : (unit, string -> unit) create val int : (unit, int -> unit) create val float : (unit, float -> unit) create val bool : (unit, bool -> unit) create val gen : (string -> 'gen) -> (unit, 'gen -> unit) create val set_string : (unit, string ref) create val set_string_opt : (unit, string option ref) create val set_int : (unit, int ref) create val set_int_opt : (unit, int option ref) create val set_float : (unit, float ref) create val set_float_opt : (unit, float option ref) create val set_date : (unit, Date.t ref) create val set_date_opt : (unit, Date.t option ref) create val set : (unit, bool ref) create val clear : (unit, bool ref) create val set_gen : (string -> 'gen) -> (unit, 'gen ref) create val set_gen_opt : (string -> 'gen) -> (unit, 'gen option ref) create (** {6 flag handling meant for use with immutable accumulator} *) val noarg_acc : ('a, 'a -> 'a) create val string_acc : ('a, 'a -> string -> 'a) create val int_acc : ('a, 'a -> int -> 'a) create val bool_acc : ('a, 'a -> bool -> 'a) create val float_acc : ('a, 'a -> float -> 'a) create val date_acc : ('a, 'a -> Date.t -> 'a) create (** [rest f]: a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val rest_acc : ('a, 'a -> string list -> 'a) create val gen_acc : (string -> 'gen) -> ('a, 'a -> 'gen -> 'a) create (** {6 flag handling meant for use with mutable accumulator} *) val noarg_mut : ('a, 'a -> unit) create val arg_mut : ('a, 'a -> string -> unit) create val string_mut : ('a, 'a -> string -> unit) create val int_mut : ('a, 'a -> int -> unit) create val bool_mut : ('a, 'a -> bool -> unit) create val float_mut : ('a, 'a -> float -> unit) create val date_mut : ('a, 'a -> Date.t -> unit) create (** [rest f]: a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val rest_mut : ('a, 'a -> string list -> unit) create val gen_mut : (string -> 'gen) -> ('a, 'a -> 'gen -> unit) create (** {2 Deprecated } This is the old deprecated interface to Flag *) module Action : sig (** ['accum]-mutating action to perform when processing a flag *) type 'accum t (** an action for a flag that takes no additional argument *) val noarg : ('accum -> unit) -> 'accum t (** an action for a flag that takes an additional string argument *) val arg : ('accum -> string -> unit) -> 'accum t (** [rest f]: an action for a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) val rest : ('accum -> string list -> unit) -> 'accum t (** [rest f]: an action for a flag that signals the end of flag processing. all remaining arguments are passed to the [f] *) (** an action for a flag that takes an additional int argument *) val int : ('accum -> int -> unit) -> 'accum t (** an action for a flag that takes an additional bool argument *) val bool : ('accum -> bool -> unit) -> 'accum t (** an action for a flag that takes an additional float argument *) val float : ('accum -> float -> unit) -> 'accum t end (* The [name] must not contain any underscores: dashes should be used instead. Whether or not underscores should be interpreted as dashes on the command line can be controlled by the [allow_underscores_and_dashes] argument to [run]. *) val create : ?aliases:string list -> ?full_flag_required:bool -> name:string -> doc:string -> 'a Action.t -> 'a t (** [lift t ~project] transforms a flag with accumulator type ['a] into a flag with a more informative accumulator type ['b] provided that [project x] returns a pair consisting of 1. a ['a]-value extracted from the ['b]-value [x], and 2. a function for rebuilding a modified ['b]-value from the modified ['a]-value resulting from processing the flag. The intended use pattern for [lift] is when ['b] is a record type with a field [foo] of type ['a] and [project] is [fun r -> (r.foo, (fun foo' -> { r with foo = foo' }))] *) val lift : 'a t -> project:('b -> 'a * ('a -> 'b)) -> 'b t val lift_unit : unit t -> 'any t (* transitional only, not for casual user *) val to_spec : ('accum -> 'accum) ref -> 'accum t -> ('c, 'c) Command.Spec.t val to_spec_unit : unit t -> ('c, 'c) Command.Spec.t val to_spec_units : unit t list -> ('c, 'c) Command.Spec.t end module Shared_flags : sig type 'a t = { flags : unit Flag.t list; get : unit -> 'a; } end (* Represents the expected command line arguments for a program. *) type t module Autocomplete : sig type t = string list -> string list (* An autocomplete function gets the list of command line arguments up to the point that TAB was pressed. It returns the list of completion possibilities. It is used to allow bash to query suggestions from the program that uses the Command module. Autocompletion works by checking some environment variables and suggesting completion options. If the environment COMMAND_OUTPUT_INSTALLATION_BASH is set, a bash script for the autocompletion is printed to stdout. The following bash function can be used by any program using the Command module. {v function js-install-command-autocompletion \{ while (( $# > 0 )); do tmp=$(mktemp) COMMAND_OUTPUT_INSTALLATION_BASH= $1 >$tmp source $tmp rm -f $tmp shift done \} v} To activate the feature in the programs foo and bar, then you need to write in yor bashrc: {v js-install-command-autocompletion foo bar v} ) *) module Bash_action : sig type t = [ | `Alias | `Arrayvar | `Binding | `Builtin | `Command | `Directory | `Disabled | `Enabled | `Export | `File | `Function | `Group | `Helptopic | `Hostname | `Job | `Keyword | `Running | `Service | `Setopt | `Shopt | `Signal | `Stopped | `User | `Variable ] end (** [create actions command_line] gets the completion suggestions that bash's compgen would generate for the selected [actions] and the last word of the [command_line]. *) val bash : Bash_action.t list -> t end (** [create ~autocomplete ~summary ~usage_arg ~init ~flags ~final main] constructs a base command from the following data: {ul {li ['accum] a mutable accumulator type for gathering arguments } {li ['args] a composite argument type for the command, build from ['accum] } {li [autocomplete] an optional argument defining a bash autocompletion function for the base command. } {li [summary] a short description of what the command does } {li [readme] a longer description of what the command does } {li [usage_arg] an abbreviation of the arguments it expects } {li [init] a function that creates an mutable accumulator of type ['accum] } {li [flags] a list of command line flags together with their associated accumulator-mutating actions } {li [final] a function that constructs the final argument structure of type ['args] from the accumulated arguments. The second argument to the function is the list of all annonymous arguments. This function should raise an exception with some explanation if it is unable to construct a complete value of type ['args]. } {li [help] an optional function that will be called to generate help for a command instead of the standard help } {li [main] the main function, parameterized by the argument structure } } *) val create : ?autocomplete:Autocomplete.t -> ?readme:(unit -> string) -> summary:string -> usage_arg:string -> init:(unit -> 'accum) -> flags:'accum Flag.t list -> final:('accum -> string list -> 'argv) -> ('argv -> unit) -> t val create0 : ?autocomplete : Autocomplete.t -> ?readme : (unit -> string) -> summary : string -> usage_arg : string -> init : (unit -> 'accum) -> flags : ('accum Flag.t list) -> final : ('accum -> 'args) -> ('args -> unit) -> t val create_no_accum : ?autocomplete : Autocomplete.t -> ?readme : (unit -> string) -> summary : string -> usage_arg : string -> flags : unit Flag.t list -> final : (string list -> 'args) -> ('args -> unit) -> t val create_no_accum0 : ?autocomplete : Autocomplete.t -> ?readme : (unit -> string) -> summary : string -> usage_arg : string -> flags : unit Flag.t list -> (unit -> unit) -> t (** [group ~summary [...; (name_i, t_i); ...]] is an aggregate command that dispatches to one of the named sub-commands. A ["help"] sub-command will also be generated for the group. The name cannot contain underscores, however passing [allow_underscores=true] into run will parse underscores as dashes on the command line. *) val group : summary:string -> ?readme:(unit -> string) -> (string * t) list -> t type 'a with_run_flags = ?version:string -> ?build_info:string (* Defaults to [Sys.argv]. *) -> ?argv:string list (* if true, unknown flags will be passed to the anon command handler *) -> ?allow_unknown_flags:bool (* if true, "-multi_arg_flag", will be handled the same as "-multi-arg-flag". If false, an exception will be raised. The default is true. *) -> ?allow_underscores:bool (* set to [true] when we expect the command to run as the result of calling a #! interpreter script. *) -> ?hash_bang_expand:bool -> ?post_parse:([ `Ok | `Error | `Help ] -> string list -> unit) -> t -> 'a val run : unit with_run_flags val get_expanded_argv : unit -> string list val get_expanded_cmdline : unit -> string module Version : sig (** Provides a ["version"] subcommand. *) (* Requiring [version] and [build_info] as arguments allows you to munge the strings before passing them to [command]. Also, passing in the strings instead of using Version_util directly prevents this module from being rebuilt constantly, I think(?). *) val command : ?version:string -> ?build_info:string -> unit -> t val print_version : ?version:string -> unit -> unit end (** This module is intended to help in using pa_fields to easily generate Command.t's when you have a record type each field of which you would like specified as a command line argument. An example is as follows: {[module M = struct type t = { field1 : int; field2 : float; field3 : bool; field4 : string option; } with fields module A = Annotated_field let ann_fields = Fields.fold ~init:[] ~field1:(A.required ~doc:" documentation for field1") ~field2:(A.default 1.0 string_of_float ~doc:" documentation for field2") ~field3:(A.set ~doc:" documentation for field3") ~field4:(A.optional ~doc:" documentation for field4") let command = create ~summary:"summary" ~init:(fun () -> A.init ann_fields) ~usage_arg:"" ~flags:(List.map ann_fields ~f:A.to_flag) ~final:(fun accum _anon_args -> let get of_string = A.get accum of_string in let get_opt of_string = A.get_opt accum of_string in Fields.map ~field1:(get int_of_string) ~field2:(get Float.of_string) ~field3:(get bool_of_string) ~field4:(get_opt ident) ) ~main:(fun _ -> assert false)]} end *) module Annotated_field : sig type t (* "accum" in the sense of 'accum above *) type accum (* naming convention follows extended_arg *) val required : ?name:string -> t list -> doc:string -> (_, _) Fieldslib.Field.t -> t list val default : ?name:string -> 'field -> ('field -> string) -> t list -> doc:string -> (_, 'field) Fieldslib.Field.t -> t list val optional : ?name:string -> ?suppress_word_optional:bool -> t list -> doc:string -> (_, _ option) Fieldslib.Field.t -> t list val set : ?name:string -> t list -> doc:string -> (_, bool) Fieldslib.Field.t -> t list val clear : ?name:string -> t list -> doc:string -> (_, bool) Fieldslib.Field.t -> t list val list : ?name:string -> t list -> doc:string -> (_, _ list) Fieldslib.Field.t -> t list val init : t list -> accum val to_flag : t -> accum Flag.t val get : accum -> (string -> 'field) -> (_, 'field) Fieldslib.Field.t -> 'field val get_opt : accum -> (string -> 'field) -> (_, 'field option) Fieldslib.Field.t -> 'field option val get_list : accum -> (string -> 'field) -> (_, 'field list) Fieldslib.Field.t -> 'field list end module Flags_ext : sig type 'a setter = | No_arg of 'a | Arg of (string -> 'a) (* 'flag can either be a Flag.t or a Flag.t list *) type ('a, 'flag) t val flag : ( _, 'flag) t -> 'flag val get : ('a, _) t -> 'a val is_set : (_, _) t -> bool (* this flag can occur at most once *) val create_optional : name:string -> doc:string -> 'a setter -> ('a option, unit Flag.t) t (* this flag can occur at most once *) val create : ?default:('a * ('a -> string)) -> name:string -> doc:string -> 'a setter -> ('a, unit Flag.t) t (* this flag can occur 0/1 or more times *) val create_many : ?at_least_one:bool -> name:string -> doc:string -> 'a setter -> ('a list, unit Flag.t) t (* this flag can occur at most once *) (* name, doc, setter triples *) val create_choice : ?default:('a * ('a -> string)) -> (string * string * 'a setter) list -> ('a, unit Flag.t list) t val create_choice_optional : (string * string * 'a setter) list -> ('a option, unit Flag.t list) t val create_set : name:string -> doc:string -> (bool, unit Flag.t) t val create_rest : ?name:string -> doc:string -> unit -> (string list option, unit Flag.t) t end module Helpers : sig exception Found_anonymous_arguments val no_anons : 'a -> string list -> 'a end val of_core_command : Core.Std.Command.t -> t core_extended-113.00.00/src/deprecated_fcommand.ml000066400000000000000000000174161256461102500217240ustar00rootroot00000000000000(** DEPRECATED: use Core.Std.Command instead *) open Core.Std module Anons_grammar : sig type t val empty : t val atom : string -> t val many : string -> t val maybe : t -> t val concat : t -> t -> t val usage_arg : t -> string end = struct type number_of_anons = Fixed | Variable type t = (string * number_of_anons) option let empty = None let atom name = Some (name, Fixed) let many name = Some (Printf.sprintf "[%s ...]" name, Variable) let maybe t = match t with | None -> None (* strange, but not meaningless *) | Some (usage, _) -> Some (Printf.sprintf "[%s]" usage, Variable) let usage_arg = function | None -> "" | Some (usage_arg, _) -> usage_arg let concat anons1 anons2 = match anons1, anons2 with | None, anons | anons, None -> anons | Some (grammar1, num1), Some (grammar2, num2) -> match num1 with | Fixed -> Some (grammar1 ^ " " ^ grammar2, num2) | Variable -> failwithf "you may not specify any more anonymous arguments \ (e.g. %s) after optional anonymous arguments (e.g. %s)" grammar2 grammar1 () end type ('a, 'b) t = { f : ('a Lazy.t * string list -> 'b Lazy.t * string list); flags : unit Deprecated_command.Flag.t list; anons : Anons_grammar.t; } let cmp f g x = f (g x) let (++) t1 t2 = { f = cmp t2.f t1.f; flags = t2.flags @ t1.flags; anons = Anons_grammar.concat t1.anons t2.anons; } let step f = { f = (fun (thunk, anons) -> (lazy (f (Lazy.force thunk)), anons)); flags = []; anons = Anons_grammar.empty; } let const x = step (fun k -> k x) let empty () = step Fn.id let either name = step (fun f x1 x2 -> match (x1, x2) with | None, None -> f None | Some x, None | None, Some x -> f (Some x) | Some _, Some _ -> failwithf "Please specify at most one %s argument" name ()) type 'a parse = string -> 'a let string : string parse = Fn.id let int : int parse = Int.of_string let float : float parse = Float.of_string let date : Date.t parse = Date.of_string let sexp : Sexp.t parse = Sexp.of_string let parse_aux ~name ~of_string arg = match Result.try_with (fun () -> of_string arg) with | Ok v -> v | Error exn -> failwithf "failed to parse %s value %S -- %s" name arg (Exn.to_string exn) () module Flag = struct type 'a state = { action : unit Deprecated_command.Flag.Action.t; read : unit -> 'a; } type 'a t = string -> 'a state let arg_flag name of_string read write = { read = read; action = Deprecated_command.Flag.Action.arg (fun () arg -> write (parse_aux ~name ~of_string arg)); } let write_option name v arg = match !v with | None -> v := Some arg | Some _ -> failwithf "flag %s passed more than once" name () let required_value ?default of_string name = let v = ref None in let read () = match !v with | Some v -> v | None -> match default with | Some v -> v | None -> failwithf "missing required flag %s" name () in let write arg = write_option name v arg in arg_flag name of_string read write let required of_string name = required_value of_string name let optional_with_default default of_string name = required_value ~default of_string name let optional of_string name = let v = ref None in let read () = !v in let write arg = write_option name v arg in arg_flag name of_string read write let no_arg name = let v = ref `Absent in let read () = !v in let write () = match !v with | `Absent -> v := `Present | `Present -> failwithf "flag %s passed more than once" name () in { read; action = Deprecated_command.Flag.Action.noarg write } let listed of_string name = let v = ref [] in let read () = List.rev !v in let write arg = v := arg :: !v in arg_flag name of_string read write let map ~f t name = let s = t name in { s with read = fun () -> f (s.read ()) } let no_arg_bool name = map no_arg name ~f:(function | `Present -> true | `Absent -> false) let capture_remaining_command_line _ = let cell = ref None in let action = Deprecated_command.Flag.Action.rest (fun () cmd_line -> cell := Some cmd_line) in let read () = !cell in { action; read } let flag name mode ~doc = let state = mode name in { f = (fun (k, anons) -> let v = state.read () in (lazy (Lazy.force k v), anons)); flags = [Deprecated_command.Flag.create ~name ~doc state.action]; anons = Anons_grammar.empty; } end include struct open Flag let capture_remaining_command_line = capture_remaining_command_line let flag = flag let listed = listed let no_arg = no_arg let no_arg_bool = no_arg_bool let optional = optional let optional_with_default = optional_with_default let required = required end module Anons = struct type 'a t = { m : (string list -> 'a * string list); grammar : Anons_grammar.t; } let return a = fun anons -> (a, anons) let (>>=) m f = fun anons -> let (a, anons) = m anons in f a anons let map ~f t = { t with m = t.m >>= fun a -> return (f a) } let parse (name, of_string) = function | [] -> failwithf "missing anonymous argument %s" name () | anon :: anons -> (parse_aux ~name ~of_string anon, anons) let (%:) name of_string = { m = parse (name, of_string); grammar = Anons_grammar.atom name; } let zero = { m = return (); grammar = Anons_grammar.empty; } let (+) = Anons_grammar.concat let t2 t1 t2 = { m = begin t1.m >>= fun a1 -> t2.m >>= fun a2 -> return (a1, a2) end; grammar = t1.grammar + t2.grammar; } let t3 t1 t2 t3 = { m = begin t1.m >>= fun a1 -> t2.m >>= fun a2 -> t3.m >>= fun a3 -> return (a1, a2, a3) end; grammar = t1.grammar + (t2.grammar + t3.grammar); } let t4 t1 t2 t3 t4 = { m = begin t1.m >>= fun a1 -> t2.m >>= fun a2 -> t3.m >>= fun a3 -> t4.m >>= fun a4 -> return (a1, a2, a3, a4) end; grammar = t1.grammar + (t2.grammar + (t3.grammar + t4.grammar)); } let maybe t = { m = (function | [] -> (None, []) | anons -> let (a, anons) = t.m anons in (Some a, anons)); grammar = Anons_grammar.maybe t.grammar; } let maybe_with_default default t = map (maybe t) ~f:(function | None -> default | Some v -> v) let evermore a = let rec loop acc anons = match anons with | [] -> (List.rev acc, []) | _ -> let (v, anons) = parse a anons in loop (v :: acc) anons in loop [] let many name of_string = { m = evermore (name, of_string); grammar = Anons_grammar.many name; } let anon t = { f = (fun (k, anons) -> let (v, remaining_anons) = t.m anons in (lazy (Lazy.force k v), remaining_anons) ); flags = []; anons = t.grammar; } end include struct open Anons let anon = anon let (%:) = (%:) let many = many let maybe = maybe let maybe_with_default = maybe_with_default let t2 = t2 let t3 = t3 let t4 = t4 let zero = zero end let cmd ~summary ?readme ?autocomplete ?(global_flags = []) t main = let flags = t.flags @ global_flags in let flag_names = List.map ~f:Deprecated_command.Flag.name flags in Option.iter (List.find_a_dup ~compare:String.compare flag_names) ~f:(fun dup -> failwithf "Duplicate flag name: %S" dup ()); Deprecated_command.create ~summary ?readme ?autocomplete ~usage_arg:(Anons_grammar.usage_arg t.anons) ~init:Fn.id ~flags ~final:(fun () anons -> let (thunk, remaining_anons) = t.f (lazy main, anons) in match remaining_anons with | [] -> thunk | _ -> failwithf "%d too many anonymous arguments" (List.length remaining_anons) () ) Lazy.force core_extended-113.00.00/src/deprecated_fcommand.mli000066400000000000000000000071531256461102500220720ustar00rootroot00000000000000(** DEPRECATED: use Core.Std.Command instead *) open Core.Std (** This module is a wrapper around Command that allows you to do away with accumulators. Here's an example: Fcommand.cmd ~summary:"Frobnicate something" Fcommand.( flag "-n" (required int) ~doc:"N number of times to frobnicate" ++ anon (args "item" string)) (fun n items -> ...) *) (** [('main_in, 'main_out) t] is a type of composable command-line specifications. Every combinator for building [t]-values is polymorphic in ['main_out]. In the final specification expected by [cmd] used to construct a command, ['main_out] is specialized to [unit]). Various primitive specifications add parameters one at a time, so the resulting type of [main] is [arg1 -> ... -> argN -> unit] It may help to think of [('a, 'b) t] as a function space ['a -> 'b] embellished with extra information about how to parse command line, including documentation about what various flags are for. *) type ('main_in, 'main_out) t (** argument parsing *) type 'a parse = string -> 'a val string : string parse val int : int parse val float : float parse val date : Date.t parse val sexp : Sexp.t parse (** flags *) module Flag : sig type 'a t (** a flag specification *) val map : f:('a -> 'b) -> 'a t -> 'b t end val required : 'a parse -> 'a Flag.t val optional : 'a parse -> 'a option Flag.t val optional_with_default : 'a -> 'a parse -> 'a Flag.t val listed : 'a parse -> 'a list Flag.t val no_arg : [`Present | `Absent] Flag.t val no_arg_bool : bool Flag.t val capture_remaining_command_line : string list option Flag.t val flag : string -> 'a Flag.t -> doc:string -> ('a -> 'm, 'm) t (** anonymous arguments *) module Anons : sig type 'a t (** anonymous args specification *) val map : f:('a -> 'b) -> 'a t -> 'b t end val (%:) : string -> 'a parse -> 'a Anons.t val many : string -> 'a parse -> 'a list Anons.t val maybe : 'a Anons.t -> 'a option Anons.t val maybe_with_default : 'a -> 'a Anons.t -> 'a Anons.t val zero : unit Anons.t val t2 : 'a Anons.t -> 'b Anons.t -> ('a * 'b) Anons.t val t3 : 'a Anons.t -> 'b Anons.t -> 'c Anons.t -> ('a * 'b * 'c) Anons.t val t4 : 'a Anons.t -> 'b Anons.t -> 'c Anons.t -> 'd Anons.t -> ('a * 'b * 'c * 'd) Anons.t val anon : 'a Anons.t -> ('a -> 'm, 'm) t (** various combinators *) (* [empty ()] is a no-op *) val empty : unit -> ('a, 'a) t (* [const v] injects the value [v] into main's parameters *) val const : 'a -> ('a -> 'm, 'm) t (* [either name ++ spec1 ++ spec2] ensures that at most one spec is supplied *) val either : string -> ('a option -> 'b, 'a option -> 'a option -> 'b) t (** [spec1 ++ spec2] composes command-line specifications [spec1] and [spec2]. Parameters specified by [spec1] will come before those specified by [spec2] in the eventual main function. *) val (++) : ('m1, 'm2) t -> ('m2, 'm3) t -> ('m1, 'm3) t (** [step] allows you to transform the way parameters are applied. For example, if you want labelled arguments, you can do: Fcommand.cmd ~summary:"..." Fcommand.( step (fun main x y z -> main ~x ~y ~z) ++ flag "-x" (optional string) ~doc:"..." ++ flag "-y" (required string) ~doc:"..." ++ flag "-z" (optional int) ~doc:"..." ) (fun ~x ~y ~z -> ... ) *) val step : ('m1 -> 'm2) -> ('m1, 'm2) t (** constructing the command we've specified *) val cmd : summary:string -> ?readme:(unit -> string) -> ?autocomplete:Deprecated_command.Autocomplete.t -> ?global_flags:(unit Deprecated_command.Flag.t list) -> ('main, unit) t -> 'main -> Deprecated_command.t core_extended-113.00.00/src/deprecated_service_command.ml000066400000000000000000000074341256461102500232750ustar00rootroot00000000000000open Core.Std let command ~lock_file ~name main = let start_main () = let release_parent = Daemon.daemonize_wait () in (* lock file created after [daemonize_wait] so that *child* pid is written to the lock file rather than the parent pid *) if Lock_file.create ~close_on_exec:true ~unlink_on_exit:true lock_file (* this writes our pid in the file *) then begin (* we release the daemon's parent *after* the lock file is created so that any error messages during lock file creation happen prior to severing the daemon's connection to std{out,err} *) let release_parent = Staged.unstage release_parent in release_parent (); main () end; 0 in let check_lock_file () = if Lock_file.is_locked lock_file then begin let pid = Pid.t_of_sexp (Sexp.load_sexp lock_file) in `Running_with_pid pid end else `Not_running in let still_alive pid = (* receiving [Signal.zero] is a no-op, but sending it gives info about whether there a running process with that pid *) match Signal.send Signal.zero (`Pid pid) with | `Ok -> true | `No_such_process -> false in let status_main () = begin match check_lock_file () with | `Not_running -> printf "%s is not running\n%!" name | `Running_with_pid pid -> if still_alive pid then printf !"%s is running with pid %{Pid}\n%!" name pid else printf !"%s is not running, even though we saw pid %{Pid} in its lockfile\n%!" name pid end; 0 in let stop_aux ~stop_signal = let was_not_running () = eprintf "%s was not running\n%!" name; `Was_not_running in match check_lock_file () with | `Not_running -> was_not_running () | `Running_with_pid pid -> let timeout_span = sec 10. in let deadline = Time.add (Time.now ()) timeout_span in match Signal.send stop_signal (`Pid pid) with | `No_such_process -> was_not_running () | `Ok -> let rec wait_loop () = if Time.(>=) (Time.now ()) deadline then begin eprintf "failed to observe %s die after %s\n%!" name (Time.Span.to_string timeout_span); `Did_not_die end else if still_alive pid then begin Time.pause (sec 0.2); wait_loop () end else `Died in wait_loop () in let stop_main ~stop_signal = match stop_aux ~stop_signal with | `Was_not_running | `Did_not_die -> 1 | `Died -> 0 in let restart_main ~stop_signal = match stop_aux ~stop_signal with | `Did_not_die -> 1 | `Was_not_running | `Died -> start_main () in let summary ~verb = sprintf "%s %s" verb name in let assert_no_anons anons = match anons with | [] -> () | anons -> failwithf "expected 0 anonymous arguments but found %d\n%!" (List.length anons) () in let base_cmd ~verb main = Deprecated_command.create (fun () -> exit (main ())) ~summary:(summary ~verb) ~usage_arg:"" ~init:Fn.id ~flags:[] ~final:(fun () anons -> assert_no_anons anons) in let stop_cmd ~verb main = Deprecated_command.create (fun stop_signal -> exit (main ~stop_signal)) ~summary:(summary ~verb) ~usage_arg:"[-kill]" ~init:(Fn.const Signal.term) ~flags:[ Deprecated_command.Flag.noarg_acc "-kill" (Fn.const Signal.kill) ~doc:" send SIGKILL instead of SIGTERM" ] ~final:(fun signal anons -> assert_no_anons anons; signal) in Deprecated_command.group ~summary:(summary ~verb:"manage") [ ("start", base_cmd ~verb:"start" start_main); ("stop", stop_cmd ~verb:"stop" stop_main); ("restart", stop_cmd ~verb:"restart" restart_main); ("status", base_cmd ~verb:"check status of" status_main); ] core_extended-113.00.00/src/deprecated_service_command.mli000066400000000000000000000012071256461102500234360ustar00rootroot00000000000000(** [command ~lock_file ~name main] creates a command group for starting, stopping, restarting, and checking the status of a daemon (the code for which lives in the argument [main]). This family of commands uses a [lock_file] to ensure that two instances of the daemon don't run concurrently on the same machine. The [name] parameter is used to name the daemon in the command help and various error messages. [lock_file] should be on the local file system (for example in /var/tmp) since file locking doesn't work over NFS. *) val command : lock_file:string -> name:string -> (unit -> unit) -> Deprecated_command.t core_extended-113.00.00/src/documented_match_statement.ml000066400000000000000000000057211256461102500233430ustar00rootroot00000000000000open Core.Std type ('input,'output) case = { pattern : 'input list; documentation : string; value : 'output; } let map_case case ~f_pattern ~f_value = { case with pattern = List.map case.pattern ~f:f_pattern; value = f_value case.value; } type ('input,'output) t = { specific_cases : ('input, unit -> 'output) case list; catchall_case : [`Used of ([ `Catchall ], 'input -> 'output ) case | `Unused of unit -> 'output]; } let map t ~f = { specific_cases = List.map t.specific_cases ~f:(map_case ~f_pattern:ident ~f_value:(fun value -> fun () -> f (value ()))); catchall_case = begin match t.catchall_case with | `Unused g -> `Unused (fun () -> f (g ())) | `Used case -> `Used (map_case case ~f_pattern:ident ~f_value:(fun g -> (fun k -> f (g k)))) end; } let map_pattern t ~f1 ~f2 = { specific_cases = List.map t.specific_cases ~f:(map_case ~f_pattern:f1 ~f_value:ident); catchall_case = begin match t.catchall_case with | `Unused x -> `Unused x | `Used case -> `Used (map_case case ~f_pattern:ident ~f_value:(fun g -> (fun k -> (g (f2 k))))) end; } let map_case case ~f = map_case case ~f_pattern:ident ~f_value:(fun g () -> f (g ())) let map_cases cases ~f = List.map cases ~f:(map_case ~f) let prepend ~specific_cases t = { t with specific_cases = specific_cases @ t.specific_cases; } let match_ t x = match List.filter t.specific_cases ~f:(fun { pattern = x'; documentation=_; value=_ } -> List.exists x' ~f:(fun y -> x = y)) with | case1::case2::_ -> failwithf "pattern appears twice in documented_match (%s,%s)" case1.documentation case2.documentation () | [case] -> case.value () | [] -> begin match t.catchall_case with | `Used case -> case.value x | `Unused f -> f () end let documentation t ~input_to_string ~title = let to_multiline_doc l = let to_multiline_doc (left,right) = List.mapi (String.split right ~on:'\n') ~f:(fun i right' -> if i = 0 then (left,right') else ("",right')) in List.concat_map l ~f:to_multiline_doc in let specific_case_lines = List.map t.specific_cases ~f:(fun case -> String.concat ~sep:", " (List.map ~f:input_to_string case.pattern), case.documentation ) |! to_multiline_doc in let catchall_case_lines = to_multiline_doc ( match t.catchall_case with | `Unused _ -> [] | `Used catchall -> [ "any other key", catchall.documentation ] ) in let header = [ "Key", "Action"; "---", "------"; ] in let lines = header @ specific_case_lines @ catchall_case_lines in let left_length = List.fold lines ~init:0 ~f:(fun max_length (key_string,_) -> max max_length (String.length key_string)) in title :: "" :: List.map lines ~f:(fun (key_string,documentation) -> let str_len = String.length key_string in key_string ^ String.make (left_length - str_len + 5) ' ' ^ documentation) core_extended-113.00.00/src/documented_match_statement.mli000066400000000000000000000046571256461102500235230ustar00rootroot00000000000000(** A [t] represents a match statement where every case is documented. You can then use it in one way to extract documentation, and in another way as the underlying function. More specifically, an [('input,'output) t] represents a match statement matching things of type [input'] and producing things of type ['output]. It consists of [specific_cases] and a [catchall_case]. The [specific_cases] are straightforward: [{pattern=pattern;documentation=documentation;value=value}] represents "| pattern -> value", with [documentation] explaining what's going on. The [catchall_case] can be either [`Unused x], representing "| _ -> x" with no documentation, or [`Used case], representing "| x -> f x", where [f] is [case.value], and [case.documentation] explains what's going on with [f]. This is intended to allow many input values to be handled uniformly without having to document each one individually. *) type ('input,'output) case = { pattern : 'input list; documentation : string; value : 'output; } type ('input,'output) t = { specific_cases : ('input, unit -> 'output) case list; catchall_case : [ `Used of ([ `Catchall ], 'input -> 'output ) case | `Unused of unit -> 'output]; } val map : ('input,'output1) t -> f:('output1 -> 'output2) -> ('input,'output2) t val map_case : ('input, unit -> 'output1) case -> f:('output1 -> 'output2) -> ('input, unit -> 'output2) case val map_cases : ('input, unit -> 'output1) case list -> f:('output1 -> 'output2) -> ('input, unit -> 'output2) case list val map_pattern : ('input1, 'output) t -> f1:('input1 -> 'input2) -> f2:('input2 -> 'input1) -> ('input2,'output) t (** [prepend ~specific_cases t] matches on [specific_cases] before moving on to [t]. A common situation is representing let f t x = match x with | `A -> ... | `B -> ... | _ -> {t with field = g t.field x} which can be done by combining [prepend] and [map]: let f' = prepend ~specific_cases:[{pattern = `A;...};{pattern = `B;...}] (map g' ~f:(fun h t -> {t with field = h t.field})) *) val prepend : specific_cases:('input, unit -> 'output) case list -> ('input,'output) t -> ('input,'output) t (** [match_ t] pulls out the underlying function of [t] *) val match_ : ('input,'output) t -> 'input -> 'output val documentation : ('input, 'output) t -> input_to_string:('input -> string) -> title:string -> string list core_extended-113.00.00/src/english.ml000066400000000000000000000052021256461102500173770ustar00rootroot00000000000000open Core.Std let parse_int = function | "one" -> 1 | "two" -> 2 | "three" -> 3 | "four" -> 4 | "five" -> 5 | "six" -> 6 | "seven" -> 7 | "eight" -> 8 | "nine" -> 9 | "ten" -> 10 | "eleven" -> 11 | "twelve" -> 12 | "thirteen" -> 13 | "fourteen" -> 14 | "fifteen" -> 15 | "sixteen" -> 16 | "seventeen" -> 17 | "eighteen" -> 18 | "nineteen" -> 19 | "twenty" -> 20 | s -> int_of_string s let failure which s = let which_s = match which with | `date -> "date" | `time -> "time" in invalid_argf "Unrecognized %s format \"%s\"" which_s s () let add_years d i = Date.add_months d (12 * i) let parse_date dt = let zone = Time.Zone.local in let dt' = String.lowercase dt in let failure () = failure `date dt in match dt' with | "today" -> Date.today ~zone | "yesterday" -> Date.add_days (Date.today ~zone) (-1) | "tomorrow" -> Date.add_days (Date.today ~zone) 1 | _ -> try Date.of_string dt with | Invalid_argument _ -> try match String.split_on_chars dt' ~on:[ ' '; '\t'; '\n'; '\r'; '_' ] with | [num; "days"] | [num; "days"; "hence"] -> Date.add_days (Date.today ~zone) (parse_int num) | [num; "weekdays"] | [num; "weekdays"; "hence"] -> Date.add_weekdays (Date.today ~zone) (parse_int num) | [num; "months"] | [num; "months"; "hence"] -> Date.add_months (Date.today ~zone) (parse_int num) | [num; "years"] | [num; "years"; "hence"] -> add_years (Date.today ~zone) (parse_int num) | [num; "days"; "ago"] -> Date.add_days (Date.today ~zone) ( -(parse_int num)) | [num; "weekdays"; "ago"] -> Date.add_weekdays (Date.today ~zone) ( -(parse_int num)) | [num; "months"; "ago"] -> Date.add_months (Date.today ~zone) ( -(parse_int num)) | [num; "years"; "ago"] -> add_years (Date.today ~zone) ( -(parse_int num)) | _ -> failure () with | _ -> failure () let parse_time ts = let failure () = failure `time ts in try Time.of_string ts with _ -> let words = Array.of_list (String.split ts ~on:' ') in match Array.findi words ~f:(fun _i word -> word = "at") with | None -> failure () | Some (idx, _) -> let range_to_string idx1 idx2 = String.concat ( Array.to_list (Array.slice words idx1 idx2) ) ~sep:" " in let date = parse_date (range_to_string 0 idx) in let rest = range_to_string (idx + 1) 0 in Time.of_string (Date.to_string date ^ " " ^ rest) core_extended-113.00.00/src/english.mli000066400000000000000000000013571256461102500175570ustar00rootroot00000000000000(** Translating English into useful data structures *) open Core.Std (** [parse_int s]: Like standard int_of_string, but try to convert the first twenty english numbers (eg. "one", "two", ... "twenty") [parse_int "thirteen"] [- : int = 13] [parse_int "5296"] [- : int = 5296] [parse_int "twenty five"] [Exception: (Failure int_of_string).] *) val parse_int : string -> int (** [parse_date s]: Convert a date in plain english (eg. "yesterday," "tomorrow," etc.) to a Date.t [parse_date "Yesterday"] [parse_date "6 8 2010"] [parse_date "4 days hence"] [parse_date "24 weekdays ago"] *) val parse_date : string -> Date.t (* just uses [parse_date] for the date part *) val parse_time : string -> Time.t core_extended-113.00.00/src/environment.ml000066400000000000000000000016021256461102500203120ustar00rootroot00000000000000open Core.Std module Assoc = List.Assoc type t = (string, string) Assoc.t let add ~key ~data t = Assoc.add t key data let find ~key t = Assoc.find t key let find_exn ~key t = Assoc.find_exn t key let mem ~key t = Assoc.mem t key let remove ~key t = Assoc.remove t key let import_from_sys ?default ~key t = match Sys.getenv key, default with | Some data, _ | None, Some data -> Assoc.add t key data | _ -> t let append_to_path ?(where=`Back) ~key ~data t = match Assoc.find t key with | Some "" | None -> Assoc.add t key data | Some old_path -> let data = match where with | `Front -> data ^ ":" ^ old_path | `Back -> old_path ^ ":" ^ data in Assoc.add t key data let to_exec_env env = List.map env ~f:(fun (k,v) -> k ^ "=" ^ v) let of_exec_env env = Array.to_list (Array.map env ~f:(String.lsplit2_exn ~on:'=')) core_extended-113.00.00/src/environment.mli000066400000000000000000000026021256461102500204640ustar00rootroot00000000000000open Core.Std type t = (string, string) List.Assoc.t (* These functions are similar to their List.Assoc counterparts *) val add : key:string -> data:string -> t -> t val find : key:string -> t -> string option val find_exn : key:string -> t -> string val mem : key:string -> t -> bool val remove : key:string -> t -> t (* Attempt to import a value in from the system environment If no system environment value is found and a default is provided, use that instead *) val import_from_sys : ?default:string -> key:string -> t -> t (* Appends a new value to the end of a path value. If [where] is `Front, add it to the front of the path specification. if it is `Back, add it to the back. `Back is the default. eg: [ add_to_path ~where:`Back [("PATH", "/bin:/usr/bin")] "PATH" "/usr/local/bin" = [("PATH", "/bin:/usr/bin:/usr/local/bin")] ] [ add_to_path ~where:`Front [("PATH", "/bin:/usr/bin")] "PATH" "/home/foo/bin" = [("PATH", "/home/foo/bin:/bin:/usr/bin")] ] *) val append_to_path : ?where:[`Front|`Back] -> key:string -> data:string -> t -> t (* Converts the Env.t into a value suitable for passing to Unix.exec and friends *) val to_exec_env : t -> string list (* Converts the a Unix.environment style environment into a Env.t *) val of_exec_env : string array -> t core_extended-113.00.00/src/exception_check.ml000066400000000000000000000046541256461102500211130ustar00rootroot00000000000000open Core.Std type t = { known_exceptions : exn String.Table.t; scheduled_exceptions : exn String.Table.t; lock : Mutex.t; (* guards reading/writing of the two tables above *) } let t = ref None let create ?(listen_port = 65100) exns = let ctx = { known_exceptions = String.Table.create ~size:1024 (); scheduled_exceptions = String.Table.create ~size:1024 (); lock = Mutex.create () } in List.iter exns ~f:(fun (c, exn) -> match Hashtbl.find ctx.known_exceptions c with | Some _ -> raise (Invalid_argument (sprintf "duplicate exception definition: %s" c)) | None -> Hashtbl.set ctx.known_exceptions ~key:c ~data:exn); let (_: Thread.t) = let module U = Unix in let clients = ref [] in let push fd = clients := fd :: !clients in let remove fd = clients := List.filter !clients ~f:(fun cl -> cl <> fd) in Thread.create (fun () -> let s = U.socket ~domain:U.PF_INET ~kind:U.SOCK_STREAM ~protocol:0 in U.bind s ~addr:(U.ADDR_INET (U.Inet_addr.bind_any, listen_port)); U.listen s ~max:10; U.set_nonblock s; while true do try let { U.Select_fds.read = rd; write=_; except=_ } = U.select ~read:(s :: !clients) ~write:[] ~except:[] ~timeout:`Never () in if List.exists rd ~f:(fun fd -> fd = s) then push (fst (U.accept s)); let rd = List.filter rd ~f:(fun fd -> fd <> s) in List.iter rd ~f:(fun fd -> let ic = U.in_channel_of_descr fd in let remove () = begin try U.close fd with _ -> () end; remove fd in try let line = input_line ic in Mutex.critical_section ctx.lock ~f:(fun () -> match Hashtbl.find ctx.known_exceptions line with | None -> () | Some exn -> Hashtbl.set ctx.scheduled_exceptions ~key:line ~data:exn) with _ -> remove ()) with U.Unix_error ((EAGAIN | EINTR | EWOULDBLOCK), _, _) -> () done) () in t := Some ctx let maybe_raise lst = match !t with | None -> () | Some t -> Mutex.critical_section t.lock ~f:(fun () -> List.iter lst ~f:(fun c -> match Hashtbl.find t.scheduled_exceptions c with | None -> () | Some exn -> Hashtbl.remove t.scheduled_exceptions c; raise exn)) core_extended-113.00.00/src/exception_check.mli000066400000000000000000000020411256461102500212500ustar00rootroot00000000000000(** Code to test the effect of exceptions happening in strategic places in daemons. In order to use this module one defines a list of (mnemonic, exception) pairs E.G. [("M.f: invalid arg", Invalid_argument "foo"); ("Z.f: sys error", Sys_error "bar"); ("R.z: failure", Failure "baz")] And one passes this list to create. Then one places calls to Exception_check.maybe_raise , in important parts of one's code. When the code is run, it will listen on [listen_port], and one can connect with netcat and type a name, which will cause that exception to be raised on the next call to [Exception_check.maybe_raise]. *) (** create should not be called more than once *) val create : ?listen_port:int -> (string * exn) list -> unit (** [maybe_raise name] if the exception associated with any name in [name] has been triggered, then raise it, otherwise do nothing. Only the first exception in the list will be raised. This function is thread safe. *) val maybe_raise : string list -> unit core_extended-113.00.00/src/extended_array.ml000066400000000000000000000013651256461102500207520ustar00rootroot00000000000000open Core.Std let foldi ~init ar ~f = fst (Array.fold ~init:(init,0) ar ~f:(fun (a,i) x -> f i a x,i+1)) TEST = 40 = foldi ~init:0 [|1;2;3;4;5|] ~f:(fun i a x -> a + i * x) let random_split ?random_state array ~p = let a = Array.copy array in if p > 1.0 || p < 0.0 then failwith "Array.random_split: p is out of bounds [0 1]"; let stop = Float.iround_exn ~dir:`Nearest (p *. (float (Array.length a))) in if stop = 0 then (* in slice a stop of 0 means slicing to the end of the array, which is not what we want *) ([||], a) else begin Array.permute a ?random_state; ((Array.slice a 0 stop), (Array.slice a stop 0)) end let random_sub ?random_state array ~p = fst (random_split ~p array ?random_state) core_extended-113.00.00/src/extended_array.mli000066400000000000000000000011241256461102500211140ustar00rootroot00000000000000(** Extensions to [Core.Core_array]. *) open Core.Std val foldi : init:'a -> 'b array -> f:(int -> 'a -> 'b -> 'a) -> 'a (** makes a random split & subset of an array; p (the fraction that you want to split) is constrained to be [0, 1]. Note that the length of the first array will be the closest integer to the fraction you desired, meaning that each element is NOT selected with probability exactly p. *) val random_split : ?random_state:Random.State.t -> 'a array -> p:float -> 'a array * 'a array val random_sub : ?random_state:Random.State.t -> 'a array -> p:float -> 'a array core_extended-113.00.00/src/extended_common.ml000066400000000000000000000043651256461102500211270ustar00rootroot00000000000000open Core.Std let run_main f = try f (); exit 0 with e -> eprintf !"Uncaught exception:\n%{Extended_exn}\n" e; if Caml.Printexc.backtrace_status () then begin Caml.Printexc.print_backtrace stderr; end; exit 1 (* Taken from diffprint; cleanup; move to using mmap and put in sys *) let file_content_ne f1 f2 = match (Extended_sys.file_kind f1),(Extended_sys.file_kind f2) with | Unix.S_LNK,Unix.S_LNK -> Unix.readlink f1 <> Unix.readlink f2 | Unix.S_REG,Unix.S_REG when (Unix.stat f1).Unix.st_size = (Unix.stat f2).Unix.st_size -> let input_nbchar ic = let rec loop () = match input_char ic with | ' ' | '\t' | '\n' -> loop () | c -> Some c in try loop () with End_of_file -> None in protectx (open_in f1,open_in f2) ~finally:(fun (ic1,ic2) -> In_channel.close ic1; In_channel.close ic2) ~f:(fun (ic1,ic2) -> let rec loop () = match input_nbchar ic1,input_nbchar ic2 with | None,None -> false | x,x' when x=x' -> loop () | _ -> true in loop () ) | _ -> true let write_wrap ?(mode:[`Clobber|`Append|`Atomic|`Atomic_update]=`Clobber) ~f fname = match mode with | (`Atomic | `Atomic_update) as mode -> let dirname,basename = Filename.split fname in let tmp_file,oc = Filename.open_temp_file ~perm:0o666 ~in_dir:dirname basename ".tmp" in protectx tmp_file ~f:(fun tmp_file -> let res = protectx oc ~f ~finally:Out_channel.close in let diff f1 f2 = try file_content_ne f1 f2 with _ -> true in begin match mode with | `Atomic_update when not (diff tmp_file fname) -> () | `Atomic | `Atomic_update -> Unix.link ~force:true ~target:tmp_file ~link_name:fname () end; res) ~finally:Unix.unlink | `Clobber -> protectx (open_out fname) ~f ~finally:Out_channel.close | `Append -> protectx (open_out_gen [Open_append;Open_creat] 0o666 fname) ~f ~finally:Out_channel.close core_extended-113.00.00/src/extended_common.mli000066400000000000000000000013741256461102500212750ustar00rootroot00000000000000(** Pervasive functions. *) val run_main : (unit -> unit) -> _ (** [write_wrap ~atomic ~f fname] Runs [f] on an [out_channel]. If [mode] is [`Atomic] or [`Atomic_update] is set all the changes will be written to a temporary file which will then be moved over [fname] otherwise we are writing straight to [fname]. Values for [mode]: - [`Clobber]: clear the file on opening (this is the default value) - [`Append]: append to the file - [`Atomic]: replace the file atomically when we are done writing it - [`Atomic_update]: replace the file atomically when we are done writing it iff its content has been modified. *) val write_wrap : ?mode:[`Clobber|`Append|`Atomic|`Atomic_update] -> f:(out_channel -> 'a) -> string -> 'a core_extended-113.00.00/src/extended_exn.ml000066400000000000000000000006741256461102500204300ustar00rootroot00000000000000open Core.Std let to_string = function | Failure s -> "Failure: " ^ s | e -> Caml.Printexc.to_string e let to_string_hum = function | Failure s -> s | e -> Caml.Printexc.to_string e let rec unwrap = function | Finally (e,_) -> unwrap e | e -> e module Exn_string = struct module T = struct type t = string with sexp, bin_io end include T include Sexpable.To_stringable (T) let of_exn exn = Exn.to_string exn end core_extended-113.00.00/src/extended_exn.mli000066400000000000000000000020721256461102500205730ustar00rootroot00000000000000(** Extensions to [Core.Exn].*) open Core.Std (** The [to_string] function is slightly tweaked to avoid escaping the string content of [Failure]. *) val to_string : exn -> string (** This is also an ever so slight variation of [to_string] target more at user than developers ([Failure s] is just printed as [s]) *) val to_string_hum : exn -> string (** [unwrap e] Tries to unwrap an exception to find the original cause of the error (Finally for instance has the propency to burry exception...). This is useful when matching on exceptions. *) val unwrap : exn -> exn (** The point of this module is to be able to include an exn in a type that has to be sexpable or binable. The [Exn_string.t] type is more descriptive than just converting to a string and is guaranteed to have come from an exn (unless someone abuses the [t_of_sexp] function or something). *) module Exn_string : sig type t = private string include Sexpable with type t := t include Stringable with type t := t include Binable with type t := t val of_exn : exn -> t end core_extended-113.00.00/src/extended_filename.ml000066400000000000000000000135641256461102500214200ustar00rootroot00000000000000open Core.Std open Filename (** Path *) let explode path = let rec aux = function | "" | "." -> [] | "/" -> ["/"] | path -> let dirname, basename = split path in basename :: aux dirname in List.rev (aux path) let implode = function | [] -> "." | "/"::rest -> "/" ^ (String.concat ~sep:"/" rest) | l -> String.concat ~sep:"/" l (* Takes out all "../" and "./" in a path, except that if it's a relative path it may start with some "../../" stuff at the front. *) let normalize_path p = List.fold p ~init:[] ~f:(fun acc path_element -> match path_element, acc with (* parent of root is root, and root can only appear as first part of path *) | "..", ["/"] -> ["/"] (* just pop the stack, e.g. /foo/bar/../ becomes just /foo/ *) | "..", h::rest when h <> ".." -> rest | ".", v -> v | _ -> path_element :: acc (* accumulate regular dirs or chains of ... at the beginning of a relative path*)) |! List.rev let make_relative ?to_ f = if to_ = None && is_relative f then f else let to_ = match to_ with | Some dir -> if is_relative f <> is_relative dir then failwithf "make_relative ~to_:%s %s: cannot work on an absolute path and a \ relative one" dir f (); dir | None -> Sys.getcwd () in let rec aux = function | (h :: t), (h' :: t') when String.equal h h' -> aux (t,t') | ".."::_, _ -> failwithf "make_relative ~to_:%s %s: negative lookahead (ie goes \"above\" the current directory)" to_ f () | p, p' -> (List.map ~f:(fun _ -> parent_dir_name) p) @ p' in let to_ = normalize_path (explode to_) and f = normalize_path (explode f) in implode (aux (to_,f)) TEST_MODULE "make_relative" = struct let make_relative ~to_ f = try Some (make_relative ~to_ f) with Failure _ -> None TEST = make_relative ~to_:".." "a" = None TEST = make_relative ~to_:".." "../a"= Some "a" TEST = make_relative ~to_:"c" "a/b" = Some "../a/b" TEST = make_relative ~to_:"/" "a/b" = None end let normalize p = implode (normalize_path (explode p)) TEST_MODULE "normalize" = struct TEST "id" = normalize "/mnt/local" ="/mnt/local" TEST "dot_dotdot" = normalize "/mnt/./../local" = "/local" TEST = normalize "/mnt/local/../global/foo" = "/mnt/global/foo" TEST "beyond_root" = normalize "/mnt/local/../../.." = "/" TEST "negative_lookahead" = normalize "../a/../../b" = "../../b" end let (//) src p = if is_absolute p then p else concat src p let make_absolute p = Sys.getcwd () // p let user_home username = match Unix.Passwd.getbyname username with | Some user -> let pw_dir = user.Unix.Passwd.dir in if String.length pw_dir = 0 then failwithf "user's \"%s\"'s home is an empty string" username () else pw_dir | None -> failwithf "user \"%s\" not found" username () let expand_user s = let expand_home = function | "~" -> user_home (Shell__core.whoami ()) | s -> user_home (String.chop_prefix_exn s ~prefix:"~") in if (String.is_prefix ~prefix:"~" s) then match String.lsplit2 ~on:'/' s with | Some (base,rest) -> expand_home base ^ "/" ^ rest | None -> expand_home s else s let expand ?(from=".") p = normalize (Sys.getcwd () // from // expand_user p) let rec is_parent_path p1 p2 = match p1, p2 with | ["/"], _ -> true | ((h1 :: p1) as l), (h2 :: p2) -> (h1 = h2 && is_parent_path p1 p2) || (h2 <> ".." && h2 <> "/" && List.for_all l ~f:((=) parent_dir_name)) | l, [] -> List.for_all l ~f:((=) parent_dir_name) | [], (h :: _) -> h <> ".." && h <> "/" let is_parent f1 f2 = is_parent_path (normalize_path (explode f1)) (normalize_path (explode f2)) (** Filename comparison *) (* Extension comparison: We have a list of lists of extension that should appear consecutive to one another. Our comparison function works by mapping extensions to (extension*int) couples, for instance "c" is mapped to "h,1" meaning it should come right after h. *) let create_extension_map l = List.fold l ~f:(fun init l -> match l with | [] -> init | idx::_ -> List.foldi l ~f:(fun pos map v -> if Map.mem map v then failwithf "Extension %s is defined twice" v (); Map.add map ~key:v ~data:(idx,pos) ) ~init ) ~init:Map.Poly.empty let extension_cmp map h1 h2 = let lookup e = Option.value (Map.find map e) ~default:(e,0) in Tuple2.compare (lookup h1) (lookup h2) ~cmp1:(Extended_string.collate) ~cmp2:(Int.compare) let basename_compare map f1 f2 = let ext_split s = Option.value (String.lsplit2 ~on:'.' s) ~default:(s,"") in Tuple2.compare (ext_split f1) (ext_split f2) ~cmp1:(Extended_string.collate) ~cmp2:(extension_cmp map) let filename_compare map v1 v2 = let v1 = explode v1 and v2 = explode v2 in List.compare (basename_compare map) v1 v2 let parent p = normalize (concat p parent_dir_name) TEST_MODULE "parent" = struct TEST = parent "/mnt/local" = "/mnt" TEST = parent "/mnt/local/../global/foo" = "/mnt/global" TEST = parent "/mnt/local/../../global" = "/" end let extension_map = create_extension_map [["h";"c"];["mli";"ml"]] let compare = filename_compare extension_map let with_open_temp_file ?in_dir ?(write=ignore) ~f prefix suffix = protectx (open_temp_file ?in_dir prefix suffix) ~f:(fun (fname,oc) -> protectx oc ~f:write ~finally:Out_channel.close; f fname) ~finally:(fun (fname,_) -> Unix.unlink fname) let with_temp_dir ?in_dir prefix suffix ~f = protectx (temp_dir ?in_dir prefix suffix) ~f ~finally:(fun dirname -> ignore (Sys.command (sprintf "rm -rf '%s'" dirname))) core_extended-113.00.00/src/extended_filename.mli000066400000000000000000000050171256461102500215630ustar00rootroot00000000000000(** Extensions to [Core.Core_filename]. *) (** [normalize path] Removes as much "." and ".." from the path as possible. If the path is absolute they will all be removed. *) val normalize : string -> string (** [parent path] The parent of the root directory is the root directory @return the path to the parent of [path]. *) val parent : string -> string (** [make_relative ~to_:src f] returns [f] relative to [src]. @raise Failure if [is_relative f <> is_relative src] *) val make_relative : ?to_:string -> string -> string (** [make_absolute src] Turn [src] into an absolute path expanded from the current working directory. *) val make_absolute : string -> string (** [expand] Makes a path absolute and expands [~] [~username] to home directories. In case of error (e.g.: path home of a none existing user) raises [Failure] with a (hopefully) helpful message. *) val expand : ?from:string -> string -> string (** Splits a given path into a list of strings. *) val explode : string -> string list (** dual to explode *) val implode : string list -> string (**/**) (* this is exported because it is used by core_extended.filename. *) val normalize_path : string list -> string list (**/**) (** Filename.compare is a comparison that normalizes filenames ("./a" = "a"), uses a more human ready algorithm based on [String.collate] ("rfc02.txt > rfc1.txt") and extenstions ("a.c" > "a.h"). It is a total comparison on normalized filenames. *) val compare: string -> string -> int (** [with_open_temp_file ~write ~f prefix suffix] create a temporary file; runs [write] on its [out_channel] and then [f] on the resulting file. The file is removed once [f] is done running. *) val with_open_temp_file: ?in_dir: string -> ?write:(out_channel -> unit) -> f: (string -> 'a) -> string -> string -> 'a (** Runs [f] with a temporary dir as option and removes the directory afterwards. *) val with_temp_dir: ?in_dir:string -> string -> string -> f:(string -> 'a) -> 'a (** [is_parent dir1 dir2] returns [true] if [dir1] is a parent of [dir2] Note: This function is context independent, use [expand] if you want to consider relatives paths from a given point. In particular: - A directory is always the parent of itself. - The root is the parent of any directory - An absolute path is never the parent of relative one and vice versa. - ["../../a"] is never the parent of ["."] even if this could be true given form the current working directory. *) val is_parent : string -> string -> bool core_extended-113.00.00/src/extended_float.ml000066400000000000000000000076031256461102500207420ustar00rootroot00000000000000open Core.Std (* in place string reversal *) let s_rev s = let n = String.length s - 1 in if n >= 1 then for i = 0 to n/2 do let c1 = s.[i] and c2 = s.[n-i] in s.[i] <- c2; s.[n-i] <- c1 done; s (* We return the value to enable us to chain applications*) (* Same as [Int_conversions.prettify_string] but introduces the underscores counting from the left*) let rpretty s = s_rev (Int_conversions.insert_underscores (s_rev s)) let to_string_hum f = let s = Float.to_string f in match String.lsplit2 s ~on:'.' with | None -> s (*nan,infinity...*) | Some (ip,fpe) -> let ip = Int_conversions.insert_underscores ip in match String.lsplit2 fpe ~on:'e' with | None -> ip ^ "." ^ rpretty fpe | Some (fp,e) -> ip ^ "." ^ rpretty fp ^ "e" ^ e (** pretty prints positive floating point numbers with no more than four characters.*) let pretty_pos f = let round f = Float.to_int (Float.round ~dir:`Down (f +. 0.5)) in let drop_redundant_suffix s = let rec loop i = if i = 0 then 1 else match String.get s i with | '.' -> i | '0' -> loop (i - 1) | _ -> i + 1 in String.sub s ~pos:0 ~len:(loop (String.length s - 1)) in let decimal sign f = assert (0.9995 <= f && f < 999.5); let spot = if f < 9.995 then 1 else if f < 99.95 then 2 else 3 in let f = f *. 1000.0 /. (10.0 ** float spot) in assert (99.5 <= f && f < 999.5); let i = round f in assert (100 <= i && i <= 999); let d1 = i / 100 in let d2 = (i mod 100) / 10 in let d3 = i mod 10 in let s = match spot with | 1 -> sprintf "%d%s%d%d" d1 sign d2 d3 | 2 -> sprintf "%d%d%s%d" d1 d2 sign d3 | 3 -> sprintf "%d%d%d%s" d1 d2 d3 sign | _ -> assert false in drop_redundant_suffix s in if f < 0.004 then "0" else if f < 0.995 then let i = round (f *. 100.0) in drop_redundant_suffix (sprintf "0.%d%d" (i / 10) (i mod 10)) else if f < 0.9995 then "1" else if f < 99.95 then decimal "." f else if f < 10_000.0 then sprintf "%d" (round f) else if f < 999.5E3 then decimal "k" (f /. 1E3) else if f < 999.5E6 then decimal "m" (f /. 1E6) else if f < 999.5E9 then decimal "g" (f /. 1E9) else if f < 999.5E12 then decimal "t" (f /. 1E12) else "HUGE" let pretty ?(on_negative=`Normal) f = let module C = Float.Class in match Float.classify f with | C.Infinite when f < 0. && on_negative <> `Blow_up -> "-inf" | C.Infinite -> "inf" | C.Nan -> "nan" | C.Subnormal | C.Normal | C.Zero when (Float.abs f) < 0.005 -> "0" | C.Subnormal | C.Normal | C.Zero when f > 0. -> pretty_pos f | C.Subnormal | C.Normal | C.Zero -> match on_negative with | `Print_dir -> "<0" | `Blow_up -> failwithf "Float.pretty ~on_negative:`Print_dir blowing up on a \ negative number (as requested)" () | `Normal -> "-"^pretty_pos (~-. f) ;; let log_10 = let log_of_10 = log 10. in (fun x -> log x /. log_of_10) ;; (* by how many orders of magnitude do two floats differ? *) let order_of_magnitude_difference a b = let a = Float.abs a in let b = Float.abs b in let oom_diff = (Float.to_int (Float.round (log_10 (Float.abs (Float.max a b /. Float.min a b))))) in if oom_diff < 0 then 0 else oom_diff ;; module Verified_spec = struct include Float let module_name = "Float" end include Number.Make_verified_std (Verified_spec) module type Fraction = sig include S0 with type repr = Float.t val one : t val random : ?rng : Random.State.t -> unit -> t end module Fraction_unsafe = struct module Spec = struct let name = "Fraction" let lower = 0. let upper = 1. end include Make_bounded_unsafe (Spec) let zero = Float.zero let one = 1. let random ?(rng = Random.State.default) () = Random.State.float rng one end module Fraction = Fraction_unsafe core_extended-113.00.00/src/extended_float.mli000066400000000000000000000022341256461102500211060ustar00rootroot00000000000000open Core.Std (** Extensions to [Core.Float].*) val pretty : ?on_negative:[ `Blow_up | `Normal | `Print_dir ] -> float -> string (** pretty-print a float using no more than five characters, using abberviations k, m, g, t. if [on_negative] is not set to [`Normal] then the resulting is never over four chars but upon negative number we either: - raise a failure - or print ["<0"] *) val to_string_hum : float -> string (** [order_of_magnitude_difference a b] by how many orders of magnitude do [a] and [b] differ? The return value is non-negative. examples: - order_of_magnitude_difference 11. 1001. = 2 - order_of_magnitude_difference 1001. 11. = 2 - order_of_magnitude_difference 131. 11. = 1 - order_of_magnitude_difference 200. 0.003 = 5 *) val order_of_magnitude_difference : float -> float -> int include Number.Verified_std with type repr = Float.t module type Fraction = sig include S0 with type repr = Float.t val one : t val random : ?rng : Random.State.t -> unit -> t end module Fraction : Fraction with type t = private Float.t module Fraction_unsafe : Fraction with type t = Float.t core_extended-113.00.00/src/extended_gc.ml000066400000000000000000000016251256461102500202240ustar00rootroot00000000000000open Core.Std (* execute function supressing compactions. the doc says: mutable max_overhead : int; Heap compaction is triggered when the estimated amount of "wasted" memory is more than max_overhead percent of the amount of live data. If max_overhead is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If max_overhead >= 1000000, compaction is never triggered. Default: 500. *) let without_compactions ?logger ~f a = (* note that f may call get/set itself, and the fields in the Gc.control struct are mutable, so it does not make much sense to save it *) protectx (Gc.get ()).Gc.Control.max_overhead ~f:(fun _ -> Gc.tune ?logger ~max_overhead:1000000 (); f a) ~finally:(fun max_overhead -> Gc.tune ?logger ~max_overhead ()) (* external print_roots : unit -> unit = "print_roots" ;; *) core_extended-113.00.00/src/extended_gc.mli000066400000000000000000000012061256461102500203700ustar00rootroot00000000000000(** Extensions to [Core.Gc].*) (** [without_compactions f a] will call f a so that Gc.compact is never called during its execution, then restore compactions to the previous setting. *) val without_compactions : ?logger:(string -> unit) -> f:('a -> 'b) -> 'a -> 'b (* (* cdaemon can't seem to compile the C bindings, even though I can. *) (** [print_roots] will trace the ocaml stack/global runtime roots and print data types it recognizes to stderr. Its purpose is to aid discovery of space leaks, calling it as a normal matter of course is not recommended as it holds the global lock. *) val print_roots : unit -> unit *) core_extended-113.00.00/src/extended_hashtbl.ml000066400000000000000000000006701256461102500212570ustar00rootroot00000000000000open Core.Std module Access_control = struct type ('a,'b,'z) any = ('a,'b) Hashtbl.Poly.t with sexp, bin_io module Immutable = struct type ('a,'b) t = ('a,'b,immutable) any with sexp, bin_io end module Read_only = struct type ('a,'b) t = ('a,'b,read) any with sexp, bin_io end module Read_write = struct type ('a,'b) t = ('a,'b,read_write) any with sexp, bin_io end let of_hashtbl = Fn.id include Hashtbl end core_extended-113.00.00/src/extended_hashtbl.mli000066400000000000000000000067511256461102500214360ustar00rootroot00000000000000open Core.Std module Access_control : sig type ('key,'data,-'z) any module Immutable : sig type ('key,'data) t = ('key,'data,immutable) any include Sexpable.S2 with type ('key,'data) t := ('key,'data) t include Binable.S2 with type ('key,'data) t := ('key,'data) t end module Read_only : sig type ('key,'data) t = ('key,'data,read) any include Sexpable.S2 with type ('key,'data) t := ('key,'data) t include Binable.S2 with type ('key,'data) t := ('key,'data) t end module Read_write : sig type ('key,'data) t = ('key,'data, read_write) any include Sexpable.S2 with type ('key,'data) t := ('key,'data) t include Binable.S2 with type ('key,'data) t := ('key,'data) t end val of_hashtbl : ('key,'data) Hashtbl.t -> ('key,'data, [< _ perms]) any val clear : (_, _) Read_write.t -> unit val copy : ('a, 'b, [> read]) any -> ('a, 'b, [< _ perms]) any val fold : ('a, 'b, [> read]) any -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val iter : ('a, 'b, [> read]) any -> f:(key:'a -> data:'b -> unit) -> unit val existsi : ('a, 'b, [> read]) any -> f:(key: 'a -> data:'b -> bool) -> bool val exists : ('a, 'b, [> read]) any -> f:('b -> bool) -> bool val length : (_, _, _) any -> int val is_empty : (_, _, _) any -> bool val mem : ('a, _, [> read]) any -> 'a -> bool val remove : ('a, _) Read_write.t -> 'a -> unit val remove_one : ('a, _ list) Read_write.t -> 'a -> unit val replace : ('a, 'b) Read_write.t -> key:'a -> data:'b -> unit val set : ('a, 'b) Read_write.t -> key:'a -> data:'b -> unit val add : ('a, 'b) Read_write.t -> key:'a -> data:'b -> [ `Ok | `Duplicate ] val add_exn : ('a, 'b) Read_write.t -> key:'a -> data:'b -> unit val change : ('a, 'b) Read_write.t -> 'a -> ('b option -> 'b option) -> unit val add_multi : ('a, 'b list) Read_write.t -> key:'a -> data:'b -> unit val map : ('a, 'b, [> read]) any -> f:('b -> 'c) -> ('a, 'c, [< _ perms]) any val mapi : ('a, 'b, [> read]) any -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c, [< _ perms]) any val filter_map : ('a, 'b, [> read]) any -> f:('b -> 'c option) -> ('a, 'c, [< _ perms]) any val filter_mapi : ('a, 'b, [> read]) any -> f:(key:'a -> data:'b -> 'c option) -> ('a, 'c, [< _ perms]) any val filter : ('a, 'b, [> read]) any -> f:('b -> bool) -> ('a, 'b, [< _ perms]) any val filteri : ('a, 'b, [> read]) any -> f:(key:'a -> data:'b -> bool) -> ('a, 'b, [< _ perms]) any val find_or_add : ('a, 'b) Read_write.t -> 'a -> default:(unit -> 'b) -> 'b val find : ('a, 'b, [> read]) any -> 'a -> 'b option val find_exn : ('a, 'b, [> read]) any -> 'a -> 'b val iter_vals : ('a, 'b, [> read]) any -> f:('b -> unit) -> unit val merge : ('k, 'a, [> read]) any -> ('k, 'b, [> read]) any -> f:(key:'k -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c option) -> ('k, 'c, [< _ perms]) any val merge_into: f:(key:'a -> 'b -> 'b option -> 'b option) -> src:('a, 'b, [> read]) any -> dst:('a, 'b) Read_write.t -> unit val keys : ('a, 'b, [> read]) any -> 'a list val data : ('a, 'b, [> read]) any -> 'b list val filter_inplace : ('a, 'b) Read_write.t -> f:('b -> bool) -> unit val filteri_inplace : ('a, 'b) Read_write.t -> f:('a -> 'b -> bool) -> unit val equal : ('a, 'b, [> read]) any -> ('a, 'b, [> read]) any -> ('b -> 'b -> bool) -> bool val to_alist : ('a, 'b, [> read]) any -> ('a * 'b) list val incr : ?by:int -> ('a, int) Read_write.t -> 'a -> unit end core_extended-113.00.00/src/extended_int.ml000066400000000000000000000021221256461102500204160ustar00rootroot00000000000000(** Extensions to [Core.Core_int] *) module Verified_spec = struct include Core.Std.Int let module_name = "Int" end include Number.Make_verified_std (Verified_spec) external gcd : int -> int -> int = "core_extended_extended_int_gcd" "noalloc" TEST = gcd 120 72 = 24 TEST = gcd 13 17 = 1 TEST = gcd 12345 12345 = 12345 TEST = gcd 300 800 = 100 TEST = gcd 300 (-800) = 100 TEST = gcd (-300) 800 = 100 TEST = gcd (-300) (-800) = 100 TEST = gcd 800 300 = 100 TEST = gcd 800 (-300) = 100 TEST = gcd (-800) 300 = 100 TEST = gcd (-800) (-300) = 100 TEST = gcd 12 45 = 3 TEST = gcd min_int min_int = min_int TEST = gcd min_int 0 = min_int TEST = gcd min_int 24 = 8 TEST = gcd min_int 5 = 1 TEST = gcd min_int max_int = 1 TEST = gcd max_int max_int = max_int BENCH_MODULE "gcd" = struct let a = Array.init 1000 (fun _ -> Random.int 1_000_000) BENCH "gcd" = let a = Obj.magic a in for i = 0 to Array.length a - 1 do let a_i = Array.unsafe_get a i in for j = 0 to Array.length a - 1 do let a_j = Array.unsafe_get a j in ignore (gcd a_i a_j) done done end core_extended-113.00.00/src/extended_int.mli000066400000000000000000000005541256461102500205760ustar00rootroot00000000000000include Number.Verified_std with type repr = Core.Std.Int.t (** Computes greatest common divisor for the given two integers, with convention that [gcd 0 0 = 0]. Returns a nonnegative value unless one of the arguments is [Int.min_value] and the other is [Int.min_value] or 0, in which case [Int.min_value] is returned. *) val gcd : int -> int -> int core_extended-113.00.00/src/extended_int32.ml000066400000000000000000000002111256461102500205600ustar00rootroot00000000000000module Verified_spec = struct include Core.Std.Int32 let module_name = "Int32" end include Number.Make_verified_std (Verified_spec) core_extended-113.00.00/src/extended_int32.mli000066400000000000000000000001501256461102500207330ustar00rootroot00000000000000(** Extensions to [Core.Core_int32] *) include Number.Verified_std with type repr = Core.Std.Int32.t core_extended-113.00.00/src/extended_int63.ml000066400000000000000000000002111256461102500205640ustar00rootroot00000000000000module Verified_spec = struct include Core.Std.Int63 let module_name = "Int63" end include Number.Make_verified_std (Verified_spec) core_extended-113.00.00/src/extended_int63.mli000066400000000000000000000001511256461102500207400ustar00rootroot00000000000000(** Extensions to [Core.Core_int63] *) include Number.Verified_std with type repr = Core.Std.Int63.t core_extended-113.00.00/src/extended_int64.ml000066400000000000000000000035561256461102500206040ustar00rootroot00000000000000open Core.Std module Filesize = struct type t = Int64.t with bin_io module Infix64 = (Int64 : sig type t = Int64.t val (+) : t -> t -> t val (-) : t -> t -> t val ( * ) : t -> t -> t val (/) : t -> t -> t end) open Infix64 let _ = (+), (-) (* Avoid unused value warnings *) let byte_dimension_suffix = ['b';'k';'m';'g';'t';'p';'z'] let rec to_string__loop v order = let divd = v / 1024L in if divd * 1024L = v (* v mod 1024 = 0 *) && v >= 1024L then to_string__loop (v / 1024L) (Int.succ order ) else let suffix = List.nth_exn byte_dimension_suffix order in Int64.to_string_hum v ^ (Char.to_string suffix) let to_string v = to_string__loop v 0 let rec of_string__get_dimension suffix mult = function | [] -> failwithf "file_size_of_string: unknown size suffix %c" suffix () | h::_ when h = suffix -> mult | _::t -> of_string__get_dimension suffix (1024L * mult) t let of_string s = let len = String.length s in if len = 0 then failwith "Int.filsize_of_string: empty string"; match s.[pred len] with | '0'..'9' -> Int64.of_string s | c -> let main = String.sub s ~pos:0 ~len:(pred len) in let main = Int64.of_string main in let dim = of_string__get_dimension c 1L byte_dimension_suffix in main * dim let t_of_sexp = function | Sexp.List _ as sexp -> Sexplib.Conv.of_sexp_error "Extended_int.Filesize.t_of_sexp:expectibg an atom" sexp | Sexp.Atom a as sexp -> try of_string a with Failure msg -> Sexplib.Conv.of_sexp_error ("Extended_int.Filesize.t_of_sexp:" ^ msg) sexp let sexp_of_t i = Sexp.Atom (to_string i) end module Verified_spec = struct include Core.Std.Int64 let module_name = "Int64" end include Number.Make_verified_std (Verified_spec) core_extended-113.00.00/src/extended_int64.mli000066400000000000000000000006731256461102500207520ustar00rootroot00000000000000open Core.Std (** Extensions to [Core.Core_int64] *) (** An int reprensting a file length Same as the int type but has a specific sexp converter so that you can write "10g". Suffixes are b,k,g,m... The sexp reader also accepts plain ints.*) module Filesize : sig type t = Int64.t with bin_io,sexp val to_string : t -> string val of_string : string -> t end include Number.Verified_std with type repr = Core.Std.Int64.t core_extended-113.00.00/src/extended_int_stubs.c000066400000000000000000000013271256461102500214560ustar00rootroot00000000000000#include #include /* See en.wikipedia.org/wiki/Binary_GCD_algorithm. Taken from Daniel Lemire's blog (with improvements by Ralph Corderoy): http://lemire.me/blog/archives/2013/12/26/fastest-way-to-compute-the-greatest-common-divisor/ */ value core_extended_extended_int_gcd(value vu, value vv) { int shift; unsigned long u = labs(Long_val(vu)), v = labs(Long_val(vv)); unsigned long m; if ((u == 0) || (u == v)) return Val_long(v); if (v == 0) return Val_long(u); shift = __builtin_ctzl(u | v); u >>= __builtin_ctzl(u); do { v >>= __builtin_ctzl(v); m = (v ^ u) & -(v < u); u ^= m; v ^= m; v -= u; } while (v != 0); return Val_long(u << shift); } core_extended-113.00.00/src/extended_linux.ml000066400000000000000000000136321256461102500207730ustar00rootroot00000000000000open Core.Std INCLUDE "config.mlh" type uids = { ruid:int; euid:int; suid:int } with sexp,bin_io module Statfs = struct IFDEF LINUX_EXT THEN module Raw = struct type t = { f_type : Int32.t; f_bsize : int; f_blocks : int; f_bfree : int; f_bavail : int; f_files : int; f_ffree : int; f_namelen : int; } ;; end ENDIF type f_type = ADFS_SUPER_MAGIC | AFFS_SUPER_MAGIC | BEFS_SUPER_MAGIC | BFS_MAGIC | CIFS_MAGIC_NUMBER | CODA_SUPER_MAGIC | COH_SUPER_MAGIC | CRAMFS_MAGIC | DEVFS_SUPER_MAGIC | EFS_SUPER_MAGIC | EXT_SUPER_MAGIC | EXT2_OLD_SUPER_MAGIC | EXT2_SUPER_MAGIC | EXT3_SUPER_MAGIC | HFS_SUPER_MAGIC | HPFS_SUPER_MAGIC | HUGETLBFS_MAGIC | ISOFS_SUPER_MAGIC | JFFS2_SUPER_MAGIC | JFS_SUPER_MAGIC | MINIX_SUPER_MAGIC | MINIX_SUPER_MAGIC2 | MINIX2_SUPER_MAGIC | MINIX2_SUPER_MAGIC2 | MSDOS_SUPER_MAGIC | NCP_SUPER_MAGIC | NFS_SUPER_MAGIC | NTFS_SB_MAGIC | UNKNOWN_SUPER_MAGIC of Int32.t ;; type t = { f_type : f_type; f_bsize : int; f_blocks : int; f_bfree : int; f_bavail : int; f_files : int; f_ffree : int; f_namelen : int; } ;; IFDEF LINUX_EXT THEN let of_rawstatfs raw = { f_type = begin match raw.Raw.f_type with | 0xadf5l -> ADFS_SUPER_MAGIC | 0xADFFl -> AFFS_SUPER_MAGIC | 0x42465331l -> BEFS_SUPER_MAGIC | 0x1BADFACEl -> BFS_MAGIC | 0xFF534D42l -> CIFS_MAGIC_NUMBER | 0x73757245l -> CODA_SUPER_MAGIC | 0x012FF7B7l -> COH_SUPER_MAGIC | 0x28cd3d45l -> CRAMFS_MAGIC | 0x1373l -> DEVFS_SUPER_MAGIC | 0x00414A53l -> EFS_SUPER_MAGIC | 0x137Dl -> EXT_SUPER_MAGIC | 0xEF51l -> EXT2_OLD_SUPER_MAGIC | 0xEF53l -> EXT2_SUPER_MAGIC (* | 0xEF53l -> EXT3_SUPER_MAGIC *) | 0x4244l -> HFS_SUPER_MAGIC | 0xF995E849l -> HPFS_SUPER_MAGIC | 0x958458f6l -> HUGETLBFS_MAGIC | 0x9660l -> ISOFS_SUPER_MAGIC | 0x72b6l -> JFFS2_SUPER_MAGIC | 0x3153464al -> JFS_SUPER_MAGIC | 0x137Fl -> MINIX_SUPER_MAGIC | 0x138Fl -> MINIX_SUPER_MAGIC2 | 0x2468l -> MINIX2_SUPER_MAGIC | 0x2478l -> MINIX2_SUPER_MAGIC2 | 0x4d44l -> MSDOS_SUPER_MAGIC | 0x564cl -> NCP_SUPER_MAGIC | 0x6969l -> NFS_SUPER_MAGIC | 0x5346544el -> NTFS_SB_MAGIC | magic -> UNKNOWN_SUPER_MAGIC magic end; f_bsize = raw.Raw.f_bsize; f_blocks = raw.Raw.f_blocks; f_bfree = raw.Raw.f_bfree; f_bavail = raw.Raw.f_bavail; f_files = raw.Raw.f_files; f_ffree = raw.Raw.f_ffree; f_namelen = raw.Raw.f_namelen } ;; ENDIF end ;; IFDEF LINUX_EXT THEN external setresuid : ruid:int -> euid:int -> suid:int -> unit = "linux_setresuid_stub" let setresuid ?(ruid= -1) ?(euid= -1) ?(suid= -1) () = setresuid ~ruid ~euid ~suid external getresuid : unit -> uids = "linux_getresuid_stub" let setresuid = Ok setresuid let getresuid = Ok getresuid (* Splicing - zero-copies between kernel buffers *) open Unix module Splice = struct type flag = MOVE | NONBLOCK | MORE | GIFT with sexp, bin_io type flags external unsafe_splice : bool -> fd_in : File_descr.t -> off_in : int -> fd_out : File_descr.t -> off_out : int -> len : int -> flags -> int * int * int = "linux_splice_stub_bc" "linux_splice_stub" let splice ?(assume_fd_is_nonblocking = false) ~fd_in ?off_in ~fd_out ?off_out ~len flags = let off_in = match off_in with | None -> -1 | Some off_in when off_in < 0 -> invalid_arg "Splice.splice: off_in < 0" | Some off_in -> off_in in let off_out = match off_out with | None -> -1 | Some off_out when off_out < 0 -> invalid_arg "Splice.splice: off_out < 0" | Some off_out -> off_out in if len < 0 then invalid_arg "Splice.splice: len < 0"; unsafe_splice assume_fd_is_nonblocking ~fd_in ~off_in ~fd_out ~off_out ~len flags external unsafe_tee : bool -> fd_in : File_descr.t -> fd_out : File_descr.t -> int -> flags -> int = "linux_tee_stub" let tee ?(assume_fd_is_nonblocking = false) ~fd_in ~fd_out len flags = if len < 0 then invalid_arg "Splice.splice: len < 0"; unsafe_tee assume_fd_is_nonblocking ~fd_in ~fd_out len flags external unsafe_vmsplice : bool -> File_descr.t -> int -> flags -> int = "linux_vmsplice_stub" let vmsplice ?(assume_fd_is_nonblocking = false) fd iovecs ?count flags = let count = match count with | None -> Array.length iovecs | Some count -> if count < 0 then invalid_arg "Splice.vmsplice: count < 0"; let n_iovecs = Array.length iovecs in if count > n_iovecs then invalid_arg "Splice.vmsplice: count > n_iovecs"; count in unsafe_vmsplice assume_fd_is_nonblocking fd count flags external make_flags : flag array -> flags = "linux_splice_make_flags_stub" let splice = Ok splice let tee = Ok tee let vmsplice = Ok vmsplice end external linux_statfs_stub : string -> Statfs.Raw.t = "linux_statfs_stub" ;; let statfs path = Statfs.of_rawstatfs (linux_statfs_stub path) ;; let statfs = Ok statfs ELSE let setresuid = Or_error.unimplemented "Extended_linux.setresuid" let getresuid = Or_error.unimplemented "Extended_linux.getresuid" module Splice = struct type flag = MOVE | NONBLOCK | MORE | GIFT with sexp, bin_io type flags = flag array let make_flags = Fn.id let splice = Or_error.unimplemented "Extended_linux.Splice.splice" let tee = Or_error.unimplemented "Extended_linux.Splice.tee" let vmsplice = Or_error.unimplemented "Extended_linux.Splice.vmsplice" end let statfs = Or_error.unimplemented "Extended_linux.statfs" ENDIF core_extended-113.00.00/src/extended_linux.mli000066400000000000000000000132761256461102500211500ustar00rootroot00000000000000open Core.Std open Unix type uids = { ruid:int; euid:int; suid:int } with sexp,bin_io val setresuid : (?ruid:int -> ?euid:int -> ?suid:int -> unit -> unit) Or_error.t val getresuid : (unit -> uids) Or_error.t (** {6 Splicing - zero-copies between kernel buffers} *) (* Example usage diagram: In the below diagram, starting at the left upper corner, we first splice a socket into a pipe. Then we duplicate this pipe into two other pipes using "tee". The first pipe is spliced into a file descriptor (e.g. to log data coming in from a socket connection to a file). The second pipe is used by the user to actually read data. After handling the received data, the user puts the new data to be sent out into an output buffer and vmsplices it into a pipe. Use double buffering ( = switching between two buffers) to prevent data inconsistencies while the kernel may be reading from the user provided pages, and make sure not to let buffers be reclaimed by the GC as long as they may still be in use! These buffers currently need not be larger than 64KB each, which is the size of kernel buffers (= Unix-pipes). The end of the output pipe is then duplicated into two more output pipes using "tee" again. If these two "tees" have seen all the data vmspliced from a user buffer, the user can safely switch to it again from the other double buffer. Finally, the first pipe is used to splice data into a socket to send out the user data, and the second pipe is used to stream this data to a file. Note that using more pipes and more "tee"-calls one can very cheaply duplicate the data to even more destinations! tee splice +----> pipe ----+---> fd splice / socket ----+---> pipe \ read +----> pipe ---+--> user input space tee | + do stuff | user output space | + vmsplice (double buffer!) | pipe | / \ tee + + tee | | pipe pipe / \ splice + + splice / \ sock fd *) module Splice : sig (** {6 Splice flags} *) (** Type of Splice event flag *) type flag = MOVE | NONBLOCK | MORE | GIFT with sexp, bin_io (** Type of Splice event flags *) type flags val make_flags : flag array -> flags (** [make_flags ar] @return flags constructed from the array of flags [ar]. *) (** {6 Splice functions} *) val splice : (?assume_fd_is_nonblocking : bool -> fd_in : File_descr.t -> ?off_in : int -> fd_out : File_descr.t -> ?off_out : int -> len : int -> flags -> int * int * int) Or_error.t (** [splice ?assume_fd_is_nonblocking ~fd_in ?off_in ~fd_out ?off_out ~len flags] see man-page for details. @return the triple [(ret, ret_off_in, ret_off_out)], where [ret] corresponds to the return value of the system call, [ret_off_in] to the final input offset, and [ret_off_out] to the final output offset. @raise Unix_error on Unix-errors. @raise Invalid_argument if the offsets or length are invalid @param assume_fd_is_nonblocking default = false @param off_in default = 0 @param off_out default = 0 *) val tee : (?assume_fd_is_nonblocking : bool -> fd_in : File_descr.t -> fd_out : File_descr.t -> int -> flags -> int) Or_error.t (** [tee ?assume_fd_is_nonblocking ~fd_in ~fd_out len flags] see man-page for details. @raise Unix_error on Unix-errors. @raise Invalid_argument if the length is invalid @param assume_fd_is_nonblocking default = false *) val vmsplice : (?assume_fd_is_nonblocking : bool -> File_descr.t -> Bigstring.t IOVec.t array -> ?count : int -> flags -> int) Or_error.t (** [vmsplice ?assume_fd_is_nonblocking fd iovecs ?count flags] see man-page for details. @raise Unix_error on Unix-errors. @raise Invalid_argument if the count is invalid @param assume_fd_is_nonblocking default = false @param count default = [Array.length iovecs] *) end module Statfs : sig type f_type = ADFS_SUPER_MAGIC | AFFS_SUPER_MAGIC | BEFS_SUPER_MAGIC | BFS_MAGIC | CIFS_MAGIC_NUMBER | CODA_SUPER_MAGIC | COH_SUPER_MAGIC | CRAMFS_MAGIC | DEVFS_SUPER_MAGIC | EFS_SUPER_MAGIC | EXT_SUPER_MAGIC | EXT2_OLD_SUPER_MAGIC | EXT2_SUPER_MAGIC | EXT3_SUPER_MAGIC | HFS_SUPER_MAGIC | HPFS_SUPER_MAGIC | HUGETLBFS_MAGIC | ISOFS_SUPER_MAGIC | JFFS2_SUPER_MAGIC | JFS_SUPER_MAGIC | MINIX_SUPER_MAGIC | MINIX_SUPER_MAGIC2 | MINIX2_SUPER_MAGIC | MINIX2_SUPER_MAGIC2 | MSDOS_SUPER_MAGIC | NCP_SUPER_MAGIC | NFS_SUPER_MAGIC | NTFS_SB_MAGIC | UNKNOWN_SUPER_MAGIC of Int32.t ;; type t = { f_type : f_type; f_bsize : int; f_blocks : int; f_bfree : int; f_bavail : int; f_files : int; f_ffree : int; f_namelen : int; } ;; end val statfs : (string -> Statfs.t) Or_error.t core_extended-113.00.00/src/extended_linux_stubs.c000066400000000000000000000111061256461102500220170ustar00rootroot00000000000000#include "config.h" #ifdef JSC_LINUX_EXT #define _GNU_SOURCE #include #include #include #include #include #include "ocaml_utils.h" #include /* resuid */ CAMLprim value linux_getresuid_stub(value __unused v_unit) { value v_res; uid_t ruid,euid,suid; if (getresuid(&ruid, &euid, &suid) == -1) uerror("getresuid", Nothing); v_res = caml_alloc_small(3, 0); Field(v_res, 0) = Val_int(ruid); Field(v_res, 1) = Val_int(euid); Field(v_res, 2) = Val_int(suid); return v_res; } CAMLprim value linux_setresuid_stub(value v_ruid, value v_euid, value v_suid) { if (setresuid(Int_val(v_ruid), Int_val(v_euid), Int_val(v_suid)) == -1) uerror("setresuid", Nothing); return Val_unit; } /* Epoll */ /* Epoll functions where removed after 80221ddbe375 HG cat this file at this revision if you need to resuscitate them */ /* Splicing - zero-copies between kernel buffers */ CAMLprim value linux_splice_make_flags_stub(value v_flags) { int flags = 0, i = Wosize_val(v_flags); while (--i >= 0) { switch (Int_val(Field(v_flags, i))) { case 0 : flags |= SPLICE_F_MOVE; break; case 1 : flags |= SPLICE_F_NONBLOCK; break; case 2 : flags |= SPLICE_F_MORE; break; default : flags |= SPLICE_F_GIFT; break; } } return caml_copy_int32(flags); } CAMLprim value linux_splice_stub( value v_assume_fd_is_nonblocking, value v_fd_in, value v_off_in, value v_fd_out, value v_off_out, value v_len, value v_flags) { int assume_fd_is_nonblocking = Bool_val(v_assume_fd_is_nonblocking); int fd_in = Int_val(v_fd_in); int fd_out = Int_val(v_fd_out); off64_t off_in = Long_val(v_off_in); off64_t *off_in_p = (off_in < 0) ? NULL : &off_in; off64_t off_out = Long_val(v_off_out); off64_t *off_out_p = (off_out < 0) ? NULL : &off_out; size_t len = Long_val(v_len); unsigned int flags = Int32_val(v_flags); long ret; value v_res; if (assume_fd_is_nonblocking) ret = splice(fd_in, off_in_p, fd_out, off_out_p, len, flags); else { caml_enter_blocking_section(); ret = splice(fd_in, off_in_p, fd_out, off_out_p, len, flags); caml_leave_blocking_section(); } if (ret == -1) uerror("splice", Nothing); v_res = caml_alloc_small(3, 0); Field(v_res, 0) = Val_long(ret); Field(v_res, 1) = Val_long(off_in); Field(v_res, 2) = Val_long(off_out); return v_res; } CAMLprim value linux_splice_stub_bc(value *argv, int __unused argn) { return linux_splice_stub( argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } CAMLprim value linux_tee_stub( value v_assume_fd_is_nonblocking, value v_fd_in, value v_fd_out, value v_len, value v_flags) { int assume_fd_is_nonblocking = Bool_val(v_assume_fd_is_nonblocking); int fd_in = Int_val(v_fd_in); int fd_out = Int_val(v_fd_out); size_t len = Long_val(v_len); unsigned int flags = Int32_val(v_flags); long ret; if (assume_fd_is_nonblocking) ret = tee(fd_in, fd_out, len, flags); else { caml_enter_blocking_section(); ret = tee(fd_in, fd_out, len, flags); caml_leave_blocking_section(); } if (ret == -1) uerror("tee", Nothing); return Val_long(ret); } CAMLprim value linux_vmsplice_stub( value v_assume_fd_is_nonblocking, value v_fd, value v_iovecs, value v_count, value v_flags) { int assume_fd_is_nonblocking = Bool_val(v_assume_fd_is_nonblocking); int fd = Int_val(v_fd); int count = Int_val(v_count); size_t total_len = 0; struct iovec *iovecs = copy_iovecs(&total_len, v_iovecs, count); unsigned int flags = Int32_val(v_flags); long ret; if (assume_fd_is_nonblocking && total_len < THREAD_IO_CUTOFF) ret = vmsplice(fd, iovecs, count, flags); else { Begin_roots1(v_iovecs); caml_enter_blocking_section(); ret = vmsplice(fd, iovecs, count, flags); caml_leave_blocking_section(); End_roots(); } if (ret == -1) uerror("vmsplice", Nothing); return Val_long(ret); } CAMLprim value linux_statfs_stub(value v_path) { CAMLparam1(v_path); CAMLlocal1(res); struct statfs sfs; memset(&sfs, 0, sizeof sfs); if (statfs(String_val(v_path), &sfs) == -1) uerror("statfs", Nothing); res = caml_alloc_tuple(8); Store_field(res, 0, caml_copy_int32(sfs.f_type)); Store_field(res, 1, Val_long(sfs.f_bsize)); Store_field(res, 2, Val_long(sfs.f_blocks)); Store_field(res, 3, Val_long(sfs.f_bfree)); Store_field(res, 4, Val_long(sfs.f_bavail)); Store_field(res, 5, Val_long(sfs.f_files)); Store_field(res, 6, Val_long(sfs.f_ffree)); Store_field(res, 7, Val_long(sfs.f_namelen)); CAMLreturn(res); } #endif /* JSC_LINUX_EXT */ core_extended-113.00.00/src/extended_list.ml000066400000000000000000000067111256461102500206070ustar00rootroot00000000000000 open Core.Std let of_option = function | None -> [] | Some x -> [x] let set_diff l1 l2 = let set = Set.Poly.of_list l2 in List.filter l1 ~f:(fun x -> not (Set.mem set x)) let set_inter l1 l2 = let set = Set.Poly.of_list l2 in List.dedup (List.filter l1 ~f:(fun x -> Set.mem set x)) let classify ?(equal=( = )) ~f list = let classify_element class_members_assoc this_member = let this_class = f this_member in let rec add_class_member new_class_members_assoc old_class_members_assoc = match old_class_members_assoc with | [] -> (this_class,[this_member])::new_class_members_assoc | (classs,members)::rest when equal classs this_class -> (classs, this_member::members)::new_class_members_assoc@rest | l::ls -> add_class_member (l::new_class_members_assoc) ls in add_class_member [] class_members_assoc in List.fold list ~init:[] ~f:classify_element let lcs = Extended_list__LCS.lcs let number = Extended_list__multimerge.number let multimerge = Extended_list__multimerge.multimerge let multimerge_unique = Extended_list__multimerge.multimerge_unique let square_unique ?null l = let headers = List.map ~f:(List.map ~f:fst) l in let header = multimerge_unique headers in let find_col_value = match null with | None -> fun row col_header -> List.Assoc.find_exn row col_header | Some default -> fun row col_header -> Option.value (List.Assoc.find row col_header) ~default in let body = List.map l ~f:(fun row -> List.map header ~f:(fun col_header -> find_col_value row col_header)) in header,body let square ?null l = let numbered = List.map l ~f:(fun row -> let row_header,row_values = List.unzip row in List.zip_exn (number row_header) row_values) in let header,body = square_unique ?null numbered in List.map ~f:fst header,body let enumerate_from = let rec loop acc n = function | [] -> List.rev acc | x::xs -> loop ((x,n)::acc) (n+1) xs in fun xs -> loop [] xs let fold_left_term lst ~f ~init = let rec loop lst ~f ~acc = match lst with | [] -> acc | hd :: tl -> match f acc hd with | `Final v -> v | `Continue acc -> loop tl ~f ~acc in loop lst ~f ~acc:init let max ?(cmp=Pervasives.compare) l = List.reduce l ~f:(fun x y -> if cmp x y > 0 then x else y) let min ?(cmp=Pervasives.compare) l = List.reduce l ~f:(fun x y -> if cmp x y < 0 then x else y) let max_exn ?(cmp=Pervasives.compare) l = List.reduce_exn l ~f:(fun x y -> if cmp x y > 0 then x else y) let min_exn ?(cmp=Pervasives.compare) l = List.reduce_exn l ~f:(fun x y -> if cmp x y < 0 then x else y) let equal = let rec loop ~equal xs ys = match xs with | [] -> begin match ys with | [] -> true | _ :: _ -> false end | x :: xs -> begin match ys with | [] -> false | y :: ys -> equal x y && loop ~equal xs ys end in loop ;; let rec compare cmp t1 t2 = match t1 with | [] -> begin match t2 with | [] -> 0 | _ :: _ -> -1 end | x :: xs -> begin match t2 with | [] -> 1 | y :: ys -> match cmp x y with | 0 -> compare cmp xs ys | res -> res end ;; let map_accum t ~f ~init = let s, rev = List.fold t ~init:(init, []) ~f:(fun (s, acc) x -> let s, y = f s x in s, y::acc) in s, List.rev rev core_extended-113.00.00/src/extended_list.mli000066400000000000000000000063031256461102500207550ustar00rootroot00000000000000(** Extensions to [Core.Core_list].*) (** [of_option o] returns a list that is empty if [o] is None, otherwise it is a singleton list. Useful to get filter_map-like behavior in the context of something like a concat_map. *) val of_option : 'a option -> 'a list (** [set_inter l1 l2] returns a list without duplicates of all elements of l1 that are in l2 *) val set_inter : 'a list -> 'a list -> 'a list (** [set_diff l1 l2] returns a list of all elements of l1 that are not in l2 *) val set_diff : 'a list -> 'a list -> 'a list (** [classify l ~equal ~f] elements [x] and [y] of list [l] are assigned to the same class iff [equal (f x) (f y)] returns true. The default for [equal] is ( = ) *) val classify : ?equal:('b -> 'b -> bool) -> f:('a -> 'b) -> 'a list -> ('b * 'a list) list (** [enumerate_from n xs] returns a list of pairs constructed by pairing an incrementing counter, starting at [n], with the elements of [xs]. e.g. enumerate_from 1 [a,b,c] = [a,1; b,2; c,3] *) val enumerate_from : int -> 'a list -> ('a * int) list (** fold_left_term is like fold_left, except that you can halt early. The function to be folded should return a bool along with the new accumulator. True indicates that it should continue, false means it should halt *) val fold_left_term : 'a list -> f:('b -> 'a -> [`Final of 'b | `Continue of 'b]) -> init:'b -> 'b (** A combination of [map] and [fold]. Applies a function to each element of the input list, building up an accumulator, returning both the final state of the accumulator and a new list. *) val map_accum : 'a list -> f:('b -> 'a -> 'b * 'c) -> init:'b -> 'b * 'c list val max : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option val min : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option val max_exn : ?cmp:('a -> 'a -> int) -> 'a list -> 'a val min_exn : ?cmp:('a -> 'a -> int) -> 'a list -> 'a (** Find the longest common subsequence between two list. *) val lcs : 'a list -> 'a list -> 'a list (** Numbers the elements in a list by occurence: [[a;b;c;a;d] -> [(a,0);(b,0);(c,0);(a,1);(d,0)]] *) val number : 'a list -> ('a * int) list (** Merges several list trying to keep the order in which the elements appear. The elements of the individual are not deduped. multimerge [[[a;b;d;a] [b;c;d]] -> [a;b;c;d;a]] *) val multimerge : 'a list list -> 'a list val multimerge_unique : 'a list list -> 'a list (** Takes a list of [`key*`value lists] and returns a header * table_body body that is obtained by splitting the lists and re-ordering the terms (so that they all have the same header). If [null_value] is not specified and the rows have different keys the function will raise an exception. [ square ~null [[(1,a_1);(2,b_1);(4,c_1)]; [(3,a_2)]; [(0,a_3);(1,b_3);(2,c_3);(3,d_3);(4,e_3)]] = ([0 ;1 ;2 ;3 ;4], [[null;a_1 ;b_1 ;null;c_1 ] [null;null;null;a_2 ;null] [a_3 ;b_3 ;c_3 ;d_3 ;e_3 ]]) ] *) val square : ?null:'v -> ('k * 'v) list list -> 'k list * 'v list list val square_unique : ?null:'v -> ('k * 'v) list list -> 'k list * 'v list list val equal : equal:('a -> 'b -> bool) -> 'a list -> 'b list -> bool val compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int core_extended-113.00.00/src/extended_list__LCS.ml000066400000000000000000000023321256461102500214420ustar00rootroot00000000000000open Core.Std (* LCS.... *) let lcsTBL x y m n = let c = Array.make_matrix ~dimx:(m+1) ~dimy:(n+1) 0 in for i = 0 to m-1 do for j = 0 to n -1 do if x.(i) = y.(j) then c.(i+1).(j+1) <- c.(i).(j) + 1 else c.(i+1).(j+1) <- max c.(i+1).(j) c.(i).(j+1) done done; c let rec lcsBacktrace c x y i j acc = if i=0 || j=0 then acc else if x.(i-1) = y.(j-1) then lcsBacktrace c x y (i-1) (j-1) (x.(i-1)::acc) else if c.(i).(j-1) > c.(i-1).(j) then lcsBacktrace c x y i (j-1) acc else lcsBacktrace c x y (i-1) j acc (** Naive dynamic programming LCS *) let lcs_kernel x y = let m = Array.length x and n = Array.length y in let c = lcsTBL x y m n in lcsBacktrace c x y m n [] (** Find common front part for an LCS *) let rec common_start x y acc = match x,y with | h::t,h'::t' when h = h' -> common_start t t' (h::acc) | _ -> acc,x,y (** LCS with common front and back part detection optimization.*) let lcs x y = let rev_start,x,y = common_start x y [] in let stop,rev_x,rev_y = common_start (List.rev x) (List.rev y) [] in let lcs_middle = lcs_kernel (Array.of_list rev_x) (Array.of_list rev_y) in List.rev_append rev_start (List.rev_append lcs_middle stop) core_extended-113.00.00/src/extended_list__LCS.mli000066400000000000000000000001301256461102500216050ustar00rootroot00000000000000(* Longest common subsequence of two lists *) val lcs : 'a list -> 'a list -> 'a list core_extended-113.00.00/src/extended_list__multimerge.ml000066400000000000000000000035751256461102500232050ustar00rootroot00000000000000open Core.Std let rec count__loop cnt el = function | [] -> cnt | h::t when h = el -> count__loop (cnt + 1) el t | _::t -> count__loop cnt el t (* [ count l el] Counts the occurences of [el] in [l] *) let count (l:'a list) (el:'a) : int = count__loop 0 el l let rec number__loop seen acc = function | [] -> List.rev acc | h::t -> number__loop (h::seen) ((h,count seen h)::acc) t let number (l:'a list) : ('a * int) list = number__loop [] [] l let unnumber = List.map ~f:fst type 'node graph = ('node * 'node list) list let insert_edge (graph:'a graph) (node:'a) (child:'a) : 'a graph = let rec loop acc = function | [] -> (node,[child])::graph | (node',children)::l when node' = node -> if List.mem children child then graph else (node,(child::children))::(List.rev_append l acc) | h::t -> loop (h::acc) t in loop [] graph let insert_node (graph:'a graph) (node:'a) : 'a graph = if List.Assoc.mem graph node then graph else (node,[]) :: graph let children (graph:'a graph) (node:'a) : 'a list = List.Assoc.find_exn graph node (** A topological sort that will degrade nicely in the presence of cycles. *) let top_sort (graph:'a graph) : 'a list = let rec visit (dead,l) v = if List.mem dead v then (dead,l) else let dead,l = List.fold (children graph v) ~f:visit ~init:((v::dead),l) in dead,(v::l) in let _,l = List.fold graph ~f:(fun acc (node,_child) -> visit acc node) ~init:([],[]) in l let rec add_dep_list graph = function | [] -> graph | [node] -> insert_node graph node | node::((child::_) as l) -> add_dep_list (insert_edge graph node child) l let multimerge_unique l = let graph = List.fold ~f:add_dep_list ~init:[] l in top_sort graph let multimerge l = let l = List.map ~f:number l in unnumber (multimerge_unique l) core_extended-113.00.00/src/extended_list__multimerge.mli000066400000000000000000000002011256461102500233350ustar00rootroot00000000000000val number : 'a list -> ('a * int) list val multimerge : 'a list list -> 'a list val multimerge_unique : 'a list list -> 'a list core_extended-113.00.00/src/extended_memo.ml000066400000000000000000000005321256461102500205640ustar00rootroot00000000000000open Core.Std let general_rec g = let fref = ref (fun _ -> assert false) in let f = Memo.general (fun x -> g !fref x) in fref := f; f ;; let reentrant_unit f = let lock = Nano_mutex.create () in let memo = Memo.unit f in fun () -> Nano_mutex.lock_exn lock; protect ~f:memo ~finally:(fun () -> Nano_mutex.unlock_exn lock) core_extended-113.00.00/src/extended_memo.mli000066400000000000000000000003551256461102500207400ustar00rootroot00000000000000(** Extensio to [Core.Memo] *) (** A version of [Memo.general] more suitable for memoizing recursively-defined functions *) val general_rec : (('a -> 'b) -> 'a -> 'b) -> ('a -> 'b) val reentrant_unit : (unit -> 'a) -> (unit -> 'a) core_extended-113.00.00/src/extended_monad.ml000066400000000000000000000017171256461102500207330ustar00rootroot00000000000000open Core.Std module List = Core.Std.List module type S = sig include Monad.S (* Like [List.map] but for functions which return monads *) val map_monad : 'a list -> f : ('a -> 'b t) -> 'b list t (* Like [map_monad] but ignores the outputs from the function. *) val map_monad_ignore : 'a list -> f : ('a -> unit t) -> unit t end module Make (M : Monad.Basic) : S with type 'a t := 'a M.t = struct include Monad.Make (M) let map_monad list ~f = all (List.map ~f list) let map_monad_ignore list ~f = all_ignore (List.map ~f list) end module type S2 = sig include Monad.S2 val map_monad : 'a list -> f : ('a -> ('b, 'c) t) -> ('b list, 'c) t val map_monad_ignore : 'a list -> f : ('a -> (unit, 'b) t) -> (unit, 'b) t end module Make2 (M : Monad.Basic2) : S2 with type ('a,'b) t := ('a,'b) M.t = struct include Monad.Make2 (M) let map_monad list ~f = all (List.map ~f list) let map_monad_ignore list ~f = all_ignore (List.map ~f list) end core_extended-113.00.00/src/extended_nativeint.ml000066400000000000000000000002211256461102500216230ustar00rootroot00000000000000module Verified_spec = struct include Core.Std.Nativeint let module_name = "Nativeint" end include Number.Make_verified_std (Verified_spec) core_extended-113.00.00/src/extended_nativeint.mli000066400000000000000000000001021256461102500217720ustar00rootroot00000000000000include Number.Verified_std with type repr = Core.Std.Nativeint.t core_extended-113.00.00/src/extended_option.ml000066400000000000000000000002601256461102500211350ustar00rootroot00000000000000 let rec of_list = function | [] -> None | (Some _ as x) :: _ -> x | _ :: xs -> of_list xs let value_raise t ~exn = match t with | Some x -> x | None -> raise exn core_extended-113.00.00/src/extended_result.ml000066400000000000000000000016361256461102500211530ustar00rootroot00000000000000open Core.Std module Ok = Result module Error = struct module T = struct type ('a,'b) t = ('b,'a) Result.t end include T include Monad.Make2 (struct include T let bind x f = match x with | Error x -> f x | Ok _ as x -> x let map x ~f = match x with | Error x -> Error (f x) | Ok _ as x -> x let map = `Custom map let return x = Error x end) end module Exn = struct module T = struct type 'a t = ('a, exn) Result.t with sexp_of end include T include Monad.Make (struct include T let return x = Ok x let bind (t : 'a t) f = match t with | Ok x -> f x | Error e -> Error e ;; let map (t : 'a t) ~f = match t with | Ok x -> Ok (f x) | Error e -> Error e ;; let map = `Custom map end) let ok = function | Ok a -> a | Error exn -> raise exn ;; end core_extended-113.00.00/src/extended_result.mli000066400000000000000000000006571256461102500213260ustar00rootroot00000000000000open Core.Std (** Extension to the {Core.Result} *) module Ok: Monad.S2 with type ('a,'err) t = ('a,'err) Result.t module Error: Monad.S2 with type ('err,'a) t = ('a,'err) Result.t module Exn : sig type 'a t = ('a, exn) Result.t val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t include Monad.S with type 'a t := 'a t (** [ok t] returns [x] if [t = Ok x], or raises [e] if [t = Error e]. *) val ok : 'a t -> 'a end core_extended-113.00.00/src/extended_sexp.ml000066400000000000000000001014251256461102500206110ustar00rootroot00000000000000open Core.Std open Sexplib.Sexp module Re2 = Re2.Std.Re2 let is_atom = function Atom _ -> true | List _ -> false let is_list = function Atom _ -> false | List _ -> true let list l = List l let atom a = Atom a let comment s = match (String.split s ~on:'\n') with | [] -> "" | h::l -> (String.concat ~sep:"\n;; " ((";; "^h)::l)) ^ "\n" open Pp.Infix let indent = 2 let rec pp_hum' fmt = function | Atom s -> Format.pp_print_string fmt (Sexplib.Pre_sexp.mach_maybe_esc_str s) | List l when List.for_all ~f:is_atom l -> Format.pp_open_hovbox fmt 2; pp_hum_rest' fmt l | List l -> Format.pp_open_hvbox fmt 2; pp_hum_rest' fmt l and pp_hum_rest' fmt l = Format.pp_print_string fmt "("; let rec loop = function | [] -> () | [v] -> pp_hum' fmt v | h::t -> pp_hum' fmt h; Format.pp_print_space fmt (); loop t in loop l; Format.pp_print_string fmt ")"; Format.pp_close_box fmt () let rec format = function | Atom s -> Pp.text (Sexplib.Pre_sexp.mach_maybe_esc_str s) | List l when List.for_all ~f:is_atom l -> Pp.fgrp (par l) | List l -> Pp.agrp (par l) and par l = Pp.text "(" $ Pp.nest indent (Pp.list ~sep:Pp.break ~f:format l) $ Pp.text ")" let to_string_hum' sexp = Pp.to_string (format sexp) module Diff : sig type t val print : ?oc:out_channel -> t -> unit val to_buffer : t -> Buffer.t val to_string : t -> string val of_sexps : original:Sexp.t -> updated:Sexp.t -> t option end = struct type t = | Different of ([`Original of Sexp.t] * [`Updated of Sexp.t]) | List of t list | Record of record_field list and record_field = | New_in_updated of Sexp.t | Not_in_updated of Sexp.t | Bad_match of string * t let make_tail make tail acc = Some (Record (List.rev (List.rev_map_append ~f:make tail acc))) let recf (k, v) = Sexp.List [Sexp.Atom k; v] let maybe_record sexps = let is_list_of_atom_pairs = function | Sexp.List [Sexp.Atom _; _] -> true | _ -> false in sexps <> [] && (List.for_all ~f:is_list_of_atom_pairs sexps) let sort_record_fields sexp_list = let to_pair = function | Sexp.List [Sexp.Atom k; v] -> k, v | _ -> assert false (* impossible *) in let pairs = List.map ~f:to_pair sexp_list in List.sort ~cmp:(fun (k1, _) (k2, _) -> compare k1 k2) pairs let rec of_record_fields acc pairs_orig pairs_upd = match pairs_orig, pairs_upd with | [], [] when acc = [] -> None | [], [] -> Some (Record (List.rev acc)) | [], tail -> make_tail (fun kv -> New_in_updated (recf kv)) tail acc | tail, [] -> make_tail (fun kv -> Not_in_updated (recf kv)) tail acc | (((k_o, v_o) as h_o) :: t_o as l_o), (((k_u, v_u) as h_u) :: t_u as l_u) -> let c = compare k_o k_u in if c = 0 then match of_sexps ~original:v_o ~updated:v_u with | None -> of_record_fields acc t_o t_u | Some diff -> of_record_fields (Bad_match (k_u, diff) :: acc) t_o t_u else if c < 0 then of_record_fields (New_in_updated (recf h_u) :: acc) l_o t_u else of_record_fields (Not_in_updated (recf h_o) :: acc) t_o l_u and of_lists acc original updated = match original, updated with | [], [] when acc = [] -> None | [], [] -> Some (List (List.rev acc)) | [], _ | _, [] -> assert false (* impossible *) | h_orig :: t_orig, h_upd :: t_upd -> match of_sexps ~original:h_orig ~updated:h_upd with | None -> of_lists acc t_orig t_upd | Some res -> of_lists (res :: acc) t_orig t_upd and of_sexps ~original ~updated = match original, updated with | Sexp.List [], Sexp.List [] -> None | Sexp.Atom a1, Sexp.Atom a2 when a1 = a2 -> None | Sexp.List orig, Sexp.List upd -> if maybe_record orig && maybe_record upd then of_record_fields [] (sort_record_fields orig) (sort_record_fields upd) else if List.length orig = List.length upd then of_lists [] orig upd else Some (Different (`Original original, `Updated updated)) | _ -> Some (Different (`Original original, `Updated updated)) let to_buffer diff = let buf = Buffer.create 80 in let print_string ~tag ~indent str = Buffer.add_string buf (Printf.sprintf "%-*s %s\n%!" indent tag str) in let print_sexp ~tag ~indent sexp = print_string ~tag ~indent (Sexp.to_string sexp) in let rec loop indent = function | Different (`Original sexp1, `Updated sexp2) -> print_sexp ~tag:"-" ~indent sexp1; print_sexp ~tag:"+" ~indent sexp2 | List lst -> print_string ~tag:"" ~indent "("; List.iter ~f:(loop (indent + 1)) lst; print_string ~tag:"" ~indent ")" | Record record_fields -> let print_record_field = function | New_in_updated sexp -> print_sexp ~tag:"+" ~indent sexp | Not_in_updated sexp -> print_sexp ~tag:"-" ~indent sexp | Bad_match (key, diff) -> print_string ~tag:"" ~indent key; loop (indent + 1) diff in List.iter ~f:print_record_field record_fields; in loop 0 diff; buf let to_string diff = Buffer.contents (to_buffer diff) let print ?(oc = stdout) diff = Buffer.output_buffer oc (to_buffer diff) end let print_diff ?oc ~original ~updated () = Option.iter (Diff.of_sexps ~original ~updated) ~f:(fun diff -> Diff.print ?oc diff) (* The purpose of this module is just to group this craziness together. *) module Summarize = struct (* An arbitrary distance metric between the nodes of an sexp, which is thought of as a tree. Take a description of the path: `Pos i means move to the ith element of a list, `Back i means the current node is the ith element of its parents list and move to that parent. *) let rec path_depth = function | `Found -> 0 | `Pos (_, path) -> 1 + path_depth path | `Back (i, (`Pos (n, path))) -> 1 + (min (abs (n-i)) i) + path_depth path | `Back (i, path) -> 1 + min 3 i + path_depth path ;; let dot_dot_dot = Sexp.Atom "...";; (* returns the parts of sexp that are "close" to the part of the sexp that path points to. *) let rec neighbors sexp path max_distance = match sexp, max_distance with | Sexp.Atom _, 0 -> failwith "Bug" | Sexp.Atom str, depth -> (* large atoms are more distant *) let length_punishment = float (max (String.length str - 3) 0) /. 10. in (* let length_punishment = log (float (String.length str)) /. 1.8 in *) let my_distance = float (path_depth path) +. length_punishment in if my_distance < float depth then Sexp.Atom str else dot_dot_dot (* performance hack: if a list is going to contain all "..." atoms, then "..." the list itself *) | Sexp.List _, (0 | 1) -> dot_dot_dot | Sexp.List sexps, max_distance -> if path_depth path >= max_distance then dot_dot_dot else let sexps = List.mapi sexps ~f:(fun i sexp -> let new_path = match path with | `Found | `Back _ -> `Back (i, path) | `Pos (n, path) -> if n = i then path else `Back (i, `Pos (n, path)) in neighbors sexp new_path max_distance ) in let sexps = (* consolidate consecutive "..." atoms into one "..." atom *) List.fold sexps ~init:[] ~f:(fun accum sexp -> match accum with | [] -> [ sexp ] | hd :: _tl -> if phys_equal sexp dot_dot_dot && phys_equal hd dot_dot_dot then accum else sexp :: accum ) |! List.rev in (* replace "(...)" with just "..." *) if sexps = [ dot_dot_dot ] then dot_dot_dot else Sexp.List sexps ;; (* given an sexp, an "erroneous" sub_sexp, and a maximum distance, returns an sexp of nodes near sub_sexp. *) let summarize_sexp sexp sub_sexp depth = let search_result = Sexp.search_physical sexp ~contained:sub_sexp in match search_result with | `Not_found -> failwithf "Sexp %s not found in sexp %s" (Sexp.to_string sub_sexp) (Sexp.to_string sexp) () | (`Found | `Pos _) as path -> let subst = Sexp.List [ Sexp.Atom "ERROR-->"; sub_sexp; Sexp.Atom "<--ERROR" ] in let annotated_sexp = Sexp.subst_found sexp ~subst path in let rec new_path path = match path with | `Pos (n, path) -> `Pos (n, new_path path) | `Found -> `Pos (1, `Found) in neighbors annotated_sexp (new_path path) depth (* Replaced below by a faster estimate of the size *) let _sexp_size sexp = String.length (Sexp.to_string sexp);; (* FIXME: does not take into account escaping *) let rec my_sexp_size = function | Sexp.List l -> List.fold l ~init:2 ~f:(fun sum sexp -> sum + my_sexp_size sexp) | Sexp.Atom str -> String.length str (* should really be +2 if spaces present *) (* should add 1 for the space between two adjacent atoms *) ;; (* summarizes sexp to have a maximum string length *) let summarize_sexp_length sexp sub_sexp length = let full_length = my_sexp_size sexp in let is_too_big max_depth = let sexp = summarize_sexp sexp sub_sexp max_depth in length >= full_length || my_sexp_size sexp > length in let rec binary_search lower_bound upper_bound = if upper_bound = Some (lower_bound + 1) then lower_bound else let depth_to_try = match upper_bound with | None -> lower_bound * 2 | Some upper_bound -> (lower_bound + upper_bound) / 2 in if is_too_big depth_to_try then binary_search lower_bound (Some depth_to_try) else binary_search depth_to_try upper_bound in let perfect_depth = binary_search 1 None in summarize_sexp sexp sub_sexp perfect_depth ;; end let summarize sexp ~sub_sexp ~size = match size with | `string s -> Summarize.summarize_sexp_length sexp sub_sexp s | `depth d -> Summarize.summarize_sexp sexp sub_sexp d let of_generated_sexp of_sexp ~original_sexp ~generated_sexp = try of_sexp generated_sexp with | Of_sexp_error (exn, error_sexp) -> let error_sexp = if phys_equal error_sexp generated_sexp then original_sexp else error_sexp in raise (Of_sexp_error (exn, error_sexp)) ;; module Make_explicit_sexp_option (T: sig type t with sexp val explicit_sexp_option_fields : string list end) : sig type t = T.t with sexp end = struct type t = T.t let fail () = failwith "Make_explicit_sexp_option failure" let t_of_sexp sexp = let sexp = match sexp with | Sexp.Atom _ -> sexp | Sexp.List l when List.exists l ~f:(function | Sexp.List [Sexp.Atom _;_] -> false | _ -> true ) -> sexp | Sexp.List l -> Sexp.List (List.filter_map l ~f:(fun field -> let name, value = match field with | Sexp.List [Sexp.Atom name;sexp] -> name,sexp | _ -> assert false in if not (List.mem T.explicit_sexp_option_fields name) then Some field else match value with | Sexp.List [] -> None | Sexp.List [sexp] -> Some sexp | Sexp.Atom _ | Sexp.List (_::_::_) -> fail () )) in T.t_of_sexp sexp let sexp_of_t t = let sexp = T.sexp_of_t t in let field_names = match sexp with | Sexp.Atom _ -> fail () | Sexp.List l -> Map.Poly.of_alist_exn (List.map l ~f:(fun field -> match field with | Sexp.List [Sexp.Atom name;sexp] -> name,sexp | _ -> fail () )) in let field_names = List.fold T.explicit_sexp_option_fields ~init:field_names ~f:(fun field_names explicit_sexp_option_field -> let value = <:sexp_of> (Map.find field_names explicit_sexp_option_field) in Map.add field_names ~key:explicit_sexp_option_field ~data:value ) in Sexp.List (List.map (Map.to_alist field_names) ~f:(fun (name,sexp) -> Sexp.List [Sexp.Atom name;sexp] )) end module Records_table = struct type 'a t = 'a list with sexp exception Invalid_record_sexp of Sexp.t with sexp exception Record_sexp_missing_field of (string * Sexp.t) list * string with sexp let sexp_of_t sexp_of_record records = let records = List.map records ~f:(fun record -> let sexp = sexp_of_record record in match sexp with | Sexp.List fields -> List.map fields ~f:(function | Sexp.List [ Sexp.Atom name; value ] -> (name, value) | _ -> raise (Invalid_record_sexp sexp)) | _ -> raise (Invalid_record_sexp sexp)) in let rows = match records with | [] -> [] | record :: _ -> let field_names = List.map record ~f:fst in let header = Sexp.List (List.map field_names ~f:(fun field_name -> Sexp.Atom field_name)) in let tuples = List.map records ~f:(fun record -> Sexp.List (List.map field_names ~f:(fun field_name -> match List.find_map record ~f:(fun (field_name', value) -> if field_name = field_name' then Some value else None) with | None -> raise (Record_sexp_missing_field (record, field_name)) | Some value -> value))) in header :: tuples in Sexp.List rows ;; exception Invalid_table_sexp with sexp let t_of_sexp record_of_sexp sexp = let error () = raise (Of_sexp_error (Invalid_table_sexp, sexp)) in let rows = match sexp with | Sexp.Atom _ -> error () | Sexp.List l -> List.map l ~f:(fun row -> match row with | Sexp.Atom _ -> error () | Sexp.List l -> l) in match rows with | [] -> [] | header :: rest -> List.map rest ~f:(fun tuple -> of_generated_sexp record_of_sexp ~original_sexp:sexp ~generated_sexp: (Sexp.List (List.map2_exn header tuple ~f:(fun field value -> Sexp.List [field; value])))) ;; end let load_sexp_conv_exn_sample ?strict ?buf ?(on_non_existence=`Exit) ?name file ~sexp_of_t ~t_of_sexp ~sample = if Sys.file_exists_exn file then Sexp.load_sexp_conv_exn ?strict ?buf file t_of_sexp else begin Sexp.save_hum file (sexp_of_t sample); let name = match name with | None -> "" | Some x -> " " ^ x in let message = sprintf "No file found at %s. Writing a sample%s" file name in match on_non_existence with | `Exit -> Printf.eprintf "%s and exiting.\n%!" message; exit 1 | `Raise -> failwithf "%s." message () end module Comprehension = struct module Format = struct type ispec = | Sing of int | IRange of int * int * int with sexp type t = | Atom of string | Plus of string list | Times of t list | Set of ispec list | CRange of char * char with sexp let print_list print_elem list = match list with | [] -> failwith "Invalid arity" | e :: es -> sprintf "{%s%s}" (print_elem e) (String.concat (List.map es ~f:(fun e -> sprintf ",%s" (print_elem e)))) let spec_to_string spec = match spec with | Sing n -> Int.to_string n | IRange(n,m,1) -> sprintf "%d..%d" n m | IRange(n,m,inc) -> sprintf "%d..%d..%d" n m inc let rec to_string fmt = match fmt with | Atom str -> str | Plus [str] -> str | Plus strs -> print_list Fn.id strs | Times es -> String.concat (List.map es ~f:to_string) | Set [Sing i] -> Int.to_string i | Set specs -> print_list spec_to_string specs | CRange (c1,c2) -> sprintf "{%c..%c}" c1 c2 end type 'a t = 'a list with sexp (* Takes a comprehension spec and produces all the strings it matches *) let rec expand fmt = let open Format in match fmt with | Atom str -> [str] | Plus strs -> strs | Times comps -> List.fold_right comps ~init:[""] ~f:(fun comp acc -> let strs = expand comp in List.concat (List.map strs ~f:(fun str1 -> List.map acc ~f:(fun str2 -> str1 ^ str2)))) (* Range is inclusive, but should never generate numbers outside the range * (see tests for clarification if needed) *) | Set elems -> List.concat (List.map elems ~f:(function | Sing x -> [Int.to_string x] | IRange (min, max, inc) -> List.init (1 + ((max - min) / inc)) ~f:(fun i -> Int.to_string (min+(i*inc))))) | CRange (cmin, cmax) -> let min, max = Char.to_int cmin, Char.to_int cmax in try List.init (1 + max - min) ~f:(fun i -> String.of_char (Char.of_int_exn (i + min))) with Failure _ -> failwith "Invalid spec for character range" (* If str begins with {, then split_brace_exn 0 str finds the matching } * and splits the string at that location. Raises an exception if * the braces aren't matched *) let rec split_brace_exn n str = match n, str with | _, '{' :: str' -> let left, right = split_brace_exn (n+1) str' in '{' :: left, right | 1, '}' :: str' -> ['}'], str' | _, '}' :: str' -> let left, right = split_brace_exn (n-1) str' in '}' :: left, right | _, c :: str' -> let left, right = split_brace_exn n str' in c :: left, right | _, [] -> failwith "Unbalanced braces in list comprehension" let str_split_brace_exn str = let str1, str2 = split_brace_exn 0 (String.to_list str) in String.of_char_list str1, String.of_char_list str2 (* If str begins with an alphanumeric, split_char str * splits it at the next opening brace *) let rec split_char str = match str with | [] -> [], [] | '{' :: _ -> [], str | c :: cs -> let left, right = split_char cs in c :: left, right let str_split_char str = let left, right = split_char (String.to_list str) in String.of_char_list left, String.of_char_list right let extract_opt ~rex str = match Re2.find_submatches rex str with | Error _ -> None | Ok ar -> Some (Array.map ar ~f:(Option.value ~default:"")) let rec parse_exn' str = let open Format in let find_crange cs = let str = String.of_char_list cs in (* Matches str {a .. z} and returns |str, a, z| *) let r = Re2.create_exn "^{ *([a-zA-Z]) *\\.\\. *([a-zA-Z]) *}$" in Option.bind (extract_opt ~rex:r str) (fun matches -> let str1, str2 = matches.(1), matches.(2) in match String.length str1, String.length str2 with | 1, 1 -> let c1, c2 = str1.[0], str2.[0] in if Char.to_int c1 < Char.to_int c2 then Some(CRange(c1,c2)) else failwith "Invalid character range in comprehension" | _ -> None) in (* Some if cs is an integer range, None if not an integer range, * exception if an invalid integer range *) let find_range cs = let str = String.of_char_list cs in (* Matches str {num1 .. num2 .. inc} and returns |str, num1, num2, inc| *) let r_inc = Re2.create_exn "^ *([0-9]+) *\\.\\. *([0-9]+) *\\.\\. *([0-9]+) *$" in match extract_opt ~rex:r_inc str with | Some matches -> let min = Int.of_string matches.(1) in let max = Int.of_string matches.(2) in let inc = Int.of_string matches.(3) in if inc = 0 then failwith "Invalid increment for range, must be positive" else IRange(min,max,inc) | None -> (* Matches str {num1 .. num2} and returns |str, num1, num2| *) let r = Re2.create_exn "^ *([0-9]+) *\\.\\. *([0-9]*) *$" in match extract_opt ~rex:r str with | Some matches -> let min, max = Int.of_string matches.(1), Int.of_string matches.(2) in if min >= max then failwith (sprintf "Invalid range in sexp: %d to %d" min max) else IRange(min,max,1) | None -> try Sing(Int.of_string (String.strip str)) with _ -> failwith (sprintf "Invalid integer spec in comprehension: %s" str) in let find_range_opt cs = try Some(find_range cs) with _ -> None in let find_set cs = let str = String.of_char_list cs in (* Sets look like {5, 11.. 23, 16, 1 .. 5 .. 2}, so as long as the first * non-blank character is a digit we've found one*) let r = Re2.create_exn "^{ *([0-9].*) *}$" in Option.bind (extract_opt ~rex:r str) (fun matches -> let separated = matches.(1) in let strs = String.split ~on:',' separated in match List.map strs ~f:(fun str -> find_range (String.to_list str)) with (* Singleton sets aren't very interesting, so let this get interpreted * as an atom later instead. Not clear whether we want this behavior - * just copying bash *) | [Sing _] -> None | specs -> Some(Set specs)) in (* Some if Plus is a valid sum expression, None otherwise *) let find_sum cs = let module S = String in let str = S.of_char_list cs in (* Check for comma because sums of one thing aren't very interesting, so let * them get interpreted as atoms later instead *) if S.is_prefix str ~prefix:"{" && S.is_suffix str ~suffix:"}" && S.contains str ',' then let stripped = S.drop_prefix (S.drop_suffix str 1) 1 in let split = S.split ~on:',' stripped in (* If it still contains braces then it looks like {foo{a,b,c}bar} * which isn't a sum. *) if S.contains stripped '{' || S.contains stripped '}' then None (* If one of the branches of the sum can be interpreted * as an integer range, then someone's probably trying to mix * integers and strings, which isn't supported right now, so don't let them. *) else if List.exists split ~f:(fun str -> Option.is_some (find_range_opt (String.to_list str))) then failwith "Can't mix integers and strings in sum comprehension" else Some(List.map ~f:S.strip split) else None in (* Splits str into consecutive blocks of brace-delimited and undelimited characters *) let rec split_prod str = match str with | [] -> [] | '{' :: _ -> let head, str' = split_brace_exn 0 str in head :: (split_prod str') | _ :: _ -> let head, str' = split_char str in head :: (split_prod str') in (* Handles the case where str is wrapped in braces but doesn't denote an expression. * This should come up rarely in our use cases, but it recursively looks for * expressions inside str *) let singleton str = match str with | '{' :: cs -> let cs' = List.take cs (List.length cs - 1) in Times[Atom "{"; parse_exn' cs'; Atom "}"] | cs -> Atom (String.of_char_list cs) in let find_prod str = match split_prod str with | [] -> Some(Atom "") | [_] -> None | strs -> Some(Times(List.map strs ~f:(function | ('{' :: _) as str -> parse_exn' str | ('}' :: _) -> failwith "Unbalanced braces in list comprehension" | str -> Atom (String.of_char_list str)))) in match find_prod str with | Some exp -> exp | None -> match find_crange str with | Some exp -> exp | None -> match find_set str with | Some exp -> exp | None -> match find_sum str with | Some strs -> Plus strs | None -> singleton str let parse_exn str = parse_exn' (String.to_list str) let expand_string_exn str = expand (parse_exn str) let expand_strings_exn strs = List.concat (List.map strs ~f:expand_string_exn) let t_of_sexp elem_of_sexp sexp = match sexp with | Atom _ -> failwith "Invalid sexp, expected list of atoms, but got atom" | List elems -> List.concat (List.map elems ~f:(fun sexp -> sexp |> Sexp.to_string |> expand_string_exn |> List.map ~f:(fun str -> str |> Sexp.of_string |> elem_of_sexp))) (* Count consecutive elements of ints that differ by delta *) let rec extract_run delta ints = match ints with | [] -> 0, [] | [_] -> 1, [] | x :: y :: xs -> if y = x + delta then let len, tail = extract_run delta (y :: xs) in len+1, tail else 1, y :: xs (* Split ints into consecutive runs*) let rec find_runs ints = match ints with | [] -> [] | [x] -> [Format.Sing x] | x :: y :: _ -> match extract_run (y - x) ints with | 1, tail -> (Format.Sing x) :: find_runs tail (* Use whatever format requires the least information: * {1,3} is less numbers than {1..3..2} but not less than * {1..2} *) | 2, tail -> if (y-x) = 1 then (Format.IRange(x,x+1,1)) :: find_runs tail else (Format.Sing x) :: (Format.Sing y) :: find_runs tail | len, tail -> (Format.IRange(x, x + (len-1)*(y-x), y-x)) :: find_runs tail let compress_ints ints = Format.Set(find_runs (List.dedup ints)) (* Simplistic compression scheme: split each string into str1str2 if possible. * For each set of matching str1 and str2, group together all the numbers in * a subpattern. *) let compress strs = let rec collect_num nums = match nums with | [] -> [] | (front,_,back) :: _-> let same, diff = List.partition_map nums ~f:(fun (front',i',back') -> if front = front' && back = back' then `Fst i' else `Snd(front', i', back')) in (front, compress_ints same, back) :: collect_num diff in let rec collect_suff nums = match nums with | [] -> [] | (front, ints, _) :: _ -> let same, diff = List.partition_map nums ~f:(fun (front', ints', back') -> if front = front' && ints = ints' then `Fst back' else `Snd(front', ints', back')) in Format.(Times[Atom front; ints; Plus same]) :: collect_suff diff in let collect_suff nums = if List.exists nums ~f:(fun (_, _, suff) -> String.exists suff ~f:(fun c -> c = ')' || c = '(')) then List.map nums ~f:(fun (front, ints, back) -> Format.(Times[Atom front; ints; Atom back])) else collect_suff nums in let num, alph = List.partition_map strs ~f:(fun str -> let r = Re2.create_exn "^([^0-9]*)([0-9]+)(.*)$" in match extract_opt ~rex:r str with | Some matches -> `Fst(matches.(1), Int.of_string matches.(2), matches.(3)) | None -> `Snd (Format.Atom str)) in List.map ~f:Format.to_string (alph @ collect_suff (collect_num num)) let sexp_of_t sexp_of_elem elems = let strs = List.map ~f:(fun elem -> elem |> sexp_of_elem |> Sexp.to_string) elems in List (List.map (compress strs) ~f:Sexp.of_string) let die f = try let _ = f () in false with _ -> true (* You should always be able to convert a string list to comprehensions and back. *) let roundtrip strs = let sort = List.sort ~cmp:String.compare in sort strs = (strs |> sort |> compress |> expand_strings_exn |> sort) TEST = Format.(["1";"2";"3"] = expand (Set[IRange(1,3,1)])) TEST = Format.(["ab1";"ab2";"ab3"] = expand (Times[Atom "ab"; Set[IRange (1,3,1)]])) TEST = Format.(["foobar"] = expand(Times[Atom "foo"; Atom "bar"])) TEST = Format.(["a1";"b1";"c1"] = expand(Times[Plus["a";"b";"c"]; Set[IRange(1,1,1)]])) TEST = Format.(["a1";"a2";"d1";"d2"] = expand(Times[Plus["a";"d"]; Set[IRange(1,2,1)]])) TEST = Format.(["135"; "136"; "145"; "146"; "235"; "236"; "245"; "246"] = expand(Times[Set[IRange(1,2,1)]; Set[IRange(3,4,1)]; Set[IRange(5,6,1)]])) (* Sums where the branches are different sizes *) TEST = ["adefg"; "adfg"; "adg"; "abdefg"; "abdfg"; "abdg"; "abcdefg"; "abcdfg"; "abcdg"] = expand_string_exn "{a,ab,abc}d{efg,fg,g}" (* Brace matching *) TEST = ("{foo}", "bar") = str_split_brace_exn "{foo}bar" TEST = ("foo", "{bar}") = str_split_char "foo{bar}" TEST = ("{{{}}{}{{}}{}}", "{{}{}}") = str_split_brace_exn "{{{}}{}{{}}{}}{{}{}}" TEST = Format.(Atom "") = parse_exn "" (* Whitepsace insensitivity for integer ranges *) TEST = Format.(Set[IRange(12,25,1)]) = parse_exn "{12 .. 25}" TEST = Format.(Set[IRange(12,25,1)]) = parse_exn "{12 .. 25}" TEST = Format.(Set[IRange(12,25,1)]) = parse_exn "{12 ..25}" TEST = Format.(Set[IRange(5,25,1)]) = parse_exn "{5.. 25}" TEST = Format.(Set[IRange(3,6,3)] = parse_exn "{3..6..3}") (* Simple sums *) TEST = Format.(Plus["a";"b";"c"]) = parse_exn "{a,b,c}" (* Character ranges *) TEST = Format.(Times([Atom "hi"; CRange('a','d'); Plus["a";"e";"f"]]) = parse_exn "hi{a..d}{a,e,f}") TEST = Format.(Times[Atom "a"; Set[IRange(1,3,1)]; Atom "c"]) = parse_exn "a{1 .. 3}c" TEST = (["{a}"; "{b}"; "{c}"] = expand_string_exn "{{a,b,c}}") TEST = (["this{is}{not}a{test}"] = expand_string_exn "this{is}{not}a{test}") TEST = (["{{{hi}}}"] = expand_string_exn "{{{hi}}}") TEST = (["{{1}{2}}hi{{a}{b}}"] = expand_string_exn "{{1}{2}}hi{{a}{b}}") TEST = (["{{1}{2}}hi{{a}{b}}"] = t_of_sexp String.t_of_sexp (List[Atom( "{{1}{2}}hi{{a}{b}}")])) TEST = (["1";"2";"5";"6";"7"] = t_of_sexp String.t_of_sexp (List[Atom("{1..2}"); Atom("{5..7}")])) TEST = (["Afoo7"; "Afoo8"; "Afoo9"; "bfoo7"; "bfoo8"; "bfoo9"] = expand_string_exn "{A,b}foo{7..9}") TEST = (["1"; "3"; "5"] = expand_string_exn "{1..5..2}") TEST = (["1"; "3"; "5"] = expand_string_exn "{1..6..2}") TEST = (["a1"; "a2"; "b1"; "b2"; "c1"; "c2"] = expand_string_exn "{a..c}{1..2}") TEST = (["{ a }b5{4}"; "{ a }b1{4}"; "{ a }b2{4}"; "{ a }b1{4}"; "{ a }b7{4}"; "{ a }c5{4}"; "{ a }c1{4}"; "{ a }c2{4}"; "{ a }c1{4}"; "{ a }c7{4}"] = expand_string_exn "{ a }{ b .. c }{ 5 , 1 .. 2 , 1 .. 2 .. 2 , 7 }{4}") TEST = roundtrip ["foo1a"; "foo2a"; "foo3a"; "foo3b"; "foo4b"; "foo5c"; "foo7c"; "foo7d"; "foo9d"; "foo11d"] TEST = roundtrip ["foo1a"; "foo2a"; "foo3b"] TEST = roundtrip["a1b1"; "a2b1"; "a1b2"; "a2b2"] (* Brace matching *) TEST = roundtrip["{{{}}{}{{}}{}}{{}{}}"] (* Keyboard-mashing*) TEST = roundtrip["1212k1"; "121k2"; "12k"; "12k1"; "12k12"; "12k12121k2"; "1k1"; "1k2"; "1kk"; "2"; "21k"; "21k2"; "2k"; "2k1"; "2k12"; "2k12121k2"; "2k121k"; "2k12k1"; "2k12k121"; "2k12k12k"; "k"; "k1"; "k21k212"; "k2k121k212k"; "k2k12k1"] (* Longish range *) TEST = (["a{1..100}b"] = compress (List.init 100 ~f:(fun i -> sprintf "a%db" (i+1)))) TEST = (["{1..100}b"] = compress (List.init 100 ~f:(fun i -> sprintf "%db" (i+1)))) TEST = (["a{1..100}"] = compress (List.init 100 ~f:(fun i -> sprintf "a%d" (i+1)))) TEST = (["{1..100}"] = compress (List.init 100 ~f:(fun i -> sprintf "%d" (i+1)))) (* Compress suffixes *) TEST = (["a{1..2}{foo,bar}"] = compress ["a1foo"; "a1bar"; "a2foo"; "a2bar"]) (* Don't compress not-suffices - one buggy implementation turns this into {1..2}a{1..2} *) TEST = (["1a1"; "2a2"] = compress ["1a1"; "2a2"]) (* Same test but considering that we compress suffixes *) TEST = roundtrip ["a1a"; "a2b"] TEST = roundtrip ["a1a"; "b1b"] TEST = roundtrip ["a1a"; "b2a"] (* Similar test, but some things should actually get compressed *) TEST = roundtrip ["a1a"; "a1b"; "aa1a"; "aa2a"; "a2b"] (* Order shouldn't matter for compression *) TEST = (compress ["a1"; "a3"; "a5"; "a7"]) = (compress ["a5"; "a1"; "a7"; "a3"]) (* If you accidentally sort the numbers as strings they could end up in lexicographic * order and finding runs would fail. So test numbers whose lexicographic order * differs from numeric order *) TEST = ["{500..1500..500}"] = compress ["1500"; "500"; "1000"] TEST = die (fun () -> expand_string_exn "{1..1}") TEST = die (fun () -> expand_string_exn "{2..1}") TEST = die (fun () -> expand_string_exn "{foo}{") TEST = die (fun () -> expand_string_exn "}{1..3}") TEST = die (fun () -> expand_string_exn "{{1}{2}}}}{{{a}") TEST = die (fun () -> expand_string_exn "{1..5..0}") TEST = die (fun () -> expand_string_exn "{z..a}") TEST = die (fun () -> expand_string_exn "{a..a}") TEST = die (fun () -> expand_string_exn "{1..23,a}") TEST = die (fun () -> expand_string_exn "{a,1..23}") TEST = die (fun () -> t_of_sexp String.t_of_sexp (Atom "hi")) TEST = die (fun () -> t_of_sexp String.t_of_sexp (List [Atom "hi"; List []])) end TEST_MODULE "sexp_parens" = struct type t = (int * int option) Comprehension.t with sexp let sexp_roundtrip t = t = t_of_sexp (sexp_of_t t) (* These elements have sexps that differ only by a suffix which contains * parens. If you compress these strings naively you'll get an invalid sexp, * and parsing it will fail *) TEST = sexp_roundtrip [(100, Some 200); (100, None)] end core_extended-113.00.00/src/extended_sexp.mli000066400000000000000000000110221256461102500207530ustar00rootroot00000000000000open Core.Std (** Extensions to [Sexplib.Sexp].*) val is_atom : Sexp.t -> bool val is_list : Sexp.t -> bool (** {3 Constructors } *) val atom : string -> Sexp.t val list : Sexp.t list -> Sexp.t (**{3 Printing }*) (** The ocaml pretty printer (used by sexplib) is a speed daemon but is, sadly enough, produces wrong output (e.g it overflows in places where this could have avoided). This uses a printer from wadler's a prettier printer to output strings suited to human consumption. *) val to_string_hum' : Sexp.t -> string val format : Sexp.t -> Pp.t (** A more readable but less compact pretty printer than the one bundled by sexplib. This is going through a test period at which point it might make it in sexplib. It uses ocaml's pretty-printing library so it is both fast and broken. *) val pp_hum' : Format.formatter -> Sexp.t -> unit (** Takes a string and returns the same string but commented according to sexp's syntax*) val comment : string -> string (** {3 Various} *) module Diff : sig type t val print : ?oc:out_channel -> t -> unit val to_buffer : t -> Buffer.t val to_string : t -> string val of_sexps : original:Sexp.t -> updated:Sexp.t -> t option end val print_diff : ?oc:out_channel -> original:Sexp.t -> updated:Sexp.t -> unit -> unit (** Returns a smaller sexp by replacing sections with "...". Will try to show parts of the sexp "near" sub_sexp. Limiting size to length a string length is less efficient than a certain depth. The meaning of a given depth is arbitrary except that more depth gives you a bigger sexp. Try 100 or so. *) val summarize : Sexp.t -> sub_sexp:Sexp.t -> size:[ `depth of int | `string of int ] -> Sexp.t (** {3 Transforming sexp parsers} *) module Records_table : sig (* Given 2 types: type t1 = { symbol : string; contracts_open : int; } type t2 = { symbol : string; contracts_open : int; description : string; } let t1_of_sexp = t_of_sexp t1_of_sexp let t2_of_sexp = t_of_sexp t2_of_sexp Both functions will successfully parse a sexp of the form: ((symbol contracts_open description) (ABC 100 "...") (XYZ 350 "...")) *) type 'a t = 'a list include Sexpable.S1 with type 'a t := 'a t end (* This module is intended to be used when [T.t] is a record type and [T.explicit_sexp_option_fields] is a list of fields declared with [sexp_option]. The sexp conversions are changed so that [None] and [Some "foo"] are written out as [()] and [("foo")] respectively, so that you can switch to regular options more easily. *) module Make_explicit_sexp_option (T: sig type t with sexp val explicit_sexp_option_fields : string list end) : sig type t = T.t with sexp end val load_sexp_conv_exn_sample : ?strict:bool -> ?buf:string -> ?on_non_existence:[`Exit | `Raise] -> ?name:string -> string -> sexp_of_t:('a -> Sexp.t) -> t_of_sexp:(Sexp.t -> 'a) -> sample:'a -> 'a (* Sexp serializer for lists that supports wildcard expansion. This follows bash brace-expansion syntax as closely as possible except when it's really inconvenient or we can do better. In particular, there are two known deviations: In bash, complicated sets of integers are written with nested braces, e.g. {{1..3},4} expands to 1 2 3 4, but our in our syntax this would be {1..3, 4}. Bash is also picky about whitespace. We're not. So { 1 .. 2 } is the same as {1..2}. Supported expansions: {a,b,c} expands to one instance for each of a, b and c {a..c} expands to one instance for each character in the range a..c pat1pat2 expands pat1 and pat2 and concatenates all possible combinations {1..10} expands to an instance for each integer 1..10 {1..10..2} expands to an instance for each integer 1..10, increasing by 2 {1,3,5} expands to an instance for each integer 1, 3, 5 All other strings expand to themselves. This is mostly meant to be used for types that have simple sexp serializers, like string and int, but can be used on more complicated types. The expansions disregard the structure of the sexp and are just a transformation on its text representation. This adds an unfortunate number of intermediate steps to the translation, but makes it easy to reason about the effects on a complicated sexp. Comprehension.t unifies with list, so you can use a Comprehension.t anywhere that you have a list and you want bash expansion/compression. *) module Comprehension : sig type 'a t = 'a list with sexp end core_extended-113.00.00/src/extended_string.ml000066400000000000000000000325511256461102500211430ustar00rootroot00000000000000open Core.Std;; (* Natural ordering like found in gnome nautilus, the mac finder etc... Refer to Mli for more documentation *) let collate s1 s2 = let pos1 = ref 0 and pos2 = ref 0 in let next ~ok s pos = if (!pos) = String.length s then None else let c = s.[!pos] in if ok c then begin incr pos; Some c end else None in let compare_non_numerical () = let ok c = not (Char.is_digit c) in let rec loop () = match next ~ok s1 pos1,next ~ok s2 pos2 with | Some _, None -> 1 | None , Some _ -> -1 | None , None -> 0 | Some c1,Some c2 when c1 = c2 -> loop () | Some c1,Some c2 -> Char.compare c1 c2 in loop () in let compare_numerical () = let rec consume0 s pos = match next ~ok:((=) '0') s pos with | Some _ -> consume0 s pos | None -> () in (* Our main loop works on string representation of ints where all the trailing zeros have been chopped of. Their magnitude is given by the length of their representation. If they have the same magnitude the lexical order is correct. Bias is used to save that information. *) let ok = Char.is_digit in let bias = ref 0 in let rec loop () = match next ~ok s1 pos1,next ~ok s2 pos2 with | Some _, None -> 1 | None , Some _ -> -1 | None , None when !bias <> 0-> !bias | None , None -> (* Both ints have the same value, The one with the shortest representation (i.e. the least trailing zeroes) is considered to be the smallest*) !pos1 - !pos2 | Some c1,Some c2 when !bias = 0 -> bias := Char.compare c1 c2; loop () | Some _ , Some _ -> loop () in consume0 s1 pos1; consume0 s2 pos2; loop () in let s1_length = String.length s1 in let s2_length = String.length s2 in let rec loop () = let r = compare_non_numerical () in let r' = compare_numerical () in match r,r' with | 0,0 when !pos1 = s1_length && !pos2 = s2_length -> 0 | 0,0 -> loop () | 0,i | i,_ -> i in loop () ;; TEST_MODULE "collate" = struct let (!) s s' = collate s s' > 0 let basic_tests = (fun (s,s') -> "invertible" @? ((s' ! s')); "total" @? (definitive_clause [s!s'])) *) (* repeat 50 basic_tests (pg sg sg); repeat 2 basic_tests (dup sg); repeat 50 (fun (s,s',s'') -> let (s1,s2,s3) = match List.sort ~cmp:String.collate [s;s';s''] with | [s1;s2;s3] -> s1,s2,s3 | _ -> assert false in "transitive" @? (((s1 emit c | None -> error ~fatal:true (Printf.sprintf "got invalid escape code %d" code) in let rec loop () = if !pos < len then begin let c = consume () in if c <> '\\' then emit c else begin let mark = !pos in try let c = consume () in match c with | '\\' | '\"' -> emit c | 'b' -> emit '\b' | 'n' -> emit '\n' | 'r' -> emit '\r' | 't' -> emit '\t' | '\n' -> let rec consume_blank () = if !pos < len then begin match consume () with | ' ' | '\t' -> consume_blank () | _ -> decr pos end in consume_blank () | 'x' -> let c2hex c = if (c >= 'A') && (c <= 'F' ) then (Char.to_int c) + 10 - Char.to_int 'A' else if (c >= 'a') && (c <= 'f' ) then (Char.to_int c) + 10 - Char.to_int 'a' else if (c >= '0') && (c <= '9') then (Char.to_int c) - Char.to_int '0' else error (Printf.sprintf "expected hex digit, got: %c" c); in let c1 = consume () in let c2 = consume () in emit_code (16 * c2hex c1 + c2hex c2); | c when Char.is_digit c -> let char_to_num c = match Char.get_digit c with | None -> error (Printf.sprintf "expected digit,got: %c" c); | Some i -> i in let i1 = char_to_num c in let i2 = char_to_num (consume ()) in let i3 = char_to_num (consume ()) in emit_code (100 * i1 + 10 * i2 + i3); | c -> error (Printf.sprintf "got invalid escape character: %c" c); with Unescape_error (false,_,_) when not strict -> emit '\\'; pos := mark end; loop () end else Buffer.contents res; in loop (); ;; let unescaped ?strict s = try unescaped' ?strict s with Unescape_error (_,pos,message) -> invalid_argf "String.unescaped error at position %d of %s: %s" pos s message () let unescaped_res ?strict s = try Result.Ok (unescaped' ?strict s) with Unescape_error (_,pos,message) -> Result.Error (pos,message) let squeeze str = let len = String.length str in let buf = Buffer.create len in let rec skip_spaces i = if i >= len then Buffer.contents buf else let c = str.[i] in if (c = ' ') || (c = '\n') || (c = '\t') || (c = '\r') then skip_spaces (i+1) else begin Buffer.add_char buf c; copy_chars (i+1) end and copy_chars i = if i >= len then Buffer.contents buf else let c = str.[i] in if (c = ' ') || (c = '\n') || (c = '\t') || (c = '\r') then begin Buffer.add_char buf ' '; skip_spaces (i+1) end else begin Buffer.add_char buf c; copy_chars (i+1) end in copy_chars 0 ;; let pad_right ?(char=' ') s l = let src_len = String.length s in if src_len >= l then s else let res = String.create l in String.blit ~src:s ~dst:res ~src_pos:0 ~dst_pos:0 ~len:src_len; String.fill ~pos:src_len ~len:(l-src_len) res char; res let pad_left ?(char=' ') s l = let src_len = String.length s in if src_len >= l then s else let res = String.create l in String.blit ~src:s ~dst:res ~src_pos:0 ~dst_pos:(l-src_len) ~len:src_len; String.fill ~pos:0 ~len:(l-src_len) res char; res let line_break ~len s = let buf = Buffer.create len in let flush_buf () = let res = Buffer.contents buf in Buffer.reset buf; res in let rec loop acc = function | [] -> let acc = if Buffer.length buf <> 0 then flush_buf ():: acc else if acc = [] then [""] else acc in List.rev acc | h::t when Buffer.length buf = 0 -> Buffer.add_string buf h; loop acc t | h::t when (Buffer.length buf + 1 + String.length h) < len -> Buffer.add_char buf ' '; Buffer.add_string buf h; loop acc t | l -> loop (flush_buf ()::acc) l in List.concat_map (String.split ~on:'\n' s) ~f:(fun s -> loop [] (String.split ~on:' ' s)) (* Finds out where to break a given line; returns the len of the line to break and the staring position of the next line.*) let rec word_wrap__break_one ~hard_limit ~soft_limit ~previous_match s ~pos ~len = if pos = String.length s then len,pos else if previous_match > 0 && len >= soft_limit then previous_match,pos-len+previous_match+1 else if len >= hard_limit then len,pos else match s.[pos] with (* Detect \r\n as one newline and not two... *) | '\r' when pos < String.length s -1 && s.[pos + 1] = '\n' -> len,pos+2 | '\r' | '\n' -> len,pos+1 | ' ' | '\t' -> word_wrap__break_one s ~hard_limit ~soft_limit ~previous_match:len ~pos:(pos+1) ~len:(len+1) | _ -> word_wrap__break_one s ~previous_match ~hard_limit ~soft_limit ~pos:(pos+1) ~len:(len+1) (* Returns an pos*length list of all the lines (as substrings of the argument passed in) *) let rec word_wrap__find_substrings ~hard_limit ~soft_limit s acc pos = if pos < String.length s then begin let len,new_pos = word_wrap__break_one s ~hard_limit ~soft_limit ~previous_match:0 ~pos ~len:0 in word_wrap__find_substrings ~hard_limit ~soft_limit s ((pos,len)::acc) new_pos end else acc let word_wrap ?(trailing_nl=false) ?(soft_limit=80) ?(hard_limit=Int.max_value) ?(nl="\n") s = let soft_limit = min soft_limit hard_limit in let lines = word_wrap__find_substrings ~soft_limit ~hard_limit s [] 0 in match lines with | [] | [_] -> if trailing_nl then s^nl else s | ((hpos,hlen)::t) -> let nl_len = String.length nl in let body_len = List.fold_left t ~f:(fun acc (_,len) -> acc + nl_len + len) ~init:0 in let res_len = if trailing_nl then body_len+hlen+nl_len else body_len+hlen in let res = String.create res_len in if trailing_nl then begin String.blit ~src:nl ~dst:res ~len:nl_len ~src_pos:0 ~dst_pos:(body_len+hlen); end; String.blit ~src:s ~dst:res ~len:hlen ~src_pos:hpos ~dst_pos:body_len; let rec blit_loop dst_end_pos = function | [] -> () | (src_pos,len)::rest -> let dst_pos = dst_end_pos-len-nl_len in String.blit ~src:s ~dst:res ~len ~src_pos ~dst_pos; String.blit ~src:nl ~dst:res ~len:nl_len ~src_pos:0 ~dst_pos:(dst_pos + len); blit_loop dst_pos rest in blit_loop body_len t; res let is_substring_deprecated ~substring:needle haystack = (* 2014-10-29 mbac: a recent release of Core introduced a fast and less surprising version of KMP. Everyone should use that. This function is simply here to maintain bug compatibiltiy with the original pure-ML version of f is_substring that used to be here. *) if String.length needle = 0 then begin if String.length haystack = 0 then false else invalid_arg "index out of bounds" end else Core.Std.String.is_substring ~substring:needle haystack TEST = is_substring_deprecated ~substring:"foo" "foo" TEST = not (is_substring_deprecated ~substring:"" "") TEST = (* For bug compatibility with the ML version that used to be here *) try ignore (is_substring_deprecated ~substring:"" "foo"); assert false (* should not be reachable *) with Invalid_argument _ -> true TEST = not (is_substring_deprecated ~substring:"foo" "") TEST = is_substring_deprecated ~substring:"bar" "foobarbaz" TEST = not (is_substring_deprecated ~substring:"Z" "z") TEST = not (is_substring_deprecated ~substring:"store" "video stapler") TEST = not (is_substring_deprecated ~substring:"sandwich" "apple") TEST = is_substring_deprecated ~substring:"z" "abc\x00z" let edit_distance_matrix ?transpose s1 s2 = let transpose = Option.is_some transpose in let l1, l2 = String.length s1, String.length s2 in let d = Array.make_matrix 0 ~dimx:(l1+1) ~dimy:(l2+1) in for x=0 to l1 do d.(x).(0) <- x done; for y=0 to l2 do d.(0).(y) <- y done; for y=1 to l2 do for x=1 to l1 do let min_d = if s1.[x-1] = s2.[y-1] then d.(x-1).(y-1) else List.reduce_exn ~f:min [d.(x-1).(y) + 1; d.(x).(y-1) + 1; d.(x-1).(y-1) + 1] in let min_d = if transpose && x > 1 && y > 1 && s1.[x-1] = s2.[y-2] && s1.[x-2] = s2.[y-1] then min min_d (d.(x-2).(y-2) + 1) else min_d in d.(x).(y) <- min_d done; done; d let edit_distance ?transpose s1 s2 = (edit_distance_matrix ?transpose s1 s2).(String.length s1).(String.length s2) TEST = edit_distance "" "" = 0 TEST = edit_distance "stringStringString" "stringStringString" = 0 TEST = edit_distance "ocaml" "coaml" = 2 TEST = edit_distance ~transpose:() "ocaml" "coaml" = 1 TEST = edit_distance "sitting" "kitten" = 3 TEST = edit_distance ~transpose:() "sitting" "kitten" = 3 TEST = edit_distance "abcdef" "1234567890" = 10 TEST = edit_distance "foobar" "fubahr" = 3 TEST = edit_distance "hylomorphism" "zylomorphism" = 1 core_extended-113.00.00/src/extended_string.mli000066400000000000000000000055371256461102500213200ustar00rootroot00000000000000(** Extensions to [Core.Core_String]. *) open Core.Std (** [collate s1 s2] sorts string in an order that's usaully more suited for human consumption by treating ints specially, e.g. it will output: [["rfc1.txt";"rfc822.txt";"rfc2086.txt"]]. It works by splitting the strings in numerical and non-numerical chunks and comparing chunks two by two from left to right (and starting on a non numerical chunk): - Non_numerical chunks are compared using lexicographical ordering. - Numerical chunks are compared based on the values of the represented ints and the number of trailing zeros. It is a total order. *) val collate : string -> string -> int (** [unescaped s] is the inverse operation of [escaped]: it takes a string where all the special characters are escaped following the lexical convention of OCaml and returns an unescaped copy. The [strict] switch is on by default and makes the function treat illegal backslashes as errors. When [strict] is [false] every illegal backslash except escaped numeral greater than [255] is copied literally. The aforementioned numerals still raise errors. This mimics the behaviour of the ocaml lexer. *) val unescaped : ?strict:bool -> string -> string (** Same as [unescaped] but instead of raising [Failure _] returns an error message with the position in the string in case of failure. *) val unescaped_res : ?strict:bool -> string -> (string,(int*string)) Result.t (** [squeeze str] reduces all sequences of spaces, newlines, tables, and * carriage returns to single spaces. *) val squeeze : string -> string (** Use Core.Std.String.is_substring instead of this function. This wrapper is here (for now) to maintain bug compatibility. *) val is_substring_deprecated : substring:string -> string -> bool (** [pad_left ~char s len] Returns [s] padded to the length [len] by adding characters [char] to the left of the string. If s is already longer than [len] it is returned unchanged. *) val pad_left : ?char:char -> string -> int -> string val pad_right : ?char:char -> string -> int -> string (**deprecated in favour of word_wrap *) val line_break: len:int -> string -> string list (** [word_wrap ~soft_limit s] Wraps the string so that it fits the length [soft_limit]. It doesn't break words unless we go over [hard_limit]. if [nl] is passed it is inserted instead of the normal newline character. *) val word_wrap: ?trailing_nl:bool -> ?soft_limit:int -> ?hard_limit:int -> ?nl:string -> string -> string (** Gives the Levenshtein distance between 2 strings, which is the number of insertions, deletions, and substitutions necessary to turn either string into the other. With the [transpose] argument, it alsos considers transpositions (Damerau-Levenshtein distance). *) val edit_distance : ?transpose : unit -> string -> string -> int core_extended-113.00.00/src/extended_sys.ml000066400000000000000000000034011256461102500204430ustar00rootroot00000000000000open Core.Std;; let home () = match Sys.getenv "HOME" with | None -> (Unix.Passwd.getbyuid_exn (Unix.geteuid ())).Unix.Passwd.dir | Some home -> home let groups = Memo.unit (fun () -> Unix.getgroups () |> Array.to_list |> List.filter_map ~f:(fun gid -> Option.map (Unix.Group.getbygid gid) ~f:(fun g -> g.Unix.Group.name)) |> (function | [] -> failwith "Expected at least one group." | groups -> groups)) let hostname = Unix.gethostname let file_kind f = (Unix.lstat f).Unix.st_kind let ls dir = Sys.readdir dir |! Array.to_list |! List.sort ~cmp:Extended_string.collate let stat_time_exn f ?(follow_symlinks=true) path = let stat = (if follow_symlinks then Unix.stat else Unix.lstat) path in Time.of_float (f stat) ;; let stat_time f ?follow_symlinks path = Option.try_with (fun () -> stat_time_exn f ?follow_symlinks path) ;; let last_accessed, last_accessed_exn = let f = (fun stat -> stat.Unix.st_atime) in stat_time f, stat_time_exn f ;; let last_modified, last_modified_exn = let f = (fun stat -> stat.Unix.st_mtime) in stat_time f, stat_time_exn f ;; let last_changed, last_changed_exn = let f = (fun stat -> stat.Unix.st_ctime) in stat_time f, stat_time_exn f ;; let file_size_exn ?(follow_symlinks=true) path = let stat = (if follow_symlinks then Unix.stat else Unix.lstat) path in stat.Unix.st_size ;; let file_size ?follow_symlinks path = Option.try_with (fun () -> file_size_exn ?follow_symlinks path) ;; let scroll_lock ixon = let stdin_fd = Unix.descr_of_in_channel stdin in let open Unix.Terminal_io in tcsetattr { (tcgetattr stdin_fd) with c_ixon = ixon } stdin_fd ~mode:TCSANOW ;; core_extended-113.00.00/src/extended_sys.mli000066400000000000000000000032001256461102500206110ustar00rootroot00000000000000(** Utility functions concerning the OCaml-runtime *) open Core.Std;; val ls : string -> string list val file_kind : string -> Unix.file_kind (** Get the home of the effective user *) val home : unit -> string (** Get the names of the groups the user belongs to *) val groups : unit -> string list val hostname : unit -> string (** [last_accessed path] returns the time [path] was last accessed. For files, the access time is updated whenever the file is read or executed. Note that some filesystems do not implement access time updates, or may allow mounting with access time updates disabled. *) val last_accessed : ?follow_symlinks:bool -> string -> Time.t option val last_accessed_exn : ?follow_symlinks:bool -> string -> Time.t (** [last_modify path] returns the time the file at [path] was last modified. For files, the modify time is updated whenever [path] is written to, or if its status attributes are updated. *) val last_modified : ?follow_symlinks:bool -> string -> Time.t option val last_modified_exn : ?follow_symlinks:bool -> string -> Time.t (** [last_changed path] returns the time [path] last had its status changed. This is not the same as last modified, as the last status change will also be updated if [path]'s ownership or permissions change. *) val last_changed : ?follow_symlinks:bool -> string -> Time.t option val last_changed_exn : ?follow_symlinks:bool -> string -> Time.t val file_size : ?follow_symlinks:bool -> string -> Int64.t option val file_size_exn : ?follow_symlinks:bool -> string -> Int64.t (** [scroll_lock false] disables scroll locking. *) val scroll_lock : bool -> unit ;; core_extended-113.00.00/src/extended_thread.ml000066400000000000000000000005101256461102500210720ustar00rootroot00000000000000open Core.Std let safe_create f = Thread.create (fun () -> try f () with e -> eprintf "In thread %i\n" (Thread.id (Thread.self ())); if Printexc.backtrace_status () then Printexc.print_backtrace stderr; prerr_endline (Exn.to_string e); exit 1) () core_extended-113.00.00/src/extended_thread.mli000066400000000000000000000003631256461102500212510ustar00rootroot00000000000000open Core.Std (** Extensions to [Core.Core_thread] *) (** Behaves like [Thread.create] but exits the program if an exception trickles to the toplevel. This is generally a safer alternative. *) val safe_create : (unit -> unit) -> Thread.t core_extended-113.00.00/src/extended_time.ml000066400000000000000000000014611256461102500205670ustar00rootroot00000000000000open Core.Std module Extended_date = struct let format ?(ofday=Time.Ofday.start_of_day) s t = Time.format (Time.of_date_ofday t ofday ~zone:Time.Zone.local) s end module Extended_span = struct let to_string_hum (t : Time.Span.t) = let sign_str = match Float.sign (t :> float) with | Float.Sign.Neg -> "-" | Float.Sign.Zero | Float.Sign.Pos -> "" in let rest = match Float.classify (t :> float) with | Float.Class.Subnormal | Float.Class.Zero -> "0:00:00.000" | Float.Class.Infinite -> "inf" | Float.Class.Nan -> "nan" | Float.Class.Normal -> let parts = Time.Span.to_parts t in let module P = Time.Span.Parts in sprintf "%d:%02d:%02d.%03d" parts.P.hr parts.P.min parts.P.sec parts.P.ms in sign_str ^ rest end core_extended-113.00.00/src/extended_time.mli000066400000000000000000000007731256461102500207450ustar00rootroot00000000000000open Core.Std module Extended_date : sig (** Shortcut for calling Core_extended.Unix.strftime without having to create a Time.t and convert it to a Unix.tm. [format "%Y-%m-%d" t] will return "YYYY-MM-DD" *) val format : ?ofday:Time.Ofday.t -> string -> Date.t -> string end module Extended_span : sig (** Convert a time span to a human-readable string, e.g. "1:23:45.778" (versus "1.396h" from [Time.Span.to_string]). *) val to_string_hum : Time.Span.t -> string end core_extended-113.00.00/src/extended_unix.ml000066400000000000000000000306501256461102500206160ustar00rootroot00000000000000open Core.Std open Unix external raw_fork_exec : stdin : File_descr.t -> stdout : File_descr.t -> stderr : File_descr.t -> ?working_dir : string -> ?setuid : int -> ?setgid : int -> ?env : (string) array -> string -> string array -> Pid.t = "extended_ml_spawn_bc" "extended_ml_spawn" module Env = struct open String.Map type t = string String.Map.t let empty : t = empty let get () = Array.fold (Unix.environment ()) ~init:empty ~f:(fun env str -> match String.lsplit2 ~on:'=' str with | Some (key,data) -> add ~key ~data env | None -> failwithf "extended_unix.Env.get %S is not in the form of key=value" str ()) let add ~key ~data env = if String.mem key '=' then failwithf "extended_unix.Env.add:\ variable to export in the environment %S contains an equal sign" key () else if String.mem key '\000' then failwithf "extended_unix.Env.add:\ variable to export in the environment %S contains an null character" key () else if String.mem data '\000' then failwithf "extended_unix.Env.add:\ value (%S) to export in the environment for %S contains an null character" data key () else String.Map.add ~key ~data env let to_string_array env = String.Map.to_alist env |! List.map ~f:(fun (k,v) -> k^"="^v) |! List.to_array end let fork_exec ?(stdin=Unix.stdin) ?(stdout=Unix.stdout) ?(stderr=Unix.stderr) ?(path_lookup=true) ?env ?working_dir ?setuid ?setgid prog args = let env = Option.map env ~f:(fun e -> let init,l = match e with | `Extend l -> Env.get (),l | `Replace l -> Env.empty,l in List.fold_left l ~init ~f:(fun env (key,data) -> Env.add ~key ~data env) |! Env.to_string_array) and full_prog = if path_lookup then match Shell__core.which prog with | Some s -> s | None -> failwithf "fork_exec: Process not found %s" prog () else prog in raw_fork_exec ~stdin ~stdout ~stderr ?working_dir ?setuid ?setgid ?env full_prog (Array.of_list (prog::args)) external seteuid : int -> unit = "extended_ml_seteuid" external setreuid : uid:int -> euid:int -> unit = "extended_ml_setreuid" external htonl : Int32.t -> Int32.t = "extended_ml_htonl" external ntohl : Int32.t -> Int32.t = "extended_ml_ntohl" TEST = htonl (ntohl 0xdeadbeefl) = 0xdeadbeefl type statvfs = { bsize: int; (** file system block size *) frsize: int; (** fragment size *) blocks: int; (** size of fs in frsize units *) bfree: int; (** # free blocks *) bavail: int; (** # free blocks for non-root *) files: int; (** # inodes *) ffree: int; (** # free inodes *) favail: int; (** # free inodes for non-root *) fsid: int; (** file system ID *) flag: int; (** mount flags *) namemax: int; (** maximum filename length *) } with sexp, bin_io (** get file system statistics *) external statvfs : string -> statvfs = "statvfs_stub" (** get load averages *) external getloadavg : unit -> float * float * float = "getloadavg_stub" module Extended_passwd = struct open Passwd let of_passwd_line_exn s = match String.split s ~on:':' with | name::passwd::uid::gid::gecos::dir::shell::[] -> { name = name; passwd = passwd; uid = Int.of_string uid; gid = Int.of_string gid; gecos = gecos; dir = dir; shell = shell } | _ -> failwithf "of_passwd_line: failed to parse: %s" s () ;; let of_passwd_line s = Option.try_with (fun () -> of_passwd_line_exn s) ;; let of_passwd_file_exn fn = Exn.protectx (In_channel.create fn) ~f:(fun chan -> List.map (In_channel.input_lines chan) ~f:of_passwd_line_exn) ~finally:In_channel.close ;; let of_passwd_file f = Option.try_with (fun () -> of_passwd_file_exn f) ;; end external strptime : fmt:string -> string -> Unix.tm = "unix_strptime" module Inet_port = struct type t = int with sexp let of_int_exn x = if x > 0 && x < 65536 then x else failwith (sprintf "%d is not a valid port number." x) let of_int x = try Some (of_int_exn x ) with _ -> None let of_string_exn x = Int.of_string x |! of_int_exn let of_string x = try Some (of_string_exn x) with _ -> None let to_string x = Int.to_string x let to_int x = x let t_of_sexp sexp = String.t_of_sexp sexp |! of_string_exn let sexp_of_t t = to_string t |! String.sexp_of_t let _flag = Command.Spec.Arg_type.create of_string_exn end TEST = Inet_port.of_string "88" = Some 88 TEST = Inet_port.of_string "2378472398572" = None TEST = Inet_port.of_int 88 = Some 88 TEST = Inet_port.of_int 872342 = None module Mac_address = struct (* An efficient internal representation would be something like a 6 byte array, but let's use a hex string to get this off the ground. *) module T = struct type t = string with sexp, bin_io, compare let ( = ) = String.( = ) let equal = ( = ) let rex = Re2.Std.Re2.create_exn "[^a-f0-9]" let of_string s = let addr = String.lowercase s |> Re2.Std.Re2.rewrite_exn rex ~template:"" in let length = String.length addr in if length <> 12 then failwithf "MAC address '%s' has the wrong length: %d" s length (); addr let to_string t = let rec loop acc = function | a::b::rest -> let x = String.of_char_list [a; b] in loop (x :: acc) rest | [] -> List.rev acc |! String.concat ~sep:":" | _ -> assert false in loop [] (String.to_list t) let to_string_cisco t = let lst = String.to_list t in let a = List.take lst 4 |! String.of_char_list and b = List.take (List.drop lst 4) 4 |! String.of_char_list and c = List.drop lst 8 |! String.of_char_list in String.concat ~sep:"." [a; b; c] let t_of_sexp sexp = String.t_of_sexp sexp |! of_string let sexp_of_t t = to_string t |! String.sexp_of_t let hash = String.hash let _flag = Command.Spec.Arg_type.create of_string end include T include Hashable.Make(T) end TEST = Mac_address.to_string (Mac_address.of_string "00:1d:09:68:82:0f") = "00:1d:09:68:82:0f" TEST = Mac_address.to_string (Mac_address.of_string "00-1d-09-68-82-0f") = "00:1d:09:68:82:0f" TEST = Mac_address.to_string (Mac_address.of_string "001d.0968.820f") = "00:1d:09:68:82:0f" TEST = Mac_address.to_string_cisco (Mac_address.of_string "00-1d-09-68-82-0f") = "001d.0968.820f" module Quota = struct type bytes = Int63.t with sexp type inodes = Int63.t with sexp let bytes x = x let inodes x = x type 'units limit = { soft : 'units sexp_option; hard : 'units sexp_option; grace : Time.t sexp_option; } with sexp type 'units usage = private 'units (* None is encoded as zero *) type 'units c_limit = { c_soft : 'units; c_hard : 'units; c_grace : Time.t; } let zero_bytes = bytes Int63.zero let zero_inodes = inodes Int63.zero let ml_limit_of_c_limit ~zero { c_soft; c_hard; c_grace } = { soft = (if c_soft = zero then None else Some c_soft); hard = (if c_hard = zero then None else Some c_hard); grace = (if c_grace = Time.epoch then None else Some c_grace); } let c_limit_of_ml_limit ~zero { soft; hard; grace } = { c_soft = (match soft with None -> zero | Some x -> x); c_hard = (match hard with None -> zero | Some x -> x); c_grace = (match grace with None -> Time.epoch | Some x -> x); } external quota_query : [ `User | `Group ] -> id:int -> path:string -> ( bytes c_limit * bytes usage * inodes c_limit * inodes usage) = "quota_query" external quota_modify : [ `User | `Group ] -> id:int -> path:string -> bytes c_limit -> inodes c_limit -> unit = "quota_modify" let query user_or_group ~id ~path = try let blimit, busage, ilimit, iusage = quota_query user_or_group ~id ~path in Ok (ml_limit_of_c_limit ~zero:zero_bytes blimit, busage, ml_limit_of_c_limit ~zero:zero_inodes ilimit, iusage) with Unix.Unix_error _ as exn -> Or_error.of_exn exn let set user_or_group ~id ~path byte_limit inode_limit = try Ok (quota_modify user_or_group ~id ~path (c_limit_of_ml_limit ~zero:zero_bytes byte_limit) (c_limit_of_ml_limit ~zero:zero_inodes inode_limit)) with Unix.Unix_error _ as exn -> Or_error.of_exn exn end module Mount_entry = struct (* see: man 3 getmntent *) type t = { fsname : string; directory : string; fstype : string; options : string; dump_freq : int sexp_option; fsck_pass : int sexp_option; } with sexp, fields let escape_seqs = [ "040", " " ; "011", "\t"; "012", "\n"; "134", "\\"; "\\", "\\"; ] let rec unescape s = match String.lsplit2 s ~on:'\\' with | None -> s | Some (l, r) -> match List.find_map escape_seqs ~f:(fun (prefix, replacement) -> Option.map (String.chop_prefix ~prefix r) ~f:(fun r -> l ^ replacement ^ unescape r)) with | None -> l ^ "\\" ^ unescape r | Some ret -> ret let parse_optional_int = function | "0" -> None | s -> Some (Int.of_string s) let parse_line line = if String.is_empty line then Ok None else if line.[0] = '#' then Ok None else match List.map ~f:unescape (String.split_on_chars ~on:[' ';'\t'] (String.strip line)) with | [] | [""] -> Ok None | fsname :: directory :: fstype :: options :: ([] | [_] | [_;_] as dump_freq_and_fsck_pass) -> begin let dump_freq, fsck_pass = match dump_freq_and_fsck_pass with | [ ] -> None, None | [dump_freq ] -> Some dump_freq, None | [dump_freq; fsck_pass] -> Some dump_freq, Some fsck_pass | _ -> assert false in try let dump_freq = Option.bind dump_freq parse_optional_int in let fsck_pass = Option.bind fsck_pass parse_optional_int in if String.equal fstype "ignore" then Ok (None) else Ok (Some { fsname; directory; fstype; options; dump_freq; fsck_pass }) with exn -> Or_error.of_exn exn end | _ -> Or_error.error "wrong number of fields" line String.sexp_of_t let visible_filesystem ts = let add_slash = function | "" -> "/" | p -> if p.[String.length p - 1] = '/' then p else p ^ "/" in let overlay map t = let remove_prefix = add_slash (directory t) in let rec loop map = match String.Map.closest_key map `Greater_than remove_prefix with | None -> map | Some (key, _) -> if not (String.is_prefix ~prefix:remove_prefix key) then map else loop (String.Map.remove map key) in String.Map.add (loop map) ~key:(directory t) ~data:t in List.fold ts ~init:String.Map.empty ~f:(fun map t -> if not (String.is_prefix ~prefix:"/" (directory t)) then map else overlay map t) end let terminal_width = lazy begin try (* When both stdout and stderr are not terminals, tput outputs 80 rather than the number of columns, so we can't use [Process.run]. Instead, we use [open_process_in] so that stderr is still the terminal. But, we don't want tput's error messages to be sent to stderr and seen by the user, so we first run tput with no output to see if it succeeds, and only then do we run it with stderr not redirected. *) Exn.protectx (Core.Std.Unix.open_process_in "/usr/bin/tput cols &> /dev/null && /usr/bin/tput cols") ~f:(fun in_channel -> In_channel.input_line in_channel |> Option.value_exn |> Int.of_string) ~finally:In_channel.close with _ -> 90 end ;; core_extended-113.00.00/src/extended_unix.mli000066400000000000000000000132311256461102500207630ustar00rootroot00000000000000open Core.Std (** Extensions to [Core.Unix]. *) val fork_exec : ?stdin:Unix.File_descr.t -> ?stdout:Unix.File_descr.t -> ?stderr:Unix.File_descr.t -> ?path_lookup:bool -> ?env:[ `Extend of (string * string) list | `Replace of (string * string) list ] -> ?working_dir:string -> ?setuid:int -> ?setgid:int -> string -> string list -> Pid.t (** [fork_exec prog args ~stdin ~stdout ~stderr ~setuid ~setgid] forks a new process that executes the program in file [prog], with arguments [args]. The pid of the new process is returned immediately; the new process executes concurrently with the current process. The function raises EPERM if when using [set{gid,uid}] and the user id is not 0. The standard input and outputs of the new process are connected to the descriptors [stdin], [stdout] and [stderr]. The close_on_exec flag is cleared from [stderr] [stdout] and [stdin] so it's safe to pass in fds with [close_on_exec] set. @param path_lookup if [true] than we use PATH to find the process to exec. @env specifies the environment the process runs in ERRORS: Unix.unix_error. This function should not raise EINTR; it will restart itself automatically. RATIONAL: [setuid] and [setgid] do not do a full id drop (e.g.: they save the id in saved id) when the user does not have the privileges required to setuid to anyone. By default all file descriptors should be set_closexec ASAP after being open to avoid being captured in parallel execution of fork_exec; resetting the closexec flag on the forked flag is a cleaner and more thread safe approach. BUGS: The capabilities for setuid in linux are not tied to the uid 0 (man 7 capabilities). It is still fair to assume that under most system this capability is there IFF uid == 0. A more fine grain permissionning approach would make this function non-portable and be hard to implement in an async-signal-way. Because this function keeps the lock for most of its lifespan and restarts automatically on EINTR it might prevent the OCaml signal handlers to run in that thread. *) val seteuid : int -> unit val setreuid : uid:int -> euid:int -> unit (** Network to host order long, like C. *) external ntohl : Int32.t -> Int32.t = "extended_ml_ntohl" (** Host to network order long, like C. *) external htonl : Int32.t -> Int32.t = "extended_ml_htonl" type statvfs = { bsize: int; (** file system block size *) frsize: int; (** fragment size *) blocks: int; (** size of fs in frsize units *) bfree: int; (** # free blocks *) bavail: int; (** # free blocks for non-root *) files: int; (** # inodes *) ffree: int; (** # free inodes *) favail: int; (** # free inodes for non-root *) fsid: int; (** file system ID *) flag: int; (** mount flags *) namemax: int; (** maximum filename length *) } with sexp, bin_io (** get file system statistics *) external statvfs : string -> statvfs = "statvfs_stub" (** get load averages *) external getloadavg : unit -> float * float * float = "getloadavg_stub" module Extended_passwd : sig open Unix.Passwd (** [of_passwd_line] parse a passwd-like line *) val of_passwd_line : string -> t option (** [of_passwd_line_exn] parse a passwd-like line *) val of_passwd_line_exn : string -> t (** [of_passwd_file] parse a passwd-like file *) val of_passwd_file : string -> t list option (** [of_passwd_file_exn] parse a passwd-like file *) val of_passwd_file_exn : string -> t list end external strptime : fmt:string -> string -> Unix.tm = "unix_strptime" (** The CIDR module moved into Core.Unix *) (** Simple int wrapper to be explicit about ports. *) module Inet_port : sig type t with sexp val of_int : int -> t option val of_int_exn : int -> t val of_string : string -> t option val of_string_exn : string -> t val to_int : t -> int val to_string: t -> string end (* MAC-48 (Ethernet) adddresses *) module Mac_address : sig type t with sexp, bin_io val equal : t -> t -> bool (* Supports standard "xx:xx:xx:xx:xx:xx", "xx-xx-xx-xx-xx-xx", and cisco "xxxx.xxxx.xxxx" representations. *) val of_string : string -> t (* To standard representation "xx:xx:xx:xx:xx:xx". Note the hex chars will be downcased! *) val to_string : t -> string (* To cisco representation "xxxx.xxxx.xxxx" *) val to_string_cisco : t -> string include Hashable.S with type t := t end module Quota : sig type bytes = private Int63.t with sexp type inodes = private Int63.t with sexp val bytes : Int63.t -> bytes val inodes : Int63.t -> inodes type 'units limit = { soft : 'units option; hard : 'units option; grace : Time.t option; } with sexp type 'units usage = private 'units val query : [ `User | `Group ] -> id:int -> path:string -> ( bytes limit * bytes usage * inodes limit * inodes usage) Or_error.t val set : [ `User | `Group ] -> id:int -> path:string -> bytes limit -> inodes limit -> unit Or_error.t end module Mount_entry : sig (* see: man 3 getmntent *) type t with sexp val parse_line : string -> t option Or_error.t val fsname : t -> string val directory : t -> string val fstype : t -> string val options : t -> string val dump_freq : t -> int option val fsck_pass : t -> int option val visible_filesystem : t list -> t String.Map.t end val terminal_width : int Lazy.t core_extended-113.00.00/src/extended_unix_stubs.c000066400000000000000000000145451256461102500216550ustar00rootroot00000000000000/* Core_unix support functions written in C. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #ifndef __USE_ISOC99 # define __USE_ISOC99 #endif #include #include #include "config.h" #include "ocaml_utils.h" #define MAX_ERROR_LEN 4096 CAMLprim value extended_ml_seteuid(value euid) { if (seteuid(Int_val(euid))) uerror("seteuid", Nothing); return Val_unit; } CAMLprim value extended_ml_setreuid(value uid, value euid) { if (setreuid(Int_val(uid),Int_val(euid))) uerror("setreuid", Nothing); return Val_unit; } CAMLprim value extended_ml_setegid(value egid) { if (seteuid(Int_val(egid)) == -1) uerror("setegid", Nothing); return Val_unit; } CAMLprim value statvfs_stub (value v_path) { CAMLparam1(v_path); CAMLlocal1(v_stat); struct statvfs s; int ret, len = caml_string_length(v_path) + 1; char *pathname = caml_stat_alloc(len); memcpy(pathname, String_val(v_path), len); caml_enter_blocking_section(); ret = statvfs(pathname,&s); caml_leave_blocking_section(); caml_stat_free(pathname); if (ret != 0) uerror("statvfs",v_path); v_stat = caml_alloc(11, 0); Store_field(v_stat, 0, Val_int(s.f_bsize)); Store_field(v_stat, 1, Val_int(s.f_frsize)); Store_field(v_stat, 2, Val_int(s.f_blocks)); Store_field(v_stat, 3, Val_int(s.f_bfree)); Store_field(v_stat, 4, Val_int(s.f_bavail)); Store_field(v_stat, 5, Val_int(s.f_files)); Store_field(v_stat, 6, Val_int(s.f_ffree)); Store_field(v_stat, 7, Val_int(s.f_favail)); Store_field(v_stat, 8, Val_int(s.f_fsid)); Store_field(v_stat, 9, Val_int(s.f_flag)); Store_field(v_stat,10, Val_int(s.f_namemax)); CAMLreturn(v_stat); } CAMLprim value getloadavg_stub (value v_unit __unused) { CAMLparam0(); CAMLlocal1(v_ret); double loadavg[3]; int ret = getloadavg(loadavg,3); if (ret < 0) uerror("getloadavg",Nothing); v_ret = caml_alloc_tuple(3); Store_field(v_ret, 2, caml_copy_double(ret >= 3 ? loadavg[2] : NAN)); Store_field(v_ret, 1, caml_copy_double(ret >= 2 ? loadavg[1] : NAN)); Store_field(v_ret, 0, caml_copy_double(ret >= 1 ? loadavg[0] : NAN)); CAMLreturn(v_ret); } #if !(defined _LINUX_QUOTA_VERSION) /* BSD, Mac OS */ # define quota_control(device, cmd, id, parg) \ quotactl((device), (cmd), (id), (parg)) # define QUOTA_BYTES_PER_SPACE_UNIT 1 # define QUOTA_SPACE_USED(quota) ((quota).dqb_curbytes) # define QUOTA_MODIFY_COMMAND Q_SETQUOTA # define QUOTA_SET_VALID_FIELDS(quota) ((void)quota) #elif _LINUX_QUOTA_VERSION < 2 # define quota_control(device, cmd, id, parg) \ quotactl((cmd), (device), (id), (parg)) # define QUOTA_BYTES_PER_SPACE_UNIT BLOCK_SIZE # define QUOTA_SPACE_USED(quota) ((quota).dqb_curblocks) # define QUOTA_MODIFY_COMMAND Q_SETQLIM # define QUOTA_SET_VALID_FIELDS(quota) ((void)quota) #else /* _LINUX_QUOTA_VERSION >= 2 */ # define quota_control(device, cmd, id, parg) \ quotactl((cmd), (device), (id), (parg)) # define QUOTA_BYTES_PER_SPACE_UNIT BLOCK_SIZE # define QUOTA_SPACE_USED(quota) ((quota).dqb_curspace) # define QUOTA_MODIFY_COMMAND Q_SETQUOTA # define QUOTA_SET_VALID_FIELDS(quota) \ do { (quota).dqb_valid = QIF_LIMITS | QIF_TIMES; } while (0) #endif int quota_command (value v_user_or_group, int command) { if (v_user_or_group == caml_hash_variant("User")) return QCMD(command, USRQUOTA); if (v_user_or_group == caml_hash_variant("Group")) return QCMD(command, GRPQUOTA); caml_failwith("Unix.Quota: I only know about `User and `Group"); } CAMLprim value quota_query (value v_user_or_group, value v_id, value v_path) { int id, cmd; struct dqblk quota; int64_t bytes_used, bytes_soft, bytes_hard; CAMLparam3(v_user_or_group, v_id, v_path); CAMLlocal3(v_ret, v_bytes_limit, v_inodes_limit); id = Int_val(v_id); cmd = quota_command(v_user_or_group, Q_GETQUOTA); memset("a, 0, sizeof(quota)); if (quota_control(String_val(v_path), cmd, id, (caddr_t)"a)) unix_error(errno, "Unix.Quota: unable to query quota", v_path); bytes_used = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) QUOTA_SPACE_USED(quota); bytes_soft = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) quota.dqb_bsoftlimit; bytes_hard = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) quota.dqb_bhardlimit; v_bytes_limit = caml_alloc_small(3, 0); Store_field(v_bytes_limit, 0, caml_alloc_int63(bytes_soft)); Store_field(v_bytes_limit, 1, caml_alloc_int63(bytes_hard)); Store_field(v_bytes_limit, 2, caml_copy_double((double)quota.dqb_btime)); v_inodes_limit = caml_alloc_small(3, 0); Store_field(v_inodes_limit, 0, caml_alloc_int63(quota.dqb_isoftlimit)); Store_field(v_inodes_limit, 1, caml_alloc_int63(quota.dqb_ihardlimit)); Store_field(v_inodes_limit, 2, caml_copy_double((double)quota.dqb_itime)); v_ret = caml_alloc_small(4, 0); Store_field(v_ret, 0, v_bytes_limit); Store_field(v_ret, 1, caml_alloc_int63(bytes_used)); Store_field(v_ret, 2, v_inodes_limit); Store_field(v_ret, 3, caml_alloc_int63(quota.dqb_curinodes)); CAMLreturn(v_ret); } CAMLprim value quota_modify (value v_user_or_group, value v_id, value v_path, value v_bytes_limit, value v_inodes_limit) { int id, cmd; struct dqblk quota; CAMLparam5(v_user_or_group, v_id, v_path, v_bytes_limit, v_inodes_limit); id = Int_val(v_id); cmd = quota_command(v_user_or_group, QUOTA_MODIFY_COMMAND); memset("a, 0, sizeof(quota)); quota.dqb_bsoftlimit = Int63_val(Field(v_bytes_limit, 0)) / QUOTA_BYTES_PER_SPACE_UNIT; quota.dqb_bhardlimit = Int63_val(Field(v_bytes_limit, 1)) / QUOTA_BYTES_PER_SPACE_UNIT; quota.dqb_btime = (time_t) Double_val(Field(v_bytes_limit, 2)); quota.dqb_isoftlimit = Int63_val(Field(v_inodes_limit, 0)); quota.dqb_ihardlimit = Int63_val(Field(v_inodes_limit, 1)); quota.dqb_itime = (time_t) Double_val(Field(v_inodes_limit, 2)); QUOTA_SET_VALID_FIELDS(quota); if (quota_control(String_val(v_path), cmd, id, (caddr_t)"a)) unix_error(errno, "Unix.Quota: unable to set quota", v_path); CAMLreturn(Val_unit); } CAMLprim value extended_ml_htonl (value v_num) { return caml_copy_int32(htonl(Int32_val(v_num))); } CAMLprim value extended_ml_ntohl (value v_num) { return caml_copy_int32(ntohl(Int32_val(v_num))); } core_extended-113.00.00/src/extra_fields.ml000066400000000000000000000016071256461102500204240ustar00rootroot00000000000000open Core.Std exception Not_a_record_type of Sexp.t with sexp let fields sexp = match sexp with | Sexp.Atom _ -> raise (Not_a_record_type sexp) | Sexp.List l -> List.map l ~f:(function | Sexp.List (Sexp.Atom field::_) -> field | _ -> raise (Not_a_record_type sexp) ) module Make (M:Sexpable) = struct type t = { value : M.t; extra_fields : string list } let sexp_of_t t = M.sexp_of_t t.value let t_of_sexp sexp = let ef_ref = Sexplib.Conv.record_check_extra_fields in let prev_ef = !ef_ref in ef_ref := false; let value = M.t_of_sexp sexp in ef_ref := prev_ef; let used_fields = fields (M.sexp_of_t value) in let all_fields = fields sexp in let extra_fields = List.filter all_fields ~f:(fun field -> not (List.mem used_fields field) ) in { value = value; extra_fields = extra_fields; } end core_extended-113.00.00/src/extra_fields.mli000066400000000000000000000004411256461102500205700ustar00rootroot00000000000000open Core.Std exception Not_a_record_type of Sexp.t with sexp (* The create [t_of_sexp] function will record whichever extra fields were passed in. *) module Make (M:Sexpable) : sig type t = { value : M.t; extra_fields : string list } include Sexpable with type t := t end core_extended-113.00.00/src/fd_leak_check.ml000066400000000000000000000070371256461102500205000ustar00rootroot00000000000000open Core.Std (** Originally in unix as Unix.get_num_open_fds. There's no good system independent way to gather this information. *BSD systems should look in /dev/fd instead of /proc/self/fd. /dev/fd is part of SVR4 but not Posix... For a more stable implementation look at: https://src.chromium.org/viewvc/chrome/trunk/src/base/process_util_posix.cc?view=markup *) (* List of directories sorted by priority to search fd files in.*) let fd_possible_dirs = ["/proc/self/fd";"/dev/fd"] let fd_dir = Memo.unit (fun () -> let res = List.find ~f:(fun s -> Sys.is_directory s = `Yes) fd_possible_dirs in match res with | None -> failwithf "couldn't find any of %s; \ are you sure you are running on linux or a BSD based system" (String.concat ~sep:"," fd_possible_dirs) () | Some s -> s) let rlimit_nofile () = match (Unix.RLimit.get Unix.RLimit.num_file_descriptors).Unix.RLimit.cur with | Unix.RLimit.Infinity -> Int.max_value | Unix.RLimit.Limit v -> Option.value (Int64.to_int v) ~default:Int.max_value let get_num_open_fds () = let fd_dir = fd_dir () in let cnt = ref 0 in try protectx (Unix.opendir ~restart:true fd_dir) ~f:(fun fd -> while true; do match Unix.readdir fd with | "." | ".." -> () | _ -> incr cnt done; assert false) ~finally:Unix.closedir; with End_of_file -> !cnt | Unix.Unix_error (EMFILE,_,_) -> rlimit_nofile () let report_open_files_num num_open_fds = eprintf "Running emergency file descriptor dump:\n%!"; let fd_dir = fd_dir () in for fd = 0 to num_open_fds do try let target = Unix.readlink (fd_dir ^/ string_of_int fd) in eprintf "fd %d -> %s\n%!" fd target with _ -> () done; if Sys.file_exists_exn "/usr/sbin/lsof" then begin eprintf "Also running lsof file descriptor dump:\n%!"; match Unix.fork () with | `In_the_child -> Signal.send_i Signal.stop (`Pid (Unix.getpid ())) | `In_the_parent pid -> begin for fd = 3 to num_open_fds - 3 do try Unix.close (Obj.magic fd : Unix.File_descr.t) with _ -> () done; Unix.sleep 1; ignore (Sys.command (Printf.sprintf "/usr/sbin/lsof -p %s 1>&2" (Pid.to_string pid))); Signal.send_i Signal.cont (`Pid pid); Unix.exit_immediately 0 end end let report_open_files () = report_open_files_num (get_num_open_fds ()) let report_on_exn exn = let module U = Unix in match exn with | U.Unix_error ((EMFILE | ENFILE), _, _) -> report_open_files () | _ -> () let run_check_at_exit = ref false let critical = ref 0.9 let max_fds () = let module R = Unix.RLimit in match (R.get R.num_file_descriptors).R.cur with | R.Infinity -> Int.max_value | R.Limit n -> match Int.of_int64 n with | Some n -> n | None -> Int.max_value ;; let check_fd_leak () = if !run_check_at_exit then try let max_fds = max_fds () in let thresh = Float.iround_exn ~dir:`Zero (!critical *. float max_fds) in let num_open_fds = get_num_open_fds () in if num_open_fds > thresh then begin eprintf "at_exit: too many open files: have %d, critical %d, maximum %d\n%!" num_open_fds thresh max_fds; report_open_files_num num_open_fds end with exn -> eprintf "exception checking for file descriptor leak: %s\n%!" (Exn.to_string exn) let () = at_exit check_fd_leak let percent_fds_in_use () = float (get_num_open_fds ()) /. float (max_fds ()) ;; core_extended-113.00.00/src/fd_leak_check.mli000066400000000000000000000015141256461102500206430ustar00rootroot00000000000000(** File descriptor leak check. This mod *) (** Toggle to turn on/off checking for descriptor leaks at exit (default: off) *) val run_check_at_exit : bool ref (** Fraction of maximum number of descriptors considered critical. Default: 0.9 *) val critical : float ref (** [report_open_files ()] prints a dump of open file descriptors to [stderr] in two formats, one using the proc file system, the other by executing [/usr/sbin/lsof] in a child process. *) val report_open_files : unit -> unit (** [report_on_exn exn] calls {!report_open_files} iff [exn] indicates a file descriptor leak (Unix error with code EMFILE or ENFILE). *) val report_on_exn : exn -> unit val get_num_open_fds : unit -> int (** [percent_fds_in_use ()] reports the percentage of fds that are in use. *) val percent_fds_in_use : unit -> float core_extended-113.00.00/src/find.ml000066400000000000000000000147731256461102500167030ustar00rootroot00000000000000open Core.Std type file_info = string * Unix.stats type path = string list let path_append path x = x :: path let path_to_string ?base path = match (base, path) with | None, [] -> "." | Some base, [] -> base | None, _ -> String.concat ~sep:"/" (List.rev path) | Some base, _ -> base ^/ String.concat ~sep:"/" (List.rev path) module Options = struct type error_handler = | Ignore | Print | Raise | Handle_with of (string -> unit) type t = { min_depth: int; max_depth: int option; follow_links: bool; on_open_errors: error_handler; on_stat_errors: error_handler; filter: (file_info -> bool) option; skip_dir: (file_info -> bool) option; relative_paths : bool; } let default = { min_depth = 1; max_depth = None; follow_links = false; on_open_errors = Raise; on_stat_errors = Raise; filter = None; skip_dir = None; relative_paths = false; } let ignore_errors = { default with on_open_errors = Ignore; on_stat_errors = Ignore } end module O = Options type t = { base: string; options: Options.t; already_seen: ((int * int), unit) Hashtbl.t; (* device num * inode *) mutable to_visit: (path * int) list; (* dir to traverse and the depth it is at *) mutable current_dir: path; mutable current_handle: [ `Just_created | `Starting | `Handle of Unix.dir_handle ]; mutable depth: int; mutable closed: bool; } let full_path_name t path = path_to_string ~base:t.base path let output_path_name t path = path_to_string ?base:(if t.options.O.relative_paths then None else Some t.base) path let rec open_next_dir t = match t.to_visit with | [] -> None | (dir_name, depth) :: rest -> try t.to_visit <- rest; t.current_handle <- `Handle (Unix.opendir (full_path_name t dir_name)); t.current_dir <- dir_name; t.depth <- depth; Some () with | e -> match t.options.O.on_open_errors with | O.Ignore -> open_next_dir t | O.Raise -> raise e | O.Handle_with f -> f (output_path_name t dir_name); open_next_dir t | O.Print -> Printf.eprintf !"unable to open %s - %{Exn}\n" (output_path_name t dir_name) e; open_next_dir t ;; let closedir t = match t.current_handle with | `Just_created | `Starting -> () | `Handle handle -> try Unix.closedir handle with | Unix.Unix_error _ -> () ;; let close t = if not t.closed then begin t.closed <- true; closedir t; Hashtbl.clear t.already_seen; t.to_visit <- []; end ;; (* returns the next file from the conceptual stream and updates the state of t - this is the only way that t should ever be updated *) let rec next t = assert (not t.closed); let stat path = let full_fn = full_path_name t path in let output_fn = output_path_name t path in try let stat = if t.options.O.follow_links then Unix.stat else Unix.lstat in Some (output_fn, path, stat full_fn) with | e -> match t.options.O.on_stat_errors with | O.Ignore -> None | O.Raise -> raise e | O.Handle_with f -> f output_fn; None | O.Print -> Printf.eprintf !"unable to stat %s - %{Exn}\n" output_fn e; None in let is_new (_output_fn, _path, stats as info) = if stats.Unix.st_kind <> Unix.S_DIR then Some info else begin let uid = (stats.Unix.st_dev, stats.Unix.st_ino) in match Hashtbl.find t.already_seen uid with | Some () -> None | None -> Hashtbl.set t.already_seen ~key:uid ~data:(); Some info end in let handle_dirs (output_fn, path, stats) = let info = output_fn, stats in if (match t.options.O.skip_dir with None -> false | Some f -> f info) then None else (* if this is a directory we need to decide if we will be traversing into it later... *) let visit () = t.to_visit <- (path, (t.depth + 1)) :: t.to_visit in if stats.Unix.st_kind = Unix.S_DIR then begin match t.options.O.max_depth with | None -> visit () | Some max_depth -> if t.depth < max_depth then visit () else () end; Some info in let filter file = if t.depth < t.options.O.min_depth then None else match t.options.O.filter with | None -> Some file | Some f -> if f file then Some file else None in let handle_child path = (* each function in this bind returns None if the file should be skipped, and Some f i if it thinks it's ok to emit - possibly updating the state or transforming f along the way *) let (>>=) = Option.bind in let skip = try stat path >>= is_new >>= handle_dirs >>= filter with | e -> closedir t; raise e in match skip with | None -> next t | file -> file in let with_next_dir k = match open_next_dir t with | None -> close t; None | Some () -> k () in match t.current_handle with | `Just_created -> begin match t.options.O.max_depth with | Some d when d < 0 -> close t; None | None | Some _ -> t.current_handle <- `Starting; handle_child t.current_dir end | `Starting -> with_next_dir (fun () -> next t) | `Handle current_handle -> let dirent = try `Dirent (Unix.readdir current_handle) with | e -> closedir t; match e with | End_of_file -> `End_of_directory | e -> raise e in match dirent with | `End_of_directory -> with_next_dir (fun () -> next t) | `Dirent ("." | "..") -> next t | `Dirent basename -> handle_child (path_append t.current_dir basename) ;; let create ?(options=Options.default) dir = { base = dir; options = options; already_seen = Hashtbl.Poly.create () ~size:11; to_visit = []; current_dir = []; current_handle = `Just_created; depth = 0; closed = false; } ;; let iter t ~f = let rec loop () = match next t with | None -> () | Some file -> f file; loop () in loop () ;; let fold t ~init ~f = let rec loop acc = match next t with | None -> acc | Some file -> loop (f acc file) in loop init ;; let to_list t = List.rev (fold t ~init:[] ~f:(fun acc file -> file :: acc)) ;; let find_all ?options dir = let t = create ?options dir in to_list t ;; core_extended-113.00.00/src/find.mli000066400000000000000000000032061256461102500170410ustar00rootroot00000000000000(** Unix like [find].*) (* Implements find (like the unix utility). Note that t is stateful both because filesystems themselves are highly stateful, and for performance reasons *) open Core.Std type t type file_info = string * Unix.stats module Options : sig type error_handler = | Ignore | Print | Raise | Handle_with of (string -> unit) type t = { min_depth: int; max_depth: int option; follow_links: bool; on_open_errors: error_handler; on_stat_errors: error_handler; filter: (file_info -> bool) option; skip_dir : (file_info -> bool) option; relative_paths : bool; } val default : t val ignore_errors : t end (** [create ?options dir] create a Find.t based in dir *) val create : ?options:Options.t -> string -> t (** [next t] return the next file from the collection of valid files in t or None if no more files remain *) val next : t -> file_info option (** [close t] drops all the resources associated with t. It is a mistake to attempt to use t again. Any Find.t will be automatically closed after the last file is read by any means. *) val close : t -> unit (** [iter t ~f] calls f on every file in t *) val iter : t -> f:(file_info -> unit) -> unit (** [fold t ~init ~f] folds f over the files in t *) val fold : t -> init:'a -> f:('a -> file_info -> 'a) -> 'a (** [to_list t] returns all of the remaining files in t as a list in the order they would have been returned by subsequent calls to next *) val to_list : t -> file_info list (** [find_all ?options dir] short for to_list (create ?options dir) *) val find_all : ?options:Options.t -> string -> file_info list core_extended-113.00.00/src/flang.ml000066400000000000000000000067231256461102500170460ustar00rootroot00000000000000open Core.Std module type Ordered_field = sig type t with compare, sexp val zero : t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t end type 'a t = [ | `Base of 'a | `Add of 'a t * 'a t | `Sub of 'a t * 'a t | `Mult of 'a t * 'a t | `Div of 'a t * 'a t | `Abs of 'a t | `Min of 'a t * 'a t | `Max of 'a t * 'a t ] with sexp, bin_io, compare let base a = `Base a let add x y = `Add (x, y) let sub x y = `Sub (x, y) let mult x y = `Mult (x, y) let div x y = `Div (x, y) let abs x = `Abs x let min x y = `Min (x, y) let max x y = `Max (x, y) let add_list xs = match xs with | [] -> failwith "Flang.add_list: empty list is not allowed" | x :: xs -> List.fold xs ~f:add ~init:x let mult_list xs = match xs with | [] -> failwith "Flang.mult_list: empty list is not allowed" | x :: xs -> List.fold xs ~f:mult ~init:x let t_of_sexp a_of_sexp sexp = let is_constructor lc s = String.equal lc (String.lowercase s) in let open Sexplib.Type in let rec t_of_sexp = function | List [Atom c; x; y] when is_constructor "div" c -> `Div (t_of_sexp x, t_of_sexp y) | List [Atom c; x; y] when is_constructor "sub" c -> `Sub (t_of_sexp x, t_of_sexp y) | List (Atom c :: xs) when is_constructor "add" c -> add_list (List.map ~f:t_of_sexp xs) | List (Atom c :: xs) when is_constructor "mult" c -> mult_list (List.map ~f:t_of_sexp xs) | List [Atom c; x] when is_constructor "abs" c -> `Abs (t_of_sexp x) | List [Atom c; x; y] when is_constructor "min" c -> `Min (t_of_sexp x, t_of_sexp y) | List [Atom c; x; y] when is_constructor "max" c -> `Max (t_of_sexp x, t_of_sexp y) | List [x; Atom "/"; y] -> div (t_of_sexp x) (t_of_sexp y) | List [x; Atom "-"; y] -> sub (t_of_sexp x) (t_of_sexp y) | List [x; Atom "+"; y] -> add (t_of_sexp x) (t_of_sexp y) | List [x; Atom "*"; y] -> mult (t_of_sexp x) (t_of_sexp y) | sexp -> `Base (a_of_sexp sexp) in t_of_sexp sexp let sexp_of_t sexp_of_a t = let open Sexplib.Type in let rec sexp_of_t = function | `Base a -> sexp_of_a a | `Add (x, y) -> List [sexp_of_t x; Atom "+"; sexp_of_t y] | `Sub (x, y) -> List [sexp_of_t x; Atom "-"; sexp_of_t y] | `Mult (x, y) -> List [sexp_of_t x; Atom "*"; sexp_of_t y] | `Div (x, y) -> List [sexp_of_t x; Atom "/"; sexp_of_t y] | `Min (x, y) -> List [Atom "min"; sexp_of_t x; sexp_of_t y] | `Max (x, y) -> List [Atom "max"; sexp_of_t x; sexp_of_t y] | `Abs x -> List [Atom "abs"; sexp_of_t x] in sexp_of_t t let rec atoms_aux t acc = match t with | `Base x -> x :: acc | `Abs x -> atoms_aux x acc | `Add (x, y) | `Sub (x, y) | `Mult (x, y) | `Div (x, y) | `Min (x, y) | `Max (x, y) -> atoms_aux x (atoms_aux y acc) let atoms t = atoms_aux t [] module Eval (F : Ordered_field) = struct module F = struct include F include Comparable.Make (F) end let eval t ~f = let rec eval = function | `Base x -> f x | `Add (x, y) -> F.( + ) (eval x) (eval y) | `Sub (x, y) -> F.( - ) (eval x) (eval y) | `Mult (x, y) -> F.( * ) (eval x) (eval y) | `Div (x, y) -> F.( / ) (eval x) (eval y) | `Min (x, y) -> F.min (eval x) (eval y) | `Max (x, y) -> F.max (eval x) (eval y) | `Abs x -> let x = eval x in if F.(x >= zero) then x else F.(zero - x) in eval t end (* The Olang module tests both Flang and Olang. *) core_extended-113.00.00/src/flang.mli000066400000000000000000000021421256461102500172060ustar00rootroot00000000000000(** The language of terms over a field. *) module type Ordered_field = sig type t with compare, sexp val zero : t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t end type 'a t = [ | `Base of 'a | `Add of 'a t * 'a t (** sexp [(x + y)] or [(add x y z ...)]. An empty list ([(add)]) is not allowed. *) | `Sub of 'a t * 'a t (** sexp [(x - y)] or [(sub x y)] *) | `Mult of 'a t * 'a t (** sexp [(x * y)] or [(mult x y z ...)]. An empty list ([(mult)]) is not allowed. *) | `Div of 'a t * 'a t (** sexp [(x / y)] or [(div x y)] *) | `Abs of 'a t | `Min of 'a t * 'a t | `Max of 'a t * 'a t ] with sexp, bin_io, compare val base : 'a -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mult : 'a t -> 'a t -> 'a t val div : 'a t -> 'a t -> 'a t val add_list : 'a t list -> 'a t val mult_list : 'a t list -> 'a t val abs : 'a t -> 'a t val min : 'a t -> 'a t -> 'a t val max : 'a t -> 'a t -> 'a t val atoms : 'a t -> 'a list module Eval (F : Ordered_field) : sig val eval : 'a t -> f:('a -> F.t) -> F.t end core_extended-113.00.00/src/float_ref.ml000066400000000000000000000025771256461102500177230ustar00rootroot00000000000000open Core.Std type t = { mutable v : float } with bin_io, sexp let create v = { v } let set t v = t.v <- v let get t = t.v TEST_UNIT = let t = create 0. in for i = 1 to 1000 do let x = Float.of_int i in assert (get t = x -. 1.); set t x; assert (get t = x) done BENCH_MODULE "" = struct type nonrec t = { x : int; mutable y : float; z : t; } BENCH "float ref set" = let t = { x = 1; y = 1.; z = create 1. } in let a = 1. in for _i = 1 to 100 do t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a; t.y <- a done BENCH "Float_ref.set" = let t = { x = 1; y = 1.; z = create 1. } in let a = 1. in for _i = 1 to 100 do set t.z a; set t.z a; set t.z a; set t.z a; set t.z a; set t.z a; set t.z a; set t.z a; set t.z a; set t.z a done BENCH "float ref get" = let t = { x = 1; y = 1.; z = create 1. } in for _i = 1 to 100 do let _ = t.y +. t.y +. t.y +. t.y +. t.y +. t.y +. t.y +. t.y +. t.y +. t.y in () done BENCH "Float_ref.get" = let t = { x = 1; y = 1.; z = create 1. } in for _i = 1 to 100 do let _ = t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v +. t.z.v in () done end core_extended-113.00.00/src/float_ref.mli000066400000000000000000000006511256461102500200630ustar00rootroot00000000000000open Core.Std (** Allows mutable float record fields where setting the value is much faster because it avoids write barrier. Benchmarks show about eight times better performance for setting the value. Reading the value is the same speed as for [mutable float]. *) type t with bin_io, sexp (** Create a [t] with the given initial value. *) val create : float -> t val get : t -> float val set : t -> float -> unit core_extended-113.00.00/src/fold_map.ml000066400000000000000000000131361256461102500175340ustar00rootroot00000000000000(*pp camlp4o -I `ocamlfind query sexplib` -I `ocamlfind query type_conv` -I `ocamlfind query bin_prot` pa_type_conv.cmo pa_sexp_conv.cmo pa_bin_prot.cmo *) open Core.Std module Map_intf = Core_kernel.Core_map_intf (* We use functors to factor out the common signature parts between the gen and specialised implementations. We expend them in the mli to keep things readable. *) module type Fold_map_funs = sig type 'a _in_value type 'a _out_value type ('a,'b) _t val empty : (_,_) _t val singleton : 'a -> 'b _in_value -> ('a,'b) _t val is_empty : (_,_) _t -> bool val length : (_,_) _t -> int val add : key:'a -> data:'b _in_value -> ('a,'b) _t -> ('a,'b) _t val find : ('a,'b) _t -> 'a -> 'b _out_value val remove : ('a,'b) _t -> 'a -> ('a,'b) _t val set : key:'a -> data:'b _out_value -> ('a,'b) _t -> ('a,'b) _t val mem : ('a,_) _t -> 'a -> bool val iter : ('a,'b) _t -> f:(key:'a -> data:'b _out_value -> unit) -> unit val fold : ('a,'b) _t -> init:'c -> f:(key:'a -> data:'b _out_value -> 'c -> 'c) -> 'c val filter : ('a,'b) _t -> f:(key:'a -> data:'b _out_value -> bool) -> ('a,'b) _t val keys : ('a,_) _t -> 'a list val data : (_,'b) _t -> 'b _out_value list val to_alist : ('a,'b) _t -> ('a * 'b _out_value) list val of_list : ('a * 'b _in_value) list -> ('a,'b) _t val for_all : (_,'b) _t -> f:('b _out_value -> bool) -> bool val exists : (_,'b) _t -> f:('b _out_value -> bool) -> bool val to_map : ('a,'b) _t -> ('a,'b _out_value) Map.Poly.t val of_map : ('a,'b _out_value) Map.Poly.t -> ('a,'b) _t end module type Foldable_gen = sig type 'a t type 'a data val init : _ t val f : 'a t -> 'a data -> 'a t end (* implementation *) module Make_fun (Fold : Foldable_gen) : Fold_map_funs with type 'a _in_value = 'a Fold.data and type 'a _out_value = 'a Fold.t and type ('a,'b) _t = ('a,'b Fold.t) Map.Poly.t = struct include (Map : Map_intf.Accessors3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) Map.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Map.Tree.t) include (Map.Poly : Map_intf.Creators2 with type ('a, 'b) t := ('a, 'b) Map.Poly.t with type ('a, 'b) tree := ('a, 'b) Map.Poly.Tree.t) type 'a _in_value = 'a Fold.data type 'a _out_value = 'a Fold.t type ('a,'b) _t = ('a,'b Fold.t) Map.Poly.t let to_map = ident let of_map = ident let singleton key in_value = Map.Poly.singleton key (Fold.f Fold.init in_value) let find t key = match Map.find t key with | None -> Fold.init | Some v -> v let add ~key ~data t = Map.add ~key ~data:(Fold.f (find t key) data) t let set ~key ~data t = Map.add t ~key ~data let of_list l = List.fold l ~init:Map.Poly.empty ~f:(fun t (key,data) -> add t ~key ~data) end (* argument to functor: maintains per-key state *) module type Foldable = sig type t type data val init : t val f : t -> data -> t end (* A map where the type of values added can be different from the type of values gotten out. *) module type S = sig type in_value type out_value type 'a t = private (('a,out_value) Map.Poly.t) include (Fold_map_funs with type 'a _in_value = in_value and type 'a _out_value = out_value and type ('a,'b) _t = 'a t) end module Make (Fold : Foldable) = struct type in_value = Fold.data type out_value = Fold.t (* with sexp *) type 'a t = ('a,Fold.t) Map.Poly.t (* with sexp *) include (Make_fun(struct type 'a t = Fold.t type 'a data = Fold.data let init = Fold.init let f = Fold.f end)) end module type Foldable_sexpable = sig include Foldable include Sexpable with type t := t end module type S_sexpable = sig include S include Sexpable.S1 with type 'key t := 'key t end module Make_sexpable (Fold : Foldable_sexpable) = struct include Make (Fold) let t_of_sexp key_of_sexp = Map.Poly.t_of_sexp key_of_sexp Fold.t_of_sexp let sexp_of_t sexp_of_key = Map.Poly.sexp_of_t sexp_of_key Fold.sexp_of_t end module type Foldable2 = sig type 'a t val init : _ t val f : 'a t -> 'a -> 'a t end module type S2 = sig type 'a out_value type ('a,'b) t = private (('a,'b out_value) Map.Poly.t) include (Fold_map_funs with type ('a) _in_value = 'a and type ('a) _out_value = 'a out_value and type ('a,'b) _t = ('a,'b) t) end module Make2 (Fold : Foldable2) = struct type 'a out_value = 'a Fold.t type ('a,'b) t = ('a,'b Fold.t) Map.Poly.t include (Make_fun(struct include Fold type 'a data = 'a end)) end module type Foldable2_sexpable = sig include Foldable2 include Sexpable.S1 with type 'a t := 'a t end module type S2_sexpable = sig include S2 include Sexpable.S2 with type ('a,'b) t := ('a,'b) t end module Make2_sexpable (Fold : Foldable2_sexpable) = struct type 'a out_value = 'a Fold.t (* with sexp *) type ('a,'b) t = ('a,'b Fold.t) Map.Poly.t with sexp include (Make_fun((struct include Fold type 'a data = 'a end))) end module Cons = Make2_sexpable (struct type 'a t = 'a list with sexp let init = [] let f list x = x :: list end) (* Fold for adding, e.g. symbol positions *) module Add = Make_sexpable (struct type data = int include Int let init = 0 let f = (+) end) module Multiply = Make_sexpable (struct type data = int include Int let init = 1 let f = ( * ) end) core_extended-113.00.00/src/fold_map.mli000066400000000000000000000115121256461102500177010ustar00rootroot00000000000000(** A map that folds in new values. An example would be a multi-map in which a key is initialized with the empty list as its value, and adding a new key/value pair appends the value to the key's list. *) open Core.Std (** Input signature of the functor {!Make} *) module type Foldable = sig (** The type of the accumlator *) type t (** The type of the folded in values. *) type data (** The initial value of the accumulator. *) val init : t (** The folding function.*) val f : t -> data -> t end (** Output signature of the functor {!Make}*) module type S = sig (** The type of the values being fold over.*) type in_value (** The type of the accumulator *) type out_value type 'key t = private (('key,out_value) Map.Poly.t) (* Used internally to tie S1 and S2 together *) type 'a _in_value = in_value type 'a _out_value = out_value type ('a,'b) _t = 'a t (** A map containing no bindings *) val empty : _ t val singleton : 'a -> in_value -> 'a t val is_empty : _ t -> bool val length : _ t -> int (** [add m ~key ~data] adds the key to the value already bound to [key] in [m]. If no value is bound to [key] than the initial value specified by the functor will be used instead. *) val add : key:'a -> data:in_value -> 'a t -> 'a t val find : 'a t -> 'a -> out_value val remove : 'a t -> 'a -> 'a t val set : key:'a -> data:out_value -> 'a t -> 'a t val mem : 'a t -> 'a -> bool val iter : 'a t -> f:(key:'a -> data:out_value -> unit) -> unit val fold : 'a t -> init:'b -> f:(key:'a -> data:out_value -> 'b -> 'b) -> 'b val filter : 'a t -> f:(key:'a -> data:out_value -> bool) -> 'a t val keys : 'a t -> 'a list val data : _ t -> out_value list val to_alist : 'a t -> ('a * out_value) list val of_list : ('a * in_value) list -> 'a t val for_all : _ t -> f:(out_value -> bool) -> bool val exists : _ t -> f:(out_value -> bool) -> bool val to_map : 'a t -> ('a , out_value) Map.Poly.t val of_map : ('a , out_value) Map.Poly.t -> 'a t end (** Builds a [fold_map] *) module Make (Fold : Foldable) : S with type in_value = Fold.data and type out_value = Fold.t (** {6 Sexpable interface} Same as above but builds the [sexp_of] and [of_sexp] functions. Requires the passed in types to be sexpable. *) module type S_sexpable = sig include S include Sexpable.S1 with type 'key t := 'key t end module type Foldable_sexpable = sig include Foldable include Sexpable with type t := t end module Make_sexpable (Fold : Foldable_sexpable) : S_sexpable with type in_value = Fold.data and type out_value = Fold.t (** {3 Polymorphic folds} Polymorphic fold take a *) module type Foldable2 = sig type 'a t val init : _ t val f : 'a t -> 'a -> 'a t end module type S2 = sig type 'a out_value type ('key,'data) t = private ('key,'data out_value) Map.Poly.t type 'a _in_value = 'a type 'a _out_value = 'a out_value type ('a,'b) _t = ('a,'b) t val empty : (_,_) t val singleton : 'a -> 'b -> ('a,'b) t val is_empty : (_,_) t -> bool val length : (_,_) t -> int val add : key:'a -> data:'b -> ('a,'b) t -> ('a,'b) t val find : ('a,'b) t -> 'a -> 'b out_value val remove : ('a,'b) t -> 'a -> ('a,'b) t val set : key:'a -> data:'b out_value -> ('a,'b) t -> ('a,'b) t val mem : ('a,_) t -> 'a -> bool val iter : ('a,'b) t -> f:(key:'a -> data:'b out_value -> unit) -> unit val fold : ('a,'b) t -> init:'c -> f:(key:'a -> data:'b out_value -> 'c -> 'c) -> 'c val filter : ('a,'b) t -> f:(key:'a -> data:'b out_value -> bool) -> ('a,'b) t val keys : ('a,_) t -> 'a list val data : (_,'b) t -> 'b out_value list val to_alist : ('a,'b) t -> ('a * 'b out_value) list val of_list : ('a * 'b) list -> ('a,'b) t val for_all : (_,'b) t -> f:('b out_value -> bool) -> bool val exists : (_,'b) t -> f:('b out_value -> bool) -> bool val to_map : ('a,'b) t -> ('a,'b out_value) Map.Poly.t val of_map : ('a,'b out_value) Map.Poly.t -> ('a,'b) t end module Make2 (Fold : Foldable2) : S2 with type 'a out_value = 'a Fold.t (** {6 Sexpable interface} *) module type Foldable2_sexpable = sig include Foldable2 include Sexpable.S1 with type 'a t := 'a t end module type S2_sexpable = sig include S2 include Sexpable.S2 with type ('a,'b) t := ('a,'b) t end module Make2_sexpable (Fold : Foldable2_sexpable) : S2_sexpable with type 'a out_value = 'a Fold.t (** {3 Predefined modules } *) module Cons : S2_sexpable with type 'a out_value = 'a list (** A fold for adding. e.g. symbol positions *) module Add : S_sexpable with type in_value = int and type out_value = int module Multiply : S_sexpable with type in_value = int and type out_value = int core_extended-113.00.00/src/fork_exec.c000066400000000000000000000231251256461102500175310ustar00rootroot00000000000000/* Core_unix support functions written in C. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include "fork_exec.h" #define PIPE_READ 0 #define PIPE_WRITE 1 /* If you want to turn on debugging you may use: #define fork_side_assert(v) assert(v) Note that assert uses non async-signal-safe functions. Do not leave this on in any production code */ #define fork_side_assert(ignore) ((void) 0) #define SYSCALL(x) \ while ((x) == -1) { \ if (errno != EINTR) { \ report_errno_on_pipe (pfd[PIPE_WRITE],errno);\ } \ } \ #define NONINTR(x) \ while ((x) == -1){ assert(errno == EINTR); } \ /* Copy an ocaml string array in a c string array terminated by a null pointer the result need to be free'd with a stat_free It is a copy of cstringvect in the ocaml unix's module. */ static char ** copy_stringvect(const value arg) { char ** res; mlsize_t size, i; size = Wosize_val(arg); res = (char **) caml_stat_alloc((size + 1) * sizeof(char *)); for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); res[size] = NULL; return res; } #ifdef __GNUC__ /* Giving Gcc as much info as possible */ static void report_errno_on_pipe (int fd,int my_err) __attribute__((noreturn)); #endif /* Write an int to an fd. This function is designed to be used on the fork side and therefor only uses async-signal-safe functions. */ static void report_errno_on_pipe (int fd, int my_err) { size_t offset = 0; ssize_t out_chars; while (offset < sizeof(int)) {; switch (out_chars=write (fd, (char *) &my_err + offset, sizeof(int) - offset)) { case -1: fork_side_assert (errno==EINTR); continue; default: offset += (size_t) out_chars; } } fork_side_assert (offset == sizeof(int)); _exit(254); } static void clear_sigprocmask(void){ sigset_t empty; (void) sigemptyset (&empty); (void) sigprocmask (SIG_SETMASK, &empty, (sigset_t *) NULL); } /* Returns 0 if there was no errno printed on the pipe and -1 if there was one. */ static int errno_from_pipe (int fd,int *my_errno) { ssize_t in_chars; size_t offset = 0; while (true) { in_chars=read(fd, (((char *) my_errno) + offset), sizeof(int) - offset); switch (in_chars) { case -1 : assert (errno==EINTR); continue; case 0: if (offset == 0) { /* The fd was closed with nothing written to it; no error */ return 0; }; assert (offset == sizeof(int)); return -1; default: offset += (size_t)in_chars; } }; } /* [set_cloexec(fd,value)] Set the close on exec flag of fd to value. Is async-signal-safe. Returns 0 on success and -1 on error. Sets errno in case of errors. */ static int set_cloexec (int fd,int v) { int flags,new_flags; if ((flags = fcntl(fd, F_GETFD)) == -1) return -1; new_flags = (v ? flags | FD_CLOEXEC : flags & ~FD_CLOEXEC); if(new_flags == flags) return 0; return fcntl(fd, F_SETFD, new_flags); } CAMLprim value extended_ml_spawn ( value v_stdin, /* Fd to connect to the forked stdin... */ value v_stdout, value v_stderr, value v_working_dir, /* A directory we want to chdir too. [String option] */ value v_setuid, /* setuid on the fork side [int option] */ value v_setgid, /* setgid on the fork side [int option] */ value v_env, /* The Environment to set for execve. pass None to call an execv instead. [string array option]*/ value v_prog, /* Program name [string] */ value v_args /* Full list of args passed to executable [string array] */ ) { CAMLparam5(v_prog, v_args, v_stdin, v_stdout, v_stderr); CAMLxparam4(v_working_dir,v_setuid,v_setgid,v_env); int stdin_fd = Int_val (v_stdin); int stdout_fd = Int_val (v_stdout); int stderr_fd = Int_val (v_stderr); char** envp = NULL; int my_errno,forked_error; int pfd[2]; /* The pipe used to report errors.. */ /* It's ok to hold pointers into the O'Caml heap, since the memory space gets duplicated upon the fork, during which we keep the O'Caml lock. */ char* prog = String_val(v_prog); char* working_dir = NULL; pid_t child_pid; char** args; /* We use a pipe to report errors on the forked side */ if (pipe(pfd) == -1) uerror("extended_ml_spawn::pipe",Nothing); /* Set both side of the pipe close_on_exec... */ (void) set_cloexec(pfd[PIPE_WRITE],true); (void) set_cloexec(pfd[PIPE_READ],true); args = copy_stringvect(v_args); if (Is_block(v_env)) envp = copy_stringvect(Field(v_env,0)); if (Is_block(v_working_dir)) working_dir = String_val(Field(v_working_dir,0)); /* This function deliberately doesn't release the O'Caml lock (i.e. it doesn't call caml_enter_blocking_section) during the fork. This is because we hold pointers into the ML heap across a fork, and releasing the lock immediately before the fork could theoretically cause the GC to run and move blocks before the fork duplicates the memory space. */ switch (child_pid = fork()) { case -1: my_errno = errno; caml_stat_free(args); if (envp) caml_stat_free(envp); NONINTR(close(pfd[PIPE_READ])); NONINTR(close(pfd[PIPE_WRITE])); unix_error(my_errno,"extended_ml_spawn: fork failed", Nothing); case 0: /* Child process. Since we've just lost all of our threads we need to be very careful not to call any function that might use a thread lock. This includes malloc,setenv and stdio functions... This is stated in the POSIX norm as: If a multi-threaded process calls fork(), the new process shall contain a replica of the calling thread and its entire address space, possibly including the states of mutexes and other resources. Consequently, to avoid errors, the child process may only execute async-signal-safe operations until such time as one of the exec functions is called. [http://pubs.opengroup.org/onlinepubs/009695399/functions/fork.html] The list of functions that we can call on the fork side can be found here: [http://pubs.opengroup.org/onlinepubs/009695399/functions/xsh_chap02_04.html] We also need to use _exit instead of [exit] because we do not want [at_exit] registered functions to be called. */ /* Reset the sigmask to get rid of the inherited one */ clear_sigprocmask(); /* Just in case any of the pipes' file descriptors are 0, 1 or 2 (not inconceivable, especially when running as a daemon), duplicate all three descriptors we need in the child to fresh descriptors before duplicating them onto stdin, stdout and stderr. This will ensure that there is one and only one copy of the file descriptors passed as arguments with id's higher than 2. F_DUPFD cannot get EINTR so we'll go only once through the loop */ SYSCALL(stdin_fd = fcntl(stdin_fd,F_DUPFD,3)); SYSCALL(stdout_fd= fcntl(stdout_fd,F_DUPFD,3)); SYSCALL(stderr_fd= fcntl(stderr_fd,F_DUPFD,3)); /* We clear out the close on exec on the fds... */ SYSCALL(set_cloexec(stdin_fd,false)); SYSCALL(set_cloexec(stdout_fd,false)); SYSCALL(set_cloexec(stderr_fd,false)); /* We must dup2 the descriptors back in place... */ SYSCALL(dup2(stdin_fd,0)); SYSCALL(dup2(stdout_fd,1)); SYSCALL(dup2(stderr_fd,2)); /* And close the old fds... */ SYSCALL(close(stdin_fd)); SYSCALL(close(stdout_fd)); SYSCALL(close(stderr_fd)); if (working_dir) { SYSCALL(chdir(working_dir)); } if (Is_block(v_setuid)) { uid_t uid = (uid_t) Int_val(Field(v_setuid,0)); if (getuid() != 0) report_errno_on_pipe (pfd[PIPE_WRITE],EPERM); SYSCALL(setuid(uid)); } if (Is_block(v_setgid)) { gid_t gid = (gid_t) Int_val(Field(v_setgid,0)); if (getuid() != 0) report_errno_on_pipe (pfd[PIPE_WRITE],EPERM); SYSCALL(setgid(gid)); } if (envp) { /* path lookups should be done on the parent side of the fork so no execvp*/ SYSCALL(execve(prog,args,envp)); }else { SYSCALL(execv(prog,args)); }; default: /* Parent process */ caml_enter_blocking_section(); NONINTR(close (pfd[PIPE_WRITE])); /* Close unused write end */ /* C side cleanup and looking for errors */ forked_error = errno_from_pipe(pfd[PIPE_READ],&my_errno); NONINTR(close (pfd[PIPE_READ])); if (forked_error) NONINTR(waitpid(child_pid, 0, 0)); caml_leave_blocking_section(); /* Caml side cleanup */ caml_stat_free(args); if (envp) caml_stat_free(envp); /* Returning the result */ if (forked_error) unix_error(my_errno,"extended_ml_spawn::forked_side" , Nothing); /* Reading the pipe.. */ CAMLreturn(Val_int(child_pid)); } } CAMLprim value extended_ml_spawn_bc(value *argv, int argn) { if (argn != 9) { caml_failwith("Unix.ml_spawn_bc got the wrong number of \ arguments. This is due to an error in the FFI."); } return extended_ml_spawn(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]); } core_extended-113.00.00/src/fork_exec.h000066400000000000000000000012621256461102500175340ustar00rootroot00000000000000/* value extended_ml_create_process */ extern CAMLprim value extended_ml_spawn ( value v_stdin, /* Fd to connect to the forked stdin... */ value v_stdout, value v_stderr, value v_working_dir, /* A directory we want to chdir too. [String option] */ value v_setuid, /* setuid on the fork side [int option] */ value v_setgid, /* setgid on the fork side [int option] */ value v_env, /* The Environment to set for execve. pass None to call an execv instead. [string array option]*/ value v_prog, /* Program name [string] */ value v_args /* Full list of args passed to executable [string array] */ ); extern CAMLprim value extended_ml_spawn_bc(value *argv, int argn); core_extended-113.00.00/src/generic.ml000066400000000000000000000035721256461102500173720ustar00rootroot00000000000000open Core.Std type ('a,'b) c = ('a -> 'b) -> 'b let ( >: ) x t y = t (fun x -> x) y x (* let ( >>: ) x t = t (fun x -> x) (fun x -> x) x *) let __ k = k (fun f x -> f x) let list map k = k (fun f -> List.map ~f:(map f) ) let option map k = k (fun f -> Option.map ~f:(map f) ) let ok map k = k (fun f -> function | Error _ as e -> e | Ok x -> Ok (map f x) ) let error map k = k (fun f -> function | Error x -> Error (map f x) | Ok _ as ok -> ok ) (* let first map k = k (fun f (a,b) -> (map f a, b) ) let second map k = k (fun f (a,b) -> (a, map f b) ) *) (* let both map k = k (fun f (a,b) -> (map f a, map f b) ) *) let string k = k (fun f -> String.map ~f) let map x ~f = x f let iter x ~f = ignore (map x ~f:(fun x -> f x; x)) let fold x ~init ~f = let acc = ref init in iter x ~f:(fun x -> acc := f !acc x ); !acc let length x = fold x ~init:0 ~f:(fun acc _ -> acc + 1) let to_list x = List.rev (fold x ~init:[] ~f:(fun l x -> x :: l)) (* let create_type map = (); fun map' k -> k (fun f x -> map x ~f:(map' f) ) *) let (>>|) x f = map x ~f TEST = map ([[1];[2;3];[3;4]] >: __ list) ~f:List.length = [1;2;2] TEST = map ([[1];[2;3];[3;4]] >: __) ~f:List.length = 3 TEST = length ([[1];[2;3];[3;4]] >: __ list list) = 5 TEST = length ([[1];[2;3];[3;4]] >: __ list) = 3 TEST = length ( [1;2;3;4] >: __ ) = 1 TEST = ([ "asdf"; "a" ] >: string list >>| fun c -> Char.uppercase c ) = [ "ASDF"; "A" ] TEST = length ([ Error "foo"; Ok (); Error "banana"] >: __ error list) = 2 TEST = length ([ Error "foo"; Ok (); Error "banana"] >: __ ok list) = 1 TEST = to_list ([ [ Error "foo"]; [Ok (); Error "banana"]] >: __ error list list) = [ "foo"; "banana" ] TEST = to_list ([Some 3; None; Some 4] >: __ option list) = [3;4] (* TEST = to_list ([Some (1,'s'); None; Some (3,'a')] >: __ first option list) = [1;3] *) core_extended-113.00.00/src/generic.mli000066400000000000000000000032451256461102500175400ustar00rootroot00000000000000open Core.Std (* Generic mapping and folding. The types are strange, you should ignore them. Just look at some examples: open Generic map ([[1];[2;3];[3;4]] >: __ list) ~f:List.length (* Result: [1;2;2] *) map ([[1];[2;3];[3;4]] >: __) ~f:List.length (* Result: 3 *) length ([[1];[2;3];[3;4]] >: __ list list) (* Result: 5 *) length ([[1];[2;3];[3;4]] >: __ list) (* Result: 3 *) length ( [1;2;3;4] >: __ ) (* Result: 1 *) [ "asdf"; "a" ] >: string list >>| fun c -> Char.uppercase c (* Result: [ "ASDF"; "A" ] *) to_list ([ [ Error "foo"]; [Ok (); Error "banana"]] >: __ error list list) (* Result: [ "foo"; "banana" ] *) to_list ([Some (1,'s'); None; Some (3,'a')] >: __ first option list) (* Result: [1;3] *) *) type ('a,'b) c = ('a -> 'b) -> 'b val ( >: ) : 'a -> (('b -> 'b) -> 'c -> 'a -> 'd) -> 'c -> 'd val map : ('a -> 'b) -> f:'a -> 'b val fold : (('a -> 'a) -> _) -> init:'b -> f:('b -> 'a -> 'b) -> 'b val iter : (('a -> 'a) -> _) -> f:('a -> unit) -> unit val length : (('a -> 'a) -> _) -> int val to_list : (('a -> 'a) -> _) -> 'a list val (>>|) : ('a -> 'b) -> 'a -> 'b val __ : ((('a -> 'b) -> 'a -> 'b) -> 'c) -> 'c val list : ('a -> 'b -> 'c) -> (('a -> 'b list -> 'c list) -> 'd) -> 'd val option : ('a -> 'b -> 'c) -> (('a -> 'b option -> 'c option) -> 'd) -> 'd val ok : ('a -> 'b -> 'c) -> (('a -> ('b, 'd) Result.t -> ('c, 'd) Result.t) -> 'e) -> 'e val error : ('a -> 'b -> 'c) -> (('a -> ('d,'b) Result.t -> ('d,'c) Result.t) -> 'e) -> 'e val string : (((char -> char) -> string -> string) -> 'a) -> 'a core_extended-113.00.00/src/hashtbl2.ml000066400000000000000000000064651256461102500174710ustar00rootroot00000000000000open Core.Std module type Key = sig type t with compare, sexp_of val hash : t -> int end type ('key1, 'key2, 'data) t = { create2 : unit -> ('key2, 'data) Hashtbl.t ; by_key1 : ('key1, ('key2, 'data) Hashtbl.t) Hashtbl.t ; sexp_of_key1 : 'key1 -> Sexp.t ; sexp_of_key2 : 'key2 -> Sexp.t } type ('key1, 'key2, 'data) sexp_repr = ('key1 * 'key2 * 'data) list with sexp_of let to_sexp_repr t = List.concat_map (Hashtbl.to_alist t.by_key1) ~f:(fun (key1, table2) -> List.map (Hashtbl.to_alist table2) ~f:(fun (key2, data) -> (key1, key2, data))) ;; let sexp_of_t sexp_of_key1 sexp_of_key2 sexp_of_data t = to_sexp_repr t |> <:sexp_of< (key1, key2, data) sexp_repr >> ;; let clear t = Hashtbl.clear t.by_key1 ;; let mem1 t key1 = Hashtbl.mem t.by_key1 key1 ;; let iter t ~f = Hashtbl.iter t.by_key1 ~f:(fun ~key:key1 ~data:by_key2 -> Hashtbl.iter by_key2 ~f:(fun ~key:key2 ~data -> f key1 key2 data)) ;; let remove_all1 t key1 = Hashtbl.remove t.by_key1 key1 let iter_key2 t key1 ~f = match Hashtbl.find t.by_key1 key1 with | None -> () | Some by_key2 -> Hashtbl.iter by_key2 ~f:(fun ~key:key2 ~data -> f key2 data) ;; let invariant invariant_key1 invariant_key2 invariant_data t = Hashtbl.iter t.by_key1 ~f:(fun ~key:_ ~data:by_key2 -> assert (not (Hashtbl.is_empty by_key2))); iter t ~f:(fun key1 key2 data -> invariant_key1 key1; invariant_key2 key2; invariant_data data) ;; let find1 t key1 = Hashtbl.find t.by_key1 key1 let find t key1 key2 = match Hashtbl.find t.by_key1 key1 with | None -> None | Some table2 -> Hashtbl.find table2 key2 ;; let add_exn t key1 key2 data = let table2 = match Hashtbl.find t.by_key1 key1 with | Some table2 -> table2 | None -> let by_key2 = t.create2 () in Hashtbl.add_exn t.by_key1 ~key:key1 ~data:by_key2; by_key2 in Hashtbl.add_exn table2 ~key:key2 ~data ;; let set t key1 key2 data = let table2 = match Hashtbl.find t.by_key1 key1 with | Some table2 -> table2 | None -> let by_key2 = t.create2 () in Hashtbl.set t.by_key1 ~key:key1 ~data:by_key2; by_key2 in Hashtbl.set table2 ~key:key2 ~data ;; let remove_error t key1 key2 = let sexp_of_key1 = t.sexp_of_key1 in let sexp_of_key2 = t.sexp_of_key2 in failwiths "Hashtbl2.remove_exn of absent keys" (key1, key2) <:sexp_of< key1 * key2 >> ;; let remove_exn t key1 key2 = match Hashtbl.find t.by_key1 key1 with | None -> remove_error t key1 key2 | Some by_key2 -> if Hashtbl.mem by_key2 key2 then begin Hashtbl.remove by_key2 key2; if Hashtbl.is_empty by_key2 then Hashtbl.remove t.by_key1 key1 end else remove_error t key1 key2 ;; module Make (Key1 : Key) (Key2 : Key) = struct module Table1 = Hashtbl.Make (struct include Key1 let t_of_sexp _ = assert false end) module Table2 = Hashtbl.Make (struct include Key2 let t_of_sexp _ = assert false end) type nonrec 'data t = (Key1.t, Key2.t, 'data) t with sexp_of let create () = { create2 = Table2.create ; by_key1 = Table1.create () ; sexp_of_key1 = <:sexp_of< Key1.t >> ; sexp_of_key2 = <:sexp_of< Key2.t >> } ;; let equal equal_data t1 t2 = Hashtbl.equal t1.by_key1 t2.by_key1 (fun by_key2_1 by_key2_2 -> Hashtbl.equal by_key2_1 by_key2_2 equal_data) ;; end core_extended-113.00.00/src/hashtbl2.mli000066400000000000000000000024051256461102500176300ustar00rootroot00000000000000open Core.Std module type Key = sig type t with compare, sexp_of val hash : t -> int end (* A hashtbl keyed by 'key1 and then 'key2. *) type ('key1, 'key2, 'data) t with sexp_of include Invariant.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t val clear : (_, _, _) t -> unit val add_exn : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data -> unit val set : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data -> unit val remove_exn : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> unit val remove_all1 : ('key1, 'key2, 'data) t -> 'key1 -> unit val find : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data option val find1 : ('key1, 'key2, 'data) t -> 'key1 -> ('key2, 'data) Hashtbl.t option (** [mem1 t key1] is true iff \exists key2 s.t. [find t key1 key2] is not None **) val mem1 : ('key1, 'key2, 'data) t -> 'key1 -> bool val iter : ('key1, 'key2, 'data) t -> f:('key1 -> 'key2 -> 'data -> unit) -> unit (** [iter_key2 t key1 ~f] is a no-op unless [mem1 t key1] **) val iter_key2 : ('key1, 'key2, 'data) t -> 'key1 -> f:('key2 -> 'data -> unit) -> unit module Make (Key1 : Key) (Key2 : Key) : sig type nonrec 'data t = (Key1.t, Key2.t, 'data) t with sexp_of include Equal.S1 with type 'a t := 'a t val create : unit -> 'data t end core_extended-113.00.00/src/hashtbl2_pair.ml000066400000000000000000000062051256461102500204740ustar00rootroot00000000000000open Core.Std module type Key = Hashtbl2.Key type ('key1, 'key2, 'data) t = { table1 : ('key1, 'key2, 'data) Hashtbl2.t ; table2 : ('key2, 'key1, 'data) Hashtbl2.t } let clear t = Hashtbl2.clear t.table1; Hashtbl2.clear t.table2; ;; let sexp_of_t sexp_of_key1 sexp_of_key2 sexp_of_data t = t.table1 |> <:sexp_of< (key1, key2, data) Hashtbl2.t >> ;; let invariant invariant_key1 invariant_key2 invariant_data t = Hashtbl2.invariant invariant_key1 invariant_key2 invariant_data t.table1; Hashtbl2.invariant invariant_key2 invariant_key1 invariant_data t.table2; let check_contained_in table1 table2 = Hashtbl2.iter table1 ~f:(fun key1 key2 data1 -> match Hashtbl2.find table2 key2 key1 with | None -> assert false | Some data2 -> assert (phys_equal data1 data2)) in check_contained_in t.table1 t.table2; check_contained_in t.table2 t.table1; ;; let iter t ~f = Hashtbl2.iter t.table1 ~f let mem1 t key1 = Hashtbl2.mem1 t.table1 key1 let mem2 t key2 = Hashtbl2.mem1 t.table2 key2 let find1 t key1 = Hashtbl2.find1 t.table1 key1 let find2 t key2 = Hashtbl2.find1 t.table2 key2 let mem t key1 key2 = match Hashtbl2.find1 t.table1 key1 with | None -> false | Some table2 -> Hashtbl.mem table2 key2 ;; let find1_iter2 t key1 ~f = Hashtbl2.iter_key2 t.table1 key1 ~f ;; let find2_iter1 t key2 ~f = Hashtbl2.iter_key2 t.table2 key2 ~f ;; let find t key1 key2 = Hashtbl2.find t.table1 key1 key2 let add_exn t key1 key2 data = Hashtbl2.add_exn t.table1 key1 key2 data; Hashtbl2.add_exn t.table2 key2 key1 data; ;; let set t key1 key2 data = Hashtbl2.set t.table1 key1 key2 data; Hashtbl2.set t.table2 key2 key1 data; ;; let remove_all1 t key1 = Hashtbl2.iter_key2 t.table1 key1 ~f:(fun key2 _ -> Hashtbl2.remove_exn t.table2 key2 key1); Hashtbl2.remove_all1 t.table1 key1; ;; let remove_exn t key1 key2 = Hashtbl2.remove_exn t.table1 key1 key2; Hashtbl2.remove_exn t.table2 key2 key1; ;; module Make (Key1 : Key) (Key2 : Key) = struct module Table1 = Hashtbl2.Make (Key1) (Key2) module Table2 = Hashtbl2.Make (Key2) (Key1) type nonrec 'data t = (Key1.t, Key2.t, 'data) t with sexp_of let create () = { table1 = Table1.create () ; table2 = Table2.create () } ;; let of_alist_exn alist = let t = create () in List.iter alist ~f:(fun (key1, key2, data) -> add_exn t key1 key2 data); t ;; let equal equal_data t1 t2 = Table1.equal equal_data t1.table1 t2.table1 end TEST_MODULE = struct module M = Make(String)(Int) let key1 = "key1" let key2 = 2 TEST_UNIT = let t = M.create () in add_exn t key1 key2 (); assert (mem t key1 key2); assert (mem1 t key1); assert (mem2 t key2); remove_exn t key1 key2; assert (not (mem t key1 key2)); assert (not (mem1 t key1)); assert (not (mem2 t key2)); ;; TEST_UNIT = let t_empty = M.create () in let t_empty2 = M.create () in add_exn t_empty2 key1 key2 (); remove_exn t_empty2 key1 key2; assert (M.equal Unit.equal t_empty t_empty2); let t_nonempty = M.create () in add_exn t_nonempty key1 key2 (); assert (not (M.equal Unit.equal t_empty t_nonempty)); ;; end core_extended-113.00.00/src/hashtbl2_pair.mli000066400000000000000000000027241256461102500206470ustar00rootroot00000000000000open Core.Std open Hashtbl module type Key = Hashtbl2.Key (* A pair of hashtbls, one keyed by 'key1 then 'key2, the other keyed by 'key2 then 'key1. *) type ('key1, 'key2, 'data) t with sexp_of include Invariant.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t val clear : (_, _, _) t -> unit val add_exn : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data -> unit val set : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data -> unit val find : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> 'data option val mem : ('key1, 'key2, 'data) t -> 'key1 -> 'key2 -> bool val mem1 : ('key1, 'key2, 'data) t -> 'key1 -> bool val mem2 : ('key1, 'key2, 'data) t -> 'key2 -> bool val iter : ('key1, 'key2, 'data) t -> f:('key1 -> 'key2 -> 'data -> unit) -> unit val find1 : ('key1, 'key2, 'data) t -> 'key1 -> ('key2, 'data) Hashtbl.t option val find2 : ('key1, 'key2, 'data) t -> 'key2 -> ('key1, 'data) Hashtbl.t option val find1_iter2 : ('key1, 'key2, 'data) t -> 'key1 -> f:('key2 -> 'data -> unit) -> unit val find2_iter1 : ('key1, 'key2, 'data) t -> 'key2 -> f:('key1 -> 'data -> unit) -> unit val remove_all1 : ('key1, _, _) t -> 'key1 -> unit val remove_exn : ('key1, 'key2, _) t -> 'key1 -> 'key2 -> unit module Make (Key1 : Key) (Key2 : Key) : sig type nonrec 'data t = (Key1.t, Key2.t, 'data) t with sexp_of include Equal.S1 with type 'a t := 'a t val create : unit -> 'data t val of_alist_exn : (Key1.t * Key2.t * 'data) list -> 'data t end core_extended-113.00.00/src/interval_map.ml000066400000000000000000000577231256461102500204460ustar00rootroot00000000000000open Core_kernel.Std open Interval_map_intf type ('k, 'v, 'cmp) t = { left_of_leftmost : 'v; (* default *) value_right_of : ('k, 'v, 'cmp) Map.t; } with fields let comparator t = Map.comparator t.value_right_of let comparing_with t = (comparator t).Comparator.compare let compare = let rec compare_tail compare_value sign const_val_left right = match right with | None -> 0 | Some ((_, val_right), right') -> let c = compare_value const_val_left val_right in if c <> 0 then c * sign else compare_tail compare_value sign const_val_left (Sequence.next right') in let rec compare compare_key compare_value left_prev left right_prev right = match left with | None -> compare_tail compare_value 1 left_prev right | Some ((left_key, left_val), left') -> match right with | None -> compare_tail compare_value (-1) right_prev left | Some ((right_key, right_val), right') -> let c_key = compare_key left_key right_key in if c_key < 0 then let c_val = compare_value left_val right_prev in if c_val <> 0 then c_val else compare compare_key compare_value left_val (Sequence.next left') right_prev right else if c_key > 0 then let c_val = compare_value left_prev right_val in if c_val <> 0 then c_val else compare compare_key compare_value left_prev left right_val (Sequence.next right') else (* c_key = 0 *) let c_val = compare_value left_val right_val in if c_val <> 0 then c_val else compare compare_key compare_value left_val (Sequence.next left') right_val (Sequence.next right') in fun compare_value left right -> let c_leftmost = compare_value left.left_of_leftmost right.left_of_leftmost in if c_leftmost <> 0 then c_leftmost else compare (comparing_with left) compare_value left.left_of_leftmost (Map.to_sequence left.value_right_of |> Sequence.next) right.left_of_leftmost (Map.to_sequence right.value_right_of |> Sequence.next) ;; let create = Fields.create let always left_of_leftmost ~comparator = { left_of_leftmost; value_right_of = Map.empty ~comparator; } let change t ~at:key data = { t with value_right_of = Map.add t.value_right_of ~key ~data; } let find t key = match Map.closest_key t.value_right_of `Less_or_equal_to key with | Some (_, v) -> v | None -> t.left_of_leftmost let map t ~f = { left_of_leftmost = f t.left_of_leftmost; value_right_of = Map.map t.value_right_of ~f; } let rec map2 lval rval left right init ~f = match left with | [] -> List.fold right ~init ~f:(fun init (key, rval) -> Map.add init ~key ~data:(f lval rval)) | ((lnext, lval') :: left') -> match right with | [] -> List.fold left ~init ~f:(fun init (key, lval) -> Map.add init ~key ~data:(f lval rval)) | ((rnext, rval') :: right') -> match (Map.comparator init).Comparator.compare lnext rnext with | 0 -> map2 lval' rval' left' right' ~f (Map.add init ~key:rnext ~data:(f lval' rval')) | n when n < 0 -> map2 lval' rval left' right ~f (Map.add init ~key:lnext ~data:(f lval' rval)) | _ -> map2 lval rval' left right' ~f (Map.add init ~key:rnext ~data:(f lval rval')) let map2 x_val y_val x_changes y_changes ~f = if Map.is_empty x_changes then Map.map y_changes ~f:(fun y -> f x_val y) else if Map.is_empty y_changes then Map.map x_changes ~f:(fun x -> f x y_val) else map2 ~f x_val y_val (Map.to_alist x_changes) (Map.to_alist y_changes) (Map.empty ~comparator:(Map.comparator x_changes)) let map2 x y ~f = { left_of_leftmost = f x.left_of_leftmost y.left_of_leftmost; value_right_of = map2 ~f x.left_of_leftmost y.left_of_leftmost x.value_right_of y.value_right_of } let iterate_changes t interval = let low_key, high_key = match interval with | `Always -> None, None | `Until high_key -> None, Some high_key | `From low_key -> Some low_key, None | `Between (low_key, high_key) -> Some low_key, Some high_key in let bounded_above = match high_key with | None -> t.value_right_of | Some high_key -> fst3 (Map.split t.value_right_of high_key) in Map.to_sequence bounded_above ?keys_greater_or_equal_to:low_key let remove_changes_within t interval = if Interval.is_empty interval ~cmp:(comparator t).Comparator.compare then t else begin match interval with | `Always -> always t.left_of_leftmost ~comparator:(comparator t) | (`Until _ | `From _ | `Between _) as interval -> { t with value_right_of = Sequence.fold (iterate_changes t interval) ~init:t.value_right_of ~f:(fun map (key, _) -> Map.remove map key); } end let set_within t interval v = if Interval.is_empty interval ~cmp:(comparator t).Comparator.compare then t else begin match interval with | `Always -> always v ~comparator:(comparator t) | `Until high_key -> { (change (remove_changes_within t interval) ~at:high_key (find t high_key)) with left_of_leftmost = v; } | `From low_key -> change (remove_changes_within t interval) ~at:low_key v | `Between (low_key, high_key) -> change (change ( remove_changes_within t interval) ~at:low_key v) ~at:high_key (find t high_key) end let map_within t interval ~f = if Interval.is_empty interval ~cmp:(comparator t).Comparator.compare then t else begin match interval with | `Always -> map t ~f | (`Until _ | `From _ | `Between _) as interval -> let base_changes = iterate_changes t interval |> Sequence.fold ~init:t.value_right_of ~f:(fun map (key, data) -> Map.add map ~key ~data:(f data)) in match interval with | `Until high_key -> { left_of_leftmost = f t.left_of_leftmost; value_right_of = Map.add base_changes ~key:high_key ~data:(find t high_key); } | `From low_key -> { left_of_leftmost = t.left_of_leftmost; value_right_of = Map.add base_changes ~key:low_key ~data:(f (find t low_key)); } | `Between (low_key, high_key) -> { left_of_leftmost = t.left_of_leftmost; value_right_of = Map.add (Map.add base_changes ~key:low_key ~data:(f (find t low_key))) ~key:high_key ~data:(find t high_key); } end module Preimage_impl = struct type ('k, 'v, 'cmp) state = | Initially of 'v * ('k * 'v) Sequence.t | From of 'k * 'v * ('k * 'v) Sequence.t | Fin let step = function | Fin -> Sequence.Step.Done | (Initially (_, seq) | From (_, _, seq)) as state -> match Sequence.next seq with | None -> Sequence.Step.Yield (begin match state with | Fin -> Error.failwithp _here_ "Reached impossible case" () <:sexp_of< unit >> | Initially (x, _) -> x, `Always | From (date, x, _) -> x, `From date end, Fin) | Some ((until, y), seq) -> Sequence.Step.Yield (begin match state with | Fin -> Error.failwithp _here_ "Reached impossible case" () <:sexp_of< unit >> | Initially (x, _) -> x, `Until until | From (from, x, _) -> x, `Between (from, until) end, From (until, y, seq)) let init { left_of_leftmost; value_right_of; } = Initially (left_of_leftmost, Map.to_sequence value_right_of) end let construct_preimage t = Sequence.unfold_step ~init:(Preimage_impl.init t) ~f:Preimage_impl.step module Make(T : Type_with_map_module) = struct module Key = T.Map.Key module Interval = struct type t = Key.t Interval.t let is_empty = Interval.is_empty ~cmp:T.compare let contains = Interval.contains ~cmp:T.compare end type nonrec 'a t = (Key.t, 'a, Key.comparator_witness) t let t_of_sexp a_of_sexp sexp = match sexp with | Sexp.Atom _ | Sexp.List [] -> raise (Sexplib.Conv.Of_sexp_error ( Failure "t_of_sexp: non-empty list needed", sexp)) | Sexp.List (left_of_leftmost :: value_right_of) -> { left_of_leftmost = a_of_sexp left_of_leftmost; value_right_of = <:of_sexp< a T.Map.t >> (Sexp.List value_right_of); } ;; let sexp_of_t sexp_of_a t = let f ~key ~data acc = Sexp.List [T.sexp_of_t key; sexp_of_a data] :: acc in Sexp.List ( sexp_of_a t.left_of_leftmost :: Map.fold_right t.value_right_of ~f ~init:[]) ;; let compare = compare let create = create let always = always ~comparator:Key.comparator let find = find let change = change let map = map let map2 = map2 let remove_changes_within = remove_changes_within let set_within = set_within let map_within = map_within let construct_preimage = construct_preimage end module Make_with_boundary (Key : Key) = struct let find' t key = find t (Left_boundary.Inc key) module Left_boundary = struct module T = struct type t = Key.t Left_boundary.t with sexp, compare end include T include Comparable.Make(T) end include Make(Left_boundary) end TEST_MODULE "Check construction from standard map." = struct (* This test is actually only checking that certain functor applications that we want to allow really do type-check. *) module Test_existing_w_String = Make(String) module Test_existing_w_Int = Make(Int) module Make_via_map_key (Key : Key) = struct include Make(struct include Key module Map = Map.Make(Key) end) end module Make_via_comparable (Key : Key) = struct include Make(struct include Key include Comparable.Make(Key) end) end end TEST_MODULE "Quickcheck tests." = struct module Int_key = Make(Int) module Interval = Interval type 'a poly_t = 'a Int_key.t with sexp, compare type t = string poly_t with sexp, compare type point = int * string with sexp open Quickcheck let point_gen = Generator.(tuple2 int string) let t_gen = let open Generator in list int ~unique:true >>= fun changes_keys -> tuple2 string (list string ~length:(`Exactly (List.length changes_keys))) >>| fun (init, changes_vals) -> create ~left_of_leftmost:init ~value_right_of:(Int.Map.of_alist_exn (List.zip_exn changes_keys changes_vals)) TEST_UNIT "compare: reflexive" = Quickcheck.test t_gen ~sexp_of:sexp_of_t ~f:(fun t -> <:test_result< int >> ~expect:0 (<:compare< t >> t t)); ;; TEST_UNIT "compare: symmetric" = Quickcheck.test Generator.(tuple2 t_gen t_gen) ~sexp_of:<:sexp_of< t * t >> ~f:(fun (x, y) -> <:test_result< int >> ~expect:(Int.neg (<:compare< t >> y x)) (<:compare< t >> x y)); ;; TEST_UNIT "compare: transitive" = let transitive_rule c_a c_b = if c_a = 0 then Some c_b else if c_b = 0 then Some c_a else if c_a = c_b then Some c_a else None in Quickcheck.test Generator.(tuple3 t_gen t_gen t_gen) ~sexp_of:<:sexp_of< t * t * t >> ~f:(fun (x, y, z) -> let a = <:compare< t >> x y in let b = <:compare< t >> y z in Option.iter (transitive_rule a b) ~f:(<:test_result< int >> ~expect:(<:compare< t >> x z))); ;; TEST_UNIT "Induction principle" = Quickcheck.test t_gen ~sexp_of:sexp_of_t ~f:(fun t -> <:test_result< t >> ~expect:t ( let { left_of_leftmost = i; value_right_of = c; } = t in Map.fold c ~init:(always i ~comparator:(Map.comparator c)) ~f:(fun ~key:at ~data i_map -> change i_map ~at data))) ;; TEST_UNIT "sexp round-trip" = Quickcheck.test t_gen ~sexp_of:sexp_of_t ~f:(fun t -> <:test_result< t >> ~expect:t (t_of_sexp (sexp_of_t t))); ;; TEST_UNIT "change interchange" = let this_test_with gen = Quickcheck.test gen ~sexp_of:<:sexp_of< t * (int * string) * (int * string) >> ~f:(fun (t, (k, v), (k', v')) -> <:test_result< t >> ~expect:(change (change t ~at:k v) ~at:k' v') begin if Int.equal k k' then (change t ~at:k v') else (change (change t ~at:k' v') ~at:k v) end); in this_test_with begin let open Generator in (* where the two keys are not equal *) bind_choice int (fun choice -> let k = Choice.value choice in let k_gen' = Choice.updated_gen choice ~keep:`All_choices_except_this_choice in tuple2 t_gen (tuple2 k_gen' (tuple2 string string)) >>| fun (t, (k', (v, v'))) -> t, (k, v), (k', v')) end; this_test_with begin let open Generator in (* where the two keys are equal *) tuple2 t_gen (tuple2 int (tuple2 string string)) >>| fun (t, (k, (v, v'))) -> t, (k, v), (k, v') end; ;; TEST_UNIT "find rules: base" = Quickcheck.test point_gen ~sexp_of:<:sexp_of< point >> ~f:(fun (k, v) -> <:test_result< string >> ~expect:v (find (Int_key.always v) k)); ;; TEST_UNIT "find rules: one change" = Quickcheck.test (Generator.tuple2 point_gen point_gen) ~sexp_of:<:sexp_of< point * point >> ~f:(fun ((l, c), (k, a)) -> <:test_result< string >> ~expect:(if l >= k then a else c) (find (change (Int_key.always c) ~at:k a) l)); ;; TEST_UNIT "find rules: n+2 changes" = Quickcheck.test Generator.(tuple2 (tuple2 t_gen int) (tuple2 point_gen point_gen)) ~sexp_of:<:sexp_of< (t * int) * (point * point) >> ~f:(fun ((t, l), ((k, a), (k', b))) -> (* where k <= k' ... *) let (k, a, k', b) = if k > k' then k', b, k, a else k, a, k', b in <:test_result< string >> ~expect:( if l >= k' then find (change t ~at:k' b) l else find (change t ~at:k a) l) (find (change (change t ~at:k a) ~at:k' b) l)); ;; TEST_UNIT "map laws: map id" = Quickcheck.test t_gen ~sexp_of:<:sexp_of< t >> ~f:(fun x -> <:test_result< t >> ~expect:x (map x ~f:Fn.id)); ;; TEST_UNIT "map laws: map composition" = let f x = `F x in let g x = `G x in Quickcheck.test t_gen ~sexp_of:<:sexp_of< t >> ~f:(fun x -> <:test_result< [ `G of [ `F of string ]] poly_t >> ~expect:(map x ~f:(fun x -> g (f x))) (map (map x ~f) ~f:g)); ;; TEST_UNIT "map laws: always/pure" = let f x = `F x in Quickcheck.test Generator.string ~sexp_of:<:sexp_of< string >> ~f:(fun x -> <:test_result< [ `F of string ] poly_t >> ~expect:(Int_key.always (f x)) (map ~f (Int_key.always x))); ;; TEST_UNIT "map laws: find over map" = let f x = `F x in Quickcheck.test Generator.(tuple2 t_gen int) ~sexp_of:<:sexp_of< (t * int) >> ~f:(fun (x, k) -> <:test_result< [ `F of string ] >> ~expect:(f (find x k)) (find (map x ~f) k)); ;; TEST_UNIT "map2 laws: always/pure" = let f x y = `F (x, y) in Quickcheck.test Generator.(tuple2 string t_gen) ~sexp_of:<:sexp_of< string * t >> ~f:(fun (x, y) -> <:test_result< [ `F of string * string ] poly_t >> ~expect:(map ~f:(f x) y) (map2 ~f (Int_key.always x) y)); ;; TEST_UNIT "map2 laws: flip" = let f x y = `F (x, y) in Quickcheck.test Generator.(tuple2 t_gen t_gen) ~sexp_of:<:sexp_of< t * t >> ~f:(fun (x, y) -> <:test_result< [ `F of string * string ] poly_t >> ~expect:(map2 ~f:(Fn.flip f) y x) (map2 ~f x y)); ;; TEST_UNIT "map2 laws: find over" = let f x y = `F (x, y) in Quickcheck.test Generator.(tuple2 (tuple2 t_gen t_gen) int) ~sexp_of:<:sexp_of< (t * t) * int >> ~f:(fun ((x, y), k) -> <:test_result< [ `F of string * string ] >> ~expect:(f (find x k) (find y k)) (find (map2 ~f x y) k)); ;; TEST_UNIT "map2 laws: associativity" = let f x y z = `F (x, y, z) in Quickcheck.test Generator.(tuple2 t_gen (tuple2 t_gen t_gen)) ~sexp_of:<:sexp_of< t * (t * t) >> ~f:(fun (x, (y, z)) -> <:test_result< [ `F of string * string * string ] poly_t >> ~expect:(map2 ~f:(fun x (y, z) -> f x y z) x (map2 ~f:(fun y z -> y, z) y z)) (map2 ~f:(fun f' z -> f' z) (map2 ~f x y) z)); ;; let within interval k = match interval with | `Always -> true | `Until high_key -> k < high_key | `From low_key -> k >= low_key | `Between (low_key, high_key) -> (k >= low_key) && (k < high_key) ;; let interval_gen : int Interval.t Generator.t = Generator.( variant4 unit int int (tuple2 int int)) |> Generator.map ~f:(function | `A () -> `Always | `B k -> `Until k | `C k -> `From k | `D (k, k') -> if k' < k then `Between (k', k) else `Between (k, k')) TEST_UNIT "remove_changes_within: always" = Quickcheck.test Generator.(tuple2 interval_gen string) ~sexp_of:<:sexp_of< int Interval.t * string >> ~f:(fun (interval, x) -> <:test_result< t >> ~expect:(Int_key.always x) (remove_changes_within (Int_key.always x) interval)); ;; TEST_UNIT "remove_changes_within: change" = Quickcheck.test Generator.(tuple3 interval_gen t_gen point_gen) ~sexp_of:<:sexp_of< int Interval.t * t * point >> ~f:(fun (interval, t, (k, x)) -> <:test_result< t >> ~expect:( let t' = remove_changes_within t interval in if within interval k then t' else change t' ~at:k x) (remove_changes_within (change t ~at:k x) interval)); ;; TEST_UNIT "set_within" = Quickcheck.test Generator.(tuple4 t_gen interval_gen string int) ~sexp_of:<:sexp_of< t * int Interval.t * string * int >> ~f:(fun (t, interval, v, k) -> <:test_result< string >> ~expect:(if within interval k then v else find t k) (find (set_within t interval v) k)); ;; TEST_UNIT "map_within: constant function gives set_within" = Quickcheck.test Generator.(tuple3 t_gen interval_gen string) ~sexp_of:<:sexp_of< t * int Interval.t * string >> ~f:(fun (t, interval, v) -> <:test_result< t >> ~expect:(set_within t interval v) (map_within t interval ~f:(Fn.const v))); ;; TEST_MODULE "map_within" = struct type r = | Base of string | F of r with compare, sexp let base x = Base x let f x = F x TEST_UNIT = Quickcheck.test Generator.(tuple3 t_gen interval_gen int) ~sexp_of:<:sexp_of< t * int Interval.t * int >> ~f:(fun (t, interval, k) -> let t = map t ~f:base in <:test_result< r >> ~expect:(if within interval k then f (find t k) else find t k) (find (map_within t interval ~f) k)); ;; end TEST_UNIT "construct_preimage: reconstruction piecewise is identity" = Quickcheck.test t_gen ~sexp_of:<:sexp_of< t >> ~f:(fun t -> construct_preimage t |> Sequence.iter ~f:(fun (v, interval) -> <:test_result< t >> ~expect:t (set_within t interval v))) ;; TEST_UNIT "construct_preimage: full reconstruction" = Quickcheck.test Generator.(tuple2 string t_gen) ~sexp_of:<:sexp_of< string * t >> ~f:(fun (str, t) -> <:test_result< t >> ~expect:t (construct_preimage t |> Sequence.fold ~init:(Int_key.always str) ~f:(fun seq (v, interval) -> set_within seq interval v))) ;; TEST_UNIT "construct_preimage: multiple reconstruction" = (* A more complex reconstruction which also ensures that the set of intervals given do not overlap. *) let cons x tail = x :: tail in Quickcheck.test t_gen ~sexp_of:<:sexp_of< t >> ~f:(fun t -> let seq1 = construct_preimage t |> Sequence.fold ~init:(Int_key.always []) ~f:(fun seq (v, interval) -> map_within seq interval ~f:(cons v)) in <:test_result< t >> ~expect:t ( map seq1 ~f:(function | [v] -> v | [] | _ :: _ :: _ -> Error.failwithp _here_ "Missing or multiple values at points" seq1 <:sexp_of< string list poly_t >>))); ;; end TEST_MODULE "Int test" = struct module For_int = Make_with_boundary(Int) let create (left_of_leftmost, values) = For_int.create ~left_of_leftmost ~value_right_of:(For_int.Left_boundary.Map.of_alist_exn values) TEST_UNIT "check sexp example" = <:test_result< Sexp.t >> ~expect:(Sexp.of_string "(Pre ((Exc 1) A) ((Inc 2) B))") (<:sexp_of< [ `A | `B | `Pre ] For_int.t >> ( create (`Pre, [Exc 1, `A; Inc 2, `B]))); ;; let l1 = [ Left_boundary.Exc 13, Some "e"; Inc 20, None; Inc 1, Some "a"; Exc 1, None; Exc 3, Some "b"; Inc 5, Some "c"; Exc 10, None; Exc 11, None; Inc 12, Some "d"; ] let t1 = create (None, l1) let test map key expected = (For_int.find' map key) = expected TEST "1/-10" = test t1 (-10) None TEST "1/-4" = test t1 (-4) None TEST "1/0" = test t1 0 None TEST "1/1" = test t1 1 (Some "a") TEST "1/2" = test t1 2 None TEST "1/3" = test t1 3 None TEST "1/4" = test t1 4 (Some "b") TEST "1/5" = test t1 5 (Some "c") TEST "1/6" = test t1 6 (Some "c") TEST "1/9" = test t1 9 (Some "c") TEST "1/10" = test t1 10 (Some "c") TEST "1/11" = test t1 11 None TEST "1/12" = test t1 12 (Some "d") TEST "1/13" = test t1 13 (Some "d") TEST "1/14" = test t1 14 (Some "e") TEST "1/15" = test t1 15 (Some "e") TEST "1/19" = test t1 19 (Some "e") TEST "1/20" = test t1 20 None TEST "1/47" = test t1 47 None let l2 = l1 @ [ Exc (-1), Some "x"; Inc (-8), Some "y"; Exc (-4), None; ] let t2 = create (Some "left", l2) TEST "2/-10" = test t2 (-10) (Some "left") TEST "2/-4" = test t2 (-4) (Some "y") TEST "2/-3" = test t2 (-3) None TEST "2/0" = test t2 0 (Some "x") TEST "2/1" = test t2 1 (Some "a") TEST "2/2" = test t2 2 None TEST "2/3" = test t2 3 None TEST "2/4" = test t2 4 (Some "b") TEST "2/5" = test t2 5 (Some "c") TEST "2/6" = test t2 6 (Some "c") TEST "2/9" = test t2 9 (Some "c") TEST "2/10" = test t2 10 (Some "c") TEST "2/11" = test t2 11 None TEST "2/12" = test t2 12 (Some "d") TEST "2/13" = test t2 13 (Some "d") TEST "2/14" = test t2 14 (Some "e") TEST "2/15" = test t2 15 (Some "e") TEST "2/19" = test t2 19 (Some "e") TEST "2/20" = test t2 20 None TEST "2/47" = test t2 47 None let cont1 = create ( "x", [ Left_boundary. Exc 40, "a"; Exc (-2), "c"; Inc 3, "d"; Inc 10, "e"; Exc (-20), "b"; ]) let test_cont map key expected = (For_int.find' map key) = expected TEST "cont -100" = test_cont cont1 (-100) "x" TEST "cont -40" = test_cont cont1 (-40) "x" TEST "cont -21" = test_cont cont1 (-21) "x" TEST "cont -20" = test_cont cont1 (-20) "x" TEST "cont -19" = test_cont cont1 (-19) "b" TEST "cont -4" = test_cont cont1 (-4) "b" TEST "cont -3" = test_cont cont1 (-3) "b" TEST "cont -2" = test_cont cont1 (-2) "b" TEST "cont -1" = test_cont cont1 (-1) "c" TEST "cont 0" = test_cont cont1 (0) "c" TEST "cont 1" = test_cont cont1 (1) "c" TEST "cont 2" = test_cont cont1 (2) "c" TEST "cont 3" = test_cont cont1 (3) "d" TEST "cont 4" = test_cont cont1 (4) "d" TEST "cont 9" = test_cont cont1 (9) "d" TEST "cont 10" = test_cont cont1 (10) "e" TEST "cont 11" = test_cont cont1 (11) "e" TEST "cont 99" = test_cont cont1 (99) "a" TEST "cont always" = test_cont (For_int.always "a") (-100) "a" end core_extended-113.00.00/src/interval_map.mli000066400000000000000000000000751256461102500206030ustar00rootroot00000000000000(** See {!Interval_map_inf}. *) include Interval_map_intf.M core_extended-113.00.00/src/interval_map_intf.ml000066400000000000000000000270411256461102500214540ustar00rootroot00000000000000open Core_kernel.Std (* This is to represent an unbounded sequence of keys where we specify what value is associated with each part interval of the sequence, and then can query the sequence for the value associated with a specific point along it. The base structure defines a continuous series where points for all keys have a value. Each point represents a low/left boundary of an interval which is open on the right side. To ensure that keys before/smaller than/left of the first point have a defined value an additional default value is specified. Augmenting the keys with [key Left_boundary.t] can be used to construct series where the left boundaries of the intervals can be inclusive or exclusive, which can be very useful when the key is a continuous type (as opposed to discrete, at least in terms of what it models). Make_with_boundary constructs a series type of this form. If you want to represent a series where some points do not have a value, this can be done by using ['a option] as the value type. This can be used to represent intervals over a limited range of keys (the leftmost default should be [None], and also some point at the right part of the range which sets to [None], inclusive or exclusive keys can be used to make the upper bound of the range exclusive or inclusive respectively). *) module type Key = Core_kernel.Core_map_intf.Key (* Something which has a map type. This is used when constructing Interval_map types so that the structures used are compatible with normal maps for that key type. The map part should be a subset of that generated with [Map.Make] or [Comparable.Make], so you should be able to satisfy this signature with many existing modules e.g. [String] or [Date], and also do e.g. Interval_map.Make(struct module T = struct type t = ... with compare, sexp end include T module Map = Map.Make(T) (* OR include Comparable.Make(T) *) end) *) module type Type_with_map_module = sig type t with sexp, compare module Map : sig module Key : Comparator.S with type t = t type +'a t = (Key.t, 'a, Key.comparator_witness) Map.t with compare, sexp end end module Interval : sig (** Represents a single interval across a key type. *) type 'k t = [ `Always | `From of 'k | `Until of 'k | `Between of 'k * 'k ] with sexp val is_empty : 'k t -> cmp:('k -> 'k -> int) -> bool val contains : 'k t -> cmp:('k -> 'k -> int) -> 'k -> bool end = struct type 'k t = [ `Always | `From of 'k | `Until of 'k | `Between of 'k * 'k ] with sexp let is_empty t ~cmp = match t with | `Always | `From _ | `Until _ -> false | `Between (min, max) -> cmp min max >= 0 let contains t ~cmp k = match t with | `Always -> true | `From min -> cmp k min >= 0 | `Until max -> cmp k max < 0 | `Between (min, max) -> (cmp k min >= 0) && (cmp k max < 0) end (** A standard incarnation of an interval map for some key type. The majority of the operations are further defined/explained in the main module type {!M}. *) module type S = sig type ('k, +'v, 'cmp) interval_map module Key : Comparator.S module Interval : sig type t = Key.t Interval.t val is_empty : t -> bool val contains : t -> Key.t -> bool end type +'a t = (Key.t, 'a, Key.comparator_witness) interval_map with sexp, compare val create : left_of_leftmost:'a -> value_right_of:(Key.t, 'a, Key.comparator_witness) Map.t -> 'a t val always : 'a -> 'a t (* For these operations, see {!M}. *) val find : 'v t -> Key.t -> 'v val change : 'v t -> at:Key.t -> 'v -> 'v t val map : 'a t -> f:('a -> 'b) -> 'b t val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val remove_changes_within : 'v t -> Interval.t -> 'v t val set_within : 'v t -> Interval.t -> 'v -> 'v t val map_within : 'v t -> Interval.t -> f:('v -> 'v) -> 'v t val construct_preimage : 'v t -> ('v * Interval.t) Sequence.t end (** An incarnation of an interval map where the key type has been wrapped with [Left_boundary.t]. The majority of the operations are further defined/explained in the main module type {!M}. *) module type S_with_boundary = sig type key module Left_boundary : sig type t = key Left_boundary.t with sexp, compare include Comparable.S with type t := t end include S with type Key.t = Left_boundary.t (** Finding the value for an unwrapped key in an interval map based on wrapped keys means searching for the value at the point [Inclusive k], because the point [Exclusive k] should not apply for keys equal to [k]. This can be very confusing, so [find' k] does this automatically. *) val find' : 'a t -> key -> 'a end module type M = sig type ('k, +'v, 'cmp) t (** Note on complexities: As the mappings are for ranges, where complexities are given they are given in terms of variables (n, m) which are the number of change points that have been inserted into the sequence. *) (** Comparison works lexicographically pointwise across the whole sequence (from -infty to +infty). Complexity is O(n + m). Note that this is a normalising comparison (a change point which changes the value to the same value is treated as if it does not exist), which means that it is not entirely extensional. In particular, two equal sequences may be distinguished by converting to sexps or using [construct_preimage], both of which do not perform normalisation. In example: {[ let module Int_interval_map = Interval_map.Make(Int) in let compare = Int_interval_map.compare Int.compare in let sexp_of_t = Int_interval_map.sexp_of_t Int.sexp_of_t in let list_preimage t = Sequence.to_list (Int_interval_map.construct_preimage t) in let x = Int_interval_map.always 42 in let y = Int_interval_map.change x ~at:0 42 in assert (compare x y = 0); assert (sexp_of_t x <> sexp_of_t y); assert (list_preimage x <> list_preimage y); ]} *) val compare : ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int (** Create a sequence with a specified far-leftmost value, and sequence of change points. O(1). *) val create : left_of_leftmost:'v -> value_right_of:('k, 'v, 'cmp) Map.t -> ('k, 'v, 'cmp) t (** Create a sequence which has a single constant value across the whole sequence of keys. O(1). *) val always : 'v -> comparator:('k, 'cmp) Comparator.t -> ('k, 'v, 'cmp) t (** Find the value associated with some point along the sequence of keys. O(log n). *) val find : ('k, 'v, 'cmp) t -> 'k -> 'v (** Insert a change point into the sequence of changes. The precise effect on the values along the sequence depends on what other change points are present, notionally inserting a change point means the value prior to this point is unchanged, then at this point the value becomes the supplied value, and then continues to be that value until the next change point which had already been inserted. If you want to control values directly within bounded intervals, [set_within] may be simpler to use. O(log n). *) val change : ('k, 'v, 'cmp) t -> at:'k -> 'v -> ('k, 'v, 'cmp) t (** Apply a function to all values within the sequence. O(n). *) val map : ('k, 'a, 'cmp) t -> f:('a -> 'b) -> ('k, 'b, 'cmp) t (** Create a sequence whose value at all points is taken by applying a function to the values of two other sequences at that point. O(n + m). *) val map2 : ('k, 'a, 'cmp) t -> ('k, 'b, 'cmp) t -> f:('a -> 'b -> 'c) -> ('k, 'c, 'cmp) t (** [remove_changes_within t interval] removes any change points within the specified interval. By removing these points of change, the value within the interval will become whatever the value already was outside the left-boundary of the interval. Some intervals are open on the left (e.g. [ `Always ] or [ `Until k ]), and in these cases the value in the interval will become [t.left_of_leftmost]. Complexity is O(log(n) + n'), where n' is the number of change points within the specified interval (not the whole sequence). *) val remove_changes_within : ('k, 'v, 'cmp) t -> 'k Interval.t -> ('k, 'v, 'cmp) t (** [set_within t interval v] modifies the sequence so that all values within the specified interval are [v], and values outside the interval are not modified. Complexity is O(log(n) + n'), where n' is the number of change points within the specified interval (not the whole sequence). *) val set_within : ('k, 'v, 'cmp) t -> 'k Interval.t -> 'v -> ('k, 'v, 'cmp) t (** [map_within t interval ~f] modifies the sequence similarly to set_within, except that it applies a function to the range rather than a constant value (i.e. [map_within t interval ~f:(Fn.const x) = set_within t interval x]). Complexity is O(log(n) + n'), where n' is the number of change points within the specified interval (not the whole sequence). *) val map_within : ('k, 'v, 'cmp) t -> 'k Interval.t -> f:('v -> 'v) -> ('k, 'v, 'cmp) t (** Construct a preimage of the sequence. This is a series of pairs of a value and an interval of keys within which the sequence has that value. O(n). Importantly note that: 1) A particular value may be output many times with different intervals. 2) Each interval output will be unique and not overlap with any other. 3) As noted above, this is one of the areas where extensionality breaks down. In example of the last point: {[ let x = Int_interval_map.always 42 in let y = Int_interval_map.change x ~at:0 42 in let list_preimage t = Sequence.to_list (Int_interval_map.construct_preimage t) in assert (list_preimage x = [(42, `Always)]); assert (list_preimage y = [(42, `Until 0); (42, `From 0)]; ]} *) val construct_preimage : ('k, 'v, 'cmp) t -> ('v * 'k Interval.t) Sequence.t (* [Make] creates an interval map which directly uses some key type. As we use the normal form of map type to construct this, we pass in the type with its map module, rather than just the type and a comparison function (this means we can use the same comparator_witness type). In this case the keys used always act as inclusive left-boundaries of a range. *) module Make (T : Type_with_map_module) : S with type Key.t = T.Map.Key.t and type Key.comparator_witness = T.Map.Key.comparator_witness and type ('k, 'v, 'cmp) interval_map := ('k, 'v, 'cmp) t (* Note on the sexp format of generated interval_map types: This type is not serialised as the above record, but rather in a manner similar to ['a Left_boundary.Map.t], for example: sexp_of_t (create ~left_of_leftmost:`Pre ~value_right_of:(Map.of_alist [Exc 1, `A; Inc 2, `B])) = (Pre ((Exc 1) A) ((Inc 2) B)) *) (* [Make_with_boundary] wraps the supplied key up using [Left_boundary.t], before constructing the interval map. The use of [Key.t Left_boundary.t] allows additional convenience functions. This is kept separate from [Make] because there are cases when the presence of inclusive and exclusive boundaries makes things very complicated. *) module Make_with_boundary (Key : Key) : S_with_boundary with type key := Key.t and type ('k, 'v, 'cmp) interval_map := ('k, 'v, 'cmp) t end core_extended-113.00.00/src/invariant.ml000066400000000000000000000005121256461102500177400ustar00rootroot00000000000000type 'a t = 'a -> unit type 'a inv = 'a t module type S1 = sig type 'a t val invariant : 'a inv -> 'a t inv end module type S2 = sig type ('a, 'b) t val invariant : 'a inv -> 'b inv -> ('a, 'b) t inv end module type S3 = sig type ('a, 'b, 'c) t val invariant : 'a inv -> 'b inv -> 'c inv -> ('a, 'b, 'c) t inv end core_extended-113.00.00/src/invocation.ml000066400000000000000000000015101256461102500201150ustar00rootroot00000000000000open Core.Std let full () = String.concat (Array.to_list Sys.argv) ~sep:" " let commands_only () = (* We are looking for the name of the executable and the prefix that denotes the actual command run (e.g. db tools sql extract). Postgres also restricts the length of an application name to 64 characters. As we don't actually know what is a flag or a filename and what is part of the command name we apply a heuristic. *) let cmd = Sys.argv.(0) |! Filename.basename in let args = List.tl_exn (Array.to_list Sys.argv) in let rec loop res args = match args with | [] -> res | a :: args -> if String.contains a '.' || String.contains a '/' || a = "" || not ('a' <= a.[0] && a.[0] <= 'z') then res else loop (res ^ " " ^ a) args in loop cmd args ;; core_extended-113.00.00/src/invocation.mli000066400000000000000000000001151256461102500202660ustar00rootroot00000000000000open Core.Std val full : unit -> string val commands_only : unit -> string core_extended-113.00.00/src/iter.ml000066400000000000000000000062671256461102500167250ustar00rootroot00000000000000open Core.Std type 'a t = { next : (unit -> 'a option); progress : (unit -> float option); } let next t = t.next () let next_exn t = match t.next () with | Some e -> e | None -> failwith "Iter.next_exn None" let progress t = t.progress () let progress_string = function None -> "" | Some x -> sprintf " (%.0f%%)" (100.0 *. x) let rec i t ~f = match t.next () with | Some e -> f e; i t ~f | None -> () let make ?(progress = (fun () -> None)) f = { next = f; progress = progress; } let empty = make ~progress:(fun () -> Some 1.0) (fun () -> None) let concat l = let remaining = ref l in let current = ref empty in let rec loop () = match !current.next () with | None -> (match !remaining with | [] -> None | h :: t -> current := h; remaining := t; loop ()) | some -> some in make loop let reduce t ~init ~f = let rec loop acc = match t.next () with | Some e -> loop (f acc e) | None -> acc in loop init let map t ~f = make ~progress:t.progress (fun () -> Option.map ~f (t.next ())) let fold = reduce let unfold ~init ~f ~stop = let state = ref init in let next () = if !state = stop then None else ( let e, i = f !state in state := i; Some e ) in make next let rec find t ~f = match t.next () with | Some e -> if f e then e else find t ~f | None -> raise Not_found let filter t ~f = let rec loop () = match t.next () with | None -> None | Some e -> if f e then Some e else loop () in make loop let rec for_all t ~f = match t.next () with | None -> true | Some e -> if f e then for_all t ~f else false let rec exists t ~f = match t.next () with | None -> false | Some e -> if f e then true else exists t ~f let t = make let of_opt o = let state = ref o in { next = (fun () -> let ret = !state in state := None; ret); progress = (fun () -> match !state with | Some _ -> Some 0.0 | None -> Some 1.0); } let of_list l = unfold ~f:(function | h::t -> h,t | [] -> failwith "Iter.of_list -> unfold [] (can't happen)") ~init:l ~stop:[] let to_list t ~f = List.rev (fold t ~init:[] ~f:(fun acc e -> (f e)::acc)) let to_list_opt t ~f = List.rev (fold t ~init:[] ~f:(fun acc e -> match f e with None -> acc | Some x -> x::acc)) let of_array a = let len = Array.length a and pos = ref 0 in { next = (fun () -> if !pos = len then None else ( let r = a.(!pos) in incr pos; Some r )); progress = (fun () -> Some ((float !pos) /. (float len))); } let to_array t ~f = Array.of_list (to_list t ~f) let to_array_opt t ~f = Array.of_list (to_list_opt t ~f) let channel_progress ?total c = try let total = match total with | Some t -> Float.of_int64 t | None -> Float.of_int64 (In_channel.length c) in fun () -> try Some ((Float.of_int64 (In_channel.pos c)) /. total) with _ -> None with _ -> (fun () -> None) (* if in_channel_length fails *) let of_channel ?total c ~f = { next = (fun () -> try Some (f c) with End_of_file -> None); progress = channel_progress ?total c; } let channel c ~f = try while true do f c; done with End_of_file -> () core_extended-113.00.00/src/iter.mli000066400000000000000000000052101256461102500170610ustar00rootroot00000000000000(** Astract iterators. *) (* Abstract iterator - a source of objects * Common use cases: * == run FUNC on each line in FILE and collect results in a list: * read_wrap FILE ~f:(fun ic -> to_list (of_channel ic) ~f:FUNC) * == map objects in array into a list without an intermediate list/array * to_list ~f (of_array a) *) type 'a t (** get the next element of the iterator *) val next : 'a t -> 'a option val next_exn : 'a t -> 'a (** get the position in the iterator either None or Some x in [0;1] *) val progress : 'a t -> float option (** convert the progress return value to a string: None->"", Some->" 33%" *) val progress_string : float option -> string (** iterate over the iterator: call f on each element *) val i : 'a t -> f:('a -> unit) -> unit (** concatenate a list of iterators *) val concat : 'a t list -> 'a t (** fold over the iterator: call f on each element and return the accumulator *) val reduce : 'a t -> init:'i -> f:('i -> 'a -> 'i) -> 'i (** transform the iterator *) val map : 'a t -> f:('a -> 'b) -> 'b t (** fold is the same as reduce *) val fold : 'a t -> init:'i -> f:('i -> 'a -> 'i) -> 'i val unfold : init:'i -> f:('i -> ('a * 'i)) -> stop:'i -> 'a t (** find an element that satisfies the predicate *) val find : 'a t -> f:('a -> bool) -> 'a (** iterate over elements that satisfy the predicate *) val filter : 'a t -> f:('a -> bool) -> 'a t (** evaluate a predicate over the entire iterator *) val for_all : 'a t -> f:('a -> bool) -> bool val exists : 'a t -> f:('a -> bool) -> bool (** create an iterator from an iterating function *) val t : ?progress:(unit -> float option) -> (unit -> 'a option) -> 'a t (** an iterator that halts immediately *) val empty : 'a t (** create an iterator that may iterate over one value *) val of_opt : 'a option -> 'a t (** create an iterator that will go over list elements *) val of_list : 'a list -> 'a t (** iterate a function and collect results to a list *) val to_list : 'a t -> f:('a -> 'b) -> 'b list val to_list_opt : 'a t -> f:('a -> 'b option) -> 'b list (** create an iterator that will go over array elements *) val of_array : 'a array -> 'a t (** iterate a function and collect results to a array *) val to_array : 'a t -> f:('a -> 'b) -> 'b array val to_array_opt : 'a t -> f:('a -> 'b option) -> 'b array (** create a progress function for an input channel *) val channel_progress : ?total:int64 -> in_channel -> (unit -> float option) (** create an iterator that will read from file using f *) val of_channel : ?total:int64 -> in_channel -> f:(in_channel -> 'a) -> 'a t (** call f on channel until End_of_file *) val channel : in_channel -> f:(in_channel -> unit) -> unit core_extended-113.00.00/src/lazy_list.ml000066400000000000000000000214351256461102500177660ustar00rootroot00000000000000open Core.Std type 'a node = | Empty | Cons of 'a * 'a lazy_list and 'a lazy_list = 'a node Lazy_m.t let rec map t ~f = Lazy_m.map t ~f:(function | Empty -> Empty | Cons (x, xs) -> Cons (f x, map xs ~f)) ;; module Base : sig type 'a t = 'a lazy_list val empty : unit -> 'a t val return : 'a -> 'a t val map : [> `Custom of ('a t -> f:('a -> 'b) -> 'b t) ] val append : 'a t -> 'a t -> 'a t val concat : 'a t t -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t end = struct type 'a t = 'a lazy_list let empty () = Lazy_m.of_val Empty let return x = Lazy_m.of_val (Cons(x, Lazy_m.of_val Empty)) let rec append t1 t2 = Lazy_m.map t1 ~f:(function | Empty -> Lazy_m.force t2 | Cons (x, xs) -> Cons (x, append xs t2)) ;; let rec concat t = Lazy_m.map t ~f:(function | Empty -> Empty | Cons (x, xs) -> Lazy_m.force (append x (concat xs))) ;; let bind m f = concat (map ~f m) let map = `Custom map end type 'a t = 'a Base.t include (Monad.Make(Base):Monad.S with type 'a t := 'a t) let empty = Base.empty let append = Base.append let concat = Base.concat let is_empty t = match Lazy_m.force t with | Cons _ -> false | Empty -> true ;; let length t = let rec loop n t = match Lazy_m.force t with | Cons(_, t) -> loop (n+1) t | Empty -> n in loop 0 t ;; let decons t = match Lazy_m.force t with | Empty -> None | Cons(h, t) -> Some(h, t) ;; let cons x t = Lazy_m.of_val (Cons(x, t));; let rec snoc t x = Lazy_m.map t ~f:(function | Empty -> Cons (x, Base.empty ()) | Cons(y, ys) -> Cons(y, snoc ys x) );; let rec find ~f t = match Lazy_m.force t with | Empty -> None | Cons(x, xs) -> if f x then Some x else find ~f xs ;; let rec filter ~f t = Lazy_m.bind t (function | Empty -> empty () | Cons(x, xs) -> if f x then cons x (filter ~f xs) else filter ~f xs );; let rec filter_opt t = Lazy_m.bind t (function | Empty -> empty () | Cons(Some x, xs) -> cons x (filter_opt xs) | Cons(None, xs) -> filter_opt xs );; let rec filter_map ~f t = Lazy_m.bind t (function | Empty -> empty () | Cons(x, xs) -> match f x with | Some y -> cons y (filter_map ~f xs) | None -> filter_map ~f xs) ;; let rec fold_left ~f ~init t = match Lazy_m.force t with | Empty -> init | Cons(x, xs) -> fold_left ~f xs ~init:(f init x) ;; let to_rev_list t = fold_left t ~init:[] ~f:(fun xs x -> x :: xs) let to_list t = List.rev (to_rev_list t) let fold_right ~f t ~init = List.fold (to_rev_list t) ~init ~f:(fun a b -> f b a) ;; let rec foldr t ~f ~init = Lazy_m.map t ~f:(function | Empty -> init | Cons(x, xs) -> f x (foldr ~f xs ~init) );; let rec iter t ~f = match Lazy_m.force t with | Empty -> () | Cons(x, xs) -> f x; iter ~f xs ;; let of_iterator ~curr ~next ~init = let rec loop accum () = match curr accum with | Some(x) -> Cons(x, Lazy_m.of_fun (loop (next accum))) | None -> Empty in Lazy_m.of_fun (loop init) ;; let rec build ~f ~seed = Lazy_m.of_fun (fun () -> match f seed with | None -> Empty | Some (x, seed) -> Cons (x, build ~f ~seed)) ;; module Of_container = struct module type T = sig type 'a t val lazy_fold : 'a t -> f:('a -> 'b Lazy_m.t -> 'b) -> last:'b -> 'b end module Make (X:T) = struct let lazy_list_of_t x = Lazy_m.of_fun (fun () -> X.lazy_fold x ~f:(fun x seed -> Cons (x, seed)) ~last:Empty) ;; end end let unfold ~f ~init = let rec loop accum () = match f accum with | Some(x) -> Cons(x, Lazy_m.of_fun (loop x)) (*| Some(x) -> Cons(accum, Lazy_m.of_fun (loop x)) *) | None -> Empty in Lazy_m.of_fun (loop init) ;; let uniter ~f = let rec loop () = match f () with | Some x -> Cons(x, Lazy_m.of_fun loop) | None -> Empty in Lazy_m.of_fun loop ;; let rec of_list xs = Lazy_m.of_fun (fun () -> match xs with | [] -> Empty | x :: xs -> Cons (x, of_list xs)) ;; let concat_list t = concat (map t ~f:of_list) let of_array ary = let rec loop i () = if i < Array.length ary then Cons(ary.(i), Lazy_m.of_fun (loop (succ i))) else Empty in Lazy_m.of_fun (loop 0) ;; let rec nth xs i = if i < 0 then None else match Lazy_m.force xs with | Empty -> None | Cons(x, xs) -> if i = 0 then Some x else nth xs (i-1) ;; let to_array t = match Lazy_m.force t with | Empty -> Array.empty () | Cons(x, xs) -> let ary = Array.create ~len:(length t) x in let i = ref 1 in iter xs ~f:(fun x -> ary.(!i) <- x; incr i); ary ;; let rec merge ~cmp xlst ylst = Lazy_m.bind xlst (function | Empty -> ylst | Cons(x, xs) -> Lazy_m.bind ylst (function | Empty -> xlst | Cons(y, ys) -> if (cmp x y) <= 0 then cons x (merge ~cmp xs ylst) else cons y (merge ~cmp xlst ys) ) );; let rec unify ~cmp xlst ylst = Lazy_m.bind xlst (function | Empty -> map ylst ~f:(fun y -> `Right y) | Cons(x, xs) -> Lazy_m.bind ylst (function | Empty -> map xlst ~f:(fun x -> `Left x) | Cons(y, ys) -> match cmp x y with | -1 -> cons (`Left x) (unify ~cmp xs ylst) | 0 -> cons (`Both (x,y)) (unify ~cmp xs ys) | 1 -> cons (`Right y) (unify ~cmp xlst ys) | _ -> assert false ) );; let lazy_sort ~cmp zlst = (* This is a stable, O(N log N) worst-case, merge sort. It has the * additional useful property that forcing the first element only takes * O(N) time, and forcing each additional element only takes O(log N) * time, meaning it is worthwhile to sort a lazy list even if you only * want the first few elements. * * The basic strategy is as follows: we convert the lazy list into a * (normal) list of one element long lazy lists. We then go through * merging pairs of lazy lists together, into 2 element long lazy lists, * then 4 element long lazy lists, etc., until we merge all the lists * back into one big list (that is now in sorted order). * * In building the final list, we end up creating about 2N intermediate * lists (2N-1, I think). Forcing the first element forces the first * element of all of these lists, meaning that it is O(N) cost to do so. * But we only remove the heads of O(log N) of these lists (those lists * whose head element is the head element of the sorted list)- so forcing * the second element only takes O(log N) work. And so on for the third * element, etc. *) let rec to_zlist_list accum = function | Empty -> accum | Cons(x, xs) -> to_zlist_list ((return x) :: accum) (Lazy_m.force xs) in let rec merge_pairs reversed accum = function | x1 :: x2 :: xs -> if reversed then merge_pairs reversed ((merge ~cmp x2 x1) :: accum) xs else merge_pairs reversed ((merge ~cmp x1 x2) :: accum) xs | [ x ] -> x :: accum | [] -> accum in let rec merge_all_pairs reversed = function | [] -> empty () | [ x ] -> x | lst -> merge_all_pairs (not reversed) (merge_pairs reversed [] lst) in merge_all_pairs true (to_zlist_list [] (Lazy_m.force zlst)) ;; let sort ~cmp zlst = (* We inline to_array here, so we can control where we catch the * invalid_argument exception Array.create ~len:throws when we try to * make too large of an array. *) match Lazy_m.force zlst with | Empty -> zlst | Cons(x, xs) -> (* Note, a little convolution is necessary here, as I want to trap * Invalid_argument exceptions *only* around the Array.create ~len:call. * Remember that iterating through the lazy list is potientially * executing code that could potientially throw Invalid_argument * for entirely other reasons, and I don't want to catch those * exceptions. *) let ary_opt = try Some (Array.create ~len:(length zlst) x) with | Invalid_argument _ -> None in match ary_opt with | None -> (* Array was too large- abort to lazy_sort *) lazy_sort ~cmp zlst | Some ary -> begin (* Fill the array *) let i = ref 1 in iter xs ~f:(fun x -> ary.(!i) <- x; incr i); (* Sort the array *) Array.sort ~cmp ary; (* Return the lazy list of the array *) of_array ary end ;; module Iterator = struct type 'a lazy_list = 'a t type 'a t = 'a lazy_list ref let create zlst = ref zlst let next t = match decons !t with | Some(hd,tl) -> t := tl; Some hd | None -> None let iter t ~f = let rec loop () = match next t with | Some item -> f item; loop () | None -> () in loop () end (* cartesian_product : [[a]] -> [[a]] *) let rec cartesian_product t = match Lazy_m.force t with | Empty -> return (empty ()) | Cons (xs, xss) -> xs >>= fun y -> cartesian_product xss >>= fun ys -> return (cons y ys) ;; core_extended-113.00.00/src/lazy_list.mli000066400000000000000000000047721256461102500201440ustar00rootroot00000000000000 open Core.Std (** Lazy lists. *) type 'a t include Monad.S with type 'a t := 'a t val empty : unit -> 'a t val is_empty : 'a t -> bool val length : 'a t -> int val decons : 'a t -> ('a * 'a t) option val cons : 'a -> 'a t -> 'a t val snoc : 'a t -> 'a -> 'a t val append : 'a t -> 'a t -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t val concat : 'a t t -> 'a t val nth : 'a t -> int -> 'a option val concat_list : 'a list t -> 'a t val find : f:('a -> bool) -> 'a t -> 'a option val filter : f:('a -> bool) -> 'a t -> 'a t val filter_opt : 'a option t -> 'a t val filter_map : f:('a -> 'b option) -> 'a t -> 'b t val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b t -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a t -> init:'b -> 'b (* [foldr ~f t ~init] is a lazy version of [fold_right] that doesn't necessarily force a traversal of the entire list, as is more natural for a lazy list. *) val foldr : 'a t -> f:('a -> 'b Lazy_m.t -> 'b) -> init:'b -> 'b Lazy_m.t val iter : 'a t -> f:('a -> unit) -> unit val of_iterator : curr:('a -> 'b option) -> next:('a -> 'a) -> init:'a -> 'b t val build : f:('s -> ('a * 's) option) -> seed:'s -> 'a t val unfold : f:('a -> 'a option) -> init:'a -> 'a t val uniter : f:(unit -> 'a option) -> 'a t val of_list : 'a list -> 'a t val to_rev_list : 'a t -> 'a list val to_list : 'a t -> 'a list val of_array : 'a array -> 'a t val to_array : 'a t -> 'a array val cartesian_product : 'a t t -> 'a t t val merge : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t val unify : cmp:('a -> 'b -> int) -> 'a t -> 'b t -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] t val sort : cmp:('a -> 'a -> int) -> 'a t -> 'a t val lazy_sort : cmp:('a -> 'a -> int) -> 'a t -> 'a t (* constructing lazy lists from values of container types *) module Of_container : sig module type T = sig type 'a t val lazy_fold : 'a t -> f:('a -> 'b Lazy_m.t -> 'b) -> last:'b -> 'b end (* (applications of) this module are meant to be included into *) module Make (X:T) : sig val lazy_list_of_t : 'a X.t -> 'a t end end (* Iterators are useful when you're trying to avoid closing over the head of a lazy list to avoid a space leak. Just create one of these outside said closure and close over the iterator instead. *) module Iterator : sig type 'a lazy_list = 'a t type 'a t val create : 'a lazy_list -> 'a t (* Produces the next element in the list and updates the iterator *) val next : 'a t -> 'a option val iter : 'a t -> f:('a -> unit) -> unit end core_extended-113.00.00/src/lazy_m.ml000066400000000000000000000017101256461102500172410ustar00rootroot00000000000000open Core.Std type 'a node = | Unevaluated of (unit -> 'a) | Evaluating | Evaluated_to_val of 'a | Evaluated_to_exn of exn type 'a t = 'a node ref type 'a lazy_m = 'a t let of_val v = ref (Evaluated_to_val v) let of_fun f = ref (Unevaluated f) exception Undefined let force t = match !t with | Evaluated_to_val v -> v | Evaluated_to_exn e -> raise e | Unevaluated f -> begin t := Evaluating; match (try `Val (f ()) with e -> `Exn e) with | `Val v -> t := Evaluated_to_val v; v | `Exn e -> t := Evaluated_to_exn e; raise e end | Evaluating -> raise Undefined let is_val t = match !t with | Evaluated_to_val _ -> true | Unevaluated _ | Evaluating | Evaluated_to_exn _ -> false include Monad.Make (struct type 'a t = 'a lazy_m let return x = of_val x let map t ~f = of_fun (fun () -> f (force t)) let bind m f = of_fun (fun () -> force (f (force m))) let map = `Custom map end) core_extended-113.00.00/src/lazy_m.mli000066400000000000000000000034771256461102500174260ustar00rootroot00000000000000(** A non-threadsafe reimplementation of [Lazy] *) open Core.Std.Interfaces (** Lazy values reimplementation. There are two advantages to reimplementing the lazy module in pure Ocaml. Advantage number one is speed: I've measured ~140 clocks to force a standard lazy value the first time, and ~80 clocks to force it the second time. If the lazy computation you're avoiding is creating a simple cons cell, this is horribly expensive. The following implementation is like ~30 clocks to force the lazy value the first time, and single-digit clocks to force it the second time. The second one is that we can make lazy values a monad. This is a correctness issue, as a common mistake with laziness is not being lazy enough. This is much easier to get right if you're doing monadic binding. There are two downsides to doing it this way. One, you can't use lazy keyword. And two, this implementation uses a little more memory per lazy value (it currently uses 5 words/lazy value). *) type 'a t (** The lazy type *) val of_val : 'a -> 'a t (** Create a lazy value of a non-lazy value. The lazy value created will be already forced, for obvious reasons. *) val of_fun : (unit -> 'a) -> 'a t (** Create a lazy value of a function. The function will not be executed until the lazy value is first forced, and will only be executed once. If the function raises an exception, all futures forces of the lazy value will also raise the same exception. *) val force : 'a t -> 'a (** Force the lazy value. If the function that produces the value throws an exception, this function will throw the same exception. *) val is_val : 'a t -> bool (** Returns true if the lazy value has been forced and did not throw an exception. *) include Monad with type 'a t := 'a t core_extended-113.00.00/src/lazy_sequence.ml000066400000000000000000000741041256461102500206240ustar00rootroot00000000000000 open Core.Std type 'a t = | Nil | Lazy of (unit -> 'a t) | Cons of 'a * (unit -> 'a t) | Protect of (unit -> unit) * 'a t let empty = Nil let (==>) x tail = Cons (x, tail) let (==>>) lst tail = match lst with | [] -> Lazy tail | lst -> List.fold_right lst ~init:tail ~f:(fun x tail -> (fun () -> Cons (x, tail))) () let initialize tail = Lazy tail let protect ~finally f = Protect (finally, Lazy f) let execute_finallys finallys = let exns = List.filter_map finallys ~f:(fun finally -> try finally (); None with exn -> Some exn) in match List.reduce exns ~f:(fun x y -> Exn.Finally (x,y)) with | None -> () | Some exn -> raise exn (* CREATING A LAZY SEQUENCE --------------------------------------------- *) let init f = let rec loop n = match f n with | None -> Nil | Some x -> x ==> fun () -> loop (n+1) in Lazy (fun () -> loop 0) let of_list list = let rec of_list list = match list with | [] -> Nil | x :: tail -> x ==> fun () -> of_list tail in Lazy (fun () -> of_list list) let of_array arr = let arr = Array.copy arr in let len = Array.length arr in let rec loop idx = if idx >= len then Nil else arr.(idx) ==> fun () -> loop (idx+1) in Lazy (fun () -> loop 0) let read_lines filename = initialize (fun () -> let ic = In_channel.create filename in protect ~finally:(fun () -> In_channel.close ic) (fun () -> let rec loop () = match In_channel.input_line ic with | None -> empty | Some line -> line ==> loop in loop () )) (* LAZY OPERATIONS --------------------------------------------------- *) let rec map t ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> map (tail ()) ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> map tail ~f)) | Cons (x, tail) -> Cons (f x, (fun () -> map (tail ()) ~f)) let mapi t ~f = let rec mapi t i ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> mapi (tail ()) i ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> mapi tail i ~f)) | Cons (x, tail) -> Cons (f i x, (fun () -> mapi (tail ()) (i+1) ~f)) in mapi t 0 ~f let rec filter_map t ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> filter_map (tail ()) ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> filter_map tail ~f)) | Cons (x, tail) -> match f x with | None -> Lazy (fun () -> filter_map (tail ()) ~f) | Some y -> Cons (y, (fun () -> filter_map (tail ()) ~f)) let filter_mapi t ~f = let rec filter_mapi t i ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> filter_mapi (tail ()) i ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> filter_mapi tail i ~f)) | Cons (x, tail) -> match f i x with | None -> Lazy (fun () -> filter_mapi (tail ()) (i+1) ~f) | Some y -> Cons (y, (fun () -> filter_mapi (tail ()) (i+1) ~f)) in filter_mapi t 0 ~f let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) let rec filter_fold_map t ~init ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> filter_fold_map (tail ()) ~init ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> filter_fold_map tail ~init ~f)) | Cons (x, tail) -> let (state,y) = f init x in match y with | None -> Lazy (fun () -> filter_fold_map (tail ()) ~init:state ~f) | Some y -> Cons (y, (fun () -> filter_fold_map (tail ()) ~init:state ~f)) let fold_map t ~init ~f = filter_fold_map t ~init ~f:(fun state x -> let (state,y) = f state x in (state, Some y)) let rec filter_map_partial t ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> filter_map_partial (tail ()) ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> filter_map_partial tail ~f)) | Cons (x, tail) -> match f x with | `Stop -> Nil | `Continue None -> Lazy (fun () -> filter_map_partial (tail ()) ~f) | `Continue (Some y) -> Cons (y, (fun () -> filter_map_partial (tail ()) ~f)) let rec zip_full t1 t2 = match t1, t2 with | Nil, Nil -> Nil (* Warning: The lazy and protect cases need to be paired like this so that if there is a sequence of lazies that lead to a protect, they all get executed atomically. Otherwise, there could be an interleaving term that raises an exception and causes the protect not to be reached, leaking a resource *) | Lazy tail, _ -> Lazy (fun () -> zip_full (tail ()) t2) | Protect (finally, tail), _ -> Protect (finally, Lazy (fun () -> zip_full tail t2)) (* Similarly, these two need to be paired *) | _, Lazy tail -> Lazy (fun () -> zip_full t1 (tail ())) | _, Protect (finally, tail) -> Protect (finally, Lazy (fun () -> zip_full t1 tail)) | Cons (x,tail1), Cons (y,tail2) -> Cons ((Some x, Some y), (fun () -> zip_full (tail1 ()) (tail2 ()))) | Cons (x,tail1), Nil -> Cons ((Some x, None), (fun () -> zip_full (tail1 ()) Nil)) | Nil, Cons (y,tail2) -> Cons ((None, Some y), (fun () -> zip_full Nil (tail2 ()))) let rec concat_list_seq t = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> concat_list_seq (tail ())) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> concat_list_seq tail)) | Cons (xlist, tail) -> xlist ==>> (fun () -> concat_list_seq (tail ())) let rec concat_map t ~f = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> concat_map (tail ()) ~f) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> concat_map tail ~f)) | Cons (x, tail) -> f x ==>> (fun () -> concat_map (tail ()) ~f) (* NONLAZY OPERATIONS ------------------------------------------------ *) let add elt listref = listref := elt :: !listref let wrap_finallys finallys f = Exn.protect ~f ~finally:(fun () -> execute_finallys !finallys) let iter t ~f = let finallys = ref [] in let rec iter t ~f = match t with | Nil -> () | Lazy tail -> iter (tail ()) ~f | Protect (finally, tail) -> add finally finallys; iter tail ~f | Cons (x, tail) -> f x; iter (tail ()) ~f in wrap_finallys finallys (fun () -> iter t ~f) let iteri t ~f = let finallys = ref [] in let rec iteri t i ~f = match t with | Nil -> () | Lazy tail -> iteri (tail ()) i ~f | Protect (finally, tail) -> add finally finallys; iteri tail i ~f | Cons (x, tail) -> f i x; iteri (tail ()) (i+1) ~f in wrap_finallys finallys (fun () -> iteri t 0 ~f) let fold t ~init ~f = let finallys = ref [] in let rec fold t ~init ~f = match t with | Nil -> init | Lazy tail -> fold (tail ()) ~init ~f | Protect (finally, tail) -> add finally finallys; fold tail ~init ~f | Cons (x, tail) -> let next = f init x in (* Make sure [f] is called before [tail] *) fold (tail ()) ~init:next ~f in wrap_finallys finallys (fun () -> fold t ~init ~f) let foldi t ~init ~f = let finallys = ref [] in let rec foldi t i ~init ~f = match t with | Nil -> init | Lazy tail -> foldi (tail ()) i ~init ~f | Protect (finally, tail) -> add finally finallys; foldi tail i ~init ~f | Cons (x, tail) -> let next = f i init x in (* Make sure [f] is called before [tail] *) foldi (tail ()) (i+1) ~init:next ~f in wrap_finallys finallys (fun () -> foldi t 0 ~init ~f) let find_map t ~f = let finallys = ref [] in let rec find_map t ~f = match t with | Nil -> None | Lazy tail -> find_map (tail ()) ~f | Protect (finally, tail) -> add finally finallys; find_map tail ~f | Cons (x, tail) -> match f x with | None -> find_map (tail ()) ~f | Some y -> Some y in wrap_finallys finallys (fun () -> find_map t ~f) let length_if_at_most ~max t = with_return (fun {return} -> if max < 0 then return None; Some (fold t ~init:0 ~f:(fun len _ -> if len + 1 > max then return None else len + 1)) ) let length_bounded_by ?min ?max t = match min, max with | None, None -> true | Some min, None -> Option.is_none (length_if_at_most ~max:(min - 1) t) | None, Some max -> Option.is_some (length_if_at_most ~max t) | Some min, Some max -> match length_if_at_most ~max t with | None -> false | Some len -> len >= min let find t ~f = find_map t ~f:(fun x -> if f x then Some x else None) let exists t ~f = Option.is_some (find_map t ~f:(fun x -> if f x then Some () else None)) let for_all t ~f = not (exists t ~f:(fun x -> not (f x))) let is_empty t = not (exists t ~f:(fun _ -> true)) let mem ?(equal = (=)) t elt = exists t ~f:(fun x -> equal x elt) let length t = Container.length ~fold t let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum m ~fold t ~f let min_elt t ~cmp = Container.min_elt ~fold t ~cmp let max_elt t ~cmp = Container.max_elt ~fold t ~cmp let to_list t = Container.to_list ~fold t let to_array t = Container.to_array ~fold t let force t = of_list (to_list t) (* ITERATOR -------------------------------------------------------------- *) module Iterator = struct type 'a seq = 'a t type 'a shared_data = { mutable tail: 'a seq; mutable finallys: (unit -> unit) list; mutable num_iters: int; } (* Shared linked list that allows iterator copies to be at different points in the sequence without loading the sequence more than once. Declare special type rather than using ('a * 'a node) option, as a performance hack to avoid an allocation. *) type 'a node = { mutable next: 'a nextnode } and 'a nextnode = | Next of 'a * 'a node | Nothing type 'a t = { mutable node: 'a node; shared: 'a shared_data; mutable closed: bool; (* Terrible hack to avoid allocation: Whenever [get] steps forward in the linked list, it stores the node it just stepped from here. Whenever peek needs to request a new element from the sequence and add a node to the linked list, if there is only one open iterator, rather than allocate a new node, it uses this stored node. Proof of correctness: Invariant: If an iterator is at the end of the list, stored_node for that iterator is either a node not in the linked list, or it is a node in the linked list strictly behind the current position of the iterator. Proof: If this invariant ever holds, it will continue to hold until possibly 1. A new node is stored. 2. A node that could potentially be phys_equal to stored_node is appended to the list. 3. The iterator advances to the end of the list. (1) only happens in [get], and the stored node is always behind the new position of the iterator. (3) only happens in [get], and in all cases where [get] advances, it does store a node. (2) only happens in [peek], and in that case, after the node is appended, no iterators are at the end of the list. The invariant holds at the creation of any iterator - created or copied iterators always set stored_node to be a newly allocated node. Therefore, it will always hold. [peek] only uses the stored node rather than allocating a new node when there is only one open iterator and peek is at the end of the list. Then, by the invariant, it must be behind the current iterator or not in the list at all. Therefore, absent the stored_node field itself, the node cannot have any references, so it would have been garbage-collectable. Therefore, it is safe to use it in place of allocating a new node. *) mutable stored_node: 'a node; } let close_shared shared = shared.tail <- Nil; let finallys = shared.finallys in shared.finallys <- []; execute_finallys finallys let next_shared shared = let rec next shared tail = match tail with | Nil -> close_shared shared; None | Lazy tail -> let tail = try tail () with exn -> close_shared shared; raise exn in next shared tail | Cons (x, tail) -> shared.tail <- Lazy tail; Some x | Protect (finally, tail) -> shared.finallys <- finally :: shared.finallys; next shared tail in next shared shared.tail let create seq = { node = { next = Nothing; }; shared = { tail = seq; finallys = []; num_iters = 1; }; closed = false; stored_node = { next = Nothing; }; } let close t = if not t.closed then begin t.closed <- true; t.node <- { next = Nothing; }; t.shared.num_iters <- t.shared.num_iters - 1; if t.shared.num_iters = 0 then close_shared t.shared end let copy t = t.shared.num_iters <- t.shared.num_iters + 1; { node = t.node; shared = t.shared; closed = t.closed; stored_node = { next = Nothing; }; } let get t = match t.node.next with | Next (x,next) -> t.stored_node <- t.node; t.node <- next; Some x | Nothing -> if t.closed then None else begin let next = next_shared t.shared in (* Performance hack - if only one iterator, we can not bother updating the linked list for iterators behind us and simply return the next value *) if t.shared.num_iters = 1 then next else match next with | None -> None | Some x -> let new_node = { next = Nothing; } in t.node.next <- Next (x, new_node); t.stored_node <- t.node; t.node <- new_node; Some x end let peek t = match t.node.next with | Next (x,_) -> Some x | Nothing -> if t.closed then None else begin match next_shared t.shared with | None -> None | Some x -> if t.shared.num_iters = 1 then begin t.stored_node.next <- Nothing; t.node.next <- Next (x, t.stored_node); end else begin let new_node = { next = Nothing; } in t.node.next <- Next (x, new_node); end; Some x end let with_sequence seq ~f = Exn.protectx (create seq) ~f ~finally:(fun t -> close_shared t.shared) let get_exn t = Option.value_exn (get t) let has_next t = Option.is_some (peek t) let iter t ~f = let rec loop () = match get t with | None -> () | Some x -> f x; loop () in Exn.protect ~f:loop ~finally:(fun () -> close t) let fold t ~init ~f = let rec loop state = match get t with | None -> state | Some x -> loop (f state x) in Exn.protect ~f:(fun () -> loop init) ~finally:(fun () -> close t) end let concat tt = initialize (fun () -> let tt_iter = Iterator.create tt in match Iterator.get tt_iter with | None -> Iterator.close tt_iter; Nil | Some first_t -> let t_iter = ref (Iterator.create first_t) in let rec loop () = match Iterator.get !t_iter with | None -> begin Iterator.close !t_iter; match Iterator.get tt_iter with | None -> Nil | Some next_t -> t_iter := Iterator.create next_t; loop () end | Some x -> Cons (x,loop) in protect loop ~finally:(fun () -> execute_finallys [ (fun () -> Iterator.close !t_iter); (fun () -> Iterator.close tt_iter); ] ) ) let concat_seq_list tlist = concat (of_list tlist) let append t1 t2 = concat_seq_list [t1; t2] let sub t ~pos ~len = if len < 0 then failwithf "Lazy_sequence.sub: ~len < 0 (value was %d)" len (); if pos < 0 then failwithf "Lazy_sequence.sub: ~pos < 0 (value was %d)" pos (); let rec sub t i = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> sub (tail ()) i) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> sub tail i)) | Cons (x, tail) -> if i >= pos then begin if i >= pos + len then Nil else Cons (x, (fun () -> sub (tail ()) (i+1))) end else Lazy (fun () -> sub (tail ()) (i+1)) in sub t 0 let nth t n = if n < 0 then failwithf "Lazy_sequence.nth: n < 0 (value was %d)" n (); match to_list (sub t ~pos:n ~len:1) with | [] -> None | [x] -> Some x | _ :: _ :: _ -> assert false let hd t = nth t 0 let take t n = sub t ~pos:0 ~len:n let drop t n = if n < 0 then failwithf "Lazy_sequence.drop: n < 0 (value was %d)" n (); let rec drop t n = match t with | Nil -> Nil | Lazy tail -> Lazy (fun () -> drop (tail ()) n) | Protect (finally, tail) -> Protect (finally, Lazy (fun () -> drop tail n)) | Cons (_, tail) -> if n <= 0 then t else Lazy (fun () -> drop (tail ()) (n-1)) in drop t n let tl t = drop t 1 let last t = Iterator.with_sequence t ~f:(fun iter -> let rec loop prev = match Iterator.get iter with | None -> prev | Some _ as cur -> loop cur in loop None ) (* TESTS------------------------------------------------------------------------------ *) let infinite_ints () = init (fun x -> Some x) let lazy_assert () = initialize (fun () -> assert false) let with_ctr n f = let ctr = ref 0 in f ctr; assert (!ctr = n) let iseven x = x % 2 = 0 let is4or6 x = (x = 4) || (x = 6) let div2 x = if x % 2 = 0 then Some (x / 2) else None let running_sum sum x = (sum + x, sum + x) let prev_even prev x = (x, if prev % 2 = 0 then Some x else None) let running_sum_geq8 sum x = (sum + x, if sum + x >= 8 then Some (sum + x) else None) let even_until_8 x = if x >= 8 then `Stop else if x % 2 = 0 then `Continue (Some x) else `Continue None let lst = to_list let seq = of_list TEST = lst (seq []) = [] TEST = lst (seq [2]) = [2] TEST = lst (seq [2;4;6;8]) = [2;4;6;8] TEST = to_array (seq [2;4;6;8]) = [|2;4;6;8|] TEST = lst (map (seq [2;4;6;8]) ~f:(fun x -> x + 1)) = [3;5;7;9] TEST = lst (mapi (seq [2;4;6;8]) ~f:(fun i x -> x + i)) = [2;5;8;11] TEST = lst (filter_map (seq [2;4;6;8]) ~f:(fun _ -> None)) = [] TEST = lst (filter_map (seq [2;4;6;8]) ~f:(fun x -> Some (x + 1))) = [3;5;7;9] TEST = lst (filter_map (seq [3;4;6;9;10]) ~f:div2) = [2;3;5] TEST = lst (filter_mapi (seq [2;4;6;8]) ~f:(fun i x -> Some (x + i))) = [2;5;8;11] TEST = lst (filter (seq [2;4;6;8]) ~f:(fun _ -> false)) = [] TEST = lst (filter (seq [2;4;6;8]) ~f:(fun _ -> true)) = [2;4;6;8] TEST = lst (filter (seq [2;4;6;8]) ~f:is4or6) = [4;6] TEST = lst (filter_fold_map (seq [3;4;6;9;10]) ~init:0 ~f:prev_even) = [3;6;9] TEST = lst (filter_fold_map (seq [3;4;6;9;10]) ~init:0 ~f:running_sum_geq8) = [13;22;32] TEST = lst (filter_fold_map (seq [3;4;6;9;10]) ~init:1 ~f:running_sum_geq8) = [8;14;23;33] TEST = lst (fold_map (seq [3;4;6;9;10]) ~init:0 ~f:running_sum) = [3;7;13;22;32] TEST = lst (fold_map (seq [3;4;6;9;10]) ~init:1 ~f:running_sum) = [4;8;14;23;33] TEST = lst (filter_map_partial (seq [3;4;6;9;10]) ~f:even_until_8) = [4;6] TEST = lst (filter_map_partial (infinite_ints ()) ~f:even_until_8) = [0;2;4;6] TEST = lst (concat_map (seq [3;4;6;9;10]) ~f:(fun x -> [x;x+1])) = [3;4;4;5;6;7;9;10;10;11] TEST = lst (concat_map (seq [[3;4];[];[6;9];[10]]) ~f:Fn.id) = [3;4;6;9;10] TEST = lst (concat_list_seq (seq [[3;4];[];[6;9];[10]])) = [3;4;6;9;10] TEST = lst (concat_seq_list [seq [3;4]; seq []; seq [6;9]; seq [10]]) = [3;4;6;9;10] TEST = lst (concat (seq [seq [3;4]; seq []; seq [6;9]; seq [10]])) = [3;4;6;9;10] TEST = lst (zip_full (seq [1;2;3]) (seq [2;4;6])) = [(Some 1,Some 2);(Some 2,Some 4);(Some 3, Some 6)] TEST = lst (zip_full (seq [1;2;3]) (seq [])) = [(Some 1,None);(Some 2,None);(Some 3,None)] TEST = lst (zip_full (seq [1;2;3]) (seq [4;5])) = [(Some 1,Some 4);(Some 2,Some 5);(Some 3,None)] TEST = hd (seq []) = None TEST = hd (seq [1;2;3]) = Some 1 TEST = hd (seq [6]) = Some 6 TEST = hd (infinite_ints ()) = Some 0 TEST = last (seq []) = None TEST = last (seq [1;2;3]) = Some 3 TEST = last (seq [6]) = Some 6 TEST = nth (seq []) 0 = None TEST = nth (seq []) 1 = None TEST = nth (seq [1;2;3]) 0 = Some 1 TEST = nth (seq [1;2;3]) 1 = Some 2 TEST = nth (seq [1;2;3]) 2 = Some 3 TEST = nth (seq [1;2;3]) 3 = None TEST = nth (infinite_ints ()) 10 = Some 10 TEST = lst (tl (seq [])) = [] TEST = lst (tl (seq [1])) = [] TEST = lst (tl (seq [1;2;3])) = [2;3] TEST = lst (take (seq []) 0) = [] TEST = lst (take (seq []) 2) = [] TEST = lst (take (seq [1;2;3]) 0) = [] TEST = lst (take (seq [1;2;3]) 1) = [1] TEST = lst (take (seq [1;2;3]) 2) = [1;2] TEST = lst (take (seq [1;2;3]) 3) = [1;2;3] TEST = lst (take (seq [1;2;3]) 4) = [1;2;3] TEST = lst (take (infinite_ints ()) 6) = [0;1;2;3;4;5] TEST = lst (drop (seq []) 0) = [] TEST = lst (drop (seq []) 1) = [] TEST = lst (drop (seq [1;2;3]) 0) = [1;2;3] TEST = lst (drop (seq [1;2;3]) 1) = [2;3] TEST = lst (drop (seq [1;2;3]) 2) = [3] TEST = lst (drop (seq [1;2;3]) 3) = [] TEST = lst (drop (seq [1;2;3]) 4) = [] TEST = lst (append (seq []) (seq [])) = [] TEST = lst (append (seq [1]) (seq [])) = [1] TEST = lst (append (seq []) (seq [2])) = [2] TEST = lst (append (seq [1]) (seq [2])) = [1;2] TEST = lst (append (seq [1;2;3]) (seq [])) = [1;2;3] TEST = lst (append (seq [1;2;3]) (seq [4;5;6])) = [1;2;3;4;5;6] TEST = lst (sub (seq []) ~pos:0 ~len:0) = [] TEST = lst (sub (seq []) ~pos:0 ~len:1) = [] TEST = lst (sub (seq []) ~pos:1 ~len:0) = [] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:0 ~len:0) = [] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:0 ~len:1) = [1] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:0 ~len:2) = [1;2] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:1 ~len:2) = [2;3] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:1 ~len:3) = [2;3;4] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:2 ~len:3) = [3;4;5] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:2 ~len:4) = [3;4;5] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:3 ~len:3) = [4;5] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:3 ~len:1) = [4] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:3 ~len:0) = [] TEST = lst (sub (seq [1;2;3;4;5]) ~pos:5 ~len:1) = [] TEST = lst (sub (infinite_ints ()) ~pos:5 ~len:4) = [5;6;7;8] TEST_UNIT = with_ctr 6 (fun ctr -> iter (seq [1;2;3]) ~f:(fun x -> ctr := !ctr + x)) TEST_UNIT = with_ctr 9 (fun ctr -> iteri (seq [1;2;3]) ~f:(fun i x -> ctr := !ctr + x + i)) TEST = fold ~init:1 (seq [1;2;3]) ~f:(+) = 7 TEST = foldi ~init:1 (seq [1;2;3]) ~f:(fun i sum x -> i + sum + x) = 10 TEST = find_map (seq [3;4;6;9;10]) ~f:div2 = Some 2 TEST = find_map (infinite_ints ()) ~f:div2 = Some 0 TEST = find (seq [1;2;5]) ~f:is4or6 = None TEST = find (seq [1;2;6;5]) ~f:is4or6 = Some 6 TEST = find (seq [1;2;5;6;4]) ~f:is4or6 = Some 6 TEST = find (seq [1;2;5;4;6]) ~f:is4or6 = Some 4 TEST = find (infinite_ints ()) ~f:is4or6 = Some 4 TEST = exists (seq []) ~f:(fun _ -> assert false) = false TEST = exists (seq [1;3;5;6;9]) ~f:iseven = true TEST = exists (seq [2;4;6;7;8]) ~f:iseven = true TEST = exists (seq [2;4;6;6;8]) ~f:iseven = true TEST = exists (infinite_ints ()) ~f:iseven = true TEST = for_all (seq []) ~f:(fun _ -> assert false) = true TEST = for_all (seq [1;3;5;6;9]) ~f:iseven = false TEST = for_all (seq [2;4;6;7;8]) ~f:iseven = false TEST = for_all (seq [2;4;6;6;8]) ~f:iseven = true TEST = for_all (infinite_ints ()) ~f:iseven = false TEST = is_empty (seq []) = true TEST = is_empty (seq [1]) = false TEST = is_empty (seq [1;2;3]) = false TEST = is_empty (infinite_ints ()) = false TEST = mem (seq [3;4;5]) 6 = false TEST = mem (seq [3;6;5]) 6 = true TEST = mem (infinite_ints ()) 10 = true TEST = length (seq []) = 0 TEST = length (seq [3;4;6;9;10]) = 5 TEST = count (seq []) ~f:iseven = 0 TEST = count (seq [3;4;6;9;10]) ~f:iseven = 3 TEST = count (seq [3;4;6;9;10]) ~f:(fun x -> not (iseven x)) = 2 TEST = length_bounded_by ~min:(-1) (seq []) = true TEST = length_bounded_by ~min:0 (seq []) = true TEST = length_bounded_by ~min:1 (seq []) = false TEST = length_bounded_by ~max:(-1) (seq []) = false TEST = length_bounded_by ~max:0 (seq []) = true TEST = length_bounded_by ~max:1 (seq []) = true TEST = length_bounded_by ~min:2 ~max:3 (seq [5]) = false TEST = length_bounded_by ~min:2 ~max:3 (seq [5;6]) = true TEST = length_bounded_by ~min:2 ~max:3 (seq [5;6;7]) = true TEST = length_bounded_by ~min:2 ~max:3 (seq [5;6;7;8]) = false TEST = length_bounded_by ~min:2 ~max:10 (infinite_ints ()) = false TEST = length_if_at_most ~max:(-1) (seq []) = None TEST = length_if_at_most ~max:0 (seq []) = Some 0 TEST = length_if_at_most ~max:1 (seq []) = Some 0 TEST = length_if_at_most ~max:0 (seq [4]) = None TEST = length_if_at_most ~max:1 (seq [4]) = Some 1 TEST = length_if_at_most ~max:3 (seq [4;5]) = Some 2 TEST = length_if_at_most ~max:3 (seq [4;5;6]) = Some 3 TEST = length_if_at_most ~max:3 (seq [4;5;6;7]) = None TEST = length_if_at_most ~max:10 (infinite_ints ()) = None (* Test laziness *) TEST_UNIT = (* Run a bunch of functions that should be lazy and do nothing Note that for sequences that actually begin with some element right away, (Cons(x,tail)), these functions will actually operate on the first element. *) let run_lazy s = ignore (map s ~f:(fun _ -> assert false) : int t); ignore (filter_map s ~f:(fun _ -> assert false) : int t); ignore (filter s ~f:(fun _ -> assert false) : int t); ignore (filter_fold_map s ~init:0 ~f:(fun _ _ -> assert false) : int t); ignore (fold_map s ~init:0 ~f:(fun _ _ -> assert false) : int t); ignore (filter_map_partial s ~f:(fun _ -> assert false) : int t); ignore (zip_full s s : (int option * int option) t); ignore (concat_map s ~f:(fun _ -> assert false) : int t); ignore (concat_seq_list [s;s] : int t); ignore (concat_list_seq (map s ~f:(fun _ -> assert false)) : int t); ignore (tl s : int t); ignore (take s 3 : int t); ignore (drop s 3 : int t); ignore (append s s : int t); ignore (sub s ~pos:3 ~len:3 : int t); () in (* All of these should be behind an initialize, so should be perfectly lazy *) run_lazy (of_list [1;2;3]); run_lazy (infinite_ints ()); run_lazy (lazy_assert ()); () let mutable_ints_protected start stop incr_on_open incr_on_close = initialize (fun () -> incr incr_on_open; let x = ref start in protect ~finally:(fun () -> incr incr_on_close) (fun () -> let rec loop () = if !x > stop then Nil else !x ==> fun () -> incr x; loop () in loop () )) (* Test that mutable state for generating sequences works and doesn't interfere with itself, and that protect's finally gets called *) TEST_UNIT = let opens = ref 0 in let closes = ref 0 in let s = mutable_ints_protected 1 4 opens closes in assert ((!opens,!closes) = (0,0)); ignore (map s ~f:(fun _x -> assert false) : int t); assert ((!opens,!closes) = (0,0)); (* Lazy map should do nothing *) assert (lst (map s ~f:(fun x -> x + 1)) = [2;3;4;5]); assert ((!opens,!closes) = (1,1)); (* Map and forcing to list should open and close *) assert (fold s ~init:100 ~f:(+) = 110); assert ((!opens,!closes) = (2,2)); (* Fold should open and close *) assert (lst (zip_full s s) = [(Some 1,Some 1);(Some 2,Some 2);(Some 3,Some 3);(Some 4,Some 4)]); assert ((!opens,!closes) = (4,4)); (* Zip with self should open and close twice *) (* Creating an iterator should do nothing *) let iter = Iterator.create s in let iter2 = Iterator.create s in assert ((!opens,!closes) = (4,4)); (* But forcing the first element should open the sequence *) assert (Iterator.get iter = Some 1); assert ((!opens,!closes) = (5,4)); assert (Iterator.peek iter = Some 2); assert ((!opens,!closes) = (5,4)); (* Should not interfere with the other iterator *) assert (Iterator.get iter2 = Some 1); assert ((!opens,!closes) = (6,4)); assert (Iterator.peek iter2 = Some 2); assert ((!opens,!closes) = (6,4)); assert (Iterator.get iter = Some 2); assert (Iterator.get iter2 = Some 2); (* And now close them *) assert (Iterator.get iter = Some 3); assert ((!opens,!closes) = (6,4)); Iterator.close iter; assert ((!opens,!closes) = (6,5)); assert (Iterator.get iter2 = Some 3); assert ((!opens,!closes) = (6,5)); Iterator.close iter2; assert ((!opens,!closes) = (6,6)); (* Closing twice should do nothing *) Iterator.close iter; Iterator.close iter2; assert ((!opens,!closes) = (6,6)); (* And we should not be able to get anything now *) assert (Iterator.get iter = None); assert (Iterator.get iter2 = None); assert (Iterator.peek iter = None); assert (Iterator.peek iter2 = None); assert ((!opens,!closes) = (6,6)); (* Raising an exception in the middle of a map should also trigger the close *) begin try ignore (lst (map s ~f:(fun _ -> failwith "fail"))); assert false with Failure "fail" -> () end; assert ((!opens,!closes) = (7,7)); (* Same with a fold *) begin try ignore (fold s ~init:0 ~f:(fun _ _ -> failwith "fail")); assert false with Failure "fail" -> () end; assert ((!opens,!closes) = (8,8)); (* Open a new iterator and make sure that falling off the end closes things *) let iter3 = Iterator.create s in assert (Iterator.get iter3 = Some 1); assert ((!opens,!closes) = (9,8)); assert (Iterator.get iter3 = Some 2); assert ((!opens,!closes) = (9,8)); assert (Iterator.get iter3 = Some 3); assert ((!opens,!closes) = (9,8)); assert (Iterator.get iter3 = Some 4); assert ((!opens,!closes) = (9,8)); assert (Iterator.get iter3 = None); assert ((!opens,!closes) = (9,9)); Iterator.close iter3; assert ((!opens,!closes) = (9,9)); (* Do a simple test that Iterator.copy works *) let iter4 = Iterator.create s in let iter5 = Iterator.copy iter4 in assert ((!opens,!closes) = (9,9)); assert (Iterator.get iter4 = Some 1); assert ((!opens,!closes) = (10,9)); assert (Iterator.get iter4 = Some 2); assert (Iterator.get iter5 = Some 1); assert ((!opens,!closes) = (10,9)); let iter6 = Iterator.copy iter4 in assert (Iterator.get iter6 = Some 3); assert (Iterator.get iter4 = Some 3); Iterator.close iter4; assert ((!opens,!closes) = (10,9)); assert (Iterator.get iter4 = None); assert ((!opens,!closes) = (10,9)); assert (Iterator.get iter6 = Some 4); assert (Iterator.get iter6 = None); assert ((!opens,!closes) = (10,10)); assert (Iterator.get iter5 = Some 2); assert (Iterator.get iter5 = Some 3); assert (Iterator.get iter5 = Some 4); assert ((!opens,!closes) = (10,10)); assert (Iterator.get iter5 = None); assert ((!opens,!closes) = (10,10)); (* Some more functions to test *) assert (length_if_at_most ~max:2 s = None); assert ((!opens,!closes) = (11,11)); (* Length if at most should open and close *) () core_extended-113.00.00/src/lazy_sequence.mli000066400000000000000000000175011256461102500207730ustar00rootroot00000000000000open Core.Std (* A lazy list, but without memoization. The lack of memoization prevents any problems with space leaks. It's memory-safe to hold on to even a very long lazy sequence and perform operations or iterate through it multiple times. However, the lack of memoization also means that when iterating through a sequence multiple times, the data will be reloaded/regenerated every time. For example, iterating twice through a sequence produced by reading a file will open, read, and close the file twice. Generally speaking, functions below that return something of type [t] are lazy, whereas functions that return an actual value will force the sequence. *) type +'a t (* This includes functions like [iter], [fold], [length], [to_list]... *) include Container.S1 with type 'a t := 'a t val iteri: 'a t -> f:(int -> 'a -> unit) -> unit val foldi: 'a t -> init:'state -> f:(int -> 'state -> 'a -> 'state) -> 'state val map: 'a t -> f:('a -> 'b) -> 'b t val mapi: 'a t -> f:(int -> 'a -> 'b) -> 'b t val filter: 'a t -> f:('a -> bool) -> 'a t val filter_map: 'a t -> f:('a -> 'b option) -> 'b t val filter_mapi: 'a t -> f:(int -> 'a -> 'b option) -> 'b t val fold_map: 'a t -> init:'state -> f:('state -> 'a -> ('state * 'b)) -> 'b t val filter_fold_map: 'a t -> init:'state -> f:('state -> 'a -> ('state * 'b option)) -> 'b t val concat: 'a t t -> 'a t val concat_seq_list: 'a t list -> 'a t val concat_list_seq: 'a list t -> 'a t val concat_map: 'a t -> f:('a -> 'b list) -> 'b t (* Will only force as much of the sequence as necessary, but may still be expensive to call repeatedly, particularly if forcing it requires some initialization time. *) val hd: 'a t -> 'a option val last: 'a t -> 'a option val nth: 'a t -> int -> 'a option (* n=0 means first element *) (* If elements are dropped from the front of the sequence, it's still the case that every time the sequence is forced, the cost of computing those elements will be present. *) val tl: 'a t -> 'a t (* tl of the empty sequence is the empty sequence *) val take: 'a t -> int -> 'a t val drop: 'a t -> int -> 'a t val append: 'a t -> 'a t -> 'a t val sub: 'a t -> pos:int -> len:int -> 'a t (* Will not filter through the rest of the sequence after stopping, so can be slightly more efficient than filter_map and can be used on infinite sequences *) val filter_map_partial: 'a t -> f:('a -> [ `Continue of 'b option | `Stop ]) -> 'b t (* Pairs up all the a's and b's. If one list ends before the other, then will return None for the elements of the list that ended *) val zip_full: 'a t -> 'b t -> ('a option * 'b option) t (* [length_if_at_most ~max t] returns Some len if [len = length t <= max], and otherwise returns None. Non-lazy, but walks through only as much of the sequence as necessary. *) val length_if_at_most: max:int -> _ t -> int option (* [length_bounded_by ~min ~max t] returns true if [min <= length t] and [length t <= max] When [min] or [max] are not provided, the check for that bound is omitted. Non-lazy, but walks through only as much of the sequence as necessary. *) val length_bounded_by: ?min:int -> ?max:int -> _ t -> bool val of_list: 'a list -> 'a t val of_array: 'a array -> 'a t (* [init f] Creates a sequence by lazily evaluating [f] on the infinite sequence [0; 1; 2; 3; ...], stopping if/when [f] returns None. *) val init: (int -> 'a option) -> 'a t (* [read_lines filename] Returns a lazy sequence of all the lines in the given file *) val read_lines: string -> string t (* NOT LAZY! Will immediately force the entire sequence into memory and return the forced version of the sequence. Equivalent to [of_list (to_list t)] *) val force: 'a t -> 'a t (* For walking through a lazy sequence, element by element *) module Iterator : sig type 'a seq = 'a t type 'a t val create: 'a seq -> 'a t val close: _ t -> unit val with_sequence: 'a seq -> f:('a t -> 'b) -> 'b val has_next: _ t -> bool (* false once the end of the sequence is reached *) (* These may raise an exception in the case that the producer of the sequence raises. If this is the case, then the iterator will automatically be closed and the exception reraised here. *) val peek: 'a t -> 'a option (* returns None when the end of the sequence is reached *) val get: 'a t -> 'a option (* returns None when the end of the sequence is reached *) val get_exn: 'a t -> 'a (* Walk through the iterator, consuming elements. Upon exception, the iterator will automatically be closed. It's also okay to call other functions on the iterator in the middle of the iter or fold. For example, calling [ignore (get t)] in the middle of an iter or fold will cause it to skip the next element. Calling [close] will cause the iter or fold to terminate after f returns. *) val iter: 'a t -> f:('a -> unit) -> unit val fold: 'a t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (* Copied iterators share the same underlying instance of the sequence. So all copies of an iterator can be advanced independently while still only loading the sequence once (such as from a file). Note that the portion of the sequence between the leftmost non-closed iterator and the rightmost point in the sequence reached by any iterator (even if later closed) will be kept in memory, which could be a concern for very long sequences. [close] will close only the existing iterator but not affect copies. [with_sequence] will close the shared underlying instance of the sequence upon return for *all* copies of the iterator that it creates. However, the parts of the sequence loaded into in memory might still be accessible from the iterators or their copies even after it returns. *) val copy: 'a t -> 'a t end (* Producing a lazy sequence manually ------------------------------------------------ *) (* Support is provided for using mutable state to generate the sequence (such as reading files, etc.). This is safe because once a user begins traversing the sequence, it is not possible in this interface to copy the state of the sequence to be retraversed from that point multiple times. Producers using mutable state should make sure that all initialization of the mutable state is wrapped with [initialize], so that if the full sequence is traversed several times, the proper initialization happens each time. Additionally, [protect] should be used for any resources that should be closed at the end of a sequence or on exception. Example use involving mutable state, [initialize], and [protect]: let read_lazy file = Lazy_sequence.initialize (fun () -> let ic = In_channel.create file in Lazy_sequence.protect ~finally:(fun () -> In_channel.close ic) (fun () -> let (==>) = Lazy_sequence.(==>) in let rec loop () = match In_channel.input_line ic with | None -> Lazy_sequence.empty | Some line -> line ==> fun () -> loop () in loop () )) *) val empty: _ t (* Empty lazy sequence *) val (==>): 'a -> (unit -> 'a t) -> 'a t (* Cons *) val (==>>): 'a list -> (unit -> 'a t) -> 'a t (* Multi-cons, lazy even if list is empty *) (* [initialize f] produces a lazy sequence where f is called when the first element of the sequence is requested. This should be used for initialization of mutable state (such as opening files to be read from) *) val initialize: (unit -> 'a t) -> 'a t (* [protect ~finally f] produces a lazy sequence where f is called when the first element of the sequence is requested, and where [finally] is called at the end of the sequence or when an iterator is closed that has forced at least one element of the sequence. If additional elements are cons-ed on the head of returned sequence, only the original subsequence will be protected by the [finally]. *) val protect: finally:(unit -> unit) -> (unit -> 'a t) -> 'a t core_extended-113.00.00/src/left_boundary.ml000066400000000000000000000005241256461102500206050ustar00rootroot00000000000000type 'k t = | Inc of 'k | Exc of 'k with sexp let key_of = function | Inc k -> k | Exc k -> k let compare compare_k t1 t2 = match compare_k (key_of t1) (key_of t2) with | 0 -> begin match t1, t2 with | Inc _, Inc _ | Exc _, Exc _ -> 0 | Inc _, Exc _ -> -1 | Exc _, Inc _ -> 1 end | n -> n core_extended-113.00.00/src/left_boundary.mli000066400000000000000000000002751256461102500207610ustar00rootroot00000000000000(* This is the leftmost value of an interval. Inc / Exc determine if that value is actually included in the interval or not *) type 'k t = | Inc of 'k | Exc of 'k with sexp, compare core_extended-113.00.00/src/libcore_extended_stubs.clib000066400000000000000000000003551256461102500227720ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: c5db530f05317d396eca7ab1db5c9d98) extended_int_stubs.o extended_linux_stubs.o extended_unix_stubs.o fork_exec.o linebuf_stubs.o low_level_debug_stubs.o malloc_stubs.o posix_clock_stubs.o # OASIS_STOP core_extended-113.00.00/src/linebuf.ml000066400000000000000000000205371256461102500174020ustar00rootroot00000000000000(** A module for reading files. *) open Core.Std (* Integer we use for file positions in this module. Makes it easier to switch between regular native integers and 64 bit integers. *) module Pos_int = Int64 let max_null_retries = 20 type lnum = Known of int | Unknown with sexp_of;; (** The type of a linebuf. *) type t = { mutable file: In_channel.t; (** The channel we maintain. *) mutable pos: Pos_int.t; (** Current file position. *) mutable lnum: lnum; (** Current line position, if known *) mutable closed: bool; (** Closed or open. *) mutable inode: int; (** The inode number of the current file *) name: string; (** File name. *) buf: Buffer.t; follow_deletes: bool; (** close and reopen the file if it is deleted and recreated. *) signal_on_truncate_or_delete: bool;(** raise exception File_truncated_or_deleted if the inode changed or the size of the file is less than pos*) close_on_eof: bool; (** whether to close the file on EOF. Useful for NFS filesystems that don't promptly notify you when files change unless you close and reopen *) null_hack: [ `Off | `Retry_then_fail | `Retry ]; (** Which null_hack_mode to use *) mutable null_retries: int; (** number of times we've tried to reread this file in response to a given null reading. *) eprint_nulls : bool; (** whether to print a warning message whenever we hit nulls *) } type error_type = Null_retry | Too_many_nulls | Exception of string * Exn.t with sexp_of;; type result = | Success of lnum * string | Nothing_available | Error of error_type | Fatal_error of string * Exn.t with sexp_of ;; (** Open a linebuffer from the passed filename. *) let create ?(pos = Pos_int.zero) ?(close_on_eof=false) ?(null_hack = `Off) ?(eprint_nulls = false) ?(follow_deletes=false) ?(signal_on_truncate_or_delete=false) fname = let file = In_channel.create ~binary:true fname in let { Unix.st_ino = inode; _ } = Unix.fstat (Unix.descr_of_in_channel file) in let lnum, pos = if Pos_int.(=) pos Pos_int.zero then Known 1, Pos_int.zero else if Pos_int.(>) pos Pos_int.zero then begin LargeFile.seek_in file pos; Unknown, pos end else invalid_argf "Linebuf.create: pos must be greater than or equal to 0, was %s" (Pos_int.to_string pos) () in { file = file; pos = pos; lnum = lnum; name = fname; closed = false; buf = Buffer.create 0; close_on_eof = close_on_eof; follow_deletes = follow_deletes; signal_on_truncate_or_delete = signal_on_truncate_or_delete; inode = inode; null_hack = null_hack; null_retries = 0; eprint_nulls = eprint_nulls; } (** Close the linebuf. *) let close lbuf = if not lbuf.closed then (try In_channel.close lbuf.file with | Unix.Unix_error (EBADF,_, _) -> ()); lbuf.closed <- true let is_closed t = t.closed exception File_truncated_or_deleted with sexp;; let possibly_reopen lbuf = if lbuf.signal_on_truncate_or_delete && (Unix.stat lbuf.name).Unix.st_size < lbuf.pos then raise File_truncated_or_deleted; if lbuf.closed then begin lbuf.file <- open_in_bin lbuf.name; lbuf.closed <- false; LargeFile.seek_in lbuf.file lbuf.pos; end ;; let reopen_if_deleted lbuf = try let {Unix.st_ino=inode; _ } = Unix.stat lbuf.name in if lbuf.inode <> inode then begin try close lbuf; lbuf.file <- open_in_bin lbuf.name; lbuf.inode <- inode; lbuf.closed <- false; lbuf.pos <- Pos_int.zero; lbuf.lnum <- Known 1; `Success_reopening with exn -> `Error ("reopen_if_deleted: closing and reopening the file failed", exn) end else `Same_file with Unix.Unix_error (ENOENT, _, _) -> `No_such_file | exn -> `Error ("reopen_if_deleted: stat failed", exn) exception Null_found with sexp;; exception Too_many_null_retries with sexp;; let try_read_lnum_verbose lbuf = try possibly_reopen lbuf; let line = input_line lbuf.file in begin match lbuf.null_hack with | `Off -> () | `Retry | `Retry_then_fail as nhm -> if String.contains line '\000' then begin if lbuf.null_retries >= max_null_retries then begin match nhm with | `Retry_then_fail -> raise Too_many_null_retries | `Retry | `Off -> () end else begin close lbuf; lbuf.null_retries <- lbuf.null_retries + 1; raise Null_found end end else lbuf.null_retries <- 0; end; lbuf.pos <- LargeFile.pos_in lbuf.file; let last_char = try LargeFile.seek_in lbuf.file (Pos_int.(-) lbuf.pos Pos_int.one); input_char lbuf.file with End_of_file -> failwith "Linebuf.try_read_lnum: unexpected EOF, file may have been truncated" in LargeFile.seek_in lbuf.file lbuf.pos; if last_char = '\n' then (* we're at the end of the line *) let lnum = lbuf.lnum in (match lbuf.lnum with | Unknown -> () | Known i -> lbuf.lnum <- Known (i + 1)); let line = if String.length line > 0 && String.nget line (-1) = '\r' then String.slice line 0 (-1) else line in if Buffer.length lbuf.buf > 0 then let oldline = Buffer.contents lbuf.buf in Buffer.clear lbuf.buf; Success (lnum,oldline ^ line) else Success (lnum,line) else begin Buffer.add_string lbuf.buf line; Nothing_available end with | Null_found -> if lbuf.eprint_nulls then eprintf "<<<>>>\n%!" lbuf.name; Error Null_retry | Too_many_null_retries -> Error Too_many_nulls | End_of_file -> begin try if lbuf.close_on_eof then close lbuf; if lbuf.follow_deletes || lbuf.signal_on_truncate_or_delete then match reopen_if_deleted lbuf with | `No_such_file | `Same_file -> Nothing_available | `Success_reopening -> if lbuf.signal_on_truncate_or_delete then raise File_truncated_or_deleted; Nothing_available | `Error (s, e) -> Error (Exception (s, e)) else Nothing_available with | File_truncated_or_deleted -> raise File_truncated_or_deleted | exn -> Fatal_error ("error while handling end of file", exn) end | File_truncated_or_deleted -> raise File_truncated_or_deleted | exn -> Fatal_error ("main loop", exn) let try_read_lnum lbuf = match try_read_lnum_verbose lbuf with | Nothing_available -> None | Error Null_retry -> None | Success (lnum, line) -> Some (lnum, line) | Error Too_many_nulls -> failwith "Too many null retries" | Error (Exception (e, exn)) -> Exn.reraisef exn "error in linebuf: %s" e () | Fatal_error (e, exn) -> Exn.reraisef exn "fatal error in linebuf: %s" e () let try_read lbuf = Option.map (try_read_lnum lbuf) ~f:snd let read_frequency = sec 0.01 let rec read lbuf = match try_read lbuf with | Some line -> line | None -> Time.pause read_frequency; read lbuf let tail lbuf = let file_size = LargeFile.in_channel_length lbuf.file in if file_size = Pos_int.zero then () else begin lbuf.pos <- Pos_int.(-) file_size Pos_int.one; LargeFile.seek_in lbuf.file lbuf.pos; lbuf.lnum <- Unknown; ignore (read lbuf) end let unsafe_tail lbuf = lbuf.pos <- LargeFile.in_channel_length lbuf.file; LargeFile.seek_in lbuf.file lbuf.pos; lbuf.lnum <- Unknown; ignore (try_read lbuf) let name t = t.name ;; let reset t = close t; t.file <- open_in_bin t.name; t.inode <- (Unix.fstat (Unix.descr_of_in_channel t.file)).Unix.st_ino; t.closed <- false; t.pos <- Pos_int.zero; t.lnum <- Known 1; LargeFile.seek_in t.file t.pos ;; core_extended-113.00.00/src/linebuf.mli000066400000000000000000000062451256461102500175530ustar00rootroot00000000000000(** Line-by-line reading of a file. A line buffer allows one to read one line of a file at a time, blocking until a line is available. Line buffers are distinct from Pervasives.read_line in that they "notice" new data arriving in the file more quickly. *) (** The type of a line buffer. *) type t type error_type = Null_retry | Too_many_nulls | Exception of string * exn type lnum = Known of int | Unknown type result = | Success of lnum * string | Nothing_available | Error of error_type | Fatal_error of string * exn exception File_truncated_or_deleted (** Open a line buffer from the passed filename. If [close_on_eof] is set, when [eof] is read, the file will be closed and reopened if necessary. if [follow_deletes] is set, then when [eof] is read linebuf will stat the file, and if it has been deleted and recreated it will open the new file. If [eprint_nulls] is set, then when nulls are found, a warning message will be printed to stderr. [null_hack] specifies the behaviour of the linebuf upon reception of null characters in the file (as seen when tailing files over CIFS). Null hack options: `Off: don't check for nulls, just keep going. `Retry: close and reopen file when nulls are read from the file. If max_null_retries is reached, then pass the line with nulls. `Retry_then_fail: the same as retry, except that an exception is raised once max_null_retries is reached. *) val create : ?pos:Int64.t -> ?close_on_eof:bool -> ?null_hack:[ `Off | `Retry_then_fail | `Retry ] -> ?eprint_nulls:bool -> ?follow_deletes:bool -> ?signal_on_truncate_or_delete:bool -> string -> t (** Closes the line buffer (and the underlying file). *) val close : t -> unit (** Returns whether or not the line buffer is closed *) val is_closed : t -> bool (** Tries to read a line from the file. If no more lines are available, returns [None]. *) val try_read : t -> string option (** [try_read_lnum] is like [try_read] except also provides the line number of the read line. *) val try_read_lnum : t -> (lnum * string) option (** Like try_read, except that it returns more verbose errors *) val try_read_lnum_verbose : t -> result (** Calls try_read every 0.01 seconds and returns when a line is available. *) val read : t -> string (** Seeks to the end of the file and blocks until another line is available -- this new line is not returned. Successive return values of [try_read_lnum] and [try_read_lnum] will return [Unknown] as the current line number until [reset] is called *) val tail : t -> unit (** Same as [tail] except it may return before a new line is available on the file i.e. it (usually) doesn't block. Note that this does interact with files in a fairly naive way, so there's no guarantee that it absolutely doesn't block. Note that when this functions is called, the next line that's read may be a partial line. After that first line, only full lines will be read. *) val unsafe_tail : t -> unit val name : t -> string (** reopens the file and seeks to the beginning. Also recovers the ability to get line numbers if [tail] has been called *) val reset : t -> unit core_extended-113.00.00/src/linebuf_stubs.c000066400000000000000000000040211256461102500204220ustar00rootroot00000000000000/* Core_unix support functions written in C. */ #include #include #include #include #include #include #include #include #include #include "ocaml_utils.h" /* Replacement for broken stat functions */ static int file_kind_table[] = { S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK }; #define Val_file_offset(fofs) caml_copy_int64(fofs) static value linebuf_cst_to_constr(int n, int *tbl, int size, int deflt) { int i; for (i = 0; i < size; i++) if (n == tbl[i]) return Val_int(i); return Val_int(deflt); } static value linebuf_stat_aux(struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, v, offset); atime = caml_copy_double((double) buf->st_atime); mtime = caml_copy_double((double) buf->st_mtime); ctime = caml_copy_double((double) buf->st_ctime); offset = Val_file_offset(buf->st_size); v = caml_alloc_small(12, 0); Field (v, 0) = Val_int (buf->st_dev); Field (v, 1) = Val_int (buf->st_ino); Field (v, 2) = linebuf_cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, sizeof(file_kind_table) / sizeof(int), 0); Field (v, 3) = Val_int (buf->st_mode & 07777); Field (v, 4) = Val_int (buf->st_nlink); Field (v, 5) = Val_int (buf->st_uid); Field (v, 6) = Val_int (buf->st_gid); Field (v, 7) = Val_int (buf->st_rdev); Field (v, 8) = offset; Field (v, 9) = atime; Field (v, 10) = mtime; Field (v, 11) = ctime; CAMLreturn(v); } static inline char * linebuf_copy_to_c_string(value v_str) { asize_t len = caml_string_length(v_str) + 1; char *p = caml_stat_alloc(len); memcpy(p, String_val(v_str), len); return p; } CAMLprim value linebuf_stat(value path) { CAMLparam1(path); int ret; struct stat buf; char *p = linebuf_copy_to_c_string(path); caml_enter_blocking_section(); ret = stat(p, &buf); caml_stat_free(p); caml_leave_blocking_section(); if (ret == -1) uerror("stat", path); CAMLreturn(linebuf_stat_aux(&buf)); } core_extended-113.00.00/src/list_zipper.ml000066400000000000000000000016171256461102500203200ustar00rootroot00000000000000open Core.Std type 'a t = { l : 'a list; r : 'a list } let create l r = { l = List.rev l; r = r } let drop_before = function | {l = []; r= _} -> None | {l = h::t ; r = r } -> Some (h,{l=t;r=r}) let drop_after = function | { l = _; r = [] } -> None | { l = l ; r = h::t } -> Some (h,{ l=l; r=t }) let drop_all_before = function | {l = []; r= _} -> None | {l = l; r = r } -> Some (l,{l=[];r=r}) let drop_all_after = function | { l = _; r = [] } -> None | { l = l; r = r } -> Some (r,{ l=l; r=[] }) let insert_before z v = {z with l = v::z.l} let insert_after z v = {z with r = v::z.r} let previous zip = match drop_before zip with | None -> None | Some (e,line) -> Some (insert_after line e) let next zip = match drop_after zip with | None -> None | Some (e,line) -> Some (insert_before line e) let replace_left z l = {z with l} let replace_right z r = {z with r} core_extended-113.00.00/src/list_zipper.mli000066400000000000000000000010341256461102500204620ustar00rootroot00000000000000type 'a t = { l : 'a list; r : 'a list; } val create : 'a list -> 'a list -> 'a t val drop_before : 'a t -> ('a * 'a t) option val drop_after : 'a t -> ('a * 'a t) option (* returns l unreversed *) val drop_all_before : 'a t -> ('a list * 'a t) option val drop_all_after : 'a t -> ('a list * 'a t) option val insert_before : 'a t -> 'a -> 'a t val insert_after : 'a t -> 'a -> 'a t val previous : 'a t -> 'a t option val next : 'a t -> 'a t option val replace_left : 'a t -> 'a list -> 'a t val replace_right : 'a t -> 'a list -> 'a t core_extended-113.00.00/src/logger.ml000066400000000000000000000120041256461102500172230ustar00rootroot00000000000000open Core.Std type message = [ `Fatal | `Error | `Warn | `Info | `Debug ] * string type size = [ `Kb of int64 | `Mb of int64 | `Unlimited ] type 'a t = { dirname:string; basename:string; max_size:size; mode:Unix.file_perm; max_archives:[`Unlimited | `Max of int]; full_callback:(string Squeue.t -> unit) option; message_to_string:('a -> string); mutable filter:('a -> bool) option; mutable oc:out_channel option; q:string Squeue.t; } type default_t = message t let queuelength = 1000000 let wasfull = queuelength - 1 let filename log = Filename.concat log.dirname log.basename ;; let filter t filterfun = t.filter <- Some filterfun ;; let clear_filter t = t.filter <- None ;; let close log = match log.oc with | None -> () | Some oc -> begin (* really try to close the log, but at least force the bad file pointer out of scope so we don't use it again *) close_out_noerr oc; log.oc <- None end ;; let too_large log = try let size = (Unix.stat (filename log)).Unix.st_size in match log.max_size with | `Kb kb when (Int64.(/) size 1024L) >= kb -> true | `Mb mb when Int64.(/) (Int64.(/) size 1024L) 1024L >= mb -> true | _ -> false with | _ -> (* any error stating a file means that we should give up on ever using it *) true ;; let roll log = let log_number log c = (filename log) ^ "." ^ (string_of_int c) in let filelist = (Array.to_list (Sys.readdir log.dirname)) in let files = List.filter_map filelist ~f:(fun f -> let basename = log.basename in if String.is_prefix f ~prefix:basename then Some (f, int_of_string (snd (String.rsplit2_exn f ~on:'.'))) else None) in let files = List.sort ~cmp:(fun x y -> Polymorphic_compare.ascending (snd x) (snd y)) files in let max_archives = match log.max_archives with | `Max m -> m | `Unlimited -> Int.max_value in let rec roll files = match files with | [] -> () | (_f, c)::rest -> begin roll rest; if c >= max_archives - 1 then Unix.unlink (log_number log c) else Unix.rename ~src:(log_number log c) ~dst:(log_number log (c + 1)) end in close log; roll files; Unix.rename ~src:(filename log) ~dst:(log_number log 0); ;; let reopen_log log = let filename = filename log in (* close the log if it happens to be open *) close log; (* roll the file if necessary *) if too_large log then roll log; (* return a file pointer to the end of the file *) let oc = open_out_gen [Open_append; Open_creat; Open_wronly] log.mode filename in log.oc <- Some oc; oc ;; let timestamp () = Time.to_string (Time.now ()) ;; let level_to_string level = match level with | `Fatal -> "FATAL" | `Error -> "ERROR" | `Warn -> "warn " | `Info -> "info " | `Debug -> "debug" ;; let log t msg = let really_log () = let success = Squeue.push_or_drop t.q (t.message_to_string msg) in if not success then match t.full_callback with | Some callback -> callback t.q | None -> () in match t.filter with | None -> really_log () | Some f -> if f msg then really_log () ;; let maybe_log topt msg = match topt with | None -> () | Some t -> log t msg ;; let create ?(max_size=`Mb 50L) ?(mode=0o644) ?(max_archives=`Max 4) ?full_callback ?filter ~message_to_string filename = let log = { dirname = Filename.dirname filename; basename = Filename.basename filename; max_size = max_size; mode = mode; max_archives = max_archives; full_callback = full_callback; message_to_string = message_to_string; filter = filter; q = Squeue.create queuelength; oc = None } in let output msg = let oc = begin match log.oc with | None -> reopen_log log | Some oc -> if too_large log then reopen_log log else oc end in output_string oc msg; Pervasives.flush oc; in ignore (Thread.create (fun () -> while true do try let (msg, length) = Squeue.lpop log.q in if length = wasfull then output "Logging queue was full - some logs potentially lost\n"; output msg with | _ -> begin Time.pause (sec 0.1); close log end done) ()); (* register a function to flush the log when the program exits *) at_exit (fun () -> while Squeue.length log.q > 0 do Thread.yield () done); log ;; let default_message_to_string ((level, msg):message) = let finalmsg = Printf.sprintf "%s [%s]: %s\n" (timestamp ()) (level_to_string level) msg in finalmsg ;; let default_filter (msgtype, _msg) = match msgtype with | `Debug -> false | _ -> true ;; let create_default ?max_size ?mode ?max_archives ?full_callback filename = create ?max_size ?mode ?max_archives ~message_to_string:(default_message_to_string) ?full_callback ~filter:(default_filter) filename; ;; core_extended-113.00.00/src/logger.mli000066400000000000000000000034411256461102500174010ustar00rootroot00000000000000(** Another logging library.*) open Core.Std;; type message = [ `Fatal | `Error | `Warn | `Info | `Debug ] * string type size = [ `Kb of int64 | `Mb of int64 | `Unlimited ] type 'messagetype t type default_t = message t (** - max_size - the maximum size of each log file (default 50Mb) - mode - mode to open the files in - max_archives - maximum number of archives to keep (default 4) - full_callback - called when the logger queue backs up so far that log items may have been lost. Defaults to doing nothing. - filter - if set, then every message is passed to filter before actually being logged. If filter returns false the message is dropped. - message_to_string - called to convert your message type to a string for logging *) val create : ?max_size:size -> ?mode:Unix.file_perm -> ?max_archives:[`Max of int | `Unlimited] -> ?full_callback:(string Squeue.t -> unit) -> ?filter:('messagetype -> bool) -> message_to_string:('messagetype -> string) -> string -> 'messagetype t (** creates a log using the default message type and a filter that drops `Debug messages *) val create_default : ?max_size:size -> ?mode:Unix.file_perm -> ?max_archives:[`Max of int | `Unlimited] -> ?full_callback:(string Squeue.t -> unit) -> string -> message t (** logs a message to log *) val log : 'messagetype t -> 'messagetype -> unit (** Sets the filter for a log *) val filter : 'messagetype t -> ('messagetype -> bool) -> unit (** removes the filter from a log *) val clear_filter : 'messagetype t -> unit (** misc helper functions *) (** logs a message to Some log, returns silently if log is None *) val maybe_log : 'messagetype t option -> 'messagetype -> unit (** Returns a timestamp as a string suitable for log files *) val timestamp : unit -> string core_extended-113.00.00/src/low_level_debug.ml000066400000000000000000000070711256461102500211120ustar00rootroot00000000000000open Core.Std (* Useful debugging functions working at a low level. *) external stop_upon_sigbus : unit -> unit = "low_level_debug_stop_upon_sigbus" external stop_upon_sigsegv : unit -> unit = "low_level_debug_stop_upon_sigsegv" external stop_upon_sigpipe : unit -> unit = "low_level_debug_stop_upon_sigpipe" external stop_upon_exit : unit -> unit = "low_level_debug_stop_upon_exit" external stop_me_now : unit -> unit = "low_level_debug_stop_me_now" let segfault_me_now () = let string_that_should_be_easy_to_detect = "The major difference between a thing that might go wrong and a thing that \ cannot possibly go wrong is that when a thing that cannot possibly go wrong \ goes wrong it usually turns out to be impossible to get at or repair." in Obj.set_field (Obj.repr 0) 0 (Obj.repr string_that_should_be_easy_to_detect) external start_canary_thread_internal : max_wait:float -> check_interval:int -> never_returns = "start_canary" let start_canary_thread = let started = ref false in let lock = Mutex.create () in fun ~max_wait ~check_interval -> Mutex.lock lock; if !started then failwith "canary thread already started, one allowed per process"; started := true; Mutex.unlock lock; let check_interval = Time.Span.to_sec check_interval in if check_interval >= 1. then invalid_arg "check_interval must be < 1s"; let check_interval = Float.iround_exn ~dir:`Zero (check_interval *. 1_000_000.) in let (_ : Thread.t) = Thread.create (fun () -> start_canary_thread_internal ~max_wait:(Time.Span.to_sec max_wait) ~check_interval) () in () ;; (* It seems that veneers like these are needed so that the functions are correctly exported in the object files. *) let stop_upon_sigbus () = stop_upon_sigbus () let stop_upon_sigsegv () = stop_upon_sigsegv () let stop_upon_sigpipe () = stop_upon_sigpipe () let stop_upon_exit () = stop_upon_exit () let stop_me_now () = stop_me_now () let rec (obj_to_sexp_ : Obj.t -> Sexp.t) = fun x -> if Obj.is_int x then Int.sexp_of_t (Obj.obj x : int) else if Obj.is_block x then begin let tag = Obj.tag x in (* no-scan tags *) if tag = Obj.string_tag then String.sexp_of_t (Obj.obj x: string) else if tag = Obj.double_tag then Float.sexp_of_t (Obj.obj x : float) else if tag = Obj.double_array_tag then <:sexp_of> (Obj.obj x : float array) else if tag = Obj.abstract_tag then Sexp.Atom "" else if tag = Obj.custom_tag then Sexp.Atom "" else if tag = Obj.final_tag then Sexp.Atom "" else if tag = Obj.int_tag then Sexp.Atom "" else if tag = Obj.out_of_heap_tag then Sexp.Atom "" else if tag = Obj.unaligned_tag then Sexp.Atom "" (* scannable tags that we don't look further into *) else if tag = Obj.closure_tag then Sexp.Atom "" else if tag = Obj.object_tag then Sexp.Atom "" else if tag = Obj.lazy_tag then Sexp.Atom "" else if tag = Obj.infix_tag then Sexp.Atom "" else if tag = Obj.forward_tag then Sexp.Atom "" (* Any other scannable tag we dig into recursively *) else if tag >= 0 && tag < Obj.no_scan_tag then begin let size = Obj.size x in Sexp.List (List.init size ~f:(fun i -> obj_to_sexp_ (Obj.field x i))) end else Sexp.Atom "" end else Sexp.Atom "" ;; let obj_to_sexp x = obj_to_sexp_ (Obj.repr x) let obj_to_string x = Sexp.to_string (obj_to_sexp x) core_extended-113.00.00/src/low_level_debug.mli000066400000000000000000000064411256461102500212630ustar00rootroot00000000000000open Core.Std (* Useful debugging functions working at a low level. NOT FOR USE IN PRODUCTION CODE. Functions here that stop programs with SIGSTOP are designed to be used in conjunction with "gdb -p". *) (* Stop the calling process or any forked children (with SIGSTOP) upon reception of SIGBUS. This overrides any other Caml-installed handler. *) val stop_upon_sigbus : unit -> unit (* Stop the calling process or any forked children (with SIGSTOP) upon reception of SIGSEGV. This overrides any other Caml-installed handler. *) val stop_upon_sigsegv : unit -> unit (* Stop the calling process or any forked children (with SIGSTOP) upon reception of SIGPIPE. This overrides any other Caml-installed handler. *) val stop_upon_sigpipe : unit -> unit (* Stop the calling process or any forked children upon normal process termination. *) val stop_upon_exit : unit -> unit (* Stop the calling process right away. This is effectively the same as setting a gdb breakpoint, but is likely easier to use, especially if the program should only be stopped under certain circumstances. One example of the use of this function is to replace "raise" by a call to [stop_me_now]; this enables you to see the stack trace leading up to the raise. (This might be useful if many functions can call a single raise point, and you don't know which caller is triggering it.) You can of course view backtraces using OCAMLRUNPARAM=b, but that can be misleading: for example if an exception is re-raised then the backtrace will show it as raised only at the most recent raise, and previous frames (including the original raise) won't be named. Using [stop_me_now] on the original raise also has the advantage that you don't need to adjust any "with" clauses between the raise point and the top level, which would have to be removed to see a backtrace with OCAMLRUNPARAM=b. *) val stop_me_now : unit -> unit val segfault_me_now : unit -> unit (** A canary thread starts two threads, one in caml and one in C. The caml thread tries to take the caml lock every [check_interval], and immediately releases it once it succeeds. The C thread checks that your thread is getting the caml lock within [max_wait], and if it isn't it stops the program (see stop_me_now). You can then inspect your program with gdb and hopefully determine what caused it to block. It is safe to continue a program stopped by the canary thread, though there is no special handling in the canary thread to support this, so it may stop your program again. If you do manage to continue, the canary thread should continue to work. It is not safe to call this function more than once, in a given program an exception will be raised if you do (but a second canary will not be started). *) val start_canary_thread : max_wait:Time.Span.t -> check_interval:Time.Span.t -> unit (** Obtain a sexp representation of any type. Note that this will likely infinite-loop and overflow the stack for any value whose structure is circularly recursive. *) val obj_to_sexp: 'a -> Sexp.t (** Obtain a string representation of any type. Note that this will likely infinite-loop and overflow the stack for any value whose structure is circularly recursive. *) val obj_to_string: 'a -> string core_extended-113.00.00/src/low_level_debug_stubs.c000066400000000000000000000064411256461102500221440ustar00rootroot00000000000000#define _GNU_SOURCE #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include "ocaml_utils.h" static void signal_handler(int sig) { char *signame = strsignal(sig); fprintf(stderr, "stopping process %d after signal %d (%s)\n", getpid(), sig, signame); fflush(stderr); kill(getpid(), SIGSTOP); } CAMLprim value low_level_debug_stop_upon_sigbus(value v_unit) { signal(SIGBUS, signal_handler); return v_unit; } CAMLprim value low_level_debug_stop_upon_sigsegv(value v_unit) { signal(SIGSEGV, signal_handler); return v_unit; } CAMLprim value low_level_debug_stop_upon_sigpipe(value v_unit) { signal(SIGPIPE, signal_handler); return v_unit; } static void at_exit_handler(void) { fprintf(stderr, "stopping process %d at exit\n", getpid()); fflush(stderr); kill(getpid(), SIGSTOP); } CAMLprim value low_level_debug_stop_upon_exit(value v_unit) { atexit(at_exit_handler); return v_unit; } CAMLprim value low_level_debug_stop_me_now(value v_unit) { fprintf(stderr, "stopping process %d now\n", getpid()); fflush(stderr); kill(getpid(), SIGSTOP); /* endless loop so this never terminates, otherwise * we might have gone past the point where we wanted * to stop and that makes debugging harder.. */ while (1); return v_unit; } /* Canary thread, detects when something is blocking the run time, and sends sigstop so the process can be examined. */ volatile double last_canary = 0.0; double max_canary_wait = 0.050; /* how often in usec to check last_canary */ long canary_check_interval = 10000; double canary_now() { struct timeval tm; gettimeofday(&tm, NULL); return (tm.tv_sec + (tm.tv_usec / 1000000.0)); } void canary_wait(int usec) { struct timeval tm; tm.tv_sec = 0; tm.tv_usec = usec; while(select(0, NULL, NULL, NULL, &tm) != 0) {} } /* Watch the thread that is trying to get the run time lock, if it doesn't succeed within max_canary_wait then send SIGSTOP to the current process. */ void * canary_thread(__unused void * unused) { double elapsed; while(1) { canary_wait(canary_check_interval); elapsed = canary_now() - last_canary; if(elapsed > max_canary_wait) { printf("canary blocked for %g aborting\n", elapsed); raise(SIGSTOP); } } return NULL; } /* never returns, starts a canary thread. The caml thread tries to take the caml lock every canary_check_interval, when it succeeds it updates last_canary. The canary thread runs every 10ms */ CAMLprim value start_canary(value v_max_wait, value v_check_interval) { pthread_t canary_pthread; last_canary = canary_now(); max_canary_wait = Double_val(v_max_wait); canary_check_interval = Long_val(v_check_interval); printf("starting canary thread, max_wait %f check_interval %ld\n", max_canary_wait, canary_check_interval); pthread_create(&canary_pthread, NULL, &canary_thread, NULL); while(1) { caml_enter_blocking_section(); canary_wait(canary_check_interval); caml_leave_blocking_section(); last_canary = canary_now(); } return Val_unit; } core_extended-113.00.00/src/malloc.ml000066400000000000000000000020301256461102500172110ustar00rootroot00000000000000open Core.Std INCLUDE "config.mlh" type mallinfo = { arena : int; ordblks : int; smblks : int; hblks : int; hblkhd : int; usmblks : int; fsmblks : int; uordblks : int; fordblks : int; keepcost : int; } with sexp, bin_io type opt = | TRIM_THRESHOLD | TOP_PAD | MMAP_THRESHOLD | MMAP_MAX | CHECK_ACTION (* | PERTURB *) with sexp, bin_io IFDEF LINUX_EXT THEN external mallinfo : unit -> mallinfo = "malloc_mallinfo_stub" external mallopt : opt -> int -> unit = "malloc_mallopt_stub" external malloc_trim : int -> unit = "malloc_trim_stub" external malloc_stats : unit -> unit = "malloc_stats_stub" let mallinfo = Ok mallinfo let mallopt = Ok mallopt let malloc_trim = Ok malloc_trim let malloc_stats = Ok malloc_stats ELSE let mallinfo = Or_error.unimplemented "Malloc.mallinfo" let mallopt = Or_error.unimplemented "Malloc.mallopt" let malloc_trim = Or_error.unimplemented "Malloc.malloc_trim" let malloc_stats = Or_error.unimplemented "Malloc.malloc_stats" ENDIF core_extended-113.00.00/src/malloc.mli000066400000000000000000000037641256461102500174010ustar00rootroot00000000000000open Core.Std (** Malloc bindings Allows you to set/query the behaviour of malloc. The functions in this module may not be implemented on your platform. *) type mallinfo = { arena : int; (** non-mmapped space allocated from system *) ordblks : int; (** number of free chunks *) smblks : int; (** number of fastbin blocks *) hblks : int; (** number of mmapped regions *) hblkhd : int; (** space in mmapped regions *) usmblks : int; (** maximum total allocated space *) fsmblks : int; (** space available in freed fastbin blocks *) uordblks : int; (** total allocated space *) fordblks : int; (** total free space *) keepcost : int; (** top-most, releasable (via malloc_trim) space *) } with sexp, bin_io (** Malloc options *) type opt = | TRIM_THRESHOLD (** Maximum amount of unused top-most memory to keep before releasing via malloc_trim in free(). *) | TOP_PAD (** Amount of extra `padding' space to allocate or retain whenever sbrk is called. *) | MMAP_THRESHOLD (** Request size threshold for using mmap() to service a request. Requests of at least this size that cannot be allocated using already-existing space will be serviced via mmap. *) | MMAP_MAX (** Maximum number of requests to simultaneously service using mmap. *) | CHECK_ACTION (** ??? *) (* | PERTURB (** ??? *) *) with sexp, bin_io (** [mallinfo ()] @return information on the state of malloced memory (C-heap). *) val mallinfo : (unit -> mallinfo) Or_error.t (** [mallopt opt n] sets malloc configuration option [opt] to [n]. *) val mallopt : (opt -> int -> unit) Or_error.t (** [malloc_trim n] release all but [n] bytes of freed top-most memory back to the system. @raise Failure if unsuccessful. *) val malloc_trim : (int -> unit) Or_error.t (** [malloc_stats ()] prints brief summary statistics on stderr. *) val malloc_stats : (unit -> unit) Or_error.t core_extended-113.00.00/src/malloc_stubs.c000066400000000000000000000025021256461102500202470ustar00rootroot00000000000000#include "config.h" #ifdef JSC_LINUX_EXT #include #include "ocaml_utils.h" CAMLprim value malloc_mallinfo_stub(value __unused v_unit) { struct mallinfo info = mallinfo(); value v_info = caml_alloc_small(10, 0); Field(v_info, 0) = Val_int(info.arena); Field(v_info, 1) = Val_int(info.ordblks); Field(v_info, 2) = Val_int(info.smblks); Field(v_info, 3) = Val_int(info.hblks); Field(v_info, 4) = Val_int(info.hblkhd); Field(v_info, 5) = Val_int(info.usmblks); Field(v_info, 6) = Val_int(info.fsmblks); Field(v_info, 7) = Val_int(info.uordblks); Field(v_info, 8) = Val_int(info.fordblks); Field(v_info, 9) = Val_int(info.keepcost); return v_info; } static int options[] = { M_TRIM_THRESHOLD, M_TOP_PAD, M_MMAP_THRESHOLD, M_MMAP_MAX, M_CHECK_ACTION, /* M_PERTURB, */ }; CAMLprim value malloc_mallopt_stub(value v_opt, value v_n) { int ret = mallopt(options[Int_val(v_opt)], Int_val(v_n)); if (ret != 1) caml_failwith("mallopt"); return Val_unit; } CAMLprim value malloc_trim_stub(value v_n) { int ret = malloc_trim(Int_val(v_n)); if (ret != 1) caml_failwith("malloc_trim"); return Val_unit; } CAMLprim value malloc_stats_stub(value __unused v_unit) { caml_enter_blocking_section(); malloc_stats(); caml_leave_blocking_section(); return Val_unit; } #endif /* JSC_LINUX_EXT */ core_extended-113.00.00/src/multi_map.ml000066400000000000000000000017221256461102500177400ustar00rootroot00000000000000open Core.Std include Fold_map.Make2_sexpable (struct type 'a t = 'a list with sexp let init = [] let f list x = x :: list end) let iter ~f m = iter ~f:(fun ~key ~data -> List.iter data ~f:(fun data -> f ~key ~data)) m let mapi ~f m = of_map (Map.mapi (to_map m) ~f:(fun ~key ~data -> List.map ~f:(fun data -> f ~key ~data) data)) let map ~f m = of_map (Map.map (to_map m) ~f:(List.map ~f)) let fold ~f m ~init = fold m ~f:(fun ~key ~data acc -> List.fold data ~f:(fun acc data -> f ~key ~data acc) ~init:acc) ~init let set ~key ~data m = if data=[] then remove m key else set ~key ~data m let filter ~f m = of_map (Map.filter_mapi (to_map m) ~f:(fun ~key ~data -> let data = List.filter data ~f:(fun data -> f ~key ~data) in if data = [] then None else Some data)) let reduce ~f m = Map.map ~f (to_map m) core_extended-113.00.00/src/multi_map.mli000066400000000000000000000034251256461102500201130ustar00rootroot00000000000000(** Maps with mutliple bindings. This is a map that allows multiple binding. Each key can have several values associated to it. *) open Core.Std type ('k,'v) t include Sexpable.S2 with type ('a,'b) t := ('a,'b) t val empty : ('k,'v) t val singleton : 'k -> 'v -> ('k,'v) t val is_empty : ('k,'v) t -> bool val add : key:'k -> data:'v -> ('k, 'v) t -> ('k, 'v) t val find : ('k, 'v) t -> 'k -> 'v list (** [find m key] returns all the elements that where added to [key] in [m] in the reverse order in which they where added. If no element where added an empty list is returned.*) val remove : ('k, 'v) t -> 'k -> ('k, 'v) t (** [remove m key] Remove all the values associated the key [key] in [m]*) val set : key:'k -> data:'v list -> ('k, 'v) t -> ('k, 'v) t val mem : ('k, 'v) t -> 'k -> bool (** [mem m key] returns true if [key] has at last one value associated to it in [m] *) val keys : ('k, 'v) t -> 'k list (** Returns all the non-empty keys in [m]. *) val iter : f:(key:'k -> data:'v -> unit) -> ('k, 'v) t -> unit val map: f:('a -> 'b) -> ('k,'a) t -> ('k,'b) t val mapi: f:(key:'k -> data:'a -> 'b) -> ('k,'a) t -> ('k,'b) t val fold : f:(key:'k -> data:'v -> 'a -> 'a) -> ('k, 'v) t -> init:'a -> 'a val filter : f:(key:'k -> data:'v -> bool) -> ('k,'v) t -> ('k,'v) t val reduce : f:('v list -> 'r) -> ('k,'v) t -> ('k,'r) Map.Poly.t (* val data : ('a, 'b) t -> 'b list val to_alist : ('a, 'b) t -> ('a * 'b list) list val of_list : ('a * 'b) list -> ('a, 'b) t val for_all : f:('a list -> bool) -> ('b, 'a) t -> bool val exists : f:('a list -> bool) -> ('b, 'a) t -> bool val to_map : ('a, 'b) t -> ('a, 'b list) Map.t val of_map : ('a, 'b list) Map.t -> ('a, 'b) t *) core_extended-113.00.00/src/net_utils.ml000066400000000000000000000044021256461102500177550ustar00rootroot00000000000000open Core.Std open Unix exception Timeout let h_name_of_sockaddr = function | ADDR_INET (inet_addr, _) -> (Host.getbyaddr_exn inet_addr).Host.name | ADDR_UNIX _ -> failwith "h_name_of_sockaddr: ADDR_UNIX" let string_of_sockaddr = function | ADDR_INET (inet_addr, _) -> Inet_addr.to_string inet_addr | ADDR_UNIX file -> file let h_name_or_string_of_sockaddr = function | ADDR_INET (inet_addr, _) -> (try (Host.getbyaddr_exn inet_addr).Host.name with Not_found -> Inet_addr.to_string inet_addr) | ADDR_UNIX _ -> failwith "h_name_or_string_of_sockaddr: ADDR_UNIX" let inet_addr_of_sockaddr = function | ADDR_INET (inet_addr, _) -> inet_addr | ADDR_UNIX _ -> failwith "inet_addr_of_sockaddr: ADDR_UNIX" let port_of_sockaddr = function | ADDR_INET (_, port) -> port | ADDR_UNIX _ -> failwith "port_of_sockaddr: ADDR_UNIX" let port_of_in_channel ic = let sa = getsockname (descr_of_in_channel ic) in port_of_sockaddr sa let tcp_socket () = Unix.socket ~domain:Unix.PF_INET ~kind:Unix.SOCK_STREAM ~protocol:0 let connect_tmout s sockaddr con_timeout = set_nonblock s; try Unix.connect s ~addr:sockaddr; true with Unix_error (EINPROGRESS, _, _) -> match select ~read:[s] ~write:[s] ~except:[] ~timeout:con_timeout () with | { Select_fds.read = []; write = []; except = [] } -> false | _ -> let err = getsockopt_int s SO_ERROR in if err <> 0 then unix_error err "connect" ""; clear_nonblock s; true let open_fd_connection_tmout ~con_timeout ~rcv_timeout ~snd_timeout sockaddr = let s = tcp_socket () in try if connect_tmout s sockaddr con_timeout then ( setsockopt_float s SO_RCVTIMEO rcv_timeout; setsockopt_float s SO_SNDTIMEO snd_timeout; s) else raise Timeout with exc -> (try close s with _ -> ()); raise exc let open_connection_tmout ~con_timeout ~rcv_timeout ~snd_timeout sockaddr = let s = open_fd_connection_tmout ~con_timeout ~rcv_timeout ~snd_timeout sockaddr in in_channel_of_descr s, out_channel_of_descr s let set_in_channel_timeout ic rcv_timeout = let s = descr_of_in_channel ic in setsockopt_float s SO_RCVTIMEO rcv_timeout let set_out_channel_timeout oc snd_timeout = let s = descr_of_out_channel oc in setsockopt_float s SO_SNDTIMEO snd_timeout core_extended-113.00.00/src/net_utils.mli000066400000000000000000000030271256461102500201300ustar00rootroot00000000000000(** Networking utilities @author Markus Mottl *) open Unix (** Exception raised if a connection attempt timed out *) exception Timeout (** Get hostname from sockaddr *) val h_name_of_sockaddr : sockaddr -> string (** Get string from sockaddr *) val string_of_sockaddr : sockaddr -> string (** Get hostname or (on Not_found) inet string from sockaddr *) val h_name_or_string_of_sockaddr : sockaddr -> string (** Get inet_addr from sockaddr *) val inet_addr_of_sockaddr : sockaddr -> inet_addr (** Get port from sockaddr *) val port_of_sockaddr : sockaddr -> int (** Get port from a socket associated with an [in_channel] *) val port_of_in_channel : in_channel -> int (** Create a standard TCP/IP-socket *) val tcp_socket : unit -> file_descr (** Connect a socket with a connect timeout *) val connect_tmout : file_descr -> sockaddr -> Core.Std.Unix.select_timeout -> bool (** Create a socket with timeouts *) val open_fd_connection_tmout : con_timeout : Core.Std.Unix.select_timeout -> rcv_timeout : float -> snd_timeout : float -> sockaddr -> file_descr (** Open a connection with timeouts *) val open_connection_tmout : con_timeout : Core.Std.Unix.select_timeout -> rcv_timeout : float -> snd_timeout : float -> sockaddr -> in_channel * out_channel (** Set a timeout for a socket associated with an [in_channel] *) val set_in_channel_timeout : in_channel -> float -> unit (** Set a timeout for a socket associated with an [out_channel] *) val set_out_channel_timeout : out_channel -> float -> unit core_extended-113.00.00/src/number.ml000066400000000000000000000105211256461102500172360ustar00rootroot00000000000000open Core.Std open Interfaces module type Spec_no_binable = sig type t include Comparable with type t := t include Floatable with type t := t include Hashable.S_binable with type t := t include Sexpable with type t := t include Stringable with type t := t end module type Spec = sig include Spec_no_binable include Binable with type t := t end module type Verified_spec = sig include Spec val check : t -> (unit, string) Result.t end module type S = sig include Spec type repr val verify : repr -> t end module type S0 = sig include S val zero : t end module Make_verified (Spec : Verified_spec) = struct include (Spec : Spec_no_binable with type t = Spec.t) type repr = Spec.t let get_err_str msg n = sprintf !"%s: %{}" msg n let verify n = match Spec.check n with | Ok () -> n | Error msg -> failwith (get_err_str msg n) let t_of_sexp sexp = let n = t_of_sexp sexp in match Spec.check n with | Ok () -> n | Error msg -> Sexplib.Conv.of_sexp_error (get_err_str msg n) sexp include Binable.Of_binable (Spec) (struct let to_binable n = n let of_binable = verify type t = Spec.t end) let of_string str = verify (of_string str) let of_float n = verify (of_float n) end module Make_verified_unsafe = Make_verified module type Verified_std_spec = sig include Spec val module_name : string val zero : t end module type Verified_std = sig type repr module type S = S with type repr = repr module type S0 = S0 with type repr = repr module Pos : S with type t = private repr module Pos0 : S0 with type t = private repr module Neg : S with type t = private repr module Neg0 : S0 with type t = private repr module type Bounded_spec = sig val name : string val lower : repr val upper : repr end module type Bounded = sig include Bounded_spec include S end module Make_bounded (Spec : Bounded_spec) : Bounded with type t = private repr module Pos_unsafe : S with type t = repr module Pos0_unsafe : S0 with type t = repr module Neg_unsafe : S with type t = repr module Neg0_unsafe : S0 with type t = repr module Make_bounded_unsafe (Spec : Bounded_spec) : Bounded with type t = repr end module Make_verified_std (Spec : Verified_std_spec) = struct type repr = Spec.t module type S = S with type repr = repr module type S0 = S0 with type repr = repr module Pos_spec = struct include Spec let check = let error = Error (module_name ^ ".Pos.t <= 0") in fun n -> if n > zero then Ok () else error end module Pos = Make_verified (Pos_spec) module Pos_unsafe = Pos module Pos0_spec = struct include Spec let check = let error = Error (module_name ^ ".Pos0.t < 0") in fun n -> if n >= zero then Ok () else error end module Pos0 = struct include Make_verified (Pos0_spec) let zero = Spec.zero end module Pos0_unsafe = Pos0 module Neg_spec = struct include Spec let check = let error = Error (module_name ^ ".Neg.t >= 0") in fun n -> if n < zero then Ok () else error end module Neg = Make_verified (Neg_spec) module Neg_unsafe = Neg module Neg0_spec = struct include Spec let check = let error = Error (module_name ^ ".Neg0.t > 0") in fun n -> if n <= zero then Ok () else error end module Neg0 = struct include Make_verified (Neg0_spec) let zero = Spec.zero end module Neg0_unsafe = Neg0 module type Bounded_spec = sig val name : string val lower : repr val upper : repr end module type Bounded = sig include Bounded_spec include S end module Make_bounded (Bounded_spec : Bounded_spec) = struct include Bounded_spec module Spec = struct include Spec let check = if lower > upper then failwithf "%s.Make_bounded: %s: lower(%s) > upper(%s)" module_name name (to_string lower) (to_string upper) () else let mk_error cmp_c bound = Error (sprintf !"%s.t %c %{}" name cmp_c bound) in let lower_error = mk_error '<' lower in let upper_error = mk_error '>' upper in fun n -> if n < lower then lower_error else if n > upper then upper_error else Ok () end include Make_verified (Spec) end module Make_bounded_unsafe = Make_bounded end core_extended-113.00.00/src/number.mli000066400000000000000000000065631256461102500174220ustar00rootroot00000000000000open Core.Std open Interfaces (** Specification of general number properties *) module type Spec = sig type t include Comparable with type t := t include Floatable with type t := t include Hashable.S_binable with type t := t include Sexpable with type t := t include Stringable with type t := t include Binable with type t := t end (** Specification of numbers with constraint checks *) module type Verified_spec = sig include Spec val check : t -> (unit, string) Result.t end (** Signature of numbers that have a verified ([t]) and unverified ([repr]) representation and a function to verify the latter. *) module type S = sig include Spec type repr val verify : repr -> t end (** Signature of numbers that also have a zero *) module type S0 = sig include S val zero : t end (** Functor for making constrained numbers from specifications. This functor enforces the invariant through a private type. *) module Make_verified (Spec : Verified_spec) : S with type repr = Spec.t with type t = private Spec.t (** Same as {!Make_verified}, but does not enforce invariants. Useful for extending verified numbers with more features before "sealing" the type with a private declaration. *) module Make_verified_unsafe (Spec : Verified_spec) : S with type repr = Spec.t with type t = Spec.t (** Specification used for standard numbers ([Int.t], [Int32.t], [Int63.t] [Int64.t], [Nativeint.t], [Float.t]) to enrich them with [Pos.t], [Pos0.t], [Neg.t], and [Neg0.t] modules, and the [Make_bounded] and [Make_bounded_unsafe] functors. *) module type Verified_std_spec = sig include Spec val module_name : string val zero : t end (** Signature of standard numbers ([Int.t], [Int32.t], [Int63.t] [Int64.t], [Nativeint.t], [Float.t]) to enrich them with [Pos.t], [Pos0.t], [Neg.t], and [Neg0.t] modules, and the [Make_bounded] and [Make_bounded_unsafe] functors. *) module type Verified_std = sig type repr (** Abbreviations *) module type S = S with type repr = repr module type S0 = S0 with type repr = repr (** Positive and negative numbers with and without zero. *) module Pos : S with type t = private repr module Pos0 : S0 with type t = private repr module Neg : S with type t = private repr module Neg0 : S0 with type t = private repr (** Specification of bounded numbers *) module type Bounded_spec = sig val name : string val lower : repr val upper : repr end (** Signature of bounded numbers *) module type Bounded = sig include Bounded_spec include S end (** Functor of creating bounded numbers *) module Make_bounded (Spec : Bounded_spec) : Bounded with type t = private repr (** Unsafe modules and functors that still fully expose the representation for extensibility. *) module Pos_unsafe : S with type t = repr module Pos0_unsafe : S0 with type t = repr module Neg_unsafe : S with type t = repr module Neg0_unsafe : S0 with type t = repr module Make_bounded_unsafe (Spec : Bounded_spec) : Bounded with type t = repr end (** Functor for enriching standard numbers ([Int.t], [Int32.t], [Int63.t] [Int64.t], [Nativeint.t], [Float.t]) with [Pos.t], [Pos0.t], [Neg.t], and [Neg0.t] modules, and the [Make_bounded] and [Make_bounded_unsafe] functors. *) module Make_verified_std (Spec : Verified_std_spec) : Verified_std with type repr = Spec.t core_extended-113.00.00/src/olang.ml000066400000000000000000000126551256461102500170600ustar00rootroot00000000000000open Core.Std type 'a t = [ | `GT of 'a * 'a | `LT of 'a * 'a | `GE of 'a * 'a | `LE of 'a * 'a | `EQ of 'a * 'a | `NE of 'a * 'a | `One_of of 'a * 'a list ] with bin_io, sexp, compare let t_of_sexp a_of_sexp sexp = let open Sexplib.Type in match sexp with | List [x; Atom ">"; y] -> `GT (a_of_sexp x, a_of_sexp y) | List [x; Atom "<"; y] -> `LT (a_of_sexp x, a_of_sexp y) | List [x; Atom ">="; y] -> `GE (a_of_sexp x, a_of_sexp y) | List [x; Atom "<="; y] -> `LE (a_of_sexp x, a_of_sexp y) | List [x; Atom "="; y] -> `EQ (a_of_sexp x, a_of_sexp y) | List [x; Atom "<>"; y] -> `NE (a_of_sexp x, a_of_sexp y) | List [x; Atom "one-of"; List xs] -> `One_of (a_of_sexp x, List.map xs ~f:a_of_sexp) | _ -> failwithf "bad predicate sexp: %s" (Sexp.to_string_hum sexp) () let sexp_of_t sexp_of_a t = let open Sexplib.Type in match t with | `GT (x, y) -> List [sexp_of_a x; Atom ">"; sexp_of_a y] | `LT (x, y) -> List [sexp_of_a x; Atom "<"; sexp_of_a y] | `GE (x, y) -> List [sexp_of_a x; Atom ">="; sexp_of_a y] | `LE (x, y) -> List [sexp_of_a x; Atom "<="; sexp_of_a y] | `EQ (x, y) -> List [sexp_of_a x; Atom "="; sexp_of_a y] | `NE (x, y) -> List [sexp_of_a x; Atom "<>"; sexp_of_a y] | `One_of (x, ys) -> List [sexp_of_a x; Atom "one-of"; List (List.map ~f:sexp_of_a ys)] include struct open Int.Replace_polymorphic_compare let eval ~compare = function | `GT (x, y) -> compare x y > 0 | `LT (x, y) -> compare x y < 0 | `GE (x, y) -> compare x y >= 0 | `LE (x, y) -> compare x y <= 0 | `EQ (x, y) -> compare x y = 0 | `NE (x, y) -> not (compare x y = 0) | `One_of (x, ys) -> List.mem ys x ~equal:(fun x y -> compare x y = 0) end TEST_MODULE = struct module Term0 = struct type t = [ `C of float | `V of string ] with sexp, bin_io, compare let t_of_sexp = function | Sexp.Atom x -> (try `C (Float.of_string x) with _ -> `V x) | sexp -> t_of_sexp sexp let sexp_of_t = function | `C x -> Float.sexp_of_t x | `V v -> String.sexp_of_t v end module Term = struct include (Flang : (module type of Flang) with type 'a t := 'a Flang.t) module X = Flang.Eval (Float) let eval = X.eval type t = Term0.t Flang.t with sexp, compare let x = base (`V "x") let const value = base (`C value) let ( + ) = add let ( * ) = mult end let sexp_of_pred = sexp_of_t Term.sexp_of_t let pred_of_sexp = t_of_sexp Term.t_of_sexp let env x = function | "x" -> Int.to_float x | _ -> assert false let eval_term ~x term = let sexp_of_term = Term.sexp_of_t term in <:test_eq< Term.t >> term (Term.t_of_sexp sexp_of_term) ~message:"Term sexp roundtrip"; let env = env x in Term.eval term ~f:(function `C v -> v | `V x -> env x) let eval_pred pred ~x = (* Roundtrip is tested further down. *) let eval_term = eval_term ~x in eval pred ~compare:(fun t t' -> Float.compare (eval_term t) (eval_term t')) let sexp1 = Sexp.of_string "((x + 1) * (x + 1))" let term1 = Term.((x + const 1.) * (x + const 1.)) let sexp2 = Sexp.of_string "(((x * x) + (2 * x)) + 1)" let term2 = Term.((x * x) + (const 2. * x) + const 1.) let sexp3 = Sexp.of_string "(min x (max x (abs x)))" let term3 = Term.(min x (max x (abs x))) TEST_UNIT "sexp term1" = <:test_result< Term.t >> ~expect:term1 (Term.t_of_sexp sexp1) TEST_UNIT "sexp term2" = <:test_result< Term.t >> ~expect:term2 (Term.t_of_sexp sexp2) TEST_UNIT "sexp term3" = <:test_result< Term.t >> ~expect:term3 (Term.t_of_sexp sexp3) TEST_UNIT "evaluate arithmetic" = let test = <:test_result< Float.t >> ~equal:Float.(=.) in for x = 1 to 100 do test ~expect:(Int.to_float ((x + 1) * (x + 1))) (eval_term term1 ~x); test ~expect:(Int.to_float ((x + 1) * (x + 1))) (eval_term term2 ~x) done TEST_UNIT "evaluate min-max" = let test = <:test_result< Float.t >> ~equal:Float.(=.) in for x = -100 to 100 do test ~expect:(Int.to_float x) (eval_term term3 ~x) done TEST_UNIT "evaluate predicate" = for x = 1 to 100 do <:test_pred< Term.t t * int >> (fun (p, x) -> eval_pred p ~x) (`EQ (term1, term2), x); <:test_pred< Term.t t * int >> (fun (p, x) -> not (eval_pred p ~x)) (`GT (term1, term2), x) done TEST_UNIT "predicate sexp" = let x = Term.base (`V "x") in let const value = Term.base (`C value) in List.iter ~f:(fun (s, expect) -> let actual = <:of_sexp< Term.t t >> (Sexp.of_string s) in <:test_result< Term.t t >> actual ~expect) [ "((x + 1) > 4)", `GT (Term.add x (const 1.), const 4.); "((x * x) one-of ((2 / x) 4))", `One_of (Term.mult x x, [Term.div (const 2.) x; const 4.]); "((x + 1.5) <> (x + 1.6))", `NE (Term.add x (const 1.5), Term.add x (const 1.6)) ] let eval_pred_s pred ~x = let sexp1 = Sexp.of_string pred in let pred = pred_of_sexp sexp1 in let sexp2 = sexp_of_pred pred in <:test_result< Sexp.t >> ~expect:sexp1 sexp2 ~message:"Pred sexp roundtrip"; eval_pred pred ~x TEST = eval_pred_s "((x + 1) = 4)" ~x:3 TEST = eval_pred_s "((x * x) = 9)" ~x:3 TEST = eval_pred_s "((x * x) > (x + x))" ~x:3 TEST = eval_pred_s "((x * x) <> 8)" ~x:3 TEST = eval_pred_s "((x * x) one-of (1 2 9 12))" ~x:3 TEST = eval_pred_s "((x / 2) = 1.5)" ~x:3 TEST = eval_pred_s "((x - 10) = -7)" ~x:3 end core_extended-113.00.00/src/olang.mli000066400000000000000000000010171256461102500172170ustar00rootroot00000000000000(** The language of predicates over an ordered set. *) type 'a t = [ | `GT of 'a * 'a (** sexp [(x > y)] *) | `LT of 'a * 'a (** sexp [(x < y)] *) | `GE of 'a * 'a (** sexp [(x >= y)] *) | `LE of 'a * 'a (** sexp [(x <= y)] *) | `EQ of 'a * 'a (** sexp [(x = y)] *) | `NE of 'a * 'a (** sexp [(x <> y)] *) | `One_of of 'a * 'a list (** sexp [(x one-of (a b c))] *) ] with bin_io, sexp, compare val eval : compare:('a -> 'a -> int) -> 'a t -> bool core_extended-113.00.00/src/packed_array.ml000066400000000000000000000376121256461102500204050ustar00rootroot00000000000000open Core.Std module Core_bool = Bool module Core_char = Char module Core_float = Float module Core_int = Int module Core_int32 = Int32 module Core_int64 = Int64 module Core_string = String module type Basic = sig type elt with sexp, bin_io type t val length : t -> int val unsafe_get : t -> int -> elt val of_array : elt array -> t val unsafe_slice : t -> pos:int -> len:int -> t end module type S = sig include Basic include Sexpable.S with type t := t include Binable.S with type t := t val get : t -> int -> elt val slice : t -> pos:int -> len:int -> t val iter : t -> f:(elt -> unit) -> unit val fold : t -> init:'a -> f:('a -> elt -> 'a) -> 'a val of_array : elt array -> t val to_array : t -> elt array val of_list : elt list -> t val to_list : t -> elt list val empty : t end module Make (B : Basic) = struct include B exception Invalid_index of int with sexp exception Invalid_slice of int * int with sexp let valid_index t i = Int.(>=) i 0 && Int.(<) i (length t) let get t i = if valid_index t i then unsafe_get t i else raise (Invalid_index i) let slice t ~pos ~len = if valid_index t pos && Int.(<=) (pos + len) (length t) then unsafe_slice t ~pos ~len else raise (Invalid_slice (pos, len)) let of_list xs = of_array (Array.of_list xs) let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i) let to_list t = List.init (length t) ~f:(fun i -> unsafe_get t i) let empty = of_array (Array.empty ()) let iter t ~f = for i = 0 to length t - 1 do f (unsafe_get t i) done let fold t ~init ~f = let len = length t in let rec loop ix acc = if Int.(<) ix len then loop (ix+1) (f acc (unsafe_get t ix)) else acc in loop 0 init include (Binable.Of_binable (struct type t = elt array with bin_io end) (struct type nonrec t = t let to_binable = to_array let of_binable = of_array end) : Binable.S with type t := t) let t_of_sexp sexp = of_array (<:of_sexp< elt array >> sexp) let sexp_of_t t = <:sexp_of< elt array >> (to_array t) end module type Basic_bigarray = sig type elt with sexp, bin_io type kind val kind : (elt, kind) Bigarray.kind end module Of_bigarray (B : Basic_bigarray) = struct open Bigarray include Make(struct include B type t = { buf : (elt, kind, c_layout) Array1.t; off : int; len : int } let length t = t.len let unsafe_get t ix = Array1.unsafe_get t.buf (ix + t.off) let of_array arr = { buf = Array1.of_array kind c_layout arr; off = 0; len = Array.length arr; } let unsafe_slice t ~pos ~len = { t with off = t.off + pos; len; } end) end module type T = sig type elt include Comparable.S with type t := elt module S : S with type elt := elt val test_list : unit -> elt list end module Test (T : T) = struct include T let test_list = T.test_list () let test_array = Array.of_list test_list let test_t = S.of_array test_array let test_elt = List.hd_exn test_list let list_equal xs ys = List.equal xs ys ~equal:(=) let array_equal xs ys = Array.equal xs ys ~equal:(=) (* If this fails then some of the other test results would be invalid *) TEST "test_list long enough" = Int.(>) (Array.length test_array) 75 TEST "of_list o to_list = ident (empty)" = list_equal (S.to_list (S.of_list [])) [] TEST "of_list o to_list = ident (singleton)" = let x = [test_elt] in list_equal (S.to_list (S.of_list x)) x TEST "of_list o to_list = ident (non-empty)" = list_equal (S.to_list (S.of_list test_list)) test_list TEST "of_array o to_array = ident (empty)" = array_equal (S.to_array (S.of_array (Array.empty ()))) (Array.empty ()) TEST "of_array o to_array = ident (singleton)" = let x = Array.create ~len:1 test_elt in array_equal (S.to_array (S.of_array x)) x TEST "of_array o to_array = ident (non-empty)" = array_equal (S.to_array (S.of_array test_array)) test_array TEST "iter" = let xs = ref [] in let ys = ref [] in List.iter test_list ~f:(fun x -> xs := x :: !xs); S.iter test_t ~f:(fun y -> ys := y :: !ys); list_equal !xs !ys TEST "t_of_sexp o sexp_of_t = ident (empty)" = let xs = S.of_array (Array.empty ()) in array_equal (S.to_array (S.t_of_sexp (S.sexp_of_t xs))) (S.to_array xs) TEST "t_of_sexp o sexp_of_t = ident (singleton)" = let xs = S.of_array (Array.create ~len:1 test_elt) in array_equal (S.to_array (S.t_of_sexp (S.sexp_of_t xs))) (S.to_array xs) TEST "t_of_sexp o sexp_of_t = ident (non-empty)" = array_equal (S.to_array (S.t_of_sexp (S.sexp_of_t test_t))) (S.to_array test_t) TEST "slice (non-empty)" = list_equal (S.to_list (S.slice test_t ~pos:25 ~len:25)) (List.sub (S.to_list test_t) ~pos:25 ~len:25) TEST "slice twice (non-empty)" = list_equal (S.to_list (S.slice (S.slice test_t ~pos:25 ~len:25) ~pos:10 ~len:5)) (List.sub (List.sub (S.to_list test_t) ~pos:25 ~len:25) ~pos:10 ~len:5) TEST "marshalable" = array_equal (S.to_array test_t) (S.to_array (Marshal.from_string (Marshal.to_string test_t [Marshal.Closures]) 0)) end module Char = Of_bigarray (struct type elt = char with sexp, bin_io type kind = Bigarray.int8_unsigned_elt let kind = Bigarray.char end) TEST_MODULE "char" = Test(struct type elt = char include (Core_char : Comparable.S with type t := elt) module S = (Char : S with type elt := elt) let test_list () = List.init 100 ~f:Core_char.of_int_exn end) module Int = Of_bigarray (struct type elt = int with sexp, bin_io type kind = Bigarray.int_elt let kind = Bigarray.int end) TEST_MODULE "int" = Test(struct type elt = int include (Core_int : Comparable.S with type t := elt) module S = (Int : S with type elt := elt) let test_list () = List.init 100 ~f:ident end) module Int8_unsigned = Of_bigarray (struct type elt = int with sexp, bin_io type kind = Bigarray.int8_unsigned_elt let kind = Bigarray.int8_unsigned end) TEST_MODULE "int8_unsigned" = Test(struct type elt = int include (Core_int : Comparable.S with type t := elt) module S = (Int8_unsigned : S with type elt := elt) let test_list () = List.init 100 ~f:ident end) module Int8 = Of_bigarray (struct type elt = int with sexp, bin_io type kind = Bigarray.int8_signed_elt let kind = Bigarray.int8_signed end) TEST_MODULE "int8" = Test(struct type elt = int include (Core_int : Comparable.S with type t := elt) module S = (Int8 : S with type elt := elt) let test_list () = List.init 100 ~f:ident end) module Int16_unsigned = Of_bigarray (struct type elt = int with sexp, bin_io type kind = Bigarray.int16_unsigned_elt let kind = Bigarray.int16_unsigned end) TEST_MODULE "int16_unsigned" = Test(struct type elt = int include (Core_int : Comparable.S with type t := elt) module S = (Int16_unsigned : S with type elt := elt) let test_list () = List.init 100 ~f:ident end) module Int16 = Of_bigarray (struct type elt = int with sexp, bin_io type kind = Bigarray.int16_signed_elt let kind = Bigarray.int16_signed end) TEST_MODULE "int16" = Test(struct type elt = int include (Core_int : Comparable.S with type t := elt) module S = (Int16 : S with type elt := elt) let test_list () = List.init 100 ~f:ident end) module Int32 = Of_bigarray (struct type elt = int32 with sexp, bin_io type kind = Bigarray.int32_elt let kind = Bigarray.int32 end) TEST_MODULE "int32" = Test(struct type elt = int32 include (Core_int32 : Comparable.S with type t := elt) module S = (Int32 : S with type elt := elt) let test_list () = List.init 100 ~f:Core_int.to_int32_exn end) module Int64 = Of_bigarray (struct type elt = int64 with sexp, bin_io type kind = Bigarray.int64_elt let kind = Bigarray.int64 end) TEST_MODULE "int64" = Test(struct type elt = int64 include (Core_int64 : Comparable.S with type t := elt) module S = (Int64 : S with type elt := elt) let test_list () = List.init 100 ~f:Core_int.to_int64 end) module Float32 = Of_bigarray (struct type elt = float with sexp, bin_io type kind = Bigarray.float32_elt let kind = Bigarray.float32 end) TEST_MODULE "float32" = Test(struct type elt = float include (Core_float : Comparable.S with type t := elt) module S = (Float32 : S with type elt := elt) let test_list () = List.init 100 ~f:Core_float.of_int end) module Float = Of_bigarray (struct type elt = float with sexp, bin_io type kind = Bigarray.float64_elt let kind = Bigarray.float64 end) TEST_MODULE "float" = Test(struct type elt = float include (Core_float : Comparable.S with type t := elt) module S = (Float : S with type elt := elt) let test_list () = List.init 100 ~f:Core_float.of_int end) module Bool = Make (struct open Bigarray type elt = bool with sexp, bin_io type t = { data: (int64, int64_elt, c_layout) Array1.t; pos: int; len: int; } let length t = t.len let mask ix = let int64_ix = ix / 64 in let bit_ix = ix mod 64 in let mask = Core_int64.shift_left Core_int64.one bit_ix in int64_ix, mask let unsafe_set data ix p = let int64_ix, mask = mask ix in let x = Array1.unsafe_get data int64_ix in let x = if p then Core_int64.bit_or x mask else Core_int64.bit_and x (Core_int64.bit_not mask) in Array1.unsafe_set data int64_ix x let unsafe_get t ix = let ix = ix + t.pos in let int64_ix, mask = mask ix in let x = Array1.unsafe_get t.data int64_ix in Core_int64.(<>) (Core_int64.bit_and x mask) Core_int64.zero let of_array arr = let len = Array.length arr in let data = Array1.create int64 c_layout ((len + 63) / 64) in Array.iteri arr ~f:(fun ix elt -> unsafe_set data ix elt); { data; pos = 0; len; } let unsafe_slice t ~pos ~len = { t with pos = t.pos + pos; len; } end) TEST_MODULE "bool" = Test(struct type elt = bool include (Core_bool : Comparable.S with type t := elt) module S = (Bool : S with type elt := elt) let test_list () = List.init 100 ~f:(fun ix -> Core_int.(=) 0 (ix mod 2)) end) module Tuple2 (A : Basic) (B : Basic) : sig type t type elt = A.elt * B.elt include (S with type elt := elt and type t := t) val zip_exn : A.t -> B.t -> t val unzip : t -> A.t * B.t end = struct module T = struct type t = A.t * B.t type elt = A.elt * B.elt with sexp, bin_io let length (a, _) = A.length a let unsafe_get (a, b) ix = A.unsafe_get a ix, B.unsafe_get b ix let unsafe_slice (a, b) ~pos ~len = (A.unsafe_slice a ~pos ~len, B.unsafe_slice b ~pos ~len) let of_array arr = let len = Array.length arr in let arr1, arr2 = if Core_int.(=) len 0 then [||], [||] else begin let arr1 = Array.create ~len (Tuple2.get1 arr.(0)) in let arr2 = Array.create ~len (Tuple2.get2 arr.(0)) in for i = len - 1 downto 1 do arr1.(i) <- Tuple2.get1 arr.(i); arr2.(i) <- Tuple2.get2 arr.(i); done; arr1, arr2 end in A.of_array arr1, B.of_array arr2 end include T include (Make(T) : S with type elt := elt and type t := t) let t_of_sexp sexp = of_array (<:of_sexp< (A.elt * B.elt) array >> sexp) let sexp_of_t t = <:sexp_of< (A.elt * B.elt) array >> (to_array t) exception Different_lengths with sexp let zip_exn a b = if Core_int.(=) (A.length a) (B.length b) then a, b else raise Different_lengths let unzip (a, b) = a, b end TEST_MODULE "int*float" = struct module T = Tuple2(Int)(Float) module Test = Test(struct type elt = int * float include Tuple.Comparable(Core_int)(Core_float) module S = (T : S with type elt := elt) let test_list () = List.init 100 ~f:(fun i -> i, Core_float.of_int i) end) TEST_MODULE = Test include Test TEST "zip_exn o unzip = id (empty)" = let xs = T.of_list [] in let a, b = T.unzip xs in array_equal (T.to_array (T.zip_exn a b)) (T.to_array xs) TEST "zip_exn o unzip = id (singleton)" = let xs = T.of_list [test_elt] in let a, b = T.unzip xs in array_equal (T.to_array (T.zip_exn a b)) (T.to_array xs) TEST "zip_exn o unzip = id (non-empty)" = let xs = T.of_list test_list in let a, b = T.unzip xs in array_equal (T.to_array (T.zip_exn a b)) (T.to_array xs) end module Of_binable (B : sig include Binable.S include Sexpable.S with type t := t end) = Make(struct type elt = B.t with sexp, bin_io type t = int array * Bin_prot.Common.buf let length (ps, _) = Array.length ps let unsafe_get (ps, buf) ix = B.bin_read_t buf ~pos_ref:(ref (Array.unsafe_get ps ix)) let of_array arr = let buf_size = Array.fold arr ~init:0 ~f:(fun acc elt -> acc + B.bin_size_t elt) in let buf = Bigstring.create buf_size in let posarr = Array.create ~len:(Array.length arr) 0 in ignore (Array.foldi arr ~init:0 ~f:(fun ix pos elt -> Array.unsafe_set posarr ix pos; B.bin_write_t buf ~pos elt)); posarr, buf let unsafe_slice (ixs, buf) ~pos ~len = Array.sub ixs ~pos ~len, buf end) module String = Of_binable(String) TEST_MODULE "string" = Test(struct type elt = string include (Core_string : Comparable.S with type t := elt) module S = (String : S with type elt := elt) let test_list () = List.init 100 ~f:Core_int.to_string end) module Of_packed_array(P : S) = struct module T = struct module Slices = Tuple2(Int)(Int) type elt = P.t with sexp, bin_io type t = Slices.t * P.t let length (ss, _) = Slices.length ss let unsafe_get (ss, buf) ix = let pos, len = Slices.unsafe_get ss ix in P.unsafe_slice buf ~pos ~len let of_array arr = let len = Array.length arr in let buf_size = Array.fold arr ~init:0 ~f:(fun acc elt -> acc + P.length elt) in let slices = Array.create ~len (0, 0) in let buf = if Core_int.(=) buf_size 0 then Array.empty () else begin (* No bounds check is necessary in this loop because buf_size <> 0 only when at least one element of the array is nonempty. *) let rec loop ix = let p = Array.unsafe_get arr ix in if Core_int.(=) (P.length p) 0 then loop (ix+1) else Array.create ~len:buf_size (P.unsafe_get p 0) in loop 0 end in ignore (Array.foldi arr ~init:0 ~f:(fun ix pos elt -> let old_pos = pos in let pos = P.fold elt ~init:pos ~f:(fun pos elt -> Array.unsafe_set buf pos elt; pos+1) in Array.unsafe_set slices ix (old_pos, pos - old_pos); pos)); Slices.of_array slices, P.of_array buf let unsafe_slice (ss, buf) ~pos ~len = Slices.unsafe_slice ss ~pos ~len, buf end include T include (Make(T) : S with type elt := elt and type t := t) let concat (ss, buf) = let ss_len = Slices.length ss in if Core_int.(=) ss_len 0 then P.empty else begin let (pos, _) = Slices.unsafe_get ss 0 in let (last_pos, last_len) = Slices.unsafe_get ss (ss_len - 1) in let len = last_pos + last_len - pos in P.unsafe_slice buf ~pos ~len end end TEST_MODULE "packed array of packed arrays of strings" = struct module T = struct type elt = String.t include Comparable.Make(struct type t = String.t with sexp let compare a b = List.compare Core_string.compare (String.to_list a) (String.to_list b) end) module S = Of_packed_array(String) let test_list () = List.init 100 ~f:(fun i -> String.of_list (List.init 100 ~f:(fun j -> Core_int.to_string (i*100 + j)))) let test_concat test_t = List.equal (String.to_list (S.concat test_t)) (List.concat_map (S.to_list test_t) ~f:String.to_list) ~equal:Core_string.equal TEST "concat" = test_concat (S.of_list (test_list ())) TEST "concat after slice" = test_concat (S.slice (S.of_list (test_list ())) ~pos:25 ~len:25) end TEST_MODULE = Test(T) end core_extended-113.00.00/src/packed_array.mli000066400000000000000000000055221256461102500205510ustar00rootroot00000000000000(** A packed array is a read-only array that has a fairly compact representation and will not be traversed by the GC. It's designed for cases where you might construct a very large array once and then read from it many times. Array access is reasonably efficient. Be warned, however, that construction can be excruciatingly slow and might even perform many intermediate allocations, depending on the type of array. *) open Core.Std (** [Basic] is the minimal interface you need to provide to make a packed array for a new type. *) module type Basic = sig type elt with sexp, bin_io type t val length : t -> int val unsafe_get : t -> int -> elt val of_array : elt array -> t val unsafe_slice : t -> pos:int -> len:int -> t end (** [S] is the packed array interface. *) module type S = sig include Basic include Sexpable.S with type t := t include Binable.S with type t := t val get : t -> int -> elt val slice : t -> pos:int -> len:int -> t val iter : t -> f:(elt -> unit) -> unit val fold : t -> init:'a -> f:('a -> elt -> 'a) -> 'a val of_array : elt array -> t val to_array : t -> elt array val of_list : elt list -> t val to_list : t -> elt list val empty : t end module Make (B : Basic) : S with type elt := B.elt and type t := B.t (** The representation of a packed array type created using [Of_binable] is a Bin_prot buffer and a packed array of indices pointing to the beginning of each serialized element in the buffer. *) module Of_binable (B : sig include Binable.S include Sexpable.S with type t := t end) : S with type elt := B.t (** the representation of a packed array of tuples is a tuple of packed arrays. This makes the [zip_exn] and [unzip] functions constant time. *) module Tuple2 (A : Basic) (B : Basic) : sig type elt = A.elt * B.elt include S with type elt := elt val zip_exn : A.t -> B.t -> t val unzip : t -> A.t * B.t end (** [Of_packed_array(P)] creates a packed array of packed arrays. The representation is a [P.t] and packed array of indices into it which point to the beginning of each inner array. *) module Of_packed_array (P : S) : sig include S with type elt := P.t val concat : t -> P.t end (** These primitive packed arrays are represented by their respective Bigarray types. *) module Bool : S with type elt := bool module Char : S with type elt := char module Int : S with type elt := int module Int8_unsigned : S with type elt := int module Int8 : S with type elt := int module Int16_unsigned : S with type elt := int module Int16 : S with type elt := int module Int32 : S with type elt := int32 module Int64 : S with type elt := int64 module Float32 : S with type elt := float module Float : S with type elt := float module String : S with type elt := string core_extended-113.00.00/src/packed_map.ml000066400000000000000000000153201256461102500200340ustar00rootroot00000000000000open Core.Std module type Key = sig type t with sexp, bin_io include Comparable.S with type t := t module Packed_array : Packed_array.S with type elt := t end module type Value = sig type t with sexp, bin_io module Packed_array : Packed_array.S with type elt := t end module type S = sig type t with sexp, bin_io type key with sexp, bin_io type value with sexp, bin_io val empty : t val of_alist : (key * value) list -> t val to_alist : t -> (key * value) list val of_aarray : (key * value) array -> t val of_sorted_aarray : (key * value) array -> t val of_hashtbl : (key, value) Hashtbl.t -> t val find : t -> key -> value option val mem : t -> key -> bool val iter : t -> f:(key:key -> data:value -> unit) -> unit val fold : t -> init:'acc -> f:(key:key -> data:value -> 'acc -> 'acc) -> 'acc end (* TODO How should we handle duplicate keys? *) module Make (K : Key) (V : Value) : S with type key := K.t and type value := V.t = struct type key = K.t with sexp, bin_io type value = V.t with sexp, bin_io module T = Packed_array.Tuple2 (struct include K.Packed_array type elt = K.t end) (struct include V.Packed_array type elt = V.t end) type t = T.t with sexp, bin_io let empty = T.empty exception Duplicate_key of key with sexp exception Unsorted_array of (key * value) array with sexp let fst (a, _) = a let cmp a b = K.compare (fst a) (fst b) let duplicate_key_sorted' arr = let len = Array.length arr in if len < 2 then None else with_return (fun r -> for i = 0 to len - 2 do if K.equal (fst (Array.unsafe_get arr i)) (fst (Array.unsafe_get arr (i+1))) then r.return (Some (fst (Array.unsafe_get arr i))) done; None) let duplicate_key_sorted arr = if not (Array.is_sorted arr ~cmp) then raise (Unsorted_array arr); duplicate_key_sorted' arr let of_sorted_aarray' = T.of_array let of_sorted_aarray arr = match duplicate_key_sorted arr with | None -> of_sorted_aarray' arr | Some k -> raise (Duplicate_key k) let of_aarray arr = of_sorted_aarray (Array.sorted_copy arr ~cmp) let destructive_of_aarray arr = Array.sort arr ~cmp; match duplicate_key_sorted' arr with | None -> of_sorted_aarray' arr | Some k -> raise (Duplicate_key k) let of_alist kvs = destructive_of_aarray (Array.of_list kvs) let to_alist = T.to_list exception Bottom of int;; let sort ~cmp a = let get = Array.unsafe_get in let set = Array.unsafe_set in let maxchild l i = let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < l then begin if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1; if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2; !x end else if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0 then i31+1 else if i31 < l then i31 else raise (Bottom i) in let rec trickledown l i e = let j = maxchild l i in if cmp (get a j) e > 0 then begin set a i (get a j); trickledown l j e; end else begin set a i e; end; in let trickle l i e = try trickledown l i e with Bottom i -> set a i e in let rec bubbledown l i = let j = maxchild l i in set a i (get a j); bubbledown l j in let bubble l i = try bubbledown l i with Bottom i -> i in let rec trickleup i e = let parent = (i - 1) / 3 in assert (i <> parent); if cmp (get a parent) e < 0 then begin set a i (get a parent); if parent > 0 then trickleup parent e else set a 0 e; end else begin set a i e; end; in let l = Array.length a in for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done; for i = l - 1 downto 2 do let e = (get a i) in set a i (get a 0); trickleup (bubble i 0) e; done; if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e); ;; let of_hashtbl tbl = let len = Hashtbl.length tbl in let arr = let x = ref None in ignore (Hashtbl.existsi tbl ~f:(fun ~key ~data -> x := Some (key, data); true)); match !x with | None -> Array.empty () | Some kv -> Array.create ~len kv in let ix = ref 0 in Hashtbl.iter tbl ~f:(fun ~key ~data -> let i = !ix in Array.unsafe_set arr i (key, data); ix := i + 1); sort arr ~cmp; of_sorted_aarray' arr let binary_search keys k = let rec binary_search ~low_inclusive ~high_inclusive = match compare low_inclusive high_inclusive with | 1 -> None | 0 -> Option.some_if (K.equal k (K.Packed_array.unsafe_get keys low_inclusive)) low_inclusive | -1 -> let ix = (low_inclusive + high_inclusive) / 2 in let k' = K.Packed_array.unsafe_get keys ix in begin match K.compare k k' with | -1 -> binary_search ~low_inclusive ~high_inclusive:(ix-1) | 0 -> Some ix | 1 -> binary_search ~low_inclusive:(ix+1) ~high_inclusive | _ -> assert false end | _ -> assert false in binary_search ~low_inclusive:0 ~high_inclusive:(K.Packed_array.length keys - 1) let find t k = let keys, values = T.unzip t in let ix = binary_search keys k in Option.map ix ~f:(fun ix -> V.Packed_array.unsafe_get values ix) let mem t k = let keys, _ = T.unzip t in Option.is_some (binary_search keys k) let iter t ~f = T.iter t ~f:(fun (key, data) -> f ~key ~data) let fold t ~init ~f = T.fold t ~init ~f:(fun acc (key, data) -> f ~key ~data acc) end TEST_MODULE "string->int" = struct module K = struct include String module Packed_array = (Packed_array.String : Packed_array.S with type elt := t) end module V = struct include Int module Packed_array = (Packed_array.Int : Packed_array.S with type elt := t) end module M = (Make(K)(V) : S with type key := string and type value := int) let keys = List.init 99 ~f:(fun ix -> let ix = if ix > 72 then ix+1 else ix in Int.to_string ix) let values = List.init 99 ~f:(fun ix -> if ix > 72 then ix+1 else ix) let alist = List.zip_exn keys values let packed_map = M.of_alist alist TEST "find (present)" = List.for_all keys ~f:(fun k -> match M.find packed_map k with | None -> false | Some v -> List.exists alist ~f:(fun (k', v') -> k = k' && v = v')) TEST "find (too low)" = assert ('/' < '0'); match M.find packed_map "/foo" with | None -> true | Some _ -> false TEST "find (too high)" = assert ('f' > '9'); not (M.mem packed_map "foo") TEST "find (not present)" = not (M.mem packed_map "73") TEST "find (empty)" = not (M.mem M.empty "foo") end core_extended-113.00.00/src/packed_map.mli000066400000000000000000000023711256461102500202070ustar00rootroot00000000000000(** A packed map is a map from keys to values, represented using a packed array of key-value tuples which is sorted by key. Construction is very slow, but lookup is a reasonable speed. The main purpose is to be able to construct very large lookup tables that don't have much GC overhead. *) open Core.Std module type Key = sig type t with sexp, bin_io include Comparable.S with type t := t module Packed_array : Packed_array.S with type elt := t end module type Value = sig type t with sexp, bin_io module Packed_array : Packed_array.S with type elt := t end module type S = sig type t with sexp, bin_io type key with sexp, bin_io type value with sexp, bin_io val empty : t val of_alist : (key * value) list -> t val to_alist : t -> (key * value) list val of_aarray : (key * value) array -> t val of_sorted_aarray : (key * value) array -> t val of_hashtbl : (key, value) Hashtbl.t -> t val find : t -> key -> value option val mem : t -> key -> bool val iter : t -> f:(key:key -> data:value -> unit) -> unit val fold : t -> init:'acc -> f:(key:key -> data:value -> 'acc -> 'acc) -> 'acc end module Make (K : Key) (V : Value) : S with type key := K.t and type value := V.t core_extended-113.00.00/src/posix_clock.ml000066400000000000000000000052321256461102500202660ustar00rootroot00000000000000open Core.Std INCLUDE "config.mlh" type t = | Realtime | Monotonic | Process_cpu | Process_thread let all = [ Realtime; Monotonic; Process_cpu; Process_thread; ] let to_string t = match t with | Realtime -> "Realtime" | Monotonic -> "Monotonic" | Process_cpu -> "Process_cpu" | Process_thread -> "Process_thread" IFDEF POSIX_TIMERS THEN external getres : t -> Int63.t = "caml_clock_getres" "noalloc" external gettime : t -> Int63.t = "caml_clock_gettime" "noalloc" module Int63_arithmetic : sig type t = Int63.t val ( - ) : t -> t -> t val ( / ) : t -> t -> t end = Int63 let min_interval t = let canary_val = Int63.of_int 1_000_000 in let current_min = ref canary_val in for _i = 1 to 10_000 do let t1 = gettime t in let t2 = gettime t in let open Int63.Replace_polymorphic_compare in let open Int63_arithmetic in if t1 <> t2 && t2 > t1 then current_min := min (t2 - t1) !current_min done; if !current_min <> canary_val then !current_min else failwith (Printf.sprintf !"unable to calculate min_interval for %{}" t) ;; let mean_gettime_cost ~measure ~using = assert (getres Process_cpu = Int63.one); let count = 10_000_000 in let start = gettime using in for _i = 1 to count do ignore (gettime measure); done; let stop = gettime using in Int63_arithmetic.((stop - start) / Int63.of_int count) ;; let getres = Ok getres let gettime = Ok gettime (* let nanosleep = Ok nanosleep *) let min_interval = Ok min_interval let mean_gettime_cost = Ok mean_gettime_cost ELSE let getres = Or_error.unimplemented "Posix_clock.getres" let gettime = Or_error.unimplemented "Posix_clock.gettime" (* let nanosleep = Or_error.unimplemented "Posix_clock.nanosleep" *) let min_interval = Or_error.unimplemented "Posix_clock.min_interval" let mean_gettime_cost = Or_error.unimplemented "Posix_clock.mean_gettime_cost" ENDIF module Time_stamp_counter = struct type t = int let diff t1 t2 = t1 - t2 IFDEF ARCH_x86_64 THEN external rdtsc : unit -> int = "caml_rdtsc" "noalloc" ELSE IFDEF ARCH_i386 THEN external rdtsc : unit -> int = "caml_rdtsc" "noalloc" ELSE let rdtsc () = failwith "Posix_clock.Time_stamp_counter.rdtsc \ is not implemented for this architecture." ENDIF ENDIF IFDEF ARCH_x86_64 THEN external rdtscp : unit -> int = "caml_rdtscp" "noalloc" ELSE IFDEF ARCH_i386 THEN external rdtscp : unit -> int = "caml_rdtscp" "noalloc" ELSE let rdtscp () = failwith "Posix_clock.Time_stamp_counter.rdtscp \ is not implemented for this architecture." ENDIF ENDIF end core_extended-113.00.00/src/posix_clock.mli000066400000000000000000000017631256461102500204440ustar00rootroot00000000000000(* The functions in this module are implemented on systems that support posix timers *) open Core.Std type t = | Realtime | Monotonic | Process_cpu | Process_thread val all : t list val to_string : t -> string (* returns the resulution of the given clock in nanoseconds *) val getres : (t -> Int63.t) Or_error.t (* returns the current value of the given clock in nanoseconds *) val gettime : (t -> Int63.t) Or_error.t (* sleeps the current thread for the specified number of nanoseconds *) (*val nanosleep : (t -> int -> unit) Or_error.t *) (* [min_interval t] returns the minimum measurable interval for t in nanoseconds *) val min_interval : (t -> Int63.t) Or_error.t (* [cost t] returns the cost of calling gettime with the given t int nanoseconds *) val mean_gettime_cost : (measure:t -> using:t -> Int63.t) Or_error.t module Time_stamp_counter : sig type t (* [rdtsc ()] returns the cpu cycle count *) val rdtsc : unit -> t val rdtscp : unit -> t val diff : t -> t -> int end core_extended-113.00.00/src/posix_clock_stubs.c000066400000000000000000000033721256461102500213230ustar00rootroot00000000000000#include "config.h" #include #include #include #include #ifdef JSC_POSIX_TIMERS #include #include #include #include #include #include #include #include #ifdef JSC_ARCH_SIXTYFOUR # define caml_alloc_int63(v) Val_long(v) #else # define caml_alloc_int63(v) caml_copy_int64(v) #endif clockid_t caml_clockid_t_of_caml (value clock_type) { switch (Int_val(clock_type)) { case 0: return CLOCK_REALTIME; case 1: return CLOCK_MONOTONIC; case 2: return CLOCK_PROCESS_CPUTIME_ID; case 3: return CLOCK_THREAD_CPUTIME_ID; }; caml_failwith ("invalid Clock.t"); } value caml_clock_getres (value clock_type) { struct timespec tp; clock_getres (caml_clockid_t_of_caml (clock_type), &tp); return (caml_alloc_int63 (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec)); } value caml_clock_gettime (value clock_type) { struct timespec tp; clock_gettime (caml_clockid_t_of_caml (clock_type), &tp); return (caml_alloc_int63 (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec)); } #endif /* JSC_POSIX_TIMERS */ #if defined (JSC_ARCH_i386) || defined (JSC_ARCH_x86_64) /* http://en.wikipedia.org/wiki/Time_Stamp_Counter */ CAMLprim value caml_rdtsc( ) { unsigned hi, lo; __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); return Val_int( ((unsigned long long)lo)|( ((unsigned long long)hi)<<32 )); } CAMLprim value caml_rdtscp( ) { unsigned hi, lo; __asm__ __volatile__ ("rdtscp" : "=a"(lo), "=d"(hi)); return Val_int( ((unsigned long long)lo)|( ((unsigned long long)hi)<<32 )); } #endif /* JSC_ARCH_i386 || JSC_ARCH_x86_64 */ core_extended-113.00.00/src/pp.ml000066400000000000000000000113511256461102500163670ustar00rootroot00000000000000open Core.Std let strlen = String.length let nl = "\n" type gmode = | GFlat (* hgrp *) | GBreak (* vgrp *) | GFill (* fgrp *) | GAuto (* agrp *) type t = | DocNil | DocCons of t * t | DocText of string | DocNest of int * t | DocBreak of string | DocGroup of gmode * t let ($) x y = DocCons(x,y) let empty = DocNil let text s = DocText(s) let nest i x = DocNest(i,x) let break = DocBreak(" ") let break_null = DocBreak ("") let break_with s = DocBreak(s) let hgrp d = DocGroup(GFlat, d) let vgrp d = DocGroup(GBreak,d) let agrp d = DocGroup(GAuto, d) let fgrp d = DocGroup(GFill, d) type sdoc = | SNil | SText of string * sdoc | SLine of int * sdoc (* newline + spaces *) let sdoc_to_string sdoc = let buf = Buffer.create 256 in let rec loop = function | SNil -> () | SText(s,d) -> ( Buffer.add_string buf s ; loop d ) | SLine(i,d) -> let prefix = String.make i ' ' in ( Buffer.add_char buf '\n' ; Buffer.add_string buf prefix ; loop d ) in ( loop sdoc ; Buffer.contents buf ) let sdoc_to_file oc doc = let pstr = output_string oc in let rec loop = function | SNil -> () | SText(s,d) -> pstr s; loop d | SLine(i,d) -> let prefix = String.make i ' ' in pstr nl; pstr prefix; loop d in loop doc type mode = | Flat | Break | Fill let rec fits w = function | _ when w < 0 -> false | [] -> true | (_,_,DocNil) :: z -> fits w z | (i,m,DocCons(x,y)) :: z -> fits w ((i,m,x)::(i,m,y)::z) | (i,m,DocNest(j,x)) :: z -> fits w ((i+j,m,x)::z) | (_,_,DocText(s)) :: z -> fits (w - strlen s) z | (_,Flat, DocBreak(s)) :: z -> fits (w - strlen s) z | (_,Fill, DocBreak(_)) :: _ -> true | (_,Break,DocBreak(_)) :: _ -> true | (i,_,DocGroup(_,x)) :: z -> fits w ((i,Flat,x)::z) (* format is cps to avoid stack overflow *) let cons s post z = post (SText (s, z)) let consl i post z = post (SLine (i, z)) let rec format w k l post = match l with | [] -> post SNil | (_,_,DocNil) :: z -> format w k z post | (i,m,DocCons(x,y)) :: z -> format w k ((i,m,x)::(i,m,y)::z) post | (i,m,DocNest(j,x)) :: z -> format w k ((i+j,m,x)::z) post | (_,_,DocText(s)) :: z -> format w (k + strlen s) z (cons s post) | (_,Flat, DocBreak(s)) :: z -> format w (k + strlen s) z (cons s post) | (i,Fill, DocBreak(s)) :: z -> let l = strlen s in if fits (w - k - l) z then format w (k+l) z (cons s post) else format w i z (consl i post) | (i,Break,DocBreak(_)) :: z -> format w i z (consl i post) | (i,_,DocGroup(GFlat ,x)) :: z -> format w k ((i,Flat ,x)::z) post | (i,_,DocGroup(GFill ,x)) :: z -> format w k ((i,Fill ,x)::z) post | (i,_,DocGroup(GBreak,x)) :: z -> format w k ((i,Break,x)::z) post | (i,_,DocGroup(GAuto, x)) :: z -> if fits (w-k) ((i,Flat,x)::z) then format w k ((i,Flat ,x)::z) post else format w k ((i,Break,x)::z) post let default_width = 80 let to_string ?(width=default_width) doc = format width 0 [0,Flat,agrp(doc)] sdoc_to_string let to_file ?(width=default_width) oc doc = format width 0 [0,Flat,agrp(doc)] (sdoc_to_file oc) let list ~sep ~f xs = let rec loop acc = function | [] -> acc | [x] -> acc $ f x | x::xs -> loop (acc $ f x $ sep) xs in loop empty xs let commalist ~f = list ~sep:(text "," $ break_null) ~f let ($/) x y = x $ break $ y let ($//) x y = x $ break_null $ y let block ?(indent=4) ~f xs = agrp (nest indent (text "{" $/ begin list ~sep:(text ";" $ break) ~f xs end) $/ text "}") module Infix = struct let ($) = ($) and ($/) = ($/) and ($//) = ($//) end let vlist, alist, hlist = let group f l = f (List.fold l ~init:empty ~f:(fun pp p -> pp $ break $ p)) in group vgrp, group agrp, group hgrp core_extended-113.00.00/src/pp.mli000066400000000000000000000134231256461102500165420ustar00rootroot00000000000000(** Functional pretty printing. *) (** This is a pretty printing library originally written by Christian Lindig and released under the Copyleft licence for the {{:http://www.cminusminus.org}c--} project. The design of this library is discussed in the article "{{: http://citeseer.ist.psu.edu/lindig00strictly.html}Strictly pretty}". The pretty printer provided by the [Pp] module is intended for tree-like structures. Documents are represented by an abstract type [t]. A document can be printed to a file or a string and during this process the pretty printer decides about the final outcome of the document. The only parameter it takes into account is the total line width and the number of characters a sub-document occupies. A document of type [t] can be very small entity like a single word. Functions combine small documents to larger ones which then can be pretty printed. @author Christian Lindig @author Till Varoquaux @see PPrint. *) type t (** The empty document is pretty printed to the empty string. Typically [empty] is used in one branch of an [if] statement. *) val empty : t (** The infix operator [x $ y] concatenates two documents [x] and [y] into a larger one. It does not introduce any space or other separation between the two original documents. *) val ($) : t -> t -> t (** The [text] function turns a string into a document. The pretty printed representation of the resulting document is exactly the string [text] was applied to.*) val text : string -> t (** The important points in a document are so-called [break]s. A [break] can be either represented by a single space or a newline followed by a number of spaces. The pretty printer makes this decision based on the available space. So think of a [break] as a space that might come out as a newline. To give the pretty printer enough flexibility documents must be joined with [break]s: [x $ break $ y]. *) val break : t (** [break_null] behaves like [break] except it does not insert anything when no newline is inserted.*) val break_null : t (** The space character used by [break] my be not always appropriate. The function [break_with s] behaves like [break] except that it uses a user supplied string [s] instead of the space.*) val break_with : string -> t (**{3 Grouping and nesting} The pretty printer considers the representation of [break]s not one by one but looks at all [break]s of a sub-document. Documents are structured into sub-documents by group-operators. Different group operators exist to control the behavior of the pretty printer. *) (** When the pretty printer decides to represent a [break] as a newline it also prints some spaces after it to indent the following line. The number of spaces is controlled by the [nest] operator that takes a document as argument: [nest n d]. All breaks turned to newlines inside document [d] are followed by [n] spaces. The [nest] operator nests properly such that it takes the spaces introduced by [nest]s on the outer level also into account. *) val nest : int -> t -> t (** A group operator takes a document and let it become a group. The [hgrp] operator creates a {i horizontal} group. Breaks inside a [hgrp] are never turned into newlines but always come out as spaces. This group has a very limited usefulness because it easily overruns any given line length. *) val hgrp : t -> t (** The [vgrp] operator creates a {i vertical} group. All [break]s inside a [vgrp] are represented as newlines followed by spaces. Although all [break]s come out as newlines the indentation of lines inside the group may differ: nesting is independent of grouping and thus different nesting levels can be active in the same group. Because of the fixed pretty printing strategy [vgrp]s are used mostly at the top level of documents only.*) val vgrp : t -> t (** The {i automatic} group [agrp] is the most versatile. Breaks inside this group are either all turned into newlines (followed by spaces), or into spaces. Subgroups are, of course, not affected but considered individually.*) val agrp : t -> t (** The break policy inside an [agrp] is fixed for all breaks of the group. Inside a {i flexible} group [fgrp] each [break] is considered individually: when the document up to the next [break] fits into the current line the [break] comes out as space. Otherwise it comes out as newline followed by spaces.*) val fgrp : t -> t (**{3 Pretty Printing} *) val to_string : ?width:int -> t -> string val to_file : ?width:int -> out_channel -> t -> unit (**{3 Auxiliaries}*) (** A list of objects which are seperated by some seperator is very common. The [list sep f] function takes care to insert the separator only between objects but not at the end of the list. It creates a [sep] separated list. Individual items are printed using [f]. For the common case where commas are used for separating we also provide an extra definition*) val list : sep:t -> f:('a -> t) -> 'a list -> t val commalist : f:('a -> t) -> 'a list -> t (** Instead of writing [x $ break $ y] to insert a [break] it is convenient to define an operator for this: [x ^/ y] joins [x] and [y] with a [break]. *) val ($/) : t -> t -> t (** Joins two documents with a [break_null].*) val ($//) : t -> t -> t (** A [block] contains objects [xs] formatted by [f] and enclosed by curly braces. Its body will be indented in case it does not fit on a single line. The default indentation is 4 *) val block : ?indent:int -> f:('a -> t) -> 'a list -> t module Infix : sig val ($) : t -> t -> t val ($/) : t -> t -> t val ($//) : t -> t -> t end (** {[ hlist [x1,..,xn] = hgrp [x1; break; x2; ...; break; xn) ]} *) val hlist : t list -> t (** {[ vlist [x1,..,xn] = vgrp [x1; break; x2; ...; break; xn) ]} *) val vlist : t list -> t val alist : t list -> t core_extended-113.00.00/src/printc.ml000066400000000000000000000015321256461102500172470ustar00rootroot00000000000000open Core.Std let (~:) l = String.concat l let (~%) = sprintf let print = print_string let fprint = output_string let eprint x = output_string stderr x let printl s = print s; print "\n"; flush stdout let fprintl f s = fprint f s; fprint f "\n"; flush stdout let eprintl s = eprint s; eprint "\n"; flush stderr let pad side ?(fill=' ') n s = let orig_len = String.length s in if orig_len >= n then s else let s' = String.make n fill in let dst_pos = match side with | `left -> n - orig_len | `right -> 0 in String.blit ~src:s ~dst:s' ~src_pos:0 ~dst_pos ~len:orig_len; s' let lpad ?fill n s = pad `left ?fill n s let rpad ?fill n s = pad `right ?fill n s let i2s = Int.to_string let f2s = Float.to_string (* let f2s fmt f = let fmt = Scanf.sscanf (~:["\"";fmt;"\""]) "%{%f%}" (fun i -> i) in sprintf fmt f *) core_extended-113.00.00/src/printc.mli000066400000000000000000000014611256461102500174210ustar00rootroot00000000000000val (~:) : string list -> string (** alias for String.concat *) val (~%) : ('a,unit,string) format -> 'a (** alias for sprintf *) (** printing functions *) val print : string -> unit val eprint : string -> unit val fprint : out_channel -> string -> unit (** printing functions that add endlines *) val printl : string -> unit val eprintl : string -> unit val fprintl : out_channel -> string -> unit (* adds padding to the left-hand side, filling with spaces by default *) val lpad : ?fill:Char.t -> int -> string -> string (* adds padding to the right-hand side, filling with spaces by default *) val rpad : ?fill:Char.t -> int -> string -> string (* [i2s n] returns a string representation of n *) val i2s : int -> string (* [f2s x] returns a string representation of x *) val f2s : float -> string core_extended-113.00.00/src/process.ml000066400000000000000000000326171256461102500174360ustar00rootroot00000000000000open Core.Std module Sys = Caml.Sys let rec temp_failure_retry f = try f () with Unix.Unix_error (EINTR, _, _) -> temp_failure_retry f let close_non_intr fd = temp_failure_retry (fun () -> Unix.close fd) (* Creates a unix pipe with both sides set close on exec *) let cloexec_pipe () = let (fd1,fd2) as res = Unix.pipe () in Unix.set_close_on_exec fd1; Unix.set_close_on_exec fd2; res module Process_info = struct type t = { pid:int; stdin : Unix.File_descr.t; stdout : Unix.File_descr.t; stderr : Unix.File_descr.t; } end (* We use a slightly more powerful version of create process than the one in core. This version is not quite as carefuly code reviewed but allows us to have more control over the forked side of the process (e.g.: chdir). *) let internal_create_process ?working_dir ?setuid ?setgid ~env ~prog ~args () = let close_on_err = ref [] in try let (in_read, in_write) = cloexec_pipe () in close_on_err := in_read :: in_write :: !close_on_err; let (out_read, out_write) = cloexec_pipe () in close_on_err := out_read :: out_write :: !close_on_err; let (err_read, err_write) = cloexec_pipe () in close_on_err := err_read :: err_write :: !close_on_err; let pid = Extended_unix.fork_exec prog args ?working_dir ?setuid ?setgid ~env ~stdin:in_read ~stdout:out_write ~stderr:err_write in close_non_intr in_read; close_non_intr out_write; close_non_intr err_write; { Process_info.pid = Pid.to_int pid; stdin = in_write; stdout = out_read; stderr = err_read } with e -> List.iter ~f:(fun fd -> try close_non_intr fd with _ -> ()) !close_on_err; raise e (** Remembers the last n-characters appended to it.... *) module Tail_buffer = struct (** remembers the output in a circular buffer. looped is used to tell whether we loop around the boundary of the buffer. *) type t = { buffer : string; length : int; mutable looped : bool; mutable position : int; } let contents b = if not b.looped then String.sub b.buffer ~pos:0 ~len:b.position else let dst = String.create (b.length + 3) in dst.[0] <- '.'; dst.[1] <- '.'; dst.[2] <- '.'; String.blit ~src:b.buffer ~dst ~dst_pos:3 ~src_pos:b.position ~len:(b.length - b.position); String.blit ~src:b.buffer ~dst ~dst_pos:(b.length - b.position + 3) ~src_pos:0 ~len:(b.position); dst let create len = { buffer = String.create len; length = len; looped = false; position = 0 } let add b src len = if b.length <= len then begin String.blit ~src ~dst:b.buffer ~dst_pos:0 ~src_pos:(len - b.length) ~len:(b.length); b.looped <- true; b.position <- 0 end else let leftover = b.length - b.position in if (len < leftover) then begin String.blit ~src ~dst:b.buffer ~dst_pos:b.position ~src_pos:0 ~len; b.position <- b.position + len; end else begin String.blit ~src ~dst:b.buffer ~dst_pos:b.position ~src_pos:0 ~len:leftover; b.looped <- true; let len = (len-leftover) in String.blit ~src ~dst:b.buffer ~dst_pos:0 ~src_pos:leftover ~len; b.position <- len end end module Status = struct type t = [ `Timeout of Time.Span.t | `Exited of int | `Signaled of Signal.t (* WStopped is impossible*) ] with sexp_of let to_string = function | `Exited i -> sprintf "exited with code %d" i | `Signaled s -> sprintf !"died after receiving %{Signal} (signal number %d)" s (Signal.to_system_int s) | `Timeout s -> sprintf !"Timed out (ran for %{Time.Span})" s end module Command_result = struct type t= { status: Status.t; stdout_tail : string; stderr_tail : string } end (** wait for a given pid to exit; returns true when the process exits and false if the process is still runing after waiting for [span] *) let wait_for_exit ?(is_child=false) span pid = let end_time = Time.add (Time.now ()) span in let exited () = if is_child then begin (* Non interuptible when used with WNOHANG*) match Caml.Unix.waitpid [Caml.Unix.WNOHANG] pid with | 0,_ -> true | v, _ -> assert (v=pid); false end else try (* The conversion function for signals is the identity on 0 so this is the equivalent of calling the c kill with 0 (test whether a process exists) *) Caml.Unix.kill pid 0; (* Non interuptible *) true with Unix.Unix_error (ESRCH,_,_) -> false in let rec loop () = if Time.(>) (Time.now ()) end_time then false (*We need to explicitely waitpid the child otherwise we are sending signals to a zombie*) else if not (exited ()) then true else begin Time.pause (sec 0.1); loop () end in loop () let kill ?is_child ?(wait_for=sec 2.0) ?(signal=Caml.Sys.sigterm) pid = Caml.Unix.kill pid signal; if not (wait_for_exit ?is_child wait_for pid) then begin begin try Caml.Unix.kill Caml.Sys.sigkill pid with Unix.Unix_error (ESRCH,_,_) -> () end; if not (wait_for_exit wait_for pid) then begin failwithf "Process.kill failed to kill %i \ (or the process wasn't collected by its parent)" pid () end end type t = { mutable open_fds : Unix.File_descr.t list; mutable in_fds : Unix.File_descr.t list; mutable out_fds : Unix.File_descr.t list; keep_open : bool; buf : String.t; in_cnt : String.t; in_len : int; out_callbacks : (Unix.File_descr.t*(string -> int -> unit)) list; pid : int; mutable in_pos : int; } let close_pooled state fd = if List.mem state.open_fds fd then close_non_intr fd; state.open_fds <- List.filter ~f:((<>) fd) state.open_fds; state.out_fds <- List.filter ~f:((<>) fd) state.out_fds; state.in_fds <- List.filter ~f:((<>) fd) state.in_fds let process_io ~read ~write state = List.iter write ~f:(fun fd -> (try let len = temp_failure_retry (fun () -> Unix.single_write fd ~buf:state.in_cnt ~pos:state.in_pos ~len:(state.in_len - state.in_pos)) in state.in_pos <- state.in_pos + len; (* Close the process's in_channel iff we are done writing to it*) if len = 0 then if state.keep_open then state.in_fds <- List.filter ~f:((<>) fd) state.in_fds else close_pooled state fd with Unix.Unix_error (EPIPE, _, _) -> close_pooled state fd)); List.iter read ~f:(fun fd -> let len = temp_failure_retry (fun () -> Unix.read fd ~buf:state.buf ~pos:0 ~len:(String.length state.buf)) in if len = 0 then close_pooled state fd else let callback = List.Assoc.find_exn state.out_callbacks fd in callback state.buf len) let available_fds = let use_select state ~timeout = let { Unix.Select_fds. read; write; _; } = temp_failure_retry (fun () -> Unix.select ~read:state.out_fds ~write:state.in_fds ~except:[] ~timeout ()) in read,write in let use_epoll epoll_create = fun state ~timeout -> let module Epoll = Linux_ext.Epoll in let timeout = match timeout with | (`Immediately | `Never) as timeout -> timeout | `After span -> `After span in let epoll_t = let fds = List.map ~f:Unix.File_descr.to_int (state.in_fds @ state.out_fds) in let max_ready_events = List.length fds in let num_file_descrs = 1 + List.fold ~init:max_ready_events ~f:Int.max fds in epoll_create ~num_file_descrs ~max_ready_events in List.iter state.in_fds ~f:(fun fd -> Epoll.set epoll_t fd Epoll.Flags.out); List.iter state.out_fds ~f:(fun fd -> Epoll.set epoll_t fd Epoll.Flags.in_); let read, write = match temp_failure_retry (fun () -> Epoll.wait epoll_t ~timeout) with | `Timeout -> ([], []) | `Ok -> Epoll.fold_ready epoll_t ~init:([], []) ~f:(fun (read, write) fd flags -> let take_matching_flags acc fd flags ~wanted = if Epoll.Flags.do_intersect wanted flags then fd :: acc else acc in let read = take_matching_flags read fd flags ~wanted:Epoll.Flags.in_ in let write = take_matching_flags write fd flags ~wanted:Epoll.Flags.out in (read, write)) in Epoll.close epoll_t; (read, write) in match Linux_ext.Epoll.create with | Error _ -> use_select | Ok epoll_create -> use_epoll epoll_create ;; let create ~keep_open ~use_extra_path ~working_dir ~setuid ~setgid ~prog ~args ~stdoutf ~stderrf ~input_string ~env = let full_prog = Shell__core.path_expand ?use_extra_path prog in let process_info = internal_create_process ?working_dir ?setuid ?setgid ~env ~prog:full_prog ~args () in let out_fd = process_info.Process_info.stdout and in_fd = process_info.Process_info.stdin and err_fd = process_info.Process_info.stderr and pid = process_info.Process_info.pid in { keep_open; open_fds = [in_fd;out_fd;err_fd]; in_fds = [in_fd]; out_fds = [err_fd;out_fd]; buf = String.create 4096; in_cnt = input_string; in_pos = 0; in_len = String.length input_string; out_callbacks = [out_fd,stdoutf; err_fd,stderrf]; pid } let rec finish_reading state = match available_fds state ~timeout:`Immediately with | [] ,_ -> () | read,_ -> process_io state ~read ~write:[]; finish_reading state let rec run_loop ~start_time ~timeout state = let read,write = available_fds state ~timeout:(`After (Time_ns.Span.of_sec 0.1)) in begin try process_io state ~read ~write with e -> kill ~is_child:true state.pid; raise e end; let elapsed = Time.diff (Time.now ()) start_time in match timeout with | Some timeout when Time.Span.(elapsed > timeout) -> kill ~is_child:true state.pid; finish_reading state; `Timeout elapsed | None | Some _ -> match Caml.Unix.waitpid [Caml.Unix.WNOHANG] state.pid with | 0,_ -> run_loop ~start_time ~timeout state | _, status -> finish_reading state; match status with | Caml.Unix.WEXITED i -> `Exited i | Caml.Unix.WSIGNALED s -> `Signaled (Signal.of_caml_int s) | Caml.Unix.WSTOPPED _ -> assert false let run ?timeout ?use_extra_path ?working_dir ?setuid ?setgid ?(env=`Extend []) ?input:(input_string="") ?(keep_open=false) ?(stdoutf=(fun _string _len -> ())) ?(stderrf=(fun _string _len -> ())) ?(tail_len = 2048) ~prog ~args () = let stdout_tail = Tail_buffer.create tail_len and stderr_tail = Tail_buffer.create tail_len in let stdoutf sbuf len = stdoutf sbuf len; Tail_buffer.add stdout_tail sbuf len and stderrf sbuf len = stderrf sbuf len; Tail_buffer.add stderr_tail sbuf len in let status = protectx (Sys.signal Sys.sigpipe Sys.Signal_ignore, create ~keep_open ~use_extra_path ~working_dir ~setuid ~setgid ~stderrf ~stdoutf ~prog ~args ~env ~input_string) ~f:(fun (_old_sigpipe,state) -> run_loop state ~start_time:(Time.now ()) ~timeout;) ~finally:(fun (old_sigpipe,state) -> List.iter state.open_fds ~f:close_non_intr; ignore (Sys.signal Sys.sigpipe old_sigpipe : Sys.signal_behavior)) in {Command_result. status = status; stdout_tail = Tail_buffer.contents stdout_tail; stderr_tail = Tail_buffer.contents stderr_tail } (* Externally export this *) let kill ?is_child ?wait_for ?signal pid = let signal = Option.map ~f:Signal.to_caml_int signal in kill ?is_child ?wait_for ?signal (Pid.to_int pid) TEST_MODULE = struct let with_fds n ~f = let restore_max_fds = let module RLimit = Core.Std.Unix.RLimit in let max_fds = RLimit.get RLimit.num_file_descriptors in match max_fds.RLimit.cur with | RLimit.Infinity -> None | RLimit.Limit limit when Int64.(of_int Int.(2 * n) < limit) -> None | RLimit.Limit _ -> RLimit.set RLimit.num_file_descriptors { max_fds with RLimit.cur = RLimit.Limit (Int64.of_int (2 * n)) }; Some max_fds in let fds = List.init n ~f:(fun _ -> Unix.openfile ~mode:[ Unix.O_RDONLY ] "/dev/null") in let retval = Or_error.try_with f in List.iter fds ~f:(fun fd -> Unix.close fd); Option.iter restore_max_fds ~f:(fun max_fds -> let module RLimit = Core.Std.Unix.RLimit in RLimit.set RLimit.num_file_descriptors max_fds); Or_error.ok_exn retval let run_process () = ignore (run ~prog:"true" ~args:[] ()) TEST_UNIT = with_fds 10 ~f:run_process TEST_UNIT = with_fds 1055 ~f:(fun () -> <:test_eq< bool >> (Result.is_ok Linux_ext.Epoll.create) (Result.is_ok (Result.try_with run_process))) end core_extended-113.00.00/src/process.mli000066400000000000000000000024341256461102500176010ustar00rootroot00000000000000(** Low-level process handling This is low-level enough that you should probably be using [Shell] instead to dispatch processes. *) open Core.Std module Status : sig type t = [ `Timeout of Time.Span.t | `Exited of int | `Signaled of Signal.t (* WStopped is impossible*) ] with sexp_of val to_string : t -> string end module Command_result : sig type t= { status : Status.t; stdout_tail : string; stderr_tail : string } end (** kills a process by sending [signal]; waiting for [wait_for] and then sending a [sigkill]. You need to set is_child to true when killing child processes or run waitpid on them in another. @raises Failure if the target program hangs for more that [wait_for] after receiving the [sigkill]. *) val kill : ?is_child:bool -> ?wait_for:Time.Span.t -> ?signal:Signal.t -> Pid.t -> unit val run : ?timeout:Time.Span.t -> ?use_extra_path:bool -> ?working_dir:string -> ?setuid:int -> ?setgid:int -> ?env:([`Extend of (string * string) list | `Replace of (string * string) list]) -> ?input:string -> ?keep_open:bool -> ?stdoutf:(string -> int -> unit) -> ?stderrf:(string -> int -> unit) -> ?tail_len:int -> prog:string -> args:string list -> unit -> Command_result.t core_extended-113.00.00/src/procfs.ml000066400000000000000000001106241256461102500172470ustar00rootroot00000000000000open Core.Std open Sexplib_num.Std (* Learn more about this business by consulting proc(5) *) (* lu and ld match the proc(5) format strings %lu and %ld *) let lu x = Big_int.big_int_of_string x let ld x = lu x (* bigint everything so we don't have to worry about overflows *) (* In_channel.input_all creates a 64k buffer and string every time. Also, In_channel.t's are custom blocks with finalizers that are allocated on the major heap. get_all_procs calls this many, many times and causes terrible GC performance. This un-thread-safe version is a work-around. *) let input_all_with_reused_buffer () = let buf_size = 65536 in let buf = String.create buf_size in let buffer = Buffer.create buf_size in let read_all fd = let rec loop () = let len = Unix.read fd ~buf ~len:(String.length buf) in if len > 0 then begin Buffer.add_substring buffer buf 0 len; loop (); end in loop (); let res = Buffer.contents buffer in Buffer.clear buffer; res in let input_all fn = Unix.with_file fn ~mode:[Unix.O_RDONLY] ~f:read_all in stage input_all ;; let string_of_file = unstage (input_all_with_reused_buffer ()) type bigint = Big_int.big_int with sexp ;; module Process = struct module Inode = struct type t = Int64.t with sexp ;; let of_string = Int64.of_string ;; let to_string = Int64.to_string ;; end ;; module Limits = struct module Rlimit = struct type value = [ `unlimited | `limited of bigint ] with sexp ;; type t = { soft : value; hard: value } with fields, sexp ;; end ;; type t = { cpu_time : Rlimit.t; file_size : Rlimit.t; data_size : Rlimit.t; stack_size : Rlimit.t; core_file_size : Rlimit.t; resident_set : Rlimit.t; processes : Rlimit.t; open_files : Rlimit.t; locked_memory : Rlimit.t; address_space : Rlimit.t; file_locks : Rlimit.t; pending_signals : Rlimit.t; msgqueue_size : Rlimit.t; nice_priority : Rlimit.t; realtime_priority : Rlimit.t; } with fields, sexp ;; let of_string s = let map = String.split s ~on:'\n' |! List.map ~f:String.strip |! List.filter ~f:(fun line -> line <> "") |! List.fold ~init:String.Map.empty ~f:(fun map line -> match String.strip line |! String.lowercase |! String.split ~on:' ' |! List.filter ~f:(fun s -> s <> "") |! List.rev with | ("units" | "seconds" | "bytes" | "processes" | "locks" | "signals" | "files") :: hard_limit :: soft_limit :: name -> let key = List.rev name |! String.concat ~sep:" " in Map.add map ~key ~data:(soft_limit, hard_limit) (* priorities don't have an entry in the "Units" column *) | hard_limit :: soft_limit :: name -> let key = List.rev name |! String.concat ~sep:" " in Map.add map ~key ~data:(soft_limit, hard_limit) | _ -> failwithf "Procfs.Limits.of_string bad format: %s" line () ) in let get key = let data = match Map.find map key with | Some data -> data | None -> failwithf "Procfs.Limits.of_string: bad key %s" key () in let value x = if x = "unlimited" then `unlimited else `limited (Big_int.big_int_of_string x) in { Rlimit.soft = fst data |! value; hard = snd data |! value } in { cpu_time = get "max cpu time"; file_size = get "max file size"; data_size = get "max data size"; stack_size = get "max stack size"; core_file_size = get "max core file size"; resident_set = get "max resident set"; processes = get "max processes"; open_files = get "max open files"; locked_memory = get "max locked memory"; address_space = get "max address space"; file_locks = get "max file locks"; pending_signals = get "max pending signals"; msgqueue_size = get "max msgqueue size"; nice_priority = get "max nice priority"; realtime_priority = get "max realtime priority" } end ;; module Stat = struct type t = { comm : string; (** The filename of the executable *) state : char; (** One character from the string "RSDZTW" *) ppid : Pid.t option; (** The PID of the parent. *) pgrp : Pid.t option; (** The process group ID of the process. *) session : int; (** The session ID of the process. *) tty_nr : int; (** The tty the process uses. *) tpgid : int; (** The process group ID of the process which currently owns the tty... *) flags : bigint; (** The kernel flags word of the process. *) minflt : bigint; (** The number of minor faults the process has made which have not required loading a memory page from disk. *) cminflt : bigint; (** The number of minor faults that the process’s waited-for children have made. *) majflt : bigint; (** The number of major faults the process has made which have required loading a page from disk. *) cmajflt : bigint; (** The number of major faults that the process’s waited-for children have made. *) utime : bigint; (** The number of jiffies that this process has been scheduled in user mode. *) stime : bigint; (** The number of jiffies that this process has been scheduled in kernel mode. *) cutime : bigint; (** The number of jiffies that this process’s waited-for children have been scheduled in user mode. *) cstime : bigint; (** The number of jiffies that this process’s waited-for children have been scheduled in kernel mode. *) priority : bigint; (** The standard nice value, plus fifteen. The value is never negative in the kernel. *) nice : bigint; (** The nice value ranges from 19 to -19*) unused : bigint; (** placeholder for removed field *) itrealvalue : bigint; (** The time in jiffies before the next SIGALRM is sent to the process due to an interval timer. *) starttime : bigint; (** The time in jiffies the process started after system boot.*) vsize : bigint; (** Virtual memory size in bytes. *) rss : bigint; (** Resident Set Size: number of pages the process has in real memory. *) rlim : bigint; (** Current limit in bytes on the rss of the process. *) startcode : bigint; (** The address above which program text can run. *) endcode : bigint; (** The address below which program text can run. *) startstack : bigint; (** The address of the start of the stack. *) kstkesp : bigint; (** The current value of esp (stack pointer) *) kstkeip : bigint; (** The current value of eip (instruction pointer) *) signal : bigint; (** The bitmap of pending signals. *) blocked : bigint; (** The bitmap of blocked signals. *) sigignore : bigint; (** The bitmap of ignored signals. *) sigcatch : bigint; (** The bitmap of caught signals. *) wchan : bigint; (** This is the "channel" in which the process is waiting. Address of a system call. *) nswap : bigint; (** (no longer maintained) *) cnswap : bigint; (** (no longer maintained) *) exit_signal : int; (** Signal sent to parent when we die. *) processor : int; (** CPU number last executed on. *) rt_priority : bigint; (** Real-time scheduling priority. *) policy : bigint; (** Scheduling policy *) } with fields, sexp ;; (* extract_command, for a stat string such as: "14574 (cat) R 10615 14574 10615 34820 14574 4194304 164 0..." returns this tuple "cat", "R 10615 14574 10615..." *) let extract_command s = let i = String.index_exn s '(' in let j = String.rindex_exn s ')' in (`command (String.sub s ~pos:(i+1) ~len:(j-(i+1))), `rest (String.sub s ~pos:(j+1) ~len:(String.length s - (j+1)))) let of_string s = let `command comm, `rest rest = extract_command s in let a = Array.of_list (String.split (String.strip rest) ~on:' ') in let d x = int_of_string x in let c x = x.[0] in { comm = comm; state = c a.(0); ppid = (match d a.(1) with | x when x < 1 -> None | x -> Some (Pid.of_int x)); (*pgrp = Pid.of_int (d a.(2)); *) pgrp = (match (d a.(2)) with | x when x < 1 -> None | x -> Some (Pid.of_int x)); session = d a.(3); tty_nr = d a.(4); tpgid = d a.(5); flags = ld a.(6); minflt = ld a.(7); cminflt = ld a.(8); majflt = ld a.(9); cmajflt = ld a.(10); utime = ld a.(11); stime = ld a.(12); cutime = ld a.(13); cstime = ld a.(14); priority = ld a.(15); nice = ld a.(16); unused = ld a.(17); itrealvalue = ld a.(18); starttime = lu a.(19); vsize = lu a.(20); rss = ld a.(21); rlim = lu a.(22); startcode = lu a.(23); endcode = lu a.(24); startstack = lu a.(25); kstkesp = lu a.(26); kstkeip = lu a.(27); signal = lu a.(28); blocked = lu a.(29); sigignore = lu a.(30); sigcatch = lu a.(31); wchan = lu a.(32); nswap = lu a.(33); cnswap = lu a.(34); exit_signal = d a.(35); processor = d a.(36); rt_priority = lu a.(37); policy = lu a.(38); } ;; end ;; module Statm = struct type t = { size : bigint; (** total program size *) resident : bigint; (** resident set size *) share : bigint; (** shared pages *) text : bigint; (** text (code) *) lib : bigint; (** library *) data : bigint; (** data/stack *) dt : bigint; (** dirty pages (unused) *) } with fields, sexp ;; let of_string s = let a = Array.of_list (String.split s ~on:' ') in { size = lu a.(0); resident = lu a.(1); share = lu a.(2); text = lu a.(3); lib = lu a.(4); data = lu a.(5); dt = lu a.(6); } ;; end ;; module Status = struct type t = { uid : int; (** Real user ID *) euid : int; (** Effective user ID *) suid : int; (** Saved user ID *) fsuid : int; (** FS user ID *) gid : int; (** Real group ID *) egid : int; (** Effective group ID *) sgid : int; (** Saved group ID *) fsgid : int; (** FS group ID *) } with fields, sexp ;; let of_string s = (* Splits "foo: 1\nbar: 2\n" into [Some ("foo"," 1"); Some ("bar"," 2"); None] *) let records = List.map (String.split s ~on:'\n') ~f:(fun x -> String.lsplit2 x ~on:':') in let _, uids = Option.value_exn (List.find_exn records ~f:(fun kv -> match kv with | Some ("Uid",_) -> true | _ -> false)) in let _, gids = Option.value_exn (List.find_exn records ~f:(fun kv -> match kv with | Some ("Gid",_) -> true | _ -> false)) in Scanf.sscanf (String.concat ~sep:" " [String.strip uids; String.strip gids]) "%d %d %d %d %d %d %d %d" (fun a b c d e f g h -> { uid = a; euid = b; suid = c; fsuid = d; gid = e; egid = f; sgid = g; fsgid = h; }) ;; end ;; module Fd = struct type fd_stat = | Path of string | Socket of Inode.t | Pipe of Inode.t | Inotify with sexp ;; type t = { fd : int; (** File descriptor (0=stdin, 1=stdout, etc.) *) fd_stat : fd_stat; (** Kind of file *) } with fields, sexp ;; end ;; type t = { pid : Pid.t; (** Process ID *) cmdline : string; (** Command-line (not reliable). *) cwd : string option; (** Symlink to working directory. *) environ : string option; (** Process environment. *) exe : string option; (** Symlink to executed command. *) root : string option; (** Per-process root (e.g. chroot) *) limits : Limits.t option; (** Per-process rlimit settings *) stat : Stat.t; (** Status information. *) statm : Statm.t; (** Memory status information. *) status : Status.t; (** Some more assorted status information. *) task_stats : Stat.t Pid.Map.t; (** Status information for each task (thread) *) top_command : string; (** Show what top would show for COMMAND *) fds : Fd.t list option; (** File descriptors *) oom_adj : int; oom_score : int; } with fields, sexp ;; let load_exn pid = let slurp f fn = try Some (f (sprintf !"/proc/%{Pid}/%s" pid fn)) with | Sys_error _ -> None | Unix.Unix_error (EACCES, _, _) -> None | Unix.Unix_error (ENOENT, _, _) -> None | Unix.Unix_error (EINVAL, _, _) -> None in let slurp_file fn = slurp string_of_file fn in let slurp_link fn = slurp Unix.readlink fn in let slurp_dir fn = slurp Sys.readdir fn in let required x = Option.value_exn x in let require_str f = slurp_file f |! required in let require_int f = slurp_file f |! required |! String.strip |! Int.of_string in let cmdline = require_str "cmdline" in (* * Process command name varies * * cmdline is ideal but not guaranteed to be there because the kernel * - may discard it in lomem situations * - discard it for zombie processes * - put nothing useful there for kernel processes * * The exe symlink might be useful, it's the name of the executable * which started the process, but permission is usually denied for * non-root/non-self viewers. * * The stat.command field will ALWAYS be there but is truncated * to 16 chars; we do here what top does: use cmdline if it is * populated, otherwise use stat.command. *) let stat = Stat.of_string (require_str "stat") in let limits = Option.try_with (fun () -> Limits.of_string (require_str "limits")) in let top_command = (if cmdline = "" then Stat.comm stat else String.tr ~target:'\x00' ~replacement:' ' cmdline) |! String.strip in let task_stats = Array.fold (required (slurp_dir "task")) ~init:Pid.Map.empty ~f:(fun m task -> Pid.Map.add m ~key:(Pid.of_string task) ~data:(Stat.of_string (require_str (String.concat ~sep:"/" ["task"; task; "stat"]))) ) in let fds = try Some ( Sys.readdir (sprintf "/proc/%s/fd" (Pid.to_string pid)) |! Array.to_list |! List.filter_map ~f:(fun fd_str -> let fd = Int.of_string fd_str in slurp Unix.readlink ("fd/" ^ fd_str) |! Option.map ~f:(fun path -> let parse inode = (* "[123]" -> 123 *) inode |! String.chop_prefix_exn ~prefix:"[" |! String.chop_suffix_exn ~suffix:"]" |! Inode.of_string in { Fd. fd = fd; fd_stat = match String.split ~on:':' path with | "socket"::inode::[] -> Fd.Socket (parse inode) | "pipe"::inode::[] -> Fd.Pipe (parse inode) | "inotify"::[] -> Fd.Inotify | _ -> Fd.Path path; } )) ) with Sys_error _ -> None in { pid = pid; cmdline = cmdline; cwd = slurp_link "cwd"; environ = slurp_file "environ"; exe = slurp_link "exe"; root = slurp_link "root"; limits = limits; stat = stat; statm = Statm.of_string (require_str "statm"); status = Status.of_string (require_str "status"); task_stats = task_stats; top_command = top_command; fds = fds; oom_adj = require_int "oom_adj"; oom_score = require_int "oom_score"; } ;; end ;; module Meminfo = struct type t = { mem_total : bigint; mem_free : bigint; buffers : bigint; cached : bigint; swap_cached : bigint; active : bigint; inactive : bigint; swap_total : bigint; swap_free : bigint; dirty : bigint; writeback : bigint; anon_pages : bigint; mapped : bigint; slab : bigint; page_tables : bigint; nfs_unstable : bigint; bounce : bigint; commit_limit : bigint; committed_as : bigint; vmalloc_total : bigint; vmalloc_used : bigint; vmalloc_chunk : bigint; } with fields, sexp ;; let load_exn () = let of_kb = Big_int.mult_int_big_int 1024 in let map = In_channel.read_lines "/proc/meminfo" |! List.fold ~init:String.Map.empty ~f:(fun map line -> match String.strip line |! String.tr ~target:':' ~replacement:' ' |! String.split ~on:' ' |! List.filter ~f:(fun s -> s <> "") with | key :: value :: "kB" :: [] -> let data = Big_int.big_int_of_string value |! of_kb in Map.add map ~key ~data | _ -> map (* ignore weird lines *) ) in let get k = match Map.find map k with | Some v -> v | None -> failwithf "meminfo_exn: cannot extract field %s" k () in { mem_total = get "MemTotal"; mem_free = get "MemFree"; buffers = get "Buffers"; cached = get "Cached"; swap_cached = get "SwapCached"; swap_free = get "SwapFree"; active = get "Active"; inactive = get "Inactive"; swap_total = get "SwapTotal"; dirty = get "Dirty"; writeback = get "Writeback"; anon_pages = get "AnonPages"; mapped = get "Mapped"; slab = get "Slab"; page_tables = get "PageTables"; nfs_unstable = get "NFS_Unstable"; bounce = get "Bounce"; commit_limit = get "CommitLimit"; committed_as = get "Committed_AS"; vmalloc_total = get "VmallocTotal"; vmalloc_used = get "VmallocUsed"; vmalloc_chunk = get "VmallocChunk"; } ;; end ;; (** Parse /proc/stat because vmstat is dumb *) module Kstat = struct type index_t = All | Number of int with sexp type cpu_t = { user : bigint; nice : bigint; sys: bigint; idle: bigint; iowait: bigint option; irq: bigint option; softirq: bigint option; steal: bigint option; guest: bigint option; } with fields, sexp;; type t = index_t * cpu_t let parse_line l = match l with | [user;nice;sys;idle;iowait;irq;softirq;steal;guest] -> (* > 2.6.24 *) { user = Big_int.big_int_of_string user; nice = Big_int.big_int_of_string nice ; sys = Big_int.big_int_of_string sys; idle = Big_int.big_int_of_string idle; iowait = Some (Big_int.big_int_of_string iowait); irq = Some (Big_int.big_int_of_string irq); softirq = Some (Big_int.big_int_of_string softirq); steal = Some (Big_int.big_int_of_string steal); guest = Some (Big_int.big_int_of_string guest)} | [user;nice;sys;idle;iowait;irq;softirq;steal] -> (* > 2.6.11 *) { user = Big_int.big_int_of_string user; nice = Big_int.big_int_of_string nice ; sys = Big_int.big_int_of_string sys; idle = Big_int.big_int_of_string idle; iowait = Some (Big_int.big_int_of_string iowait); irq = Some (Big_int.big_int_of_string irq); softirq = Some (Big_int.big_int_of_string softirq); steal = Some (Big_int.big_int_of_string steal); guest = None} | [user;nice;sys;idle;iowait;irq;softirq] -> (* > 2.6.0 *) { user = Big_int.big_int_of_string user; nice = Big_int.big_int_of_string nice ; sys = Big_int.big_int_of_string sys; idle = Big_int.big_int_of_string idle; iowait = Some (Big_int.big_int_of_string iowait); irq = Some (Big_int.big_int_of_string irq); softirq = Some (Big_int.big_int_of_string softirq); steal = None; guest = None} | [user; nice; sys; idle] -> (* < 2.5.41 ish *) { user = Big_int.big_int_of_string user; nice = Big_int.big_int_of_string nice ; sys = Big_int.big_int_of_string sys; idle = Big_int.big_int_of_string idle; iowait = None; irq = None; softirq = None; steal = None; guest = None } |_ -> failwith "No idea what this line is" let load_exn () = In_channel.read_lines "/proc/stat" |! List.fold ~init:[] ~f:(fun accum line -> match String.strip line |! String.split ~on:' ' |! List.filter ~f:(fun s -> s <> "") with | "cpu" :: rest -> (All, (parse_line rest)) :: accum | cpuidx :: rest -> if String.is_prefix ~prefix:"cpu" cpuidx then let idx = String.slice cpuidx 3 (String.length cpuidx) in ((Number (Int.of_string idx)), (parse_line rest)) :: accum else accum | _ -> accum (* ignore weird lines *) ) end module Loadavg = struct type t = { one : float; ten : float; fifteen : float; } with fields (* /proc/loadavg has just 1 line nearly all the time, but occasionally there's an extra blank line. just be extra forgiving and grab only the first line. *) let load_exn () = match In_channel.read_lines "/proc/loadavg" with | line::_rest -> begin match String.split line ~on:' ' with | o::t::f::_rest -> let one,ten,fifteen = Float.of_string o, Float.of_string t, Float.of_string f in {one;ten;fifteen} | _ -> failwithf "couldn't parse load average from line: %s" line () end | [] -> failwith "no lines read from /proc/loadavg!" end let get_all_procs () = Sys.readdir "/proc" |! Array.to_list |! List.filter_map ~f:(fun pid -> (* Failures usually aren't a fatal *system* condition. procfs queries on Linux simply are not consistent. They're generally thwarted by terminating processes. We simply skip the proc entry on failure. *) Option.try_with (fun () -> Process.load_exn (Pid.of_string pid)) ) ;; let with_pid_exn = Process.load_exn ;; let with_pid pid = Option.try_with (fun () -> with_pid_exn pid) ;; let with_uid uid = List.filter (get_all_procs ()) ~f:(fun p -> Process.Status.uid (Process.status p) = uid) ;; let with_username_exn name = with_uid (Unix.Passwd.getbyname_exn name).Unix.Passwd.uid ;; let with_username name = Option.try_with (fun () -> with_username_exn name) ;; let get_uptime () = match string_of_file "/proc/uptime" |! String.split ~on:' ' with | secs_since_boot :: _ -> Float.of_string secs_since_boot | _ -> failwithf "Error parsing /proc/uptime" () ;; (* * This is a partial translation of * sysinfo.c:init_Hertz_value from procps (top) *) let jiffies_per_second_exn () = let rec sample () = let up1 = get_uptime () in let statlines = In_channel.read_lines "/proc/stat" in (* On modern systems the second line is always cpu0 (even uni-processors) *) let statline = Option.value_exn (List.nth statlines 1) in let user_j, nice_j, sys_j, idle_j, iowait_j = Scanf.sscanf statline "cpu0 %Lu %Lu %Lu %Lu %Lu" (fun a b c d e -> a,b,c,d,e) in let up2 = get_uptime () in if ((up2 -. up1) > 0.01) then sample () (* sampling latency too high. try again *) else let (+) = Int64.(+) in user_j + nice_j + sys_j + idle_j + iowait_j, ((up1 +. up2) /. 2.) in let jiffies, seconds = sample () in (Int64.to_float jiffies) /. seconds ;; let jiffies_per_second () = Option.try_with jiffies_per_second_exn ;; let process_age' ~jiffies_per_second p = let start_time = Big_int.float_of_big_int p.Process.stat.Process.Stat.starttime /. jiffies_per_second in Time.Span.of_sec (get_uptime () -. start_time) ;; let process_age p = Option.map (jiffies_per_second ()) ~f:(fun jiffies_per_second -> process_age' ~jiffies_per_second p) ;; let meminfo_exn = Meminfo.load_exn let meminfo () = Option.try_with meminfo_exn let loadavg_exn = Loadavg.load_exn let loadavg () = Option.try_with loadavg_exn let pgrep f = List.filter (get_all_procs ()) ~f ;; let pkill ~signal f = List.fold (get_all_procs ()) ~init:[] ~f:(fun a p -> if not (f p) then a else begin let pid = Process.pid p in let result = try Ok (ignore (Signal.send signal (`Pid pid))) with | Unix.Unix_error (e, _, _) -> Error e | e -> Exn.reraisef e "Procfs.pkill caught exception trying to signal process %s" (Pid.to_string pid) () in (pid, result) :: a end) ;; module Net = struct module Dev = struct type t = { iface : string; rx_bytes : int; rx_packets: int; rx_errs : int; rx_drop : int; rx_fifo : int; rx_frame : int; rx_compressed : bool; rx_multicast : bool; tx_bytes : int; tx_packets: int; tx_errs : int; tx_drop : int; tx_fifo : int; tx_colls : int; tx_carrier: int; tx_compressed : bool; } with fields;; let eval_mul_comp rx_tx = match rx_tx with | 0 -> false; | 1 -> true; | _ -> failwithf "Proc.Net.Dev error : value is %d, expected 0 or 1." rx_tx () let of_string str = let s = String.strip in let ios str = Int.of_string str in match String.split ~on:'\t' str with | [ iface; rx_bytes; rx_packets; rx_errs; rx_drop; rx_fifo; rx_frame; rx_compressed; rx_multicast; tx_bytes; tx_packets; tx_errs; tx_drop; tx_fifo; tx_colls; tx_carrier; tx_compressed ] -> Some { iface = s iface; rx_bytes = ios (s rx_bytes); rx_packets = ios (s rx_packets); rx_errs = ios (s rx_errs); rx_drop = ios (s rx_drop); rx_fifo = ios (s rx_fifo); rx_frame = ios (s rx_frame); rx_compressed = (eval_mul_comp (ios rx_compressed)); rx_multicast = (eval_mul_comp (ios rx_multicast)); tx_bytes = ios (s tx_bytes); tx_packets = ios (s tx_packets); tx_errs = ios (s tx_errs); tx_drop = ios (s tx_drop); tx_fifo = ios (s tx_fifo); tx_colls = ios (s tx_colls); tx_carrier = ios (s tx_carrier); tx_compressed = (eval_mul_comp (ios tx_compressed)); } | _ -> failwithf "Net.Dev.of_string: unsupported format: %s" str () (* add interfaces () to get a list of all interfaces on box *) let interfaces () = In_channel.with_file "/proc/net/dev" ~f:In_channel.input_lines |> List.tl_exn |> List.tl_exn |> List.map ~f:(fun x -> let rex = Re2.Std.Re2.create_exn "(\\w+):" in let matches = Re2.Std.Re2.find_submatches_exn rex (String.lstrip x) in matches.(1) |> Option.value ~default:"" ) end module Route = struct type t = { iface : string; destination : Unix.Inet_addr.t ; gateway : Unix.Inet_addr.t ; flags : int; refcnt : int; use : int; metric : int; mask : Unix.Inet_addr.t; mtu : int; window : int; irtt : int; } with fields;; let unix_inet_addr_of_revhex revhex_str = let ip = Scanf.sscanf revhex_str "%2x%2x%2x%2x" (fun a b c d -> sprintf "%d.%d.%d.%d" d c b a) in Unix.Inet_addr.of_string ip ;; let of_string str = let s = String.strip in match String.split ~on:'\t' str with | [ iface; dest; gw; flags; refcnt; use; metric; mask; mtu; window; irtt ] -> Some { iface = iface; destination = unix_inet_addr_of_revhex dest; gateway = unix_inet_addr_of_revhex gw; flags = Int.of_string flags; refcnt = Int.of_string refcnt; use = Int.of_string use; metric = Int.of_string metric; mask = unix_inet_addr_of_revhex mask; mtu = Int.of_string mtu; window = Int.of_string window; irtt = Int.of_string (s irtt); } | _ -> failwithf "Net.Route.of_string: unsupported format: %s" str () let raw_route_list () = let routes = In_channel.with_file "/proc/net/route" ~f:In_channel.input_lines |! List.tl_exn in List.filter_map routes ~f:(of_string) let default = let default_route = Unix.Inet_addr.bind_any in fun () -> match List.filter_map ( raw_route_list () ) ~f:(fun x -> if ( x.destination = default_route ) then Some x.gateway else None ) with | [x] -> x | [] -> failwith "No default gateway set?" | unk -> failwithf "Looks like there are > 1 gateway set: %s !" (String.concat ~sep:", " (List.map unk ~f:Unix.Inet_addr.to_string )) () ;; end (* This doesn't belong here at all but meh *) module Tcp_state = struct type t = TCP_ESTABLISHED | TCP_SYN_SENT | TCP_SYN_RECV | TCP_FIN_WAIT1 | TCP_FIN_WAIT2 | TCP_TIME_WAIT | TCP_CLOSE | TCP_CLOSE_WAIT | TCP_LAST_ACK | TCP_LISTEN | TCP_CLOSING | TCP_MAX_STATES let to_int = function | TCP_ESTABLISHED -> 1 | TCP_SYN_SENT -> 2 | TCP_SYN_RECV -> 3 | TCP_FIN_WAIT1 -> 4 | TCP_FIN_WAIT2 -> 5 | TCP_TIME_WAIT -> 6 | TCP_CLOSE -> 7 | TCP_CLOSE_WAIT -> 8 | TCP_LAST_ACK -> 9 | TCP_LISTEN -> 10 | TCP_CLOSING -> 11 | TCP_MAX_STATES -> 12 let of_int = function | 1 -> TCP_ESTABLISHED | 2 -> TCP_SYN_SENT | 3 -> TCP_SYN_RECV | 4 -> TCP_FIN_WAIT1 | 5 -> TCP_FIN_WAIT2 | 6 -> TCP_TIME_WAIT | 7 -> TCP_CLOSE | 8 -> TCP_CLOSE_WAIT | 9 -> TCP_LAST_ACK | 10 -> TCP_LISTEN | 11 -> TCP_CLOSING | 12 -> TCP_MAX_STATES | _ -> failwith "Invalid tcp status flag" let of_hex s = of_int (Int.of_string ("0x"^s)) (* to_hex? to_string? *) end module Tcp = struct type t = { sl : int; local_address : Core.Std.Unix.Inet_addr.t; local_port : Extended_unix.Inet_port.t; remote_address : Core.Std.Unix.Inet_addr.t; remote_port : Extended_unix.Inet_port.t option; state : Tcp_state.t; tx_queue : int; rx_queue : int; tr:int; tm_when : int; retrnsmt: int; uid : int; timeout : int; inode : Process.Inode.t; (* I think this is right *) rest : string; } with fields let dehex ~int_of_string s = int_of_string ("0x"^s) let dehex_int = dehex ~int_of_string:Int.of_string let dehex_int32 = dehex ~int_of_string:Int32.of_string let of_line_exn line = match String.tr ~target:':' ~replacement:' ' line |! String.split ~on:' ' |! List.filter ~f:(fun x -> x <> "") with | [sl; local_address; local_port; remote_address; remote_port; st; tx_queue; rx_queue; tr;tm_when; retrnsmt; uid; timeout; inode; plus; some; other; state; i; guess; lol] -> { sl = Int.of_string sl; local_address= Unix.Inet_addr.inet4_addr_of_int32 (Extended_unix.ntohl (dehex_int32 local_address)); local_port= Extended_unix.Inet_port.of_int_exn (dehex_int local_port); remote_address= Unix.Inet_addr.inet4_addr_of_int32 (Extended_unix.ntohl (dehex_int32 remote_address)); (* This can be 0 which is technically invalid but...*) remote_port = Extended_unix.Inet_port.of_int (dehex_int remote_port); state= Tcp_state.of_hex st; tx_queue = dehex_int tx_queue; rx_queue = dehex_int rx_queue; tr = dehex_int tr ; tm_when = dehex_int tm_when; retrnsmt = dehex_int retrnsmt; uid = Int.of_string uid; timeout = Int.of_string timeout; inode = Process.Inode.of_string inode; rest = String.concat ~sep:" " [plus; some; other; state; i; guess; lol] } | _ -> failwith "Unable to parse this line!\n%!" let of_line line = try Some (of_line_exn line ) with _ -> None let load_exn () = let lines = In_channel.read_lines "/proc/net/tcp" in List.fold ~init:[] ~f:(fun res line -> match of_line line with | Some data -> data :: res | None -> res ) lines TEST = of_line " 40: 458719AC:9342 CC1619AC:0016 01 00000000:00000000 02:000296F0 00000000 12021 0 64400541 2 ffff88022c777400 20 3 0 10 -1" <> None (* Port 0 on the other side *) TEST = of_line " 31: 0100007F:177E 00000000:0000 0A 00000000:00000000 00:00000000 00000000 12021 0 778748 1 ffff8102edd1ad00 3000 0 0 2 -1" <> None TEST = of_line " 40: 458719AC:9342 CC1619AC:0016 01 00000000:00000000 02:000296F0 00000000 12021 0 64400541 2 ffff88022c777400 20 3 0 10 -1" = Some { sl = 40; local_address = (Unix.Inet_addr.of_string "172.25.135.69"); local_port = (Extended_unix.Inet_port.of_int_exn 37698); remote_address = (Unix.Inet_addr.of_string "172.25.22.204"); remote_port = Some (Extended_unix.Inet_port.of_int_exn 22); state = Tcp_state.TCP_ESTABLISHED; tx_queue = 0; rx_queue = 0; tr = 2; tm_when = 169712; retrnsmt = 0; uid = 12021; timeout = 0; inode = Process.Inode.of_string "64400541"; rest = "2 ffff88022c777400 20 3 0 10 -1" } end end module Mount = struct type t = { spec : string; (* block device special name *) file : string; (* fs path prefix *) vfstype : string; (* ext3, nfs, etc. *) mntops : string list; (* mount options -o *) freq : int; (* dump frequency *) passno : int; (* pass number of parallel dump *) } with fields ;; let of_string s = match String.split ~on:' ' s |! List.filter ~f:(fun s -> s <> "") with | [ spec; file; vfstype; mntops; freq; passno ] -> { spec; file; vfstype; mntops = String.split ~on:',' mntops; freq = Int.of_string freq; passno = Int.of_string passno } | _ -> failwithf "Mount.of_string: unsupported format: %s" s () end let mounts () = In_channel.with_file "/proc/mounts" ~f:In_channel.input_lines |! List.map ~f:Mount.of_string ;; let mounts_of_fstab () = In_channel.with_file "/etc/fstab" ~f:In_channel.input_lines (* strip comments *) |! List.map ~f:(fun line -> (* filter '#' *) match String.split ~on:'#' line with | [] -> "" | content :: _comment -> content) (* turn tabs into spaces *) |! List.map ~f:(String.tr ~target:'\t' ~replacement:' ') (* chop padding *) |! List.map ~f:String.strip |! List.filter ~f:(fun line -> line <> "") |! List.map ~f:Mount.of_string ;; let supported_filesystems () = In_channel.with_file "/proc/filesystems" ~f:In_channel.input_lines |! List.map ~f:(fun line -> match String.split ~on:'\t' line |! List.rev with | vfstype :: _ -> vfstype | _ -> failwithf "Procfs.supported_filesystems: bad format: %s" line ()) ;; let uptime () = get_uptime () |! Time.Span.of_float ;; core_extended-113.00.00/src/procfs.mli000066400000000000000000000335021256461102500174170ustar00rootroot00000000000000open Core.Std (** Process and system stats *) type bigint = Big_int.big_int with sexp ;; val input_all_with_reused_buffer : unit -> (string -> string) Staged.t module Process : sig module Inode : sig type t with sexp ;; val of_string : string -> t val to_string : t -> string end ;; module Limits : sig module Rlimit : sig type value = [ `unlimited | `limited of bigint ] with sexp ;; type t = { soft : value; hard: value } with fields, sexp ;; end ;; type t = { cpu_time : Rlimit.t; file_size : Rlimit.t; data_size : Rlimit.t; stack_size : Rlimit.t; core_file_size : Rlimit.t; resident_set : Rlimit.t; processes : Rlimit.t; open_files : Rlimit.t; locked_memory : Rlimit.t; address_space : Rlimit.t; file_locks : Rlimit.t; pending_signals : Rlimit.t; msgqueue_size : Rlimit.t; nice_priority : Rlimit.t; realtime_priority : Rlimit.t; } with fields, sexp ;; val of_string : string -> t end ;; module Stat : sig type t = { comm : string; (** The filename of the executable *) state : char; (** One character from the string "RSDZTW" *) ppid : Pid.t option; (** The PID of the parent. *) pgrp : Pid.t option ; (** The process group ID of the process. *) session : int; (** The session ID of the process. *) tty_nr : int; (** The tty the process uses. *) tpgid : int; (** The process group ID of the process which currently owns the tty... *) flags : bigint; (** The kernel flags word of the process. *) minflt : bigint; (** The number of minor faults the process has made which have not required loading a memory page from disk. *) cminflt : bigint; (** The number of minor faults that the process’s waited-for children have made. *) majflt : bigint; (** The number of major faults the process has made which have required loading a page from disk. *) cmajflt : bigint; (** The number of major faults that the process’s waited-for children have made. *) utime : bigint; (** The number of jiffies that this process has been scheduled in user mode. *) stime : bigint; (** The number of jiffies that this process has been scheduled in kernel mode. *) cutime : bigint; (** The number of jiffies that this process’s waited-for children have been scheduled in user mode. *) cstime : bigint; (** The number of jiffies that this process’s waited-for children have been scheduled in kernel mode. *) priority : bigint; (** The standard nice value, plus fifteen. The value is never negative in the kernel. *) nice : bigint; (** The nice value ranges from 19 to -19*) unused : bigint; (** placeholder for removed field *) itrealvalue : bigint; (** The time in jiffies before the next SIGALRM is sent to the process due to an interval timer. *) starttime : bigint; (** The time in jiffies the process started after system boot.*) vsize : bigint; (** Virtual memory size in bytes. *) rss : bigint; (** Resident Set Size: number of pages the process has in real memory. *) rlim : bigint; (** Current limit in bytes on the rss of the process. *) startcode : bigint; (** The address above which program text can run. *) endcode : bigint; (** The address below which program text can run. *) startstack : bigint; (** The address of the start of the stack. *) kstkesp : bigint; (** The current value of esp (stack pointer) *) kstkeip : bigint; (** The current value of eip (instruction pointer) *) signal : bigint; (** The bitmap of pending signals. *) blocked : bigint; (** The bitmap of blocked signals. *) sigignore : bigint; (** The bitmap of ignored signals. *) sigcatch : bigint; (** The bitmap of caught signals. *) wchan : bigint; (** This is the "channel" in which the process is waiting. Address of a system call. *) nswap : bigint; (** (no longer maintained) *) cnswap : bigint; (** (no longer maintained) *) exit_signal : int; (** Signal sent to parent when we die. *) processor : int; (** CPU number last executed on. *) rt_priority : bigint; (** Real-time scheduling priority. *) policy : bigint; (** Scheduling policy *) } with fields, sexp ;; (* For a stat string such as "14574 (cat) R 10615 14574 ...", extract_command returns (`command "cat", `rest "R 10615 14574 ..."). Note that the pid at the beginning is dropped. *) val extract_command : string -> [`command of string] * [`rest of string] val of_string : string -> t end ;; module Statm : sig type t = { size : bigint; (** total program size *) resident : bigint; (** resident set size *) share : bigint; (** shared pages *) text : bigint; (** text (code) *) lib : bigint; (** library *) data : bigint; (** data/stack *) dt : bigint; (** dirty pages (unused) *) } with fields, sexp ;; val of_string : string -> t end ;; module Status : sig type t = { uid : int; (** Real user ID *) euid : int; (** Effective user ID *) suid : int; (** Saved user ID *) fsuid : int; (** FS user ID *) gid : int; (** Real group ID *) egid : int; (** Effective group ID *) sgid : int; (** Saved group ID *) fsgid : int; (** FS group ID *) } with fields, sexp ;; val of_string : string -> t end ;; module Fd : sig type fd_stat = | Path of string | Socket of Inode.t | Pipe of Inode.t | Inotify with sexp ;; type t = { fd : int; (** File descriptor (0=stdin, 1=stdout, etc.) *) fd_stat : fd_stat; (** Kind of file *) } with fields, sexp ;; end ;; type t = { pid : Pid.t; (** Process ID *) cmdline : string; (** Command-line (not reliable). *) cwd : string option; (** Symlink to working directory. *) environ : string option; (** Process environment. *) exe : string option; (** Symlink to executed command. *) root : string option; (** Per-process root (e.g. chroot) *) limits : Limits.t option; (** Per-process rlimit settings *) stat : Stat.t; (** Status information. *) statm : Statm.t; (** Memory status information. *) status : Status.t; (** Some more assorted status information. *) task_stats : Stat.t Pid.Map.t; (** Status information for each task (thread) *) top_command : string; (** Show what top would show for COMMAND *) fds : Fd.t list option; (** File descriptors *) oom_adj : int; (** OOM killer niceness [range: -17 to +15] *) oom_score : int; (** OOM "sacrifice" priority *) } with fields, sexp ;; end ;; module Meminfo : sig (** [t] corresponds to the values in /proc/meminfo. All values in bytes. *) type t = { mem_total : bigint; mem_free : bigint; buffers : bigint; cached : bigint; swap_cached : bigint; active : bigint; inactive : bigint; swap_total : bigint; swap_free : bigint; dirty : bigint; writeback : bigint; anon_pages : bigint; mapped : bigint; slab : bigint; page_tables : bigint; nfs_unstable : bigint; bounce : bigint; commit_limit : bigint; committed_as : bigint; vmalloc_total : bigint; vmalloc_used : bigint; vmalloc_chunk : bigint; } with fields, sexp ;; end ;; module Kstat : sig type index_t = All | Number of int with sexp type cpu_t = { user : bigint; nice : bigint; sys : bigint; idle : bigint; iowait : bigint option; irq : bigint option; softirq : bigint option; steal : bigint option; guest : bigint option; } with fields, sexp;; type t = index_t * cpu_t val load_exn : unit -> t list end module Loadavg : sig (** [t] corresponds to the values in /proc/loadavg. *) type t = { one : float; ten : float; fifteen : float; } with fields end (** [get_all_procs] returns a list of all processes on the system *) val get_all_procs : unit -> Process.t list (** [with_pid_exn pid] returns a single process that matches pid, or raises Not_found *) val with_pid_exn : Pid.t -> Process.t (** [with_pid pid] returns a single process that matches pid *) val with_pid : Pid.t -> Process.t option (** [with_uid uid] returns all processes owned by uid *) val with_uid : int -> Process.t list (** [pgrep f] returns all processes for which f is true *) val pgrep : (Process.t -> bool) -> Process.t list (** [pkill ~signal f] sends the signal to all processes for which f returns true. It returns the list of processes that were signaled, and the resulting errors if any. *) val pkill : signal:Signal.t -> (Process.t -> bool) -> (Pid.t * (unit, Unix.Error.t) Result.t) list (** [with_username_exn user] calls with_uid after looking up the user's uid *) val with_username_exn : string -> Process.t list (** [with_username user] calls with_uid after looking up the user's uid *) val with_username : string -> Process.t list option (** [jiffies_per_second_exn]. A jiffy "is one tick of the system timer interrupt. It is not an absolute time interval unit, since its duration depends on the clock interrupt frequency of the particular hardware platform." Further reading: https://secure.wikimedia.org/wikipedia/en/wiki/Jiffy_(time) *) val jiffies_per_second_exn : unit -> float val jiffies_per_second : unit -> float option (** [meminfo_exn] queries /proc/meminfo and fills out Meminfo.t. All values in bytes. *) val meminfo_exn : unit -> Meminfo.t val meminfo : unit -> Meminfo.t option (** [loadavg_exn] parses /proc/loadavg. *) val loadavg_exn : unit -> Loadavg.t val loadavg : unit -> Loadavg.t option module Net : sig (*will put in some stuff from proc net *) module Dev : sig type t = { iface : string; rx_bytes : int; rx_packets: int; rx_errs : int; rx_drop : int; rx_fifo : int; rx_frame : int; rx_compressed : bool; rx_multicast : bool; tx_bytes : int; tx_packets: int; tx_errs : int; tx_drop : int; tx_fifo : int; tx_colls : int; tx_carrier: int; tx_compressed : bool; } with fields;; val interfaces : unit -> string list val of_string : string -> t option end module Route : sig type t = { iface : string; (* maybe this shouldn't be a string? *) destination : Unix.Inet_addr.t; gateway : Unix.Inet_addr.t; flags : int; refcnt : int; use : int; metric : int; mask : Unix.Inet_addr.t; mtu : int; window : int; irtt : int; } with fields ;; val default : unit -> Unix.Inet_addr.t end (* This should probably be somewhere else but I don't know where. *) module Tcp_state : sig type t = TCP_ESTABLISHED | TCP_SYN_SENT | TCP_SYN_RECV | TCP_FIN_WAIT1 | TCP_FIN_WAIT2 | TCP_TIME_WAIT | TCP_CLOSE | TCP_CLOSE_WAIT | TCP_LAST_ACK | TCP_LISTEN | TCP_CLOSING | TCP_MAX_STATES val to_int : t -> int val of_int : int -> t end (** /proc/net/tcp, or what netstat or lsof -i parses. *) module Tcp : sig type t = { sl : int; local_address : Core.Std.Unix.Inet_addr.t; local_port : Extended_unix.Inet_port.t; remote_address : Core.Std.Unix.Inet_addr.t; remote_port : Extended_unix.Inet_port.t option; (* can be 0 if there's no connection. *) state : Tcp_state.t; tx_queue : int; rx_queue : int; tr:int; tm_when : int; retrnsmt: int; uid : int; timeout : int; inode : Process.Inode.t; rest : string; } with fields (** These don't do any IO and should be async-ok *) val of_line : string -> t option val of_line_exn : string -> t (** This does IO and is not async-ok. *) val load_exn : unit -> t list end end module Mount : sig type t = { spec : string; (* block device special name *) file : string; (* fs path prefix *) vfstype : string; (* ext3, nfs, etc. *) mntops : string list; (* mount options -o *) freq : int; (* dump frequency *) passno : int; (* pass number of parallel dump *) } with fields ;; end val mounts : unit -> Mount.t list val mounts_of_fstab : unit -> Mount.t list val supported_filesystems : unit -> string list val uptime : unit -> Time.Span.t val process_age : Process.t -> Time.Span.t option val process_age' : jiffies_per_second : float -> Process.t -> Time.Span.t core_extended-113.00.00/src/prod_or_test.ml000066400000000000000000000003761256461102500204600ustar00rootroot00000000000000open Core.Std type t = [ `Prod | `Test ] with sexp, bin_io, compare let is_prod t = t = `Prod let is_test t = t = `Test let of_prod_bool = function | true -> `Prod | false -> `Test let of_test_bool = function | true -> `Test | false -> `Prod core_extended-113.00.00/src/prod_or_test.mli000066400000000000000000000002611256461102500206220ustar00rootroot00000000000000open Core.Std type t = [ `Prod | `Test ] with sexp, bin_io, compare val is_prod : t -> bool val is_test : t -> bool val of_prod_bool : bool -> t val of_test_bool : bool -> t core_extended-113.00.00/src/quickcheck_deprecated.ml000066400000000000000000000032131256461102500222400ustar00rootroot00000000000000open Core.Std let rec foldn ~f ~init:acc i = if i = 0 then acc else foldn ~f ~init:(f acc i) (i-1) type 'a gen = unit -> 'a let pfg () = exp (Random.float 30. -. 15.) let fg () = pfg () *. (if Random.bool () then 1. else -1.) let nng () = let p = Random.float 1. in if p < 0.5 then Random.int 10 else if p < 0.75 then Random.int 100 else if p < 0.95 then Random.int 1_000 else Random.int 10_000 (* Below uniform random in range min_int, min_int+1,...,max_int. Here's why: * bound = max_int + 1 * 0 <= r <= max_int * 0 <= r <= max_int && -max_int -1 <= -r - 1 <= -1 * -max_int -1 <= result <= max_int * min_int <= result <= max_int *) let uig = let bound = Int64.(+) 1L (Int64.of_int Int.max_value) in fun () -> let r = Int64.to_int_exn (Random.int64 bound) in if Random.bool () then r else -r - 1 let lg gen ?(size_gen=nng) () = foldn ~f:(fun acc _ -> (gen ())::acc) ~init:[] (size_gen ()) let pg gen1 gen2 () = (gen1 (), gen2 ()) let tg g1 g2 g3 () = (g1 (),g2 (), g3 ()) let cg () = char_of_int (Random.int 256) let sg ?(char_gen = cg) ?(size_gen = nng) () = let s = String.create (size_gen ()) in for i = 0 to String.length s - 1 do s.[i] <- char_gen () done; s let always x () = x let rec laws iter gen func = if iter <= 0 then None else let input = gen () in try if not (func input) then Some input else laws (iter-1) gen func with _ -> Some input let laws_exn name iter gen func = match laws iter gen func with None -> () | Some _ -> failwith (Printf.sprintf "law %s failed" name) let repeat times test gen = for _i = 1 to times do test (gen()) done core_extended-113.00.00/src/quickcheck_deprecated.mli000066400000000000000000000024711256461102500224160ustar00rootroot00000000000000(* Deprecated. Left in Core_extended for old uses, but shouldn't be used in new code. *) (** the type of a random ['a]-generator *) type 'a gen = unit -> 'a (** float generator (no nan, inf, etc.) *) val fg : float gen (** character generator *) val cg : char gen (** natural number generator *) val nng : int gen (** unsigned int generator (uniform random in range min_int, max_int) *) val uig : int gen (** pair generator *) val pg : 'a gen -> 'b gen -> ('a * 'b) gen (** triple generator *) val tg : 'a gen -> 'b gen -> 'c gen -> ('a * 'b * 'c) gen (** list generator *) val lg : 'a gen -> ?size_gen:int gen -> 'a list gen (** string generator *) val sg : ?char_gen : char gen -> ?size_gen : int gen -> string gen (** generator that always returns given value *) val always : 'a -> 'a gen (** [laws iter gen func] applies [func] repeatedly ([iter] times) on output of [gen], and if [func] ever returns false, then the input that caused the failure is returned optionally. *) val laws : int -> 'a gen -> ('a -> bool) -> 'a option (** Like laws, but throws an exception instead of returning an option. *) val laws_exn : string -> int -> 'a gen -> ('a -> bool) -> unit (* [repeat n f gen] runs [f] for [n] iterations, each using a different value from [gen] *) val repeat : int -> ('a -> unit) -> 'a gen -> unit core_extended-113.00.00/src/random_selection.ml000066400000000000000000000024231256461102500212750ustar00rootroot00000000000000(* reservoir sampling see http://www.nist.gov/dads/HTML/reservoirSampling.html see http://hnr.dnsalias.net/wordpress/?p=43 *) open Core.Std type 'a t = { rand : int -> int; desired_sample_size : int; selection : 'a option array; num_seen : int ref; } let desired_sample_size t = t.desired_sample_size let to_list t = List.filter_opt (Array.to_list t.selection) let create ?random_state desired_sample_size = let rand = let state = match random_state with | None -> Random.State.default | Some state -> state in fun n -> Random.State.int state n in let selection = Array.create ~len:desired_sample_size None in { rand; desired_sample_size; selection; num_seen = ref 0 } let maybe_add {rand; desired_sample_size; selection; num_seen} elem = incr num_seen; if !num_seen <= desired_sample_size then Array.set selection (!num_seen - 1) (Some elem) else begin if rand !num_seen < desired_sample_size then begin Array.set selection (rand desired_sample_size) (Some elem); end end let select ?random_state ~next desired_sample_size = let t = create ?random_state desired_sample_size in let rec loop () = match next () with | None -> () | Some elem -> maybe_add t elem; loop () in loop (); to_list t core_extended-113.00.00/src/random_selection.mli000066400000000000000000000021421256461102500214440ustar00rootroot00000000000000(** reservoir sampling *) open Core.Std type 'a t (** a random sample of ['a] values *) (** [create ~random_state desired_sample_size] creates an empty sample of ['a] values. The sample will grow no larger than [desired_sample_size] when presented with more values by calling [add]. *) val create : ?random_state:Random.State.t -> int -> 'a t (** the desired sample size *) val desired_sample_size : 'a t -> int (** [maybe_add t x] will randomly either add [x] to [t] or ignore it. If adding [x] would grow the sample larger than [desired_sample_size t], some previously selected value will be discarded. *) val maybe_add : 'a t -> 'a -> unit (** the current selection from values previously seen by [t]. Of all previously seen values, each subset of size [desired_sample_size t] is equally likely to have been selected. *) val to_list : 'a t -> 'a list (** randomly select a subset of size [sample_size] from a stream of unknown length. Each possible subset is chosen with equal probability. *) val select : ?random_state:Random.State.t -> next:(unit -> 'a option) -> int -> 'a list core_extended-113.00.00/src/readline.ml000066400000000000000000000130511256461102500175320ustar00rootroot00000000000000open Core.Std open Textutils.Std type completer = (left:string -> right:string -> string list) let registered = ref false let cleanupFun = ref None (** Finally is always run, even if we press [ctrl + c] This is used because we HAVE to restore the terminal when we exit otherwise we will face the wrath of very angry users!!! This function cannot be used in nested calls. *) let unwind_protect ~f ~finally = if not !registered then begin at_exit (fun () -> Option.call ~f:!cleanupFun ()); registered := true end; let finally () = cleanupFun := None; finally () in cleanupFun := Some finally; let res= try f () with e -> finally (); raise e in finally (); res let with_readline f = let module T = Unix.Terminal_io in let attr_in = T.tcgetattr Unix.stdin and attr_out = T.tcgetattr Unix.stdout in unwind_protect ~f:( fun () -> let attr_in = { attr_in with T. c_echo = false; c_icanon = false; c_vmin = 1; c_ixon = false; } and attr_out = { attr_out with T.c_icanon = false; c_vmin = 1 } in T.tcsetattr attr_out ~mode:T.TCSAFLUSH Unix.stdout; T.tcsetattr attr_in ~mode:T.TCSADRAIN Unix.stdin; f () ) ~finally:(fun () -> T.tcsetattr attr_out ~mode:T.TCSAFLUSH Unix.stdout; T.tcsetattr attr_in ~mode:T.TCSADRAIN Unix.stdin; ) (* let interactive_readline ~prompt = print_string (prompt); let res = try Shell.run_one "zenity" [ "--entry" ; "--text=" ^ prompt ; "--title=\"Toploop readline!!\"" ] with _ -> None in Option.iter res ~f:print_endline; res *) let mainloop ?text ~map_out ?completion ~prompt ~hist = let module IL = Readline__input_loop in let rec loop v = IL.print ~prompt ~map_out v; match Readline__input_char.get () with | `Newline -> print_newline (); IL.contents v; | #IL.input as in_v -> loop (IL.step ?completion v in_v) in try if Console.is_color_tty () then with_readline (fun () -> Some (loop (IL.create ?text hist))) else begin print_string prompt; Some (Pervasives.read_line ()) end with End_of_file -> None (** Handling the history. We do this in a very quick and dirty way: _We keep two lists: [current] and [pending] and append to both; when pending's length reaches [size] we rotate [pending] to [current] and place a new list in [pending]. *) module History = struct type t = { size : int; mutable current:string list; mutable pending:string list } let create size = { size = size; current = []; pending = [] } let flush h = h.current <- []; h.pending <- [] let to_list h = List.take h.current h.size let of_list ?(size=50) l = let l = List.take l size in { size = size; current = l; pending = l; } let snapshot h = if h.size = 0 then [] else h.current let add h v = h.current <- v::h.current; h.pending <- v::h.pending; if List.length h.pending > h.size then begin h.current <- h.pending; h.pending <- [] end let null = create 0 let default = create 50 end let input_line ?(history = History.default) ?(prompt="> ") ?text ?tab_completion () = let res = mainloop ~map_out:ident ~hist:(History.snapshot history) ~prompt ?text ?completion:tab_completion in begin match res with | None | Some "" -> () | Some v -> History.add history v end; res let input_line_eof ?history ?prompt ?text ?tab_completion () = match input_line ?history ?prompt ?text ?tab_completion () with | None -> raise End_of_file | Some v -> v let password ?(prompt="") () = mainloop ~map_out:(String.map ~f:(fun _ -> '*')) ~hist:[] ~prompt ?completion:None ?text:None let confirm ?(prompt="") true_answer = let ans = mainloop ~map_out:ident ~hist:[] ~prompt ?completion:None ?text:None in Option.value_map ans ~f:(fun v -> String.lowercase v = String.lowercase true_answer) ~default:false let choice choices = Option.iter (List.find_a_dup (List.map ~f:fst choices)) ~f:(fun v -> failwithf "Readline.choice: two different choices for %s" v ()); let make_sel_string s pos = sprintf "%s(%c)%s" (String.sub s ~pos:0 ~len:pos) s.[pos] (String.sub s ~pos:(pos+1) ~len:(String.length s -pos -1) ) in let rec choose_id_char assigned s pos = if pos >= String.length s then None else let sel_string = String.of_char (s.[pos]) in if List.Assoc.mem assigned sel_string then choose_id_char assigned s (pos+1) else Some (sel_string,make_sel_string s pos) in let (strings,choices) = List.fold_left choices ~f:(fun (strings,choices) (s,v) -> match choose_id_char choices s 0 with | Some (idx,string) -> (string::strings),((idx,v)::choices) | None -> (** Failed to assign a short char *) (s::strings),choices) ~init:([],choices) in let prompt = String.concat ~sep:"," (List.rev strings) ^ "? " in let rec loop () = match mainloop ~prompt ~map_out:ident ~hist:[] ?completion:None ?text:None with | None -> None | Some x -> match List.Assoc.find choices (String.strip x) with | Some _ as s -> s | None -> loop () in loop () core_extended-113.00.00/src/readline.mli000066400000000000000000000034101256461102500177010ustar00rootroot00000000000000(** Interactive line editing. This implements very basic [readline] abilities: backspace, left and right arrows work as expected. There's also a history that can be browsed through the [up] and [down] arrows. *) type completer = (left:string -> right:string -> string list) module History : sig type t val null : t (** A value which is always empty *) val default : t val create : int -> t val flush : t -> unit val to_list : t -> string list val of_list : ?size:int -> string list -> t end (** A mutable variable representing the history. *) val input_line : ?history:History.t -> ?prompt:string -> ?text:string -> ?tab_completion:completer -> unit -> string option (** @param prompt the string to use as a prompt (default value [">"]) @param history the mutable value used as a history. The deault value is [History.default]. If you don't want any history ou should use [History.null] @param tab_completion the function use to complete on tab. By default there is no completion. @return [None] on [EOF] (i.e. the user typed [ctrl + d]) *) val input_line_eof : ?history:History.t -> ?prompt:string -> ?text:string -> ?tab_completion:completer -> unit -> string val password : ?prompt:string -> unit -> string option (** Prompts for a password. Displays '*' instead of typed characters. @return [None] on [EOF] *) val confirm : ?prompt:string -> string -> bool (** Prompts for an answer. Returns true if the answer equals the given string (ignoring case), false otherwise. *) val choice : (string * 'a) list -> 'a option (** [ choice ["a",a;"b",b] ] Prompts the user to choose a between several value (associated to strings) and returns the value chosen by the user. @return [None] on [EOF]. *) core_extended-113.00.00/src/readline__input_char.ml000066400000000000000000000035511256461102500221110ustar00rootroot00000000000000open Core.Std type t = [ | `Backspace | `Tab | `Newline | `Char of char | `Up | `Down | `Left | `Right | `Home | `End | `Delete | `Eof | `Unknown_escape of (string*int option*int option) ] let char () = input_char stdin (** An Ecma escape sequence is two characters separated by one or two optional numbers. This reads Ecma sequences from the stdin; it doesn't however read the escape character ["\027"]. It is based on specifications and reverse engineering... *) (* Does not handle all the bells and whistles of Ecma-48 because we only need to handle what the keyboard can reasonably output. *) let parse_esc ()= let b1 = Buffer.create 4 and b2 = Buffer.create 4 in let cmd = String.create 2 in cmd.[0] <- char (); let rec aux seen_semi = let c = char () in let b = if seen_semi then b2 else b1 in match c with | ';' when not seen_semi -> aux true | '0'..'9' -> Buffer.add_char b c; aux seen_semi |'~' when Buffer.length b > 0 -> let c = Buffer.nth b 0 in let b_cnt = Buffer.sub b 1 (Buffer.length b -1) in Buffer.clear b; Buffer.add_string b b_cnt; c | _ -> c in let c = aux false in cmd.[1] <- c; let quant b = match Buffer.contents b with | "" -> None | s -> Some (int_of_string s) in cmd,quant b1,quant b2 let get () = match char () with | '\n' -> `Newline | '\t' -> `Tab | '\127' -> `Backspace | '\004' -> `Eof | '\027' -> (* Escape sequence *) (match (parse_esc ()) with | "[A",(None | Some 1),None -> `Up | "[B",(None | Some 1),None -> `Down | "[D",(None | Some 1),None -> `Left | "[C",(None | Some 1),None -> `Right | "[3",(None | Some 1),None -> `Delete | "OH",None,None -> `Home | "OF",None,None -> `End | v -> `Unknown_escape v) | c -> `Char c core_extended-113.00.00/src/readline__input_char.mli000066400000000000000000000004571256461102500222640ustar00rootroot00000000000000(* This is an internal module: it shouldn't be used outside of core_extended *) type t = [ | `Backspace | `Tab | `Newline | `Char of char | `Up | `Down | `Left | `Right | `Home | `End | `Delete | `Eof | `Unknown_escape of (string*int option*int option) ] val get : unit -> t core_extended-113.00.00/src/readline__input_loop.ml000066400000000000000000000050601256461102500221420ustar00rootroot00000000000000open Core.Std open Textutils.Std module Term = Console.Ansi module LZ = List_zipper module SZ = String_zipper type t = { hist : string LZ.t; line : SZ.t } let create ?(text="") hist = let hist = LZ.create [] hist in let line = SZ.create text "" in { hist = hist; line = line} let contents v = SZ.contents v.line let print ~prompt ~map_out v = Term.home_cursor (); Term.kill_line (); print_string prompt; print_string (map_out (SZ.left_contents v.line)); Term.save_cursor(); print_string (map_out (SZ.right_contents v.line)); Term.unsave_cursor(); flush stdout type input = [ `Backspace | `Char of char | `Delete | `Down | `End | `Eof | `Home | `Left | `Right | `Tab | `Unknown_escape of (string*int option*int option) | `Up ] let complete ~f v = let leftp = SZ.left_contents v.line in let rightp = SZ.right_contents v.line in match f ~left:leftp ~right:rightp with | [left] -> {v with line = SZ.create left ""} | [] -> Term.bell(); v | matches -> (* TODO: Multiple entries on one line with console.*) print_newline (); List.iter matches ~f:print_endline; v let backspace v = match SZ.drop_before v.line with | None -> v | Some (_,l) -> {v with line = l} let delete v = match SZ.drop_after v.line with | None -> v | Some (_,l) -> {v with line = l } let up_history v = match LZ.drop_after v.hist with | None -> v | Some (e,h) -> { hist = LZ.insert_before h (SZ.contents v.line); line = SZ.create e "" } let down_history v = match LZ.drop_before v.hist with | None -> v | Some (e,h) -> {hist = LZ.insert_after h (SZ.contents v.line); line = (SZ.create e "") } let cursor_left v = { v with line = Option.value (SZ.previous v.line) ~default:v.line } let cursor_right v = { v with line = Option.value (SZ.next v.line) ~default:v.line } let step ?completion (v:t) : input -> t = function | `Tab -> begin match completion with | Some f -> complete ~f v | None -> { v with line = SZ.insert_before v.line '\t' } end | `Backspace -> backspace v | `Delete -> delete v | `Up -> up_history v | `Down -> down_history v | `Left -> cursor_left v | `Right -> cursor_right v | `Home -> { v with line = SZ.first v.line } | `End -> { v with line = SZ.last v.line } | `Unknown_escape _ -> v | `Char c -> { v with line = SZ.insert_before v.line c } | `Eof -> raise End_of_file core_extended-113.00.00/src/readline__input_loop.mli000066400000000000000000000007461256461102500223210ustar00rootroot00000000000000(* This is an internal module: it shouldn't be used outside of core_extended*) type t val create : ?text:string -> string list -> t val print : prompt:string -> map_out:(string -> string) -> t -> unit val contents : t -> string type input = [ `Backspace | `Char of char | `Delete | `Down | `End | `Eof | `Home | `Left | `Right | `Tab | `Unknown_escape of (string*int option*int option) | `Up ] val step : ?completion:(left:string -> right:string -> string list) -> t -> input -> t core_extended-113.00.00/src/runtime_blockout_detector.ml000066400000000000000000000007661256461102500232360ustar00rootroot00000000000000open Core.Std let default_callback ~elapsed = eprintf !"tick thread stopped for %{Time.Span}\n%!" elapsed ;; let start ?(callback = default_callback) () = let r = ref (Time.now ()) in ignore (Thread.create (fun () -> while true do Time.pause (Time.Span.of_ms 10.0); let now = Time.now () in let elapsed = Time.diff now !r in r := now; if Time.Span.(>) elapsed (Time.Span.of_ms 50.) then callback ~elapsed; done) () : Thread.t); ;; core_extended-113.00.00/src/runtime_blockout_detector.mli000066400000000000000000000005661256461102500234050ustar00rootroot00000000000000(** [Runtime_blockout_detector] is used detect bugs in C libraries that fail to release the OCaml runtime lock before making blocking calls. *) open Core.Std (** [start] starts a thread that watches for blockouts where the OCaml lock isn't released. By default, it prints a message to stderr. *) val start : ?callback:(elapsed:Time.Span.t -> unit) -> unit -> unit core_extended-113.00.00/src/rw_mutex.ml000066400000000000000000000136321256461102500176260ustar00rootroot00000000000000(* This is a complete rewrite of David Mentré's Rw_mutex-module (part of his ocaml_thread_synchro-library): Copyright 2004 Jane Street Group, LLC (author: Markus Mottl) Copyright 2001 David Mentré All rights reserved. This file is distributed under the terms of the GNU Library General Public License. *) type pref = [ `Readers | `Writers | `NoPref ] type 'pref kind = pref let r_pref = `Readers let w_pref = `Writers let np_pref = `NoPref type rw_t = { rw_mtx : Mutex.t; read_cond : Condition.t; write_cond : Condition.t; mutable rw_active : int; mutable read_wait : int; mutable write_wait : int; } type np_t = { np_mtx : Mutex.t; cond : Condition.t; mutable np_active : int; } type 'pref t = Readers of rw_t | Writers of rw_t | NoPref of np_t let create_rw () = { rw_mtx = Mutex.create (); read_cond = Condition.create (); write_cond = Condition.create (); rw_active = 0; read_wait = 0; write_wait = 0; } let create = function | `Readers -> Readers (create_rw ()) | `Writers -> Writers (create_rw ()) | `NoPref -> NoPref { np_mtx = Mutex.create (); cond = Condition.create (); np_active = 0; } let r_lock = function | Readers m -> let mtx = m.rw_mtx in Mutex.lock mtx; if m.rw_active < 0 then ( m.read_wait <- m.read_wait + 1; while m.rw_active < 0 do Condition.wait m.read_cond mtx done; m.read_wait <- m.read_wait - 1); m.rw_active <- m.rw_active + 1; Mutex.unlock mtx | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; if m.rw_active < 0 || m.write_wait > 0 then ( m.read_wait <- m.read_wait + 1; while m.rw_active < 0 || m.write_wait > 0 do Condition.wait m.read_cond mtx done; m.read_wait <- m.read_wait - 1); m.rw_active <- m.rw_active + 1; Mutex.unlock mtx | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; while m.np_active < 0 do Condition.wait m.cond mtx done; m.np_active <- m.np_active + 1; Mutex.unlock mtx let r_unlock = function | Readers m | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; let active_1 = m.rw_active - 1 in m.rw_active <- active_1; if active_1 = 0 && m.write_wait > 0 then Condition.signal m.write_cond; Mutex.unlock mtx | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; let active_1 = m.np_active - 1 in m.np_active <- active_1; if active_1 = 0 then Condition.signal m.cond; Mutex.unlock mtx let w_lock = function | Readers m | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; if m.rw_active <> 0 then ( m.write_wait <- m.write_wait + 1; while m.rw_active <> 0 do Condition.wait m.write_cond mtx done; m.write_wait <- m.write_wait - 1); m.rw_active <- -1; Mutex.unlock mtx | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; while m.np_active <> 0 do Condition.wait m.cond mtx done; m.np_active <- -1; Mutex.unlock mtx let w_unlock = function | Readers m -> let mtx = m.rw_mtx in Mutex.lock mtx; m.rw_active <- 0; if m.read_wait > 0 then Condition.broadcast m.read_cond else if m.write_wait > 0 then Condition.signal m.write_cond; Mutex.unlock mtx | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; m.rw_active <- 0; if m.write_wait > 0 then Condition.signal m.write_cond else if m.read_wait > 0 then Condition.broadcast m.read_cond; Mutex.unlock mtx | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; m.np_active <- 0; Condition.broadcast m.cond; Mutex.unlock mtx let try_r_lock = function | Readers m -> let mtx = m.rw_mtx in Mutex.lock mtx; let active = m.rw_active in let only_readers = active >= 0 in if only_readers then m.rw_active <- active + 1; Mutex.unlock mtx; only_readers | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; let active = m.rw_active in let only_readers = m.write_wait = 0 && active >= 0 in if only_readers then m.rw_active <- active + 1; Mutex.unlock mtx; only_readers | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; let active = m.np_active in let only_readers = active >= 0 in if only_readers then m.np_active <- active + 1; Mutex.unlock mtx; only_readers let try_w_lock = function | Readers m -> let mtx = m.rw_mtx in Mutex.lock mtx; let no_others = m.rw_active = 0 && m.read_wait = 0 in if no_others then m.rw_active <- -1; Mutex.unlock mtx; no_others | Writers m -> let mtx = m.rw_mtx in Mutex.lock mtx; let no_others = m.rw_active = 0 in if no_others then m.rw_active <- -1; Mutex.unlock mtx; no_others | NoPref m -> let mtx = m.np_mtx in Mutex.lock mtx; let no_others = m.np_active = 0 in if no_others then m.np_active <- -1; Mutex.unlock mtx; no_others let wrap_r_lock m f = r_lock m; let res = try f () with exc -> r_unlock m; raise exc in r_unlock m; res let try_wrap_r_lock m f = if try_r_lock m then ( let res = try f () with exc -> r_unlock m; raise exc in r_unlock m; Some res) else None let btry_wrap_r_lock m f = try_r_lock m && ( (try f () with exc -> r_unlock m; raise exc); r_unlock m; true) let wrap_w_lock m f = w_lock m; let res = try f () with exc -> w_unlock m; raise exc in w_unlock m; res let try_wrap_w_lock m f = if try_w_lock m then ( let res = try f () with exc -> w_unlock m; raise exc in w_unlock m; Some res) else None let btry_wrap_w_lock m f = try_w_lock m && ( (try f () with exc -> w_unlock m; raise exc); w_unlock m; true) core_extended-113.00.00/src/rw_mutex.mli000066400000000000000000000055661256461102500200060ustar00rootroot00000000000000(** Read/write mutexes @author Markus Mottl *) (** {2 Types} *) (** {3 Real types} *) (** Type of r/w mutexes *) type 'pref t (** {3 Phantom types} *) (** Preference for readers, writers, or no preference *) type pref = [ `Readers | `Writers | `NoPref ] (** Preference kind of read/write mutexes *) type 'pref kind (** {2 Phantom values} *) val r_pref : [ `Readers ] kind (** [r_pref] preference kind for readers. *) val w_pref : [ `Writers ] kind (** [w_pref] preference kind for writers. *) val np_pref : [ `NoPref ] kind (** [np_pref] no preference for readers or writers. *) (** {2 Mutex operations} *) val create : 'pref kind -> 'pref t (** [create pref] @return a r/w-mutex with preference kind [pref]. *) val r_lock : [< pref ] t -> unit (** [r_lock mtx] locks [mtx] for a reader. *) val r_unlock : [< pref ] t -> unit (** [r_unlock mtx] unlocks [mtx] for a reader. *) val w_lock : [< pref ] t -> unit (** [w_lock mtx] locks [mtx] for a writer. *) val w_unlock : [< pref ] t -> unit (** [w_unlock mtx] unlocks [mtx] for a writer. *) val try_r_lock : [< pref ] t -> bool (** [try_r_lock mtx] tries to lock [mtx] for a reader without blocking. @return [true] iff [mtx] could be locked, [false] otherwise. *) val try_w_lock : [< pref ] t -> bool (** [try_w_lock mtx] tries to lock [mtx] for a writer without blocking. @return [true] iff [mtx] could be locked, [false] otherwise. *) val wrap_r_lock : [< pref ] t -> (unit -> 'a) -> 'a (** [wrap_r_lock mtx f] locks [mtx] for a reader, executes [f] and unlocks the mutex again. @return the result of [f]. *) val try_wrap_r_lock : [< pref ] t -> (unit -> 'a) -> 'a option (** [try_wrap_r_lock mtx f] tries to lock [mtx] for a reader without blocking, executes [f] and unlocks the mutex again. @return [Some res], where [res] is the result of [f], iff the mutex could be locked, [None] otherwise. *) val btry_wrap_r_lock : [< pref ] t -> (unit -> unit) -> bool (** [btry_wrap_r_lock mtx f] tries to lock [mtx] for a reader without blocking, executes [f] and unlocks the mutex again. @return [true] iff the mutex could be locked, [false] otherwise. *) val wrap_w_lock : [< pref ] t -> (unit -> 'a) -> 'a (** [wrap_w_lock mtx f] locks [mtx] for a writer, executes [f] and unlocks the mutex again. @return the result of [f]. *) val try_wrap_w_lock : [< pref ] t -> (unit -> 'a) -> 'a option (** [try_wrap_w_lock mtx f] tries to lock [mtx] for a writer without blocking, executes [f] and unlocks the mutex again. @return [Some res], where [res] is the result of [f], iff the mutex could be locked, [None] otherwise. *) val btry_wrap_w_lock : [< pref ] t -> (unit -> unit) -> bool (** [btry_wrap_w_lock mtx f] tries to lock [mtx] for a writer without blocking, executes [f] and unlocks the mutex again. @return [true] iff the mutex could be locked, [false] otherwise. *) core_extended-113.00.00/src/sampler.ml000066400000000000000000000055371256461102500174240ustar00rootroot00000000000000(* This algorithm was originally described in the paper "A Linear Algorithm For Generating Random Numbers With a Given Distribution" by Michael Vose. original paper: http://web.eecs.utk.edu/~vose/Publications/random.pdf decent exposition: http://www.keithschwarz.com/darts-dice-coins/ *) open Core.Std type 'a cell = Single of 'a | Branch of float * 'a * 'a type 'a t = 'a cell array let sample ?state t = let module R = Random.State in let s = Option.value state ~default:R.default in let i = R.int s (Array.length t) in match t.(i) with | Single a -> a | Branch (p, a, b) -> if R.float s 1.0 < p then a else b let create dist = let dist = (* the following two steps are fused together into a single normalization phase that is both more efficient and more numerically stable than the two passes done in sequence. 1. we support histograms as inputs by scaling all "probabilities" so that they add up to 1. This is done by dividing each "probability" by the sum of all the "probabilities". 2. the remainder of the algorithm works in terms of scaled probabilities: multiplied by the size of the distribution. *) let w = List.fold ~f:(fun sum (_, p) -> sum +. p) ~init:0. dist in let n = float (List.length dist) in List.map dist ~f:(fun (a, p) -> (a, (p *. n) /. w)) in (* loop invariants: 1. forall [ p >= 1 | (_, p) <- above ] 2. forall [ p < 1 | (_, p) <- below ] 3. length acc + length above + length below = length dist *) let add (below, above) (x, p) = if p < 1. then ((x, p) :: below, above) else (below, (x, p) :: above) in let rec loop acc = function | ((b, pb) :: below, (a, pa) :: above) -> let pa = (pa +. pb) -. 1.0 in loop (Branch (pb, b, a) :: acc) (add (below, above) (a, pa)) | (below, (x, _) :: above) | ((x, _) :: below, above) -> loop (Single x :: acc) (below, above) | ([], []) -> Array.of_list acc in loop [] (List.fold ~f:add ~init:([], []) dist) TEST_MODULE = struct let probs = [ ("A", 0.083); ("B", 0.084); ("C", 0.333); ("D", 0.500); ] let t : string t = create probs let histogram = String.Table.create ~size:5 () let num_samples = 10_000_000 TEST_UNIT = for _i = 1 to num_samples do let key = sample t in incr (Hashtbl.find_or_add histogram key ~default:(fun () -> ref 0)) done let test_outcome key = let prob = List.Assoc.find_exn probs key in let count = !(Hashtbl.find_exn histogram key) in let percentage = float count /. float num_samples in if Float.abs (percentage -. prob) > 0.001 then failwithf "prob = %G; percentage = %G" prob percentage () TEST_UNIT = test_outcome "A" TEST_UNIT = test_outcome "B" TEST_UNIT = test_outcome "C" TEST_UNIT = test_outcome "D" end core_extended-113.00.00/src/sampler.mli000066400000000000000000000011751256461102500175670ustar00rootroot00000000000000open Core.Std (** a compiled finite discrete probability distribution that supports constant time sampling *) type 'a t (** [create dist] compiles a discrete probability distribution into a form supporting constant-time sampling. The running time is O(N) where N = [List.length dist]. [dist] may be either a probability distribution (all floats are non-negative and sum to 1) or, more generally, a histogram in which frequencies are interpreted as probabilities. *) val create : ('a * float) list -> 'a t (** randomly sample the distribution in constant time *) val sample : ?state:Random.State.t -> 'a t -> 'a core_extended-113.00.00/src/search_foo.ml000066400000000000000000000065511256461102500200660ustar00rootroot00000000000000open Core.Std type comparison = int (** cf Jane.Std.Common.ascending *) let cmp_fasc f = fun x y -> compare (f x) (f y) (** cf Jane.Std.Common.descending *) let cmp_fdesc f = fun x y -> compare (f y) (f x) (** Given a function [f], returns a maximizer of [f]. *) let maxf f = (fun x y -> if (f x) > (f y) then x else y) (** Given a function [f], returns a minimizer of [f]. *) let minf f = (fun x y -> if (f x) < (f y) then x else y) let rec in_order lst ~cmp = match lst with | [] | _::[] -> true | first::second::tl -> if (cmp first second) = -1 then (in_order (second::tl) ~cmp) else false (* return the max length of strings in the array *) let max_len ~key strings = Array.fold ~init:0 strings ~f:(fun acc s -> max acc (String.length (key s))) (** Binary search. (f i) returns an integer and should be monotonic. f should have values for all i in [low,high], inclusive. if \E i \in [low,high] such that (f i) = 0, then such an i is returned. Otherwise, i is returned such that (f i > 0) and (f (i-1) < 0). Unless it's all > 0 or all < 0. If it's all > 0, then the first i is returned. If it's all < 0, then returns None *) let bsearch_internal ~f ~low ~high = let rec loop ~f ~low ~high = if low = high then match f low with | 0 -> Some low | x -> if x > 0 then Some low else None else let mid = (low + high)/2 in match f mid with | 0 -> Some mid | x -> if x > 0 then loop ~f ~low ~high:mid else loop ~f ~low:(mid+1) ~high in if high < low then None else loop ~f ~low ~high let bsearch_opt = bsearch_internal let bsearch_exn ~f ~low ~high = match bsearch_internal ~f ~low ~high with | Some x -> x | None -> raise Not_found let bsearch = bsearch_opt type poly_comparison = [`Low | `Good | `High] let bsearch2_internal ~f ~low ~high = let rec loop ~f ~low ~high = if low = high then match f low with `Good -> Some low | _ -> None else let mid = (low + high)/2 in match f mid with | `Good -> Some mid | `Low -> loop ~f ~low:(mid+1) ~high | `High -> loop ~f ~low ~high:mid in if high < low then None else loop ~f ~low ~high let bsearch2_opt = bsearch2_internal let bsearch2_exn ~f ~low ~high = match bsearch2_internal ~f ~low ~high with | Some x -> x | None -> raise Not_found let bsearch2 = bsearch2_opt (** similar to bsearch, but returns (index,value) pair. f is expected to return a (test,value) pair, where test is like the output of f above, and value is some related value. *) let bsearch_val_internal ~f ~low ~high = let rec loop ~f ~low ~high = if low = high then let (test,value) = f low in match test with | 0 -> Some (low,value) | x -> if x > 0 then Some (low,value) else None else let mid = (low + high)/2 in let (test,value) = f mid in match test with | 0 -> Some (mid,value) | 1 -> loop ~f ~low ~high:mid | (-1) -> loop ~f ~low:(mid+1) ~high | _ -> raise (Failure ("bsearch_val: " ^ "Search returned value other than -1,0,1")) in if high < low then None else loop ~f ~low ~high let bsearch_val_opt = bsearch_val_internal let bsearch_val_exn ~f ~low ~high = match bsearch_val_internal ~f ~low ~high with | Some x -> x | None -> raise Not_found let bsearch_val = bsearch_val_opt core_extended-113.00.00/src/search_foo.mli000066400000000000000000000026311256461102500202320ustar00rootroot00000000000000(* stands for a comparison like would be returned by polymorphic compare *) type comparison = int (* 'comparable is supposed to indicate a type on which polymorphic compare will not raise an exception *) val cmp_fasc : ('a -> 'comparable) -> 'a -> 'a -> comparison val cmp_fdesc : ('a -> 'comparable) -> 'a -> 'a -> comparison val maxf : ('a -> 'comparable) -> 'a -> 'a -> 'a val minf : ('a -> 'comparable) -> 'a -> 'a -> 'a val in_order : 'a list -> cmp:('a -> 'a -> comparison) -> bool val max_len : key:('a -> string) -> 'a array -> int (* [f] should return the comparison of its argument with the "good" value. *) val bsearch : f:(int -> comparison) -> low:int -> high:int -> int option val bsearch_opt : f:(int -> comparison) -> low:int -> high:int -> int option val bsearch_exn : f:(int -> comparison) -> low:int -> high:int -> int type poly_comparison = [`Low | `Good | `High] val bsearch2 : f:(int -> poly_comparison) -> low:int -> high:int -> int option val bsearch2_opt : f:(int -> poly_comparison) -> low:int -> high:int -> int option val bsearch2_exn : f:(int -> poly_comparison) -> low:int -> high:int -> int val bsearch_val : f:(int -> comparison * 'a) -> low:int -> high:int -> (int * 'a) option val bsearch_val_opt : f:(int -> comparison * 'a) -> low:int -> high:int -> (int * 'a) option val bsearch_val_exn : f:(int -> comparison * 'a) -> low:int -> high:int -> (int * 'a) core_extended-113.00.00/src/semaphore.ml000066400000000000000000000016171256461102500177370ustar00rootroot00000000000000type 'a t = { mutable v_opt : 'a option; mtx : Mutex.t; cond : Condition.t } let init v_opt = { v_opt = v_opt; mtx = Mutex.create (); cond = Condition.create () } let signal sem v = Mutex.lock sem.mtx; let v_opt = sem.v_opt in sem.v_opt <- Some v; if v_opt = None then Condition.signal sem.cond; Mutex.unlock sem.mtx let wait_return sem v = sem.v_opt <- None; Mutex.unlock sem.mtx; v let rec wait_loop sem = Condition.wait sem.cond sem.mtx; match sem.v_opt with | None -> wait_loop sem | Some v -> wait_return sem v let wait sem = Mutex.lock sem.mtx; match sem.v_opt with | None -> wait_loop sem | Some v -> wait_return sem v let get sem = match sem.v_opt with | None as none -> none | _ -> Mutex.lock sem.mtx; let res = sem.v_opt in sem.v_opt <- None; Mutex.unlock sem.mtx; res let look sem = sem.v_opt core_extended-113.00.00/src/semaphore.mli000066400000000000000000000022431256461102500201040ustar00rootroot00000000000000(** Semaphores @author Markus Mottl *) (** Type of semaphores *) type 'a t val init : 'a option -> 'a t (** [init v] initializes a semaphore with an optional value [v]. If it is [Some x], then {!Semaphore.wait} will return immediately with [x], otherwise it will block until {!Semaphore.signal} is called. *) val signal : 'a t -> 'a -> unit (** [signal sem v] allows one thread blocked in {!Semaphore.wait} on semaphore [sem] to continue. The semaphore will then block again further threads. *) val wait : 'a t -> 'a (** [wait sem] blocks the calling thread on semaphore [sem] if it was not initialized with [Some x] or not signalled before. The semaphore is reset to [None], i.e. calling [wait] again will block unless the semaphore was signalled inbetween. *) val get : 'a t -> 'a option (** [get sem] @return [None] if semaphore is not set, [Some value] otherwise. The semaphore is reset to [None], and a subsequent wait will block again. *) val look : 'a t -> 'a option (** [look sem] @return [None] if semaphore is not set, [Some value] otherwise. The state of the semaphore remains unchanged. *) core_extended-113.00.00/src/sendmail.ml000066400000000000000000000052131256461102500175440ustar00rootroot00000000000000(** Simple (and likely incomplete) interface for sending mail *) (* Sendmail is specified in the LSB http://refspecs.linux-foundation.org/LSB_3.2.0/LSB-Core-generic/LSB-Core-generic/baselib-sendmail-1.html and should respect the rfc-5322 http://tools.ietf.org/html/rfc5322.html Do not change antyhing in here if you haven't read the rfc. *) (* TODO: implement mime encoding... Email adr validation? *) open Core.Std (* Sadly enough not all mta implement the rfc properly so we need to sniff them out. There's no reliable way to do so but most distributions rely on symlinks. *) type mta = | Ssmtp | Sendmail | Unknown (* Memo.unit isn't threadsafe. Multiple concurrent calls to sendmail can raise Lazy.Undefined *) let mta_mutex = Mutex.create () ;; let mta_memo = Memo.unit (fun () -> match Result.try_with (fun () -> match Shell.run_one "readlink" ["-f";"/usr/sbin/sendmail"] with | None -> assert false | Some path -> Filename.basename path) with | Ok "sendmail.sendmail" -> Sendmail | Ok "ssmtp" -> Ssmtp | _ -> Unknown ) ;; let mta () = Mutex.critical_section mta_mutex ~f:mta_memo ;; let header k v buf nl = Printf.bprintf buf "%s%s" (Extended_string.word_wrap (k ^ ": " ^ v) ~nl:(nl^ " ") ~trailing_nl:false ~soft_limit:78 ~hard_limit:998) nl let send ?sender ?subject ?(cc=[]) ?(bcc=[]) ?(reply_to=[]) ?content_type ?message_id ?in_reply_to ?auto_generated ~recipients body = let nl = match mta () with | Sendmail | Unknown -> "\r\n" | Ssmtp -> "\n" (* ssmtp really is a piece of junk... *) in let buf = Buffer.create (String.length body * 2) in let option key = Option.iter ~f:(fun v -> header key v buf nl) in let list key = function | [] -> () | l -> header key (String.concat ~sep:("," ^ nl ^ " ") l) buf nl in (* Both the [Auto-Submitted] and [Precedence] headers are used to indicate an auto-generated email. To improve the odds of working with an unknown mail server, send both headers. *) let auto_generated_headers () = header "Auto-Submitted" "auto-generated" buf nl; header "Precedence" "bulk" buf nl in option "From" sender; list "To" recipients; option "Subject" subject; option "Content-type" content_type; list "Cc" cc; list "Bcc" bcc; list "Reply-to" reply_to; option "Message-ID" message_id; option "In-Reply-To" in_reply_to; Option.iter auto_generated ~f:auto_generated_headers; Printf.bprintf buf "%s%s" nl body; let input = Buffer.contents buf in Shell.run ~input "/usr/sbin/sendmail" ["-t";"-oi"] core_extended-113.00.00/src/sendmail.mli000066400000000000000000000004161256461102500177150ustar00rootroot00000000000000val send : ?sender:string -> ?subject:string -> ?cc:string list -> ?bcc:string list -> ?reply_to:string list -> ?content_type:string -> ?message_id:string -> ?in_reply_to:string -> ?auto_generated:unit -> recipients:string list -> string -> unit core_extended-113.00.00/src/service-template.sh000066400000000000000000000011231256461102500212170ustar00rootroot00000000000000#!/usr/bin/env bash # # /etc/rc.d/init.d/foo # # Starts the foo daemon # # chkconfig: 345 95 5 # description: the foo service makes all your dreams come true and \ # is really quite awesome. # processname: foo . /etc/init.d/functions # this definition belongs in /etc/init.d/functions function ocaml-init-script { cmd="$1" subcmd="$2" case "$subcmd" in start|stop|restart|status) $cmd $subcmd; exit $? ;; *) echo $"Usage: $0 {start|stop|restart|status}" exit 1 esac } ocaml-init-script '/path/to/exe/for/foo subcommand ... service-subcommand' "$1" core_extended-113.00.00/src/service_command.ml000066400000000000000000000114771256461102500211170ustar00rootroot00000000000000open Core.Std type slot = { lock_file : string; name : string; redirect_stdout : Daemon.Fd_redirection.t; redirect_stderr : Daemon.Fd_redirection.t; } module type T = sig type main val slot_spec : unit -> (slot -> 'm, 'm) Command.Spec.t val main_spec : (foreground:bool -> main, unit -> unit) Command.Spec.t val main : slot -> main end type t = (module T) let check_lock_file { lock_file; name=_; redirect_stdout=_; redirect_stderr=_ } = if Lock_file.is_locked lock_file then `Running_with_pid (Pid.t_of_sexp (Sexp.load_sexp lock_file)) else `Not_running let acquire_lock_exn slot = Lock_file.create ~close_on_exec:false ~unlink_on_exit:true slot.lock_file let still_alive pid = (* receiving [Signal.zero] is a no-op, but sending it gives info about whether there a running process with that pid *) match Signal.send Signal.zero (`Pid pid) with | `Ok -> true | `No_such_process -> false let start_daemon slot main ~foreground = let release_parent = if foreground then Fn.id else unstage (Daemon.daemonize_wait () ~redirect_stdout:slot.redirect_stdout ~redirect_stderr:slot.redirect_stderr) in (* lock file created after [daemonize_wait] so that *child* pid is written to the lock file rather than the parent pid *) if acquire_lock_exn slot (* this writes our pid in the file *) then begin (* we release the daemon's parent *after* the lock file is created so that any error messages during lock file creation happen prior to severing the daemon's connection to std{out,err} *) release_parent (); main slot end else begin eprintf "lock file already held for %s. refusing to start.\n%!" slot.name; (* To be absolutely safe, we can't automatically remove the lock even if the locking process is dead, because there could be a race condition. *) begin match check_lock_file slot with | `Not_running -> eprintf "locking process not running.\n%!"; eprintf "if safe, remove %s and try again.\n%!" slot.lock_file | `Running_with_pid pid -> eprintf "locking process %d may still be running.\n%!" (Pid.to_int pid); eprintf "if desired, kill and try again.\n%!" end; exit 1 end let stop_signal_flag = Command.Spec.( map ~f:(fun kill -> if kill then Signal.kill else Signal.term) (flag "-kill" no_arg ~doc:" send SIGKILL instead of SIGTERM") ) let stop signal slot = let was_not_running () = eprintf "%s was not running\n%!" slot.name; `Was_not_running in match check_lock_file slot with | `Not_running -> was_not_running () | `Running_with_pid pid -> let timeout_span = sec 10. in let deadline = Time.add (Time.now ()) timeout_span in match Signal.send signal (`Pid pid) with | `No_such_process -> was_not_running () | `Ok -> let rec wait_loop () = if Time.(>=) (Time.now ()) deadline then begin eprintf "failed to observe %s die after %s\n%!" slot.name (Time.Span.to_string timeout_span); `Did_not_die end else if still_alive pid then begin Time.pause (sec 0.2); wait_loop () end else `Died in wait_loop () let status_command t = let module T = (val t : T) in Command.basic ~summary:(sprintf "check status of daemon") (T.slot_spec ()) (fun slot () -> match check_lock_file slot with | `Not_running -> printf "%s is not running\n%!" slot.name | `Running_with_pid pid -> if still_alive pid then printf !"%s is running with pid %{Pid}\n%!" slot.name pid else printf !"%s is not running, even though we saw pid %{Pid} in its lockfile\n%!" slot.name pid) let stop_command t = let module T = (val t : T) in Command.basic ~summary:"stop daemon" Command.Spec.(empty +> stop_signal_flag ++ T.slot_spec ()) (fun signal slot -> match stop signal slot with | `Was_not_running | `Did_not_die -> exit 1 | `Died -> exit 0) let start_command t = let module T = (val t : T) in Command.basic ~summary:"restart daemon" Command.Spec.(T.slot_spec () ++ T.main_spec) (fun slot -> start_daemon slot T.main) let restart_command t = let module T = (val t : T) in Command.basic ~summary:"restart daemon" Command.Spec.(empty +> stop_signal_flag ++ T.slot_spec () ++ T.main_spec) (fun signal slot -> match stop signal slot with | `Did_not_die -> exit 1 | `Was_not_running | `Died -> start_daemon slot T.main) let group t ~summary = Command.group ~summary [ ("start", start_command t); ("stop", stop_command t); ("restart", restart_command t); ("status", status_command t); ] let start = start_command let stop = stop_command let restart = restart_command let status = status_command core_extended-113.00.00/src/service_command.mli000066400000000000000000000016341256461102500212620ustar00rootroot00000000000000open Core.Std type slot = { lock_file : string; name : string; redirect_stdout : Daemon.Fd_redirection.t; redirect_stderr : Daemon.Fd_redirection.t; } module type T = sig val slot_spec : unit -> (slot -> 'm, 'm) Command.Spec.t type main val main_spec : (foreground:bool -> main, unit -> unit) Command.Spec.t val main : slot -> main end type t = (module T) val start : t -> Command.t val stop : t -> Command.t val status : t -> Command.t val restart : t -> Command.t val group : t -> summary:string -> Command.t (** [acquire_lock_exn slot] locks [slot]. This can be used from within another program to ensure that no server is running while, e.g., an offline backup is run. Due to the semantics of the underlying [Lock_file.create] call, this lock is only released when the process exits. To release earlier, delete the lock file manually. **) val acquire_lock_exn : slot -> bool core_extended-113.00.00/src/set_lang.ml000066400000000000000000000307121256461102500175460ustar00rootroot00000000000000 open Core.Std module Raw = struct (* Invariants: 1. Unions are right-associative, with at most one Set as top left child. 2. Inters are right-associative, with at most one Set as top left child. 3. Diffs have at most one Set child. 4. Unions, Diffs, and Inters do not have empty Sets as children. *) type ('base, 'set) t = | Base of 'base | Set of 'set | Union of ('base, 'set) t * ('base, 'set) t | Inter of ('base, 'set) t * ('base, 'set) t | Diff of ('base, 'set) t * ('base, 'set) t with bin_io, compare end open Raw type ('base, 'elt, 'cmp) t = ('base, ('elt, 'cmp) Set.t) Raw.t with compare (**************************************** Constructors ****************************************) let base b = Base b let set s = Set s let u s1 s2 = Set (Set.union s1 s2) let i s1 s2 = Set (Set.inter s1 s2) let d s1 s2 = Set (Set.diff s1 s2) let rec union2 t1 t2 = match t1, t2 with | Union (Set s1, t1), Union (Set s2, t2) -> union2 (u s1 s2) (union2 t1 t2) | Union (Set s1, t), Set s2 | Set s1, Union (Set s2, t) -> union2 (u s1 s2) t | Set s1, Set s2 -> u s1 s2 | Union (Set s, t1), t2 | t1, Union (Set s, t2) -> union2 (Set s) (union2 t1 t2) | Set s, t | t, Set s when Set.is_empty s -> t | Set s, t | t, Set s -> Union (Set s, t) | Union (t1, t2), t3 -> union2 t1 (union2 t2 t3) | t1, t2 -> Union (t1, t2) let rec inter2 t1 t2 = match t1, t2 with | Inter (Set s1, t1), Inter (Set s2, t2) -> inter2 (i s1 s2) (inter2 t1 t2) | Inter (Set s1, t), Set s2 | Set s1, Inter (Set s2, t) -> inter2 (i s1 s2) t | Set s1, Set s2 -> i s1 s2 | Inter (Set s, t1), t2 | t1, Inter (Set s, t2) -> inter2 (Set s) (inter2 t1 t2) | Set s, _ | _, Set s when Set.is_empty s -> Set s | Set s, t | t, Set s -> Inter (Set s, t) | Inter (t1, t2), t3 -> inter2 t1 (inter2 t2 t3) | t1, t2 -> Inter (t1, t2) let rec diff t1 t2 = match t1, t2 with (* The next three clauses do not enforce invariants, but they do allow us to simplify the term by precomputing the difference of two concrete sets. *) | Set s1, Union (Set s2, t) -> diff (d s1 s2) t | Inter (Set s1, t), Set s2 -> inter2 (d s1 s2) t | Inter (Set s1, t1), Union (Set s2, t2) -> diff (inter2 (d s1 s2) t1) t2 (* The next clause does not enforce an invariant, and does not necessarily simplify the term. However, it does turn nested diff into union, and union has more ways it can simplify. *) | Diff (t1, t2), t3 -> diff t1 (union2 t2 t3) | Set s1, Set s2 -> d s1 s2 | Set s, _ when Set.is_empty s -> Set s | t, Set s when Set.is_empty s -> t | t1, t2 -> Diff (t1, t2) let union (t, ts) = List.fold ts ~init:t ~f:union2 let inter (t, ts) = List.fold ts ~init:t ~f:inter2 let union_list = function | [] -> Or_error.error_string "Set_lang.union_list: empty list is not allowed" | t::ts -> Or_error.return (union (t,ts)) let inter_list = function | [] -> Or_error.error_string "Set_lang.inter_list: empty list is not allowed" | t::ts -> Or_error.return (inter (t,ts)) let union_list_exn ts = Or_error.ok_exn (union_list ts) let inter_list_exn ts = Or_error.ok_exn (inter_list ts) let make_union empty ts = match ts with | [] -> set empty | t::ts -> union (t,ts) (**************************************** Invariant ****************************************) let rec invariant = function (* Union, Inter, and Diff do not have empty Set as child *) | Union (Set s, _) | Inter (Set s, _) | Diff (Set s, _) | Union (_, Set s) | Inter (_, Set s) | Diff (_, Set s) when Set.is_empty s -> assert false (* Union and Inter are right-associative *) | Union (Union (_,_), _) | Inter (Inter (_,_), _) -> assert false (* Union and Inter only have Set as left child *) | Union (_, Set _) | Inter (_, Set _) -> assert false (* Union and Inter only have Set as top child *) | Union (_, Union (Set _,_)) | Inter (_, Inter (Set _,_)) -> assert false (* Diff has at most one Set as child *) | Diff (Set _, Set _) -> assert false | Union (t1,t2) | Inter (t1,t2) | Diff (t1,t2) -> invariant t1; invariant t2 | Set _ | Base _ -> () (**************************************** Accessors ****************************************) let rec values_acc t acc = match t with | Base b -> b :: acc | Set _ -> acc | Union (t1, t2) -> values_acc t1 (values_acc t2 acc) | Inter (t1, t2) -> values_acc t1 (values_acc t2 acc) | Diff (t1, t2) -> values_acc t1 (values_acc t2 acc) let values t = values_acc t [] let constant_value = function | Set s -> Some s | _ -> None (**************************************** Sexp Conversion ****************************************) let rec gather_union = function | Union (t1, t2) -> t1 :: gather_union t2 | t -> [t] let rec gather_inter = function | Inter (t1, t2) -> t1 :: gather_inter t2 | t -> [t] let sexp_of_t sexp_of_base sexp_of_set = let rec loop = function | Base b -> sexp_of_base b | Union (t1, t2) -> Sexp.List (Sexp.Atom "union" :: loop t1 :: List.map (gather_union t2) ~f:loop) | Inter (t1, t2) -> Sexp.List (Sexp.Atom "inter" :: loop t1 :: List.map (gather_inter t2) ~f:loop) | Diff (t1, t2) -> Sexp.List [ Sexp.Atom "diff"; loop t1; loop t2 ] | Set s -> Sexp.List [Sexp.Atom "set" ; sexp_of_set s ] in loop let is_tag str1 str2 = String.lowercase str1 = String.lowercase str2 let make_t_of_sexp ~module_name ~union base_of_sexp set_of_sexp = let type_name = "Set_lang." ^ module_name ^ ".t" in let rec loop sexp0 = match sexp0 with | Sexp.List (Sexp.Atom tag :: sexps) when is_tag tag "union" -> union (List.map sexps ~f:loop) | Sexp.List (Sexp.Atom tag :: sexps) when is_tag tag "inter" -> (match sexps with | sexp1 :: rest -> inter (loop sexp1, List.map rest ~f:loop) | _ -> Sexplib.Conv_error.stag_incorrect_n_args type_name tag sexp0) | Sexp.List (Sexp.Atom tag :: sexps) when is_tag tag "diff" -> (match sexps with | [sexp1; sexp2] -> diff (loop sexp1) (loop sexp2) | _ -> Sexplib.Conv_error.stag_incorrect_n_args type_name tag sexp0) | Sexp.List (Sexp.Atom tag :: sexps) when is_tag tag "set" -> (match sexps with | [sexp] -> set (set_of_sexp sexp) | _ -> Sexplib.Conv_error.stag_incorrect_n_args type_name tag sexp0) | _ -> base (base_of_sexp sexp0) in loop (**************************************** Modules and Functors ****************************************) module Make_monadic_eval( M : Monad.S ) = struct include M.Monad_infix let rec subst t ~f = match t with | Base b -> f b | (Set _) as t -> M.return t | Union (t1, t2) -> subst t1 ~f >>= fun t3 -> subst t2 ~f >>| fun t4 -> union2 t3 t4 | Inter (t1, t2) -> subst t1 ~f >>= fun t3 -> subst t2 ~f >>| fun t4 -> inter2 t3 t4 | Diff (t1, t2) -> subst t1 ~f >>= fun t3 -> subst t2 ~f >>| fun t4 -> diff t3 t4 let map t ~f = subst t ~f:(fun b -> f b >>| base) let specialize t ~f = subst t ~f:(fun b -> f b >>| fun opt -> Option.value_map opt ~f:set ~default:(base b)) let rec eval t ~f = match t with | Base b -> f b | Set s -> M.return s | Union (t1, t2) -> eval t1 ~f >>= fun s1 -> eval t2 ~f >>| fun s2 -> Set.union s1 s2 | Inter (t1, t2) -> eval t1 ~f >>= fun s1 -> eval t2 ~f >>| fun s2 -> Set.inter s1 s2 | Diff (t1, t2) -> eval t1 ~f >>= fun s1 -> eval t2 ~f >>| fun s2 -> Set.diff s1 s2 end module Identity_basic = struct type 'a t = 'a let bind x f = f x let return x = x let map x ~f = f x let map = `Custom map end module Identity = struct include Identity_basic include Monad.Make(Identity_basic) end include Make_monadic_eval(Identity) module type S = Set_lang_intf.S with module Raw := Raw module type S_binable = Set_lang_intf.S_binable with module Raw := Raw module Make (Elt : Comparable.S) = struct module Set = Elt.Set type 'base t = ('base, Set.t) Raw.t with compare let base = base let set = set let union2 = union2 let inter2 = inter2 let diff = diff let inter = inter let inter_list = inter_list let inter_list_exn = inter_list_exn let union ts = make_union Set.empty ts let sexp_of_t sexp_of_base = sexp_of_t sexp_of_base Set.sexp_of_t let t_of_sexp base_of_sexp = make_t_of_sexp ~module_name:"Make(_)" ~union base_of_sexp Set.t_of_sexp let values = values let constant_value = constant_value let map = map let subst = subst let specialize = specialize let eval = eval module Make_monadic_eval(M : Monad.S) = Make_monadic_eval(M) end module Make_binable (Elt : Comparable.S_binable) = struct module Set = Elt.Set type 'base t = ('base, Set.t) Raw.t with bin_io, compare let base = base let set = set let union2 = union2 let inter2 = inter2 let diff = diff let inter = inter let inter_list = inter_list let inter_list_exn = inter_list_exn let union ts = make_union Set.empty ts let sexp_of_t sexp_of_base = sexp_of_t sexp_of_base Set.sexp_of_t let t_of_sexp base_of_sexp = make_t_of_sexp ~module_name:"Make_binable(_)" ~union base_of_sexp Set.t_of_sexp let values = values let constant_value = constant_value let map = map let subst = subst let specialize = specialize let eval = eval module Make_monadic_eval(M : Monad.S) = Make_monadic_eval(M) end TEST_MODULE "set lang" = struct module Set = Char.Set module Slang = Make(Char) let compare_slang = Slang.compare String.compare let sexp_of_slang = Slang.sexp_of_t sexp_of_string let slang_of_sexp = Slang.t_of_sexp string_of_sexp module Random = struct let prng = Random.State.make (String.to_list "In theory, it does not matter what is written here." |> Array.of_list |> Array.map ~f:Char.to_int) let int i () = Random.State.int prng i let elem xs () = List.nth_exn xs (int (List.length xs) ()) let list ?(length=(int 6 ())) ~f () = List.init length ~f:(fun _ -> f ()) let chars = ['a';'b';'c'] let char () = elem chars () let char_list () = list ~f:char () let set () = Set.of_list (char_list ()) let string () = String.of_char_list (char_list ()) end let set_of_string str = Char.Set.of_list (String.to_list str) let eval_string str = set_of_string str let map_string str = String.rev str let subst_string str = if String.length str < 3 then set (eval_string str) else base (map_string str) let specialize_string str = if String.length str < 3 then Some (eval_string str) else None let eval_slang slang = eval slang ~f:eval_string let map_slang slang = map slang ~f:map_string let subst_slang slang = subst slang ~f:subst_string let specialize_slang slang = specialize slang ~f:specialize_string let cache = ref [(Char.Set.empty, set Char.Set.empty)] let set_and_slang () = let recur = Random.elem (!cache) in let recur2 () = recur(), recur() in let (set, slang) = Lazy.force (Random.elem [ lazy (let s = Random.set () in s, set s) ; lazy (let str = Random.string () in set_of_string str, base str) ; lazy (let (s1,l1),(s2,l2) = recur2() in Set.union s1 s2, Slang.union2 l1 l2) ; lazy (let (s1,l1),(s2,l2) = recur2() in Set.inter s1 s2, Slang.inter2 l1 l2) ; lazy (let (s1,l1),(s2,l2) = recur2() in Set.diff s1 s2, Slang.diff l1 l2) ; lazy (let s,l = recur() in s, map_slang l) ; lazy (let s,l = recur() in s, subst_slang l) ; lazy (let s,l = recur() in s, specialize_slang l) ] ()) in cache := (set,slang) :: !cache; (set,slang) let test set slang = let sexp = sexp_of_slang slang in let test name bool = if bool then () else failwithf "%s of:\n%s" name (Sexp.to_string_hum sexp) () in test "invariant" (try invariant slang; true with _ -> false); test "eval" (0 = Set.compare set (eval_slang slang)); test "map" (0 = Set.compare set (eval_slang (map_slang slang))); test "subst" (0 = Set.compare set (eval_slang (subst_slang slang))); test "specialize" (0 = Set.compare set (eval_slang (specialize_slang slang))); test "sexp" (0 = compare_slang slang (slang_of_sexp sexp)) TEST_UNIT = for _i = 1 to 50 * 1000 do let s,l = set_and_slang() in test s l done; end core_extended-113.00.00/src/set_lang.mli000066400000000000000000000102641256461102500177170ustar00rootroot00000000000000(* A simple DSL for sets. *) open Core.Std module Raw : sig (* [Raw.t] spells out the variants of a [t]: - value of base type - set constant - union - intersection - difference [Raw.t] is useful in interfaces because there is no explicit comparator. It is not intended for direct use in code; instead, use [t]. *) type ('base, 'set) t = private | Base of 'base | Set of 'set | Union of ('base, 'set) t * ('base, 'set) t | Inter of ('base, 'set) t * ('base, 'set) t | Diff of ('base, 'set) t * ('base, 'set) t with compare end (* A [t] is a Raw.t specialized to Set.t. *) type ('base, 'elt, 'cmp) t = ('base, ('elt, 'cmp) Set.t) Raw.t with compare (* [base], [set], [inter2], [union2], [diff]: These are "smart" constructors that simplify away constants where possible. *) val base : 'base -> ('base, _, _) t val set : ('elt, 'cmp) Set.t -> (_, 'elt, 'cmp) t val inter2 : ('b,'e,'c) t -> ('b,'e,'c) t -> ('b,'e,'c) t val union2 : ('b,'e,'c) t -> ('b,'e,'c) t -> ('b,'e,'c) t val diff : ('b,'e,'c) t -> ('b,'e,'c) t -> ('b,'e,'c) t (* [union], [union_list], [union_list_exn], [inter], [inter_list], [inter_list_exn]: These are more "smart" constructors like those above. They create unions or intersections of one or more [t]. Without a specific set type, constructing an empty union is impossible. Regardless of set type, an empty intersection is meaningless. *) val union : ('b,'e,'c) t * ('b,'e,'c) t list -> ('b,'e,'c) t val inter : ('b,'e,'c) t * ('b,'e,'c) t list -> ('b,'e,'c) t val union_list : ('b,'e,'c) t list -> ('b,'e,'c) t Or_error.t val inter_list : ('b,'e,'c) t list -> ('b,'e,'c) t Or_error.t val union_list_exn : ('b,'e,'c) t list -> ('b,'e,'c) t val inter_list_exn : ('b,'e,'c) t list -> ('b,'e,'c) t (* [values] extracts all values of the base type *) val values : ('base, _, _) t -> 'base list (* [constant_value (Set s) = Some s] [constant_value _ = None] otherwise *) val constant_value : (_, 'elt, 'cmp) t -> ('elt, 'cmp) Set.t option (* [subst], [map], [specialize], [eval]: These functions fold over an entire [t]. [subst (Base b) ~f = f b] [subst (Set s) ~f = Set s] [subst (Union (t1,t2)) ~f = union2 (subst t1 ~f) (subst t2 ~f)] [subst (Inter (t1,t2)) ~f = inter2 (subst t1 ~f) (subst t2 ~f)] [subst (Diff (t1,t2)) ~f = diff (subst t1 ~f) (subst t2 ~f)] [map t ~f = subst t ~f:(fun b -> base (f b))] [specialize t ~f = subst t ~f:(fun b -> match f b with Some s -> set s | _ -> base b)] [eval t ~f = Option.value_exn (constant_value (specialize t ~f:(fun b -> Some (f b))))] except [eval] never raises an exception. *) val subst : ('b1,'e,'c) t -> f:('b1 -> ('b2,'e,'c) t) -> ('b2,'e,'c) t val map : ('b1,'e,'c) t -> f:('b1 -> 'b2) -> ('b2,'e,'c) t val specialize : ('b,'e,'c) t -> f:('b -> ('e,'c) Set.t option) -> ('b,'e,'c) t val eval : ('b,'e,'c) t -> f:('b -> ('e,'c) Set.t) -> ('e,'c) Set.t (* [invariant t] should be equivalent to [assert true] *) val invariant : ('base, 'elt, 'cmp) t -> unit (* [Make_monadic_eval] defines new versions of [subst], [map], [specialize], and [eval] that work inside the given monad. Useful, for instance, if evaluating a base value produces a Deferred.t. *) module Make_monadic_eval( M : Monad.S ) : sig val subst : ('b,'e,'c) t -> f:('b -> ('b,'e,'c) t M.t) -> ('b,'e,'c) t M.t val map : ('b,'e,'c) t -> f:('b -> 'b M.t) -> ('b,'e,'c) t M.t val specialize : ('b,'e,'c) t -> f:('b -> ('e,'c) Set.t option M.t) -> ('b,'e,'c) t M.t val eval : ('b,'e,'c) t -> f:('b -> ('e,'c) Set.t M.t) -> ('e,'c) Set.t M.t end (* The functors [Make] and [Make_binable] specialize this interface to specific set types. In doing so, they also enable sexp and bin_io conversions, and [union] of empty lists. See [Set_lang_intf] for their interfaces. *) module type S = Set_lang_intf.S with module Raw := Raw module type S_binable = Set_lang_intf.S_binable with module Raw := Raw module Make ( Elt : Comparable.S ) : S with module Set = Elt.Set module Make_binable ( Elt : Comparable.S_binable ) : S_binable with module Set = Elt.Set core_extended-113.00.00/src/set_lang_intf.ml000066400000000000000000000053571256461102500205750ustar00rootroot00000000000000open Core.Std module type S_eval = sig (* [S_eval] defines a generic interface for instantiations of [subst], [map], [specialize], and [eval] to different set types and monads. See [Set_lang] for documentation of [subst], [map], [specialize], and [eval]. *) type 'base t type set type 'a result val subst : 'b1 t -> f:('b1 -> 'b2 t result) -> 'b2 t result val map : 'b1 t -> f:('b1 -> 'b2 result) -> 'b2 t result val specialize : 'b t -> f:('b -> set option result) -> 'b t result val eval : 'b t -> f:('b -> set result) -> set result end (* The ['a value] type serves to instantiate [S_eval] for non-monadic use. *) type 'a value = 'a module type S_lang = sig (* [S_lang] defines a generic interface for instantiation of [Set_lang] operations to a known set type. These operations differ from [Set_lang] in that [union] accepts empty lists, and there is no need for separate [union_list] or [union_list_exn] operations. Otherwise, see [Set_lang] for documentation of individual operations. *) type set type 'base t val base : 'base -> 'base t val set : set -> _ t val inter2 : 'b t -> 'b t -> 'b t val union2 : 'b t -> 'b t -> 'b t val diff : 'b t -> 'b t -> 'b t val union : 'b t list -> 'b t val inter : 'b t * 'b t list -> 'b t val inter_list : 'b t list -> 'b t Or_error.t val inter_list_exn : 'b t list -> 'b t val values : 'base t -> 'base list val constant_value : _ t -> set option (* [S] includes non-monadic [subst], [map], [specialize], and [eval]. *) include S_eval with type 'base t := 'base t with type set := set with type 'a result := 'a value (* [S] can also construct monadic [subst], [map], [specialize], and [eval]. *) module Make_monadic_eval (M : Monad.S) : S_eval with type 'base t := 'base t with type set := set with type 'a result := 'a M.t end module type S = sig (* [S] specializes [S_lang] to set types implementing Set.S. See [S_lang] for its contents. See [Set_lang] for documentation of individual operations. *) module Raw : sig type ('base, 'set) t end module Set : Set.S type 'base t = ('base, Set.t) Raw.t with compare, sexp include S_lang with type 'base t := 'base t with type set := Set.t end module type S_binable = sig (* [S_binable] specializes [S_lang] to set types implementing Set.S_binable. See [S_lang] for its contents. See [Set_lang] for documentation of individual operations. *) module Raw : sig type ('base, 'set) t end module Set : Set.S_binable type 'base t = ('base, Set.t) Raw.t with compare, sexp, bin_io include S_lang with type 'base t := 'base t with type set := Set.t end core_extended-113.00.00/src/shell.ml000066400000000000000000000326321256461102500170640ustar00rootroot00000000000000(* TODO: Ron wants the ability to run interactive commands and to expose the fd version of process handling.*) open Core.Std open Textutils.Std module Line_buffer = Shell__line_buffer include (Shell__core:sig val extra_path : string list ref end) module Process = struct exception Early_exit with sexp type status = [ `Timeout of Time.Span.t | Process.Status.t ] with sexp_of (* type status = (unit, error) Result.t with sexp_of *) type t = { program : string; arguments : string list; } with sexp_of type result = { command : t; status : status; stdout : string; stderr : string; } with sexp_of exception Failed of result with sexp let to_string {program=prog; arguments=args} = let f s = if not (String.contains s ' ') && not (String.contains s '"') then s else sprintf "%S" s in String.concat ~sep:" " (List.map ~f (prog::args)) let status_to_string = function | `Timeout t -> sprintf !"Timed out (ran for %{Time.Span})" t | #Process.Status.t as s -> Process.Status.to_string s let format_failed c = String.concat ~sep:" " ["Command failed:"; to_string c.command; "Exit status:"; status_to_string c.status; "stderr:"; c.stderr] let () = Caml.Printexc.register_printer (function | Failed r -> Some (format_failed r) | _ -> None) module Defaults = struct let timeout = ref None let verbose = ref false let echo = ref false let preserve_euid = ref false end let set_defaults ?timeout ?verbose ?echo ?preserve_euid () = Option.iter ~f:(fun v -> Defaults.verbose := v) verbose; Option.iter ~f:(fun v -> Defaults.timeout := v) timeout; Option.iter ~f:(fun v -> Defaults.echo := v) echo; Option.iter ~f:(fun v -> Defaults.preserve_euid := v) preserve_euid let cmd program arguments = { program = program; arguments = arguments; } let shell s = let addtl_args = if !Defaults.preserve_euid then [ "-p" ] else [] in { program = "/bin/bash"; arguments = addtl_args @ [ "-c" ; s ] } (* avoid asking for the password at all costs. *) let noninteractive_ssh_options = ["-o";"BatchMode yes"] let noninteractive_no_hostkey_checking_options = [ "-n"; "-q"; "-x"; "-o"; "ConnectTimeout=10"; "-o"; "CheckHostIP=no"; "-o"; "StrictHostKeyChecking=no"; "-o"; "BatchMode=yes"; ] (* Passes the remote command to ssh *) let make_ssh_command ?(ssh_options = noninteractive_ssh_options) ?(quote_args=true) ?user ~host args = (* quote_args quotes all arguments to the shell. We need to escape all the arguments because ssh is passing this to the remote shell which will unescape all of that before passing it over to our program.*) let url = match user with | None -> host | Some user -> user ^"@"^host in let args = if quote_args then List.map ~f:Filename.quote args else args in { program = "/usr/bin/ssh"; arguments = ssh_options @ [url; "--"] @ args; } let remote ?ssh_options ?quote_args ?user ~host cmd = make_ssh_command ?ssh_options ?quote_args ?user ~host (cmd.program :: cmd.arguments) type 'res acc = { add_stdout : string -> int -> [`Stop | `Continue]; add_stderr : string -> int -> [`Stop | `Continue]; flush : unit -> 'res; } type 'res reader = unit -> 'res acc let run_k' k ?use_extra_path ?(timeout = !Defaults.timeout) ?working_dir ?setuid ?setgid ?env ?(verbose = !Defaults.verbose) ?(echo = !Defaults.echo) ?input ?keep_open ?tail_len = k (fun cmd stdoutf stderrf -> if echo then Console.Ansi.printf [`Underscore] !"Shell: %{}\n%!" cmd; let stderrf = if verbose then (fun s len -> Console.Ansi.output [`Red] stderr s 0 len) else stderrf and stdoutf = if verbose then (fun s len -> Console.Ansi.output [`Green] stdout s 0 len; stdoutf s len) else stdoutf in (Process.run ?timeout ?input ?keep_open ?working_dir ?setuid ?setgid ?use_extra_path ?env ?tail_len ~stdoutf ~stderrf ~prog:cmd.program ~args:cmd.arguments ())) let run_k k ?(expect = [0]) = run_k' (fun f -> k (fun cmd reader -> let acc = reader () in let stdoutf s len = match acc.add_stdout s len with | `Continue -> () | `Stop -> raise Early_exit in let stderrf s len = match acc.add_stderr s len with | `Continue -> () | `Stop -> raise Early_exit in try let r = f cmd stdoutf stderrf in let module Res = Process.Command_result in match r.Res.status with | `Exited i when List.mem expect i -> acc.flush () | status -> raise (Failed { command = cmd; status = (status :> status); stderr = r.Res.stderr_tail; stdout = r.Res.stdout_tail; }) with Early_exit -> acc.flush ())) let run ?expect = run_k (fun f cmd reader -> f cmd reader) ?expect let test_k k ?(true_v = [0]) ?(false_v = [1]) = run_k' (fun f -> k (fun cmd -> let r = f cmd (fun _ _ -> ()) (fun _ _ -> ()) in let module Res = Process.Command_result in match r.Res.status with | `Exited i when List.mem true_v i -> true | `Exited i when List.mem false_v i -> false | #status as status -> raise (Failed { command = cmd; status = (status :> status); stderr = r.Res.stderr_tail; stdout = r.Res.stdout_tail }))) let test ?true_v = test_k (fun f cmd -> f cmd) ?true_v let discard () = { add_stdout = (fun _ _ -> `Continue); add_stderr = (fun _ _ -> `Continue); flush = (fun () -> ()) } let callback ~add ~flush () = { add_stdout = (fun s len -> add s len;`Continue); add_stderr = (fun _ _ -> `Continue); flush } let callback_with_stderr ~add ~add_err ~flush () = { add_stdout = (fun s len -> add s len;`Continue); add_stderr = (fun s len -> add_err s len; `Continue); flush } let content () = let buffer = Buffer.create 16 in { add_stdout = (fun s len -> Buffer.add_substring buffer s 0 len; `Continue); add_stderr = (fun _ _ -> `Continue); flush = (fun () -> Buffer.contents buffer); } let content_and_stderr () = let stdout_buffer = Buffer.create 16 in let buffer_stderr = Buffer.create 16 in { add_stdout = (fun s len -> Buffer.add_substring stdout_buffer s 0 len; `Continue); add_stderr = (fun s len -> Buffer.add_substring buffer_stderr s 0 len; `Continue); flush = (fun () -> Buffer.contents stdout_buffer, Buffer.contents buffer_stderr ); } let fold_lines (type ret) (type v) ?eol ~(init:v) ~(f: v -> string -> (v * [`Continue | `Stop])) ~(flush:v -> ret) () : ret acc = let acc = ref init and continue = ref `Continue in let lb = Line_buffer.create ?eol (fun line -> let acc_v,continue_v = f !acc line in acc := acc_v; continue := continue_v) in { add_stdout = (fun s len -> Line_buffer.add_substring lb s ~pos:0 ~len; !continue); add_stderr = (fun _ _ -> `Continue); flush = (fun () -> if !continue = `Continue then Line_buffer.flush lb; flush !acc) } let lines ?eol () = fold_lines ?eol ~flush:List.rev ~init:[] ~f:(fun acc line -> (line::acc) , `Continue) let aux_head ~flush ?eol () = fold_lines ?eol ~flush ~init:None ~f:(fun _acc line -> Some line,`Stop) let head ?eol () = aux_head ~flush:(fun x -> x) ?eol () exception Empty_head let head_exn ?eol () = aux_head ~flush:(function Some x -> x | None -> raise Empty_head) ?eol () end type 'a with_process_flags = ?use_extra_path:bool -> ?timeout:Time.Span.t option -> ?working_dir:string (* rename to run_in? *) -> ?setuid:int -> ?setgid:int -> ?env:[`Extend of (string * string) list |`Replace of (string * string) list] -> ?verbose:bool -> ?echo:bool -> ?input:string -> ?keep_open:bool -> ?tail_len:int -> 'a type 'a with_run_flags = (* Defaults to [0]*) ?expect:int list -> ('a with_process_flags) type 'a with_test_flags = ?true_v:int list -> ?false_v:int list -> ('a with_process_flags) type 'a cmd = string -> string list -> 'a type ('a,'ret) sh_cmd = (('a, unit, string,'ret) format4 -> 'a) let run_gen reader = Process.run_k (fun f prog args -> f (Process.cmd prog args) reader) let run = run_gen Process.discard let run_lines ?eol = run_gen (Process.lines ?eol ()) let run_one ?eol = run_gen (Process.head ?eol ()) let run_one_exn ?eol = run_gen (Process.head_exn ?eol ()) let run_full = run_gen Process.content let run_fold ?eol ~init ~f = run_gen (Process.fold_lines ?eol ~init ~f ~flush:(fun x -> x)) (* TEST_UNIT = (* This should not hand because the stdin is closed... *) run ~timeout:(Some (sec 0.5)) "cat" [] TEST_UNIT = try run ~timeout:(Some (sec 0.5)) "cat" [] with Process. *) let test = Process.test_k (fun f prog args -> f (Process.cmd prog args)) let k_shell_command k f fmt = ksprintf (fun command -> k f (Process.shell command)) fmt let sh_gen reader = Process.run_k (k_shell_command (fun f cmd -> f cmd reader)) let sh ?expect = sh_gen Process.discard ?expect let sh_lines ?expect = sh_gen (Process.lines ()) ?expect let sh_full ?expect = sh_gen Process.content ?expect let sh_one ?expect = sh_gen (Process.head ()) ?expect let sh_one_exn ?expect = sh_gen (Process.head_exn ()) ?expect TEST = sh_lines "yes yes | head -n 200000" = List.init 200_000 ~f:(fun _num -> "yes") let sh_test ?true_v = Process.test_k (k_shell_command (fun f cmd -> f cmd)) ?true_v type 'a with_ssh_flags = ?ssh_options:string list -> ?user:string -> host:string -> 'a let noninteractive_ssh_options = Process.noninteractive_ssh_options let noninteractive_no_hostkey_checking_options = Process.noninteractive_no_hostkey_checking_options let k_remote_command k f ?ssh_options ?user ~host fmt = ksprintf (fun command -> k f (Process.make_ssh_command ~quote_args:false ?ssh_options ?user ~host [command])) fmt let ssh_gen reader ?ssh_options ?user ~host = Process.run_k (k_remote_command (fun f cmd -> f cmd reader) ?ssh_options ?user ~host) let ssh ?ssh_options = ssh_gen Process.discard ?ssh_options let ssh_lines ?ssh_options = ssh_gen (Process.lines ()) ?ssh_options let ssh_full ?ssh_options = ssh_gen Process.content ?ssh_options let ssh_one ?ssh_options = ssh_gen (Process.head ()) ?ssh_options let ssh_one_exn ?ssh_options = ssh_gen (Process.head_exn ()) ?ssh_options let ssh_test ?ssh_options ?user ~host = Process.test_k (k_remote_command (fun f cmd -> f cmd) ?ssh_options ?user ~host) let whoami = Shell__core.whoami let which = Shell__core.which let ln ?s ?f src dst = let s = Option.map s ~f:(fun () -> "-s") in let f = Option.map f ~f:(fun () -> "-f") in run "/bin/ln" (List.filter_map ~f:ident [s; f] @ ["-n"; "--"; src; dst]) let rm ?r ?f path = let r = Option.map r ~f:(fun () -> "-r") in let f = Option.map f ~f:(fun () -> "-f") in run "/bin/rm" (List.filter_map ~f:ident [r; f; Some "--"; Some path]) let mv src dst = run "/bin/mv" ["--";src;dst] let mkdir ?p ?perm path = let p = Option.map p ~f:(fun () -> "-p") in let mode = Option.map perm ~f:(sprintf "--mode=%o") in run "/bin/mkdir" (List.filter_map ~f:ident [p; mode;Some "--";Some path]) (* TODO: Deal with atomicity *) let cp ?(overwrite=true) ?perm src dst = let perm = match perm with | Some p -> p | None -> (Unix.lstat src).Unix.st_perm in let dst = if Sys.is_directory dst = `Yes then dst ^/ (Filename.basename src) else dst in let out_mode = if overwrite then [ Unix.O_WRONLY; Unix.O_NOCTTY; Unix.O_CREAT; Unix.O_TRUNC ] else [ Unix.O_WRONLY; Unix.O_NOCTTY; Unix.O_CREAT; Unix.O_EXCL ] in protectx (Unix.openfile src ~mode:[ Unix.O_RDONLY; Unix.O_NOCTTY ] ~perm:0) ~f:(fun infh -> protectx (Unix.openfile dst ~mode:out_mode ~perm) ~f:(fun outfh -> let buflen = 4096 in let buf = String.create buflen in let rec loop () = let rlen = Unix.read infh ~buf ~pos:0 ~len:buflen in if rlen <> 0 then let wlen = Unix.write outfh ~buf ~pos:0 ~len:rlen in if rlen <> wlen then failwithf "Short write: tried to write %d bytes, \ only wrote %d bytes" rlen wlen (); loop () in loop (); ) ~finally:Unix.close ) ~finally:Unix.close ;; let scp ?(compress=false) ?(recurse=false) ?user ~host f t = let user_arg = Option.value_map user ~default:"" ~f:(fun user -> user ^ "@") in let args = [f; user_arg ^ host ^ ":" ^ t] in let args = if recurse then "-r"::args else args in let args = if compress then "-C"::args else args in run "scp" args ;; core_extended-113.00.00/src/shell.mli000066400000000000000000000225511256461102500172340ustar00rootroot00000000000000(** Shell scripting in OCaml. This module contains basic blocks for shell scripting in OCaml. It tends to be safer than just using [Unix.system] because it handles errors more strictly. *) open Core.Std (** {6 Process handling } *) (** This type is an umbrella type for all the command that dispatch a process. It comes with a list of arguments whose default value can be tweaked by set_defaults. - [use_extra_path] : if we fail to find the command in the path then we look for it [extra_path] - [timeout] : the command will raise [Failed] if the program doesn't do any IO for this period of time - [working_dir] : run the command in this directory - [verbose] : prints the output of the command - [echo] : print out the command before running it - [input] : a string to pipe through the program's standard in - [export] : a list of variable to export in the environement of the dispatched program - [preserve_euid] : pass the '-p' option to bash when running the command; this should disable the default bash behavior of replacing the effective user ID with the current value of the real user ID, useful in programs where privileges are escalated and de-escalated using seteuid(2) WARNING: the input argument to this function should not be used because it can deadlock if the input is too big (~160kb?) *) type 'a with_process_flags = ?use_extra_path:bool -> ?timeout:Time.Span.t option -> ?working_dir:string (* rename to run_in? *) -> ?setuid:int -> ?setgid:int -> ?env:[`Extend of (string * string) list |`Replace of (string * string) list] -> ?verbose:bool -> ?echo:bool -> ?input:string -> ?keep_open:bool -> ?tail_len:int -> 'a (** This is the list of flags for normal process dispatch. It is an extension of [with_process_flags]. - [expect] : an int list of valid return codes. default value is [[0]], if the return code of the dispatched is not in this list we will blowup with [Process.Failure] *) type 'a with_run_flags = ?expect:int list -> 'a with_process_flags (** {9 Basic run functions} In all the functions below the command is specified with two arguments. The first one is a string representing the process to run. The second one is the list of arguments to pass. Although the arguments do not need to be escaped there is still a risk that they might be interpreted as flags when they aren't. Most basic unix utilities provide the ability to pass arguments after "--" to avoid this. Usage example: {[ let patch = run_full ~expect:[0;1] "diff" ["-u";"--";file1;file2] ]} *) type 'a cmd = string -> string list -> 'a (** Runs a command and discards its output. *) val run : unit cmd with_run_flags (** Runs a command and returns its output line separated. Note: most commands print a newline at the end of their output so the shell prompt appears on its own line. If the output ends in a newline, it is stripped before splitting the output into a string list to avoid there being a final element in the list containing just the empty string. In some cases, the newline should not be stripped (e.g., "cat" will not "add" a newline). If you care, use [run_full] for the entire buffer. *) val run_lines : ?eol:char -> string list cmd with_run_flags (** Returns the first line of the command's output. (This function might terminate the program early the same way that piping through grep would) *) val run_one : ?eol:char -> string option cmd with_run_flags val run_one_exn : ?eol:char -> string cmd with_run_flags (** Return the full command's output in one string. See the note in [run_lines]. *) val run_full : string cmd with_run_flags (** Fold over the lines in the stdout of a process; The `Continue/`Stop argument is there to allow early returning. [eol] specifies the end of line character used to separate the lines outputted by the the program *) val run_fold : ?eol:char -> init:'a -> f:('a -> string -> 'a * [ `Continue | `Stop ]) -> 'a cmd with_run_flags (** {9 Dispatch to /bin/bash} All these function take a format (like printf) and run it through the shell. Usage example: {[ sh "cp -- %s %s" (Filename.quote file1) (Filename.quote file2) ]} In general it is recommended to avoid using those too much and to prefer the run* family of function instead because it avoids pitfall like escaping issues and is much more straightforward to think about. *) type ('a,'ret) sh_cmd = ('a, unit, string,'ret) format4 -> 'a val sh : ('a,unit) sh_cmd with_run_flags val sh_lines : ('a,string list) sh_cmd with_run_flags val sh_full : ('a,string) sh_cmd with_run_flags val sh_one : ('a,string option) sh_cmd with_run_flags val sh_one_exn : ('a,string) sh_cmd with_run_flags (* Magic invocation to avoid asking for password if we can. These arguments are passed to ssh in the [ssh_*] functions below. They're exposed in case you want to use them in a different context. *) val noninteractive_ssh_options : string list val noninteractive_no_hostkey_checking_options : string list type 'a with_ssh_flags = ?ssh_options:string list -> ?user:string -> host:string -> 'a val ssh : ('a,unit) sh_cmd with_run_flags with_ssh_flags val ssh_lines : ('a,string list) sh_cmd with_run_flags with_ssh_flags val ssh_full : ('a,string) sh_cmd with_run_flags with_ssh_flags val ssh_one : ('a,string option) sh_cmd with_run_flags with_ssh_flags val ssh_one_exn : ('a,string) sh_cmd with_run_flags with_ssh_flags (** {9 Test dispatches} Usage example: {[ if Shell.test "diff" ["-q";"--";file1;file2] then Printf.printf "Files %S and %S are the same\n%!" file1 file2; ]} *) (** This is the list of flags for dispatching processes in test mode. This is used to test the return code of the dispatched program. The return value of these functions will be : - [true] if the exit code is in [true_v]. - [false] if the exit code is in [false_v] and not in [true_v]. - Raises [Process.Failure] otherwise The default values are: - [true_v]: default value [[0]] - [false_v]: default_value [[1]] *) type 'a with_test_flags = ?true_v:int list -> ?false_v:int list -> ('a with_process_flags) val test : bool cmd with_test_flags val sh_test : ('a,bool) sh_cmd with_test_flags val ssh_test : ('a,bool) sh_cmd with_test_flags with_ssh_flags (** variable used by dispatch command to find binaries not in the path. The default values contains only directory which should be in PATH and is only useful in environments where the PATH variable has been blown away. *) val extra_path : string list ref (** Process dispatching *) module Process : sig type status = [ `Timeout of Time.Span.t | `Exited of int | `Signaled of Signal.t (* WStopped is impossible*) ] (** The termination status of a process. This is an extension of [Unix.Process_status.t] to allow timeouts. *) type t type result = { command : t; status : status; stdout : string; stderr : string } exception Failed of result val to_string : t -> string val status_to_string : status -> string val set_defaults : ?timeout:Time.Span.t option -> ?verbose:bool -> ?echo:bool -> ?preserve_euid:bool -> unit -> unit val format_failed : result -> string val cmd : string -> string list -> t val shell : string -> t val make_ssh_command : ?ssh_options:string list -> ?quote_args:bool -> ?user:string -> host:string -> string list -> t val remote : ?ssh_options:string list -> ?quote_args:bool -> ?user:string -> host:string -> t -> t type 'a reader val content : string reader val content_and_stderr : (string * string) reader val discard : unit reader val lines : ?eol:char -> unit -> string list reader val head : ?eol:char -> unit -> string option reader exception Empty_head val head_exn : ?eol:char -> unit -> string reader val callback : add:(string -> int -> unit) -> flush:(unit -> unit) -> unit reader val callback_with_stderr : add:(string -> int -> unit) -> add_err:(string -> int -> unit) -> flush:(unit -> unit) -> unit reader val run : (t -> 'a reader -> 'a) with_run_flags val run_k : ((t -> 'a reader -> 'a) -> 'b) -> 'b with_run_flags val test : (t -> bool) with_test_flags val test_k : ((t -> bool) -> 'a) -> 'a with_test_flags end (** {6 Small helper commands} *) val mkdir : ?p:unit -> ?perm:int -> string -> unit val cp : ?overwrite:bool -> ?perm:Unix.file_perm -> string -> string -> unit val ln : ?s:unit -> ?f:unit -> string -> string -> unit val rm : ?r:unit -> ?f:unit -> string -> unit val mv : string -> string -> unit (** Raises "Failed_command" *) (** Get the username. By default, the effective username. If real is true, get the real username. *) val whoami : ?real:bool -> unit -> string val which : ?use_extra_path:bool -> string -> string option (** [scp user host from to] copy local file from to to *) val scp : ?compress:bool -> ?recurse:bool -> ?user:string -> host:string -> string -> string -> unit core_extended-113.00.00/src/shell__core.ml000066400000000000000000000036141256461102500202310ustar00rootroot00000000000000open Core.Std let extra_path = ref ["/bin";"/usr/bin";"/usr/local/bin"] let get_path ?(use_extra_path=true) () = let env_path = Sys.getenv "PATH" |! Option.map ~f:(String.split ~on:':') |! Option.value ~default:[] |! List.filter ~f:(( <> ) "") in let path = if use_extra_path then env_path @ !extra_path else env_path in List.stable_dedup path let is_executable path = try let stat = Unix.stat path in stat.Unix.st_kind = Unix.S_REG (* Is file *) && (stat.Unix.st_perm land 0o111 > 0) (* Is executable*) with | Unix.Unix_error ((ENOENT | ENOTDIR), _, _) -> false (* File not found *) let path_lookup ?use_extra_path bin = let rec loop = function | [] -> None | h::t -> let file = h ^/ bin in try if is_executable file then Some file else raise Exit with (Unix.Unix_error _) | Exit -> loop t in loop (get_path ?use_extra_path ()) let which ?use_extra_path bin = if not (String.contains bin '/') then path_lookup ?use_extra_path bin else begin if not (is_executable bin) then None else Some bin end let path_expand ?use_extra_path prog = if not (String.contains prog '/') then match path_lookup ?use_extra_path prog with | None -> failwithf "executable %s not found in $PATH (%s)" prog (String.concat ~sep:":" (get_path ())) () | Some v -> v else if Filename.is_relative prog then Sys.getcwd () ^/ prog else prog (* "real" switches between real and effective uids. sudo sets both real and effective uids, so this will not work, though you should be able to use $SUDO_UID *) let whoami ?(real=false) () = let uid = if real then Unix.getuid () else Unix.geteuid () in match Unix.Passwd.getbyuid uid with | Some user -> user.Unix.Passwd.name | None -> failwith "unable to determine username" core_extended-113.00.00/src/shell__core.mli000066400000000000000000000007321256461102500204000ustar00rootroot00000000000000(* This is an internal module; it shouldn't be used by anything not in core_extended *) (* some of the core functions of the "Shell" go in here because they are needed by other modules which are in turn required by the full shell module *) val extra_path : string list ref val whoami : ?real:bool -> unit -> string val is_executable : string -> bool val which : ?use_extra_path:bool -> string -> string option val path_expand : ?use_extra_path:bool -> string -> string core_extended-113.00.00/src/shell__line_buffer.ml000066400000000000000000000046761256461102500215720ustar00rootroot00000000000000open Core.Std (** Look for a newline in a given substring and returns its absolute position. Returns None if no newlines are found. *) let rec nl_between (s:string) ~(eol:char) ~(pos:int) ~(len:int) : int option = if len = 0 then None else if s.[pos] = eol then Some pos else nl_between s ~eol ~pos:(pos + 1) ~len:(len - 1) TEST = nl_between "abcd" ~eol:'\n' ~pos:0 ~len:4 = None TEST = nl_between "a\nb\ncd" ~eol:'\n' ~pos:0 ~len:6 = Some 1 TEST = nl_between "a\nb\ncd" ~eol:'\n' ~pos:3 ~len:3 = Some 3 TEST = nl_between "a\nb\ncd" ~eol:'\n' ~pos:4 ~len:2 = None (** Type for line buffers. [flush] will be called back on every fully read newline or when the buffer itself is flushed by the user. *) type t = { buffer : Buffer.t; eol : char; flush : string -> unit } (* *) let create ?(eol='\n') flush = { buffer = Buffer.create 0; eol; flush; } let flush b = if Buffer.length b.buffer > 0 then begin b.flush (Buffer.contents b.buffer); Buffer.reset b.buffer end let add_char b c = if c = b.eol then begin b.flush (Buffer.contents b.buffer); Buffer.reset b.buffer end else Buffer.add_char b.buffer c let rec add_substring b s ~pos ~len = match nl_between s ~eol:b.eol ~pos ~len with | None -> Buffer.add_substring b.buffer s pos len | Some suffix_end_pos -> (* whatever is in the buffer + this suffix is our newline*) let suffix_len = suffix_end_pos - pos and prefix_len = Buffer.length b.buffer in let line = String.create (prefix_len + suffix_len) in Buffer.blit b.buffer 0 line 0 prefix_len; String.blit ~src:s ~dst:line ~src_pos:pos ~dst_pos:prefix_len ~len:suffix_len; Buffer.reset b.buffer; b.flush line; add_substring b s ~pos:(suffix_end_pos + 1) ~len:(len - suffix_len - 1) let add_string b s = add_substring b s ~pos:0 ~len:(String.length s) (** [test_list l]: adds all the strings in [l] to a new blank buffer and returns all the lines that the callback function was called on.*) let test_list l = let lines = ref [] in let b = create (fun s -> lines := s :: !lines) in List.iter ~f:(fun s -> add_string b s) l; flush b; List.rev !lines TEST = test_list ["abcd\nas\nere\n"] = ["abcd";"as";"ere"] TEST = test_list ["ab";"cd";"\nas\n";"ere\n"] = ["abcd";"as";"ere"] TEST = test_list ["no new\nline";" at the end"] = ["no new";"line at the end"] TEST = test_list ["a new line";" at the end\n"] = ["a new line at the end"] core_extended-113.00.00/src/shell__line_buffer.mli000066400000000000000000000015751256461102500217360ustar00rootroot00000000000000(** String buffers that automatically get flushed at every line return. *) type t (** [create ~eol f] Create a new line buffer where f will be called once on every line. Eol is the endline character (it's possible to use a Linebuffer to process null separated strings ) *) val create : ?eol:char -> (string -> unit) -> t (** [flush b] Flushes any pending output to the callback function. This causes unfinished newlines to be flushed out so adding more characters after flushing might result in there looking as though there are more lines than there really were. *) val flush : t -> unit val add_char : t -> char -> unit val add_string : t -> string -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) val add_substring : t -> string -> pos:int -> len:int -> unit core_extended-113.00.00/src/sntp.ml000066400000000000000000000066761256461102500167520ustar00rootroot00000000000000open Core.Std ;; module TS = Time.Span ;; (* mbacarella: This code appeared wholesale copy/pasted in a couple of utilities. It's generalized enough (now) that Core_extended looks like a decent place for it. *) module Internal = struct let ntp_conv_const = 2. ** 32. let delta = 2208988800. (** difference in seconds between 1900 and 1970 *) let ntpfp_to_float (ipart,fpart) = Int64.to_float ipart +. Int64.to_float fpart /. ntp_conv_const -. delta let float_to_ntpfp f = let f = f +. delta in let ipart = Int64.of_float f in let fpart = Int64.of_float ((f -. Float.round ~dir:`Down f) *. ntp_conv_const) in (ipart,fpart) let bytemask = Int64.of_int 0xFF let short_int64_to_buf buf pos bits = for i = 0 to 3 do let byte64 = Int64.bit_and (Int64.shift_right_logical bits (8 * i)) bytemask in let char = Char.of_int_exn (Int64.to_int_exn byte64) in String.set buf (pos + 3 - i) char done let short_int64_of_buf buf pos = let value = ref Int64.zero in for i = 0 to 3 do let byte = Int64.of_int (Char.to_int (String.get buf (pos + 3 - i))) in value := Int64.(+) !value (Int64.shift_left byte (i * 8)) done; !value let float_to_buf buf pos f = let (ipart,fpart) = float_to_ntpfp f in short_int64_to_buf buf pos ipart; short_int64_to_buf buf (pos + 4) fpart let float_from_buf buf pos = let ipart = short_int64_of_buf buf pos in let fpart = short_int64_of_buf buf (pos + 4) in ntpfp_to_float (ipart,fpart) let ntp_packet_length = 48 let buf = String.create ntp_packet_length let () = String.fill ~pos:0 ~len:(String.length buf) buf '\000' type t = { client_xmit : float; server_recv : float; server_xmit : float; client_recv : float; } ;; let query ~timeout ~port ipaddr = let addr = Unix.get_sockaddr ipaddr port in Exn.protectx (Unix.socket ~domain:Unix.PF_INET ~kind:Unix.SOCK_DGRAM ~protocol:0) ~f:(fun s -> String.set buf 0 (Char.of_int_exn 0b100011); float_to_buf buf 40 (Unix.gettimeofday ()); Unix.sendto s ~buf ~pos:0 ~len:(String.length buf) ~mode:[] ~addr |! ignore; let sfds = Unix.select ~read:[s] ~write:[] ~except:[] ~timeout:(`After (Time_ns.Span.of_span timeout)) () in match sfds.Unix.Select_fds.read with | [] -> None | s :: [] -> begin Unix.recvfrom s ~buf ~pos:0 ~len:(String.length buf) ~mode:[] |! ignore; let client_recv = Unix.gettimeofday () in Some { client_xmit = float_from_buf buf 24; server_recv = float_from_buf buf 32; server_xmit = float_from_buf buf 40; client_recv = client_recv } end | _ -> failwithf "BUG! too many file descriptors?!" () ) ~finally:Unix.close end ;; let query ?(timeout=TS.of_float 5.0) ?(port=123) hostname = try begin match Internal.query ~timeout ~port hostname with | None -> `Timeout | Some x -> let mid a b = (a +. b) /. 2.0 in let client_time = mid x.Internal.client_xmit x.Internal.client_recv in let server_time = mid x.Internal.server_recv x.Internal.server_xmit in `Offset (TS.of_float (client_time -. server_time)) end with e -> `Error e ;; core_extended-113.00.00/src/sntp.mli000066400000000000000000000010251256461102500171020ustar00rootroot00000000000000(** Simple Network Time Protocol *) open Core.Std ;; (** [query hostname] returns the difference between the clock on the local host and the clock on the host specified by [hostname]. If the remote host is down or not running an (S)NTP service this call will `Timeout. Other errors, including some classes of resolution or network will raise an exception, which will be returned as `Error. *) val query : ?timeout:Time.Span.t -> ?port:int -> string -> [ `Error of Exn.t | `Timeout | `Offset of Time.Span.t ] core_extended-113.00.00/src/splay_tree.ml000066400000000000000000000237271256461102500201310ustar00rootroot00000000000000open Core.Std module type Key = sig type t with sexp include Comparable with type t := t end module type S = sig type 'a t with sexp type key with sexp val empty : 'a t val is_empty : 'a t -> bool val length : 'a t -> int val keys : 'a t -> key list val data : 'a t -> 'a list val to_alist : 'a t -> (key * 'a) list val mem : 'a t -> key -> 'a t * bool val find : 'a t -> key -> 'a t * 'a option val set : 'a t -> key:key -> data:'a -> 'a t val delete : 'a t -> key -> 'a t val delete_min : 'a t -> (key * 'a * 'a t) option val delete_max : 'a t -> (key * 'a * 'a t) option val delete_after : 'a t -> key -> (key * 'a * 'a t) option val delete_before : 'a t -> key -> (key * 'a * 'a t) option val map : 'a t -> f:('a -> 'b) -> 'b t val map_range : 'a t -> min_key:key -> max_key:key -> f:((key * 'a) list -> (key * 'a) list) -> 'a t val split : 'a t -> key -> 'a t * 'a option * 'a t end module Make (Key : Key) : (S with type key = Key.t) = struct type key = Key.t with sexp (* [Kernel] ensures that no Node can be constructed with an incorrect size *) module Kernel : sig type size (* tree size *) type 'a t = private | Empty | Node of 'a t * key * 'a * 'a t * size with sexp val length : 'a t -> int val node : 'a t -> key -> 'a -> 'a t -> 'a t val empty : 'a t end = struct type size = int with sexp type 'a t = | Empty | Node of 'a t * key * 'a * 'a t * size with sexp let length = function | Empty -> 0 | Node (_left, _key, _value, _right, size) -> size let node left key value right = Node (left, key, value, right, length left + length right + 1) let empty = Empty end include Kernel (* zipper type representing the context of a sub-[t] within a larger [t] *) type 'a ctx = | Top | Fst of 'a ctx * key * 'a * 'a t | Snd of 'a t * key * 'a * 'a ctx (* [plug t ctx] restores the overall tree from the subtree [t] and its context [ctx]. NOTE: this definition is used nowhere in the remainder of this file. It serves only to indicate what a context /means/. *) let rec plug t = function | Top -> t | Fst (ctx, k, v, r) -> plug (node t k v r) ctx | Snd (l, k, v, ctx) -> plug (node l k v t) ctx let _ = plug let fold_right t ~init ~f = let rec loop acc = function | [] -> acc | `Elem (key, data) :: to_visit -> loop (f ~key ~data acc) to_visit | `Tree Empty :: to_visit -> loop acc to_visit | `Tree (Node (l, key, data, r, _)) :: to_visit -> loop acc (`Tree r :: `Elem (key, data) :: `Tree l :: to_visit) in loop init [`Tree t] (* this is in CPS so that it is tail-recursive *) let rec map_cps : 'r 'a 'b. 'a t -> f:('a -> 'b) -> ('b t -> 'r) -> 'r = fun t ~f k -> match t with | Empty -> k empty | Node (l, key, data, r, _ ) -> map_cps l ~f (fun l -> map_cps r ~f (fun r -> k (node l key (f data) r) )) let map t ~f = map_cps t ~f Fn.id (* [find_in_ctx t x] finds the subtree of [t] where the binary-search-tree property would have the key [x] sit. It also returns the context of this subtree. This subtree is Empty iff [x] is not in [t]. If [x] is in [t], the returned subtree will have key [x] at its root. *) let find_in_ctx t x = let rec loop ctx this = match this with | Empty -> (ctx, this) | Node (l, y, yv, r, _) -> let cmp = Key.compare x y in if cmp < 0 then loop (Fst (ctx, y, yv, r)) l else if cmp > 0 then loop (Snd (l, y, yv, ctx)) r else (ctx, this) in loop Top t (* [zip l r ctx = (l', r')] is the second pass of a splay operation. It pulls a phantom node [x] from its position at [ctx] up to the top of the tree by doing double and single rotations. (ctx) (top) ... [x] ==> [x] / \ / \ l r l' r' *) let rec zip l r = function | Top -> (l, r) | Fst (Top, y, yv, c) -> let a = l in let b = r in (* y [x] / \ / \ [x] c => a y / \ / \ a b b c *) (a, node b y yv c) | Snd (a, y, yv, Top) -> let b = l in let c = r in (* y [x] / \ / \ a [x] => y c / \ / \ b c a b *) (node a y yv b, c) | Fst (Fst (ctx, z, zv, d), y, yv, c) -> let a = l in let b = r in (* z [x] / \ / \ y d a y / \ => / \ [x] c b z / \ / \ a b c d *) zip a (node b y yv (node c z zv d)) ctx | Snd (b, y, yv, Snd (a, z, zv, ctx)) -> let c = l in let d = r in (* z [x] / \ / \ a y y d / \ => / \ b [x] z c / \ / \ c d a b *) zip (node (node a z zv b) y yv c) d ctx | ( Snd (a, y, yv, Fst (ctx, z, zv, d)) | Fst (Snd (a, y, yv, ctx), z, zv, d) ) -> let b = l in let c = r in (* z y / \ [x] / \ y d / \ a z / \ => y z <= / \ a [x] / \ / \ [x] d / \ a b c d / \ b c b c *) zip (node a y yv b) (node c z zv d) ctx let splay' t x = let result v (l, r) = (l, v, r) in match find_in_ctx t x with | (ctx, Node (l, k, xv, r, _)) -> result (Some (k, xv)) (zip l r ctx) | (ctx, Empty) -> result None (zip empty empty ctx) let splay t x = let (l, kv, r) = splay' t x in (l, Option.map ~f:snd kv, r) let is_empty = function | Empty -> true | Node _ -> false let set t k v = match splay t k with (l, _, r) -> node l k v r let find_rightmost t = let rec loop ctx t = match t with | Empty -> ctx | Node (l, y, yv, r, _) -> loop (Snd (l, y, yv, ctx)) r in loop Top t let find_leftmost t = let rec loop t ctx = match t with | Empty -> ctx | Node (l, y, yv, r, _) -> loop l (Fst (ctx, y, yv, r)) in loop t Top let delete_min t = match find_leftmost t with | Top -> None | Snd _ -> (* find_leftmost only accumulates Top and Fst constructors *) assert false | Fst (ctx, x, xv, r) -> match zip empty r ctx with | (Empty, r) -> Some (x, xv, r) | _ -> (* when [ctx] contains only Top and Fst constructors, as it does here since it was returned by [find_leftmost], then [fst (zip Empty t ctx)] will always be [Empty] for all [t]. *) assert false let delete_max t = match find_rightmost t with | Top -> None | Fst _ -> (* find_rightmost only accumulates Top and Snd constructors *) assert false | Snd (l, x, xv, ctx) -> match zip l empty ctx with | (l, Empty) -> (* order reversed here to give the same type as [delete_min] *) Some (x, xv, l) | _ -> (* when [ctx] contains only Top and Snd constructors, as it does here since it was returned by [find_rightmost], then [snd (zip Empty t ctx)] will always be [Empty] for all [t]. *) assert false let concat l r = match delete_min r with | None -> l | Some (x, xv, r) -> node l x xv r let data t = fold_right t ~init:[] ~f:(fun ~key:_ ~data acc -> data :: acc) let keys t = fold_right t ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) let to_alist t = fold_right t ~init:[] ~f:(fun ~key ~data acc -> (key, data) :: acc) let delete t x = match splay t x with (l, _, r) -> concat l r let mem t x = match splay t x with | (l, None, r) -> (concat l r, false) | (l, Some xv, r) -> (node l x xv r, true) let find t x = match splay t x with | (l, None, r) -> (concat l r, None) | (l, Some xv, r) -> (node l x xv r, Some xv) let splay_just_before t k = let (before, at, after) = splay t k in Option.map (delete_max before) ~f:(fun (k, v, before) -> let after = Option.fold at ~init:after ~f:(fun t v -> set t k v) in (before, k, v, after)) let splay_just_after t k = let (before, at, after) = splay t k in Option.map (delete_min after) ~f:(fun (k, v, after) -> let before = Option.fold at ~init:before ~f:(fun t v -> set t k v) in (before, k, v, after)) let delete_before t k = Option.map (splay_just_before t k) ~f:(fun (before, k, v, after) -> (k, v, concat before after)) let delete_after t k = Option.map (splay_just_after t k) ~f:(fun (before, k, v, after) -> (k, v, concat before after)) let map_range t ~min_key ~max_key ~f = let (old_range, t) = let (before, t) = match splay t min_key with | (before, None, after) -> (before, after) | (before, Some min_val, after) -> (before, set after min_key min_val) in let (t, after) = match splay t max_key with | (before, None, after) -> (before, after) | (before, Some max_val, after) -> (set before max_key max_val, after) in (to_alist t, concat before after) in let new_range = f old_range in List.fold new_range ~init:t ~f:(fun t (key, data) -> set t key data) let set t ~key ~data = set t key data let split = splay end core_extended-113.00.00/src/splay_tree.mli000066400000000000000000000017661256461102500203010ustar00rootroot00000000000000open Core.Std module type Key = sig type t with sexp include Comparable with type t := t end module type S = sig type 'a t with sexp type key with sexp val empty : 'a t val is_empty : 'a t -> bool val length : 'a t -> int val keys : 'a t -> key list val data : 'a t -> 'a list val to_alist : 'a t -> (key * 'a) list val mem : 'a t -> key -> 'a t * bool val find : 'a t -> key -> 'a t * 'a option val set : 'a t -> key:key -> data:'a -> 'a t val delete : 'a t -> key -> 'a t val delete_min : 'a t -> (key * 'a * 'a t) option val delete_max : 'a t -> (key * 'a * 'a t) option val delete_after : 'a t -> key -> (key * 'a * 'a t) option val delete_before : 'a t -> key -> (key * 'a * 'a t) option val map : 'a t -> f:('a -> 'b) -> 'b t val map_range : 'a t -> min_key:key -> max_key:key -> f:((key * 'a) list -> (key * 'a) list) -> 'a t val split : 'a t -> key -> 'a t * 'a option * 'a t end module Make (Key : Key) : (S with type key = Key.t) core_extended-113.00.00/src/std.ml000066400000000000000000000074151256461102500165500ustar00rootroot00000000000000include Extended_common include Textutils.Std module Alternating_primary_backup_assignment = Alternating_primary_backup_assignment module Array = struct include Core.Std.Array include Extended_array end module Atomic_edit = Atomic_edit module Deprecated_bench = Deprecated_bench module Bin_io_utils = Bin_io_utils module Bitarray = Bitarray module Cache = Cache module Cbuffer = Cbuffer module Color_print = Color_print module Service_command = Service_command module Csv_writer = Csv_writer module Date = struct include Core.Std.Date include Extended_time.Extended_date end module Deprecated_fcommand = Deprecated_fcommand module Deprecated_command = Deprecated_command module Deprecated_service_command = Deprecated_service_command module English = English module Environment = Environment module Documented_match_statement = Documented_match_statement module Exception_check = Exception_check module Exn = struct include Core.Std.Exn include Extended_exn end module Extra_fields = Extra_fields module Fd_leak_check = Fd_leak_check module Filename = struct include Core.Std.Filename include Extended_filename end module Find = Find module Fold_map = Fold_map module Float = struct include Core.Std.Float include Extended_float end module Float_ref = Float_ref module Gc = struct include Core.Std.Gc include Extended_gc end module Hashtbl = struct include Core.Std.Hashtbl include Extended_hashtbl end module Hashtbl2 = Hashtbl2 module Hashtbl2_pair = Hashtbl2_pair module Int = struct include Core.Std.Int include Extended_int end module Int32 = struct include Core.Std.Int32 include Extended_int32 end module Int63 = struct include Core.Std.Int63 include Extended_int63 end module Int64 = struct include Core.Std.Int64 include Extended_int64 end module Interval_map = Interval_map module Invocation = Invocation module Lazy_sequence = Lazy_sequence module Low_level_debug = Low_level_debug module Nativeint = struct include Core.Std.Nativeint include Extended_nativeint end module Number = Number module Thread = struct include Core.Std.Thread include Extended_thread end module Timed_function = Timed_function module Iter = Iter module Lazy_list = Lazy_list module Lazy_m = Lazy_m module Linebuf = Linebuf module Linux_ext = struct include Core.Std.Linux_ext include Extended_linux end module List = struct include Core.Std.List include Extended_list end module List_zipper = List_zipper module Logger = Logger module Memo = struct include Core.Std.Memo include Extended_memo end module Multi_map = Multi_map module Net_utils = Net_utils module Packed_array = Packed_array module Packed_map = Packed_map module Flang = Flang module Olang = Olang module Set_lang = Set_lang module Pp = Pp module Printc = Printc module Process = Process module Procfs = Procfs module Prod_or_test = Prod_or_test module Posix_clock = Posix_clock module Random_selection = Random_selection module Readline = Readline module Result = struct include Core.Std.Result include Extended_result end module Runtime_blockout_detector = Runtime_blockout_detector module Rw_mutex = Rw_mutex module Sampler = Sampler module Search = Search_foo module Semaphore = Semaphore module Sendmail = Sendmail module Sexp = struct include Core.Std.Sexp include Extended_sexp end module Shell = Shell module Sntp = Sntp module String = struct include Core.Std.String include Extended_string end module String_zipper = String_zipper module Sys = struct include Core.Std.Sys include Extended_sys end module Sys_utils = Sys_utils module Tcp = Tcp module Time = struct include Core.Std.Time include Extended_time end module Trie = Trie module Unix = struct include Core.Core_unix include Extended_unix end module Unix_utils = Unix_utils module Update_queue = Update_queue module Splay_tree = Splay_tree core_extended-113.00.00/src/string_zipper.ml000066400000000000000000000022561256461102500206530ustar00rootroot00000000000000open Core.Std type t = char List_zipper.t open List_zipper let drop_before = drop_before let drop_after = drop_after let drop_all_before = drop_all_before let drop_all_after = drop_all_after let insert_before = insert_before let insert_after = insert_after let previous = previous let next = next let contents zip = let ll = List.length zip.l and lr = List.length zip.r in let res = String.create (ll+lr) in List.iteri zip.l ~f:(fun i c -> res.[ll-1-i] <- c); List.iteri zip.r ~f:(fun i c -> res.[ll+i] <- c); res let left_contents zip = let len = List.length zip.l in let res = String.create len in List.iteri zip.l ~f:(fun i c -> res.[len-1-i] <- c); res let right_contents zip = let len = List.length zip.r in let res = String.create len in List.iteri zip.r ~f:(fun i c -> res.[i] <- c); res let first zip = { l = []; r = List.rev zip.l @ zip.r; } let last zip = { l = List.rev zip.r @ zip.l; r = []; } let create left right = { l = String.to_list_rev left; r = String.to_list right } let replace_left z l = replace_left z (String.to_list_rev l) let replace_right z r = replace_right z (String.to_list r) core_extended-113.00.00/src/string_zipper.mli000066400000000000000000000011461256461102500210210ustar00rootroot00000000000000type t val contents : t -> string val left_contents : t -> string val right_contents : t -> string val insert_before : t -> char -> t val insert_after : t -> char -> t val drop_before : t -> (char * t) option val drop_after : t -> (char * t) option val drop_all_before : t -> (char list * t) option val drop_all_after : t -> (char list * t) option val previous : t -> t option val next : t -> t option val first : t -> t val last : t -> t val replace_left : t -> string -> t val replace_right : t -> string -> t val create : string -> string -> t core_extended-113.00.00/src/sys_utils.ml000066400000000000000000000205311256461102500200060ustar00rootroot00000000000000open Core.Std let get_gen env_vars defaults = let env_var_programs = List.filter_map env_vars ~f:Sys.getenv in let programs = env_var_programs @ defaults in let rec first_valid = function | [] -> None | p::ps -> (* ignore options given in env vars (e.g., emacsclient -c). String.split always returns list of at least 1 element. *) let p_no_opts = String.split ~on:' ' p |! List.hd_exn in match Shell.which p_no_opts with | Some _ -> Some p | None -> first_valid ps in first_valid programs ;; let get_editor () = get_gen ["EDITOR"; "VISUAL"] ["vim"; "emacs"; "nano"] ;; let get_editor_exn () = get_editor () |! Option.value_exn ~message:"No valid editors found! Try setting EDITOR environment variable." ;; let get_pager () = get_gen ["PAGER"] ["less"; "more"] ;; let page_contents ?pager ?(pager_options=[])?(tmp_name="sys_utils.page_contents") contents = let tmp_file = Filename.temp_file tmp_name ".txt" in let pager = match pager with | Some p -> p | None -> get_pager () |! Option.value_exn ~message:"Couldn't find pager - very weird. Try setting PAGER variable?" in Exn.protect ~f:(fun () -> Out_channel.with_file tmp_file ~f:(fun f -> Out_channel.output_string f contents); (* Shell.run doesn't work here *) let cmd = sprintf "%s %s %s" pager (String.concat ~sep:" " pager_options) tmp_file in ignore (Unix.system cmd)) ~finally:(fun () -> Shell.rm tmp_file) let pid_alive pid = Sys.is_directory_exn ("/proc" ^/ Pid.to_string pid) let get_groups user = match Shell.run_lines "/usr/bin/groups" [user] with | [line] -> begin match String.chop_prefix line ~prefix:(user^" : ") with | Some groups -> String.split ~on:' ' groups | None -> failwithf "get_groups couldn't parse \"groups\" output:\n%s" line () end | lines -> failwithf "get_groups expected exactly 1 line from \"groups\". Got:\n%s" (String.concat ~sep:"\n" lines) () let with_tmp ~pre ~suf f = let tmp_file = Filename.temp_file pre suf in Exn.protect ~f:(fun () -> f tmp_file) ~finally:(fun () -> Sys.remove tmp_file) (* -d is supposed to make it find a smaller set of changes. *) let diff ?(options=["-d";"-u"]) s1 s2 = with_tmp ~pre:"sysutils" ~suf:"diff1" (fun f1 -> with_tmp ~pre:"sysutils" ~suf:"diff2" (fun f2 -> Out_channel.write_all f1 ~data:s1; Out_channel.write_all f2 ~data:s2; Shell.run_full ~expect:[0;1] "/usr/bin/diff" (options @ ["--"; f1; f2]))) let ip_of_name name = Unix.Inet_addr.of_string_or_getbyname name |! Unix.Inet_addr.to_string let getbyname_ip () = ip_of_name (Unix.gethostname ()) let ifconfig_ip_rex = Re2.Std.Re2.create_exn "inet addr:([0-9]{1,3}\\.[0-9]{1,3}\\.[0-9]{1,3}\\.[0-9]{1,3})" let ifconfig_ips () = Shell.run_lines "/sbin/ifconfig" [] |> List.filter_map ~f:(fun line -> match Re2.Std.Re2.find_submatches ifconfig_ip_rex line with | Ok [|_; Some ip|] -> Some ip | Ok _ | Error _ -> None) |> String.Set.of_list let digest file = if Sys.file_exists file <> `No then Digest.file file else "" (** Safe editions *) let edit_one file = (** Get the digest of the file we are editing. This is used to test for modifications on the file.*) let md5 = digest file in let editor = match get_editor () with | Some v -> v | None -> failwithf "Could find an not find a suitable editor" () in let pid = Extended_unix.fork_exec editor [file] in let ret = Unix.waitpid pid in match ret with (** We have to discard the return value because different editors have different conventions... *) | Ok () | Error #Unix.Exit.error -> let new_digest = Digest.file file in if new_digest = md5 then `Unchanged else `Ok | Error (`Signal _ as v) -> v let rec edit_until check file = let relaunch () = match Readline.choice ["retry",`Retry;"abort",`Abort] with | Some `Retry -> edit_until check file | Some `Abort | None -> `Abort in match edit_one file with | `Ok -> begin match check file with | None -> `Ok | Some v -> printf "There were errors while validating the file:\n%s\n" v; relaunch () end | `Unchanged -> `Unchanged | #Unix.Exit_or_signal_or_stop.error as e -> printf "The editor died unexpectedly (%s)\n" (Unix.Exit_or_signal_or_stop.to_string_hum (Error e)); relaunch () let checked_edit ?(create=false) ~check file = (* Blow up early if the file is not accessible *) let dirname,basename = Filename.split file in let exists = Sys.file_exists_exn file in if create && not exists then Unix.access_exn dirname [ `Read; `Write ] else (* This will blow up if the file does not exist*) Unix.access_exn file [ `Read; `Write ]; let main,ext = match String.rsplit2 ~on:'.' basename with | Some (main,ext) -> (main,"."^ext) | None -> basename,"" in let original_digest = digest file in let tmp_file = Filename.temp_file main ext in let edit_status = try if exists then Shell.cp file tmp_file; edit_until check tmp_file with e -> Shell.rm tmp_file; raise e in match edit_status with | `Abort -> Shell.rm tmp_file; `Abort | `Ok -> if digest file <> original_digest then failwithf "The underlying file changed while we were editing it.\ your version is saved as: %S" tmp_file (); Shell.mv tmp_file file; `Ok | `Unchanged -> Shell.rm tmp_file; `Ok module Sexp_checked_edit (S:Sexpable) = struct let check file = try ignore (Sexp.load_sexp_conv_exn file S.t_of_sexp : S.t); None with exc -> Some (Extended_exn.to_string_hum exc) let check_sexps file = try ignore (Sexp.load_sexps_conv_exn file S.t_of_sexp : S.t list); None with exc -> Some (Extended_exn.to_string_hum exc) let edit = checked_edit ~check let edit_sexps = checked_edit ~check:check_sexps end module Cpu_use = struct type cpu_sample = { jiffies : Big_int.big_int; time : Time.t; } type t = { pid : Pid.t; jps : float; (* needed because of time-skew issues (see comment in sys_utils.mli) *) initial_age : Time.Span.t; mutable age : Time.Span.t; mutable fds : int; mutable rss : Big_int.big_int; mutable cpu0 : cpu_sample; mutable cpu1 : cpu_sample; } with fields module P = Procfs.Process let sample_of_stat {P.Stat.utime; stime; _ } = { jiffies = Big_int.add_big_int utime stime; time = Time.now () } let fds_of_proc proc = proc.P.fds |! Option.value_map ~f:List.length ~default:0 let get ?(pid=Unix.getpid ()) () = let proc0 = Procfs.with_pid_exn pid in let proc1 = Procfs.with_pid_exn pid in let jiffies_per_second = Procfs.jiffies_per_second_exn () in { pid; jps = jiffies_per_second; initial_age = Procfs.process_age' ~jiffies_per_second proc1; age = Time.Span.zero; fds = fds_of_proc proc1; rss = proc1.P.stat.P.Stat.rss; cpu0 = sample_of_stat proc0.P.stat; cpu1 = sample_of_stat proc1.P.stat; } let update_exn t = let proc = Procfs.with_pid_exn t.pid in let age = Time.Span.(-) (Procfs.process_age' ~jiffies_per_second:t.jps proc) t.initial_age in t.age <- age; t.fds <- fds_of_proc proc; t.rss <- proc.P.stat.P.Stat.rss; t.cpu0 <- t.cpu1; t.cpu1 <- sample_of_stat proc.P.stat let cpu_use {jps; cpu0={jiffies=j0;time=t0}; cpu1={jiffies=j1;time=t1}; _} = let proc_jps = Big_int.float_of_big_int (Big_int.sub_big_int j1 j0) /. Time.Span.to_sec (Time.diff t1 t0) in proc_jps /. jps (* rss is in pages. /should/ call getpagesize... but it's 4k. *) let resident_mem_use_in_kb t = Big_int.float_of_big_int t.rss *. 4. end module Lsb_release = struct type t = { distributor_id : string; (* e.g. "Red Hat", "CentOS" *) release : string; (* e.g. "5.7", "6.3" on CentOs, 'testing' on debian*) codename : string; (* e.g. "Final", "Lucid", etc. *) } with sexp, fields, bin_io let query () = let q flag = match Shell.run_one "lsb_release" ["-s"; flag] with | None -> failwithf "Lsb_release.query(%s): failed Shell.run_one" flag () | Some value -> value in { distributor_id = q "-i"; release = q "-r"; codename = q "-c" } end core_extended-113.00.00/src/sys_utils.mli000066400000000000000000000072751256461102500201710ustar00rootroot00000000000000open Core.Std (** Various system utility functions. *) (** Get the default editor (program) for this user. This functions checks the EDITOR and VISUAL environment variables and then looks into a hard coded list of editors. *) val get_editor : unit -> string option val get_editor_exn : unit -> string (** Analogous to [get_editor], defaulting to a list including less and more. *) val get_pager : unit -> string option (** [page_contents ?pager ?tmp_name str] will show str in a pager. The optional [tmp_name] parameter gives the temporary file prefix. The temporary file is removed after running. *) val page_contents : ?pager:string -> ?pager_options:string list -> ?tmp_name:string -> string -> unit val pid_alive : Pid.t -> bool val get_groups : string -> string list (** [with_tmp pre suf f] creates a temp file, calls f with the file name, and removes the file afterwards. *) val with_tmp : pre:string -> suf:string -> (string -> 'a) -> 'a (** [diff s1 s2] returns diff (1) output of the two strings. Identical files returns the empty string. The default value of [options] is "-d -u", to provide shorter, unified diffs. *) val diff : ?options : string list -> string -> string -> string (** [ip_of_name hostname] looks up the hostname and prints the IP in dotted-quad format. *) val ip_of_name : string -> string (** [getbyname_ip ()] returns the IP of the current host by resolving the hostname. *) val getbyname_ip : unit -> string (** [ifconfig_ips ()] returns IPs of all active interfaces on the host by parsing ifconfig output. Note that this will include 127.0.0.1, assuming lo is up. *) val ifconfig_ips : unit -> String.Set.t (** [checked_edit ~check file] Edit a file in safe way, like [vipw(8)]. Launches your default editor on [file] and uses [check] to check its content. @param check a function returning a text representing the error in the file. @param create create the file if it doesn't exists. Default [true] @return [`Ok] or [`Abort]. If [`Abort] is returned the files was not modified (or created). *) val checked_edit : ?create:bool -> check:(string -> string option) -> string -> [ `Abort | `Ok ] (** Edit files containing sexps. *) module Sexp_checked_edit (S:Sexpable): sig val check : string -> string option val check_sexps : string -> string option val edit : ?create:bool -> string -> [ `Abort | `Ok ] val edit_sexps : ?create:bool -> string -> [ `Abort | `Ok ] end (** A module for getting a process's CPU use. *) module Cpu_use : sig type t (** [get] returns a Cpu_use.t for the given pid or the current processes's pid, if none given. Note that the [cpu_use] given by this initial value will probably be invalid. *) val get : ?pid : Pid.t -> unit -> t (** [update_exn] updates a Cpu_use.t. It will fail if the process no longer exists. *) val update_exn : t -> unit (** [cpu_use] gives an estimated CPU usage (between 0 and 1) in the time period between the last 2 calls to [update_exn]. *) val cpu_use : t -> float val resident_mem_use_in_kb : t -> float val age : t -> Time.Span.t val fds : t -> int end (* The Linux Standard Base (LSB) standardizes a few OS properties. *) (* Phahn 2012-11-29 I changed this from a float to a string to handle debian. It should be a proper type but there were only 2 uses both in selket checks so I just bodged. *) module Lsb_release : sig type t = { distributor_id : string; (* e.g. "Red Hat", "CentOS" *) release : string; (* e.g. "5.7", "6.3" or 'testing' on debian *) codename : string; (* e.g. "Final", "Lucid", etc. *) } with sexp, fields, bin_io val query : unit -> t end core_extended-113.00.00/src/tcp.ml000066400000000000000000000027061256461102500165420ustar00rootroot00000000000000open Core.Std ;; exception Connect_timeout ;; let with_connection ?(timeout=(Time.Span.of_float 30.)) ~host ~port ~f () = Exn.protectx (Unix.socket ~domain:Unix.PF_INET ~kind:Unix.SOCK_STREAM ~protocol:0) ~f:(fun sd -> Unix.set_nonblock sd; begin try Unix.connect sd ~addr:(Unix.get_sockaddr host port) with | Unix.Unix_error (EINPROGRESS, _, _) -> () | e -> raise e end; let sfds = Unix.select ~read:[] ~write:[sd] ~except:[sd] ~timeout:(`After (Time_ns.Span.of_span timeout)) () in begin match sfds.Unix.Select_fds.except with | [] -> () | sd :: [] -> Unix.unix_error (Unix.getsockopt_int sd Unix.SO_ERROR) "connect" (sprintf "%s:%d" host port) | _ -> assert false end; begin match sfds.Unix.Select_fds.write with | [] -> raise Connect_timeout | sd :: [] -> Unix.clear_nonblock sd; Exn.protectx (Unix.in_channel_of_descr sd, Unix.out_channel_of_descr sd) ~f:(fun (in_chan, out_chan) -> f in_chan out_chan) ~finally:(fun (in_chan, out_chan) -> try Out_channel.close out_chan with _e -> (); try In_channel.close in_chan with _e -> () ) | _ -> assert false end ) ~finally:(fun sd -> try Unix.close sd with _e -> ()) ;; core_extended-113.00.00/src/tcp.mli000066400000000000000000000014201256461102500167030ustar00rootroot00000000000000open Core.Std ;; (** [with_conn] opens a connection to the TCP service on [host] [port] and if successful calls [f] with In_channel.t and Out_channel.t as arguments. The return value of [f] will be returned by [with_conn]. [with_conn] raises Connect_timeout if the connection attempt times out. Unix_error will be raised if there are any other connect errors. Any exceptions raised by [f] will be re-raised, which may include Unix_errors raised by underlying channel read/write calls. The [In_channel.t], [Out_channel.t], and underlying socket will be closed by with_conn before it returns. *) exception Connect_timeout val with_connection : ?timeout:Time.Span.t -> host:string -> port:int -> f:(In_channel.t -> Out_channel.t -> 'a) -> unit -> 'a core_extended-113.00.00/src/timed_function.ml000066400000000000000000000036231256461102500207620ustar00rootroot00000000000000open Core.Std exception Timeout type 'a forked_computation = ('a,Sexp.t) Result.t with sexp let run_in_fork ~f ~sexp_of v = let pipe_read,pipe_write = Unix.pipe () in match Unix.fork() with | `In_the_child -> Unix.close pipe_read; let oc = Unix.out_channel_of_descr pipe_write in let res = try Ok (f v) with e -> Error (Exn.sexp_of_t e) in Sexp.output oc (sexp_of_forked_computation sexp_of (res : 'a forked_computation)); exit 0 | `In_the_parent pid -> Unix.close pipe_write; pid,pipe_read (** All our input comes in one burst so we do not need to run a select loop... *) let wait_for_input ~timeout fd = let select_fds = Unix.select () ~restart:true ~timeout:(`After (Time_ns.Span.of_span timeout)) ~read:[fd] ~write:[] ~except:[] in if select_fds.Unix.Select_fds.read = [] then None else Some (In_channel.input_all (Unix.in_channel_of_descr fd)) let run ~timeout ~f ~sexp_of ~of_sexp v = let pid,pipe_read = run_in_fork ~f ~sexp_of v in protectx () ~f:(fun () -> match wait_for_input ~timeout pipe_read with | None -> (* We timed out *) Process.kill ~is_child:true pid; raise Timeout | Some s -> let status = Unix.waitpid pid in if Result.is_error status then begin failwithf "Timed forked-out process exited with status %s" (Unix.Exit_or_signal.to_string_hum status) () end; match forked_computation_of_sexp of_sexp (Sexp.of_string s) with | Result.Error e -> failwithf "Timed forked-out function died with exception %s" (Sexp.to_string_hum e) (); | Result.Ok ok -> ok) ~finally:(fun () -> Unix.close pipe_read) core_extended-113.00.00/src/timed_function.mli000066400000000000000000000006201256461102500211250ustar00rootroot00000000000000open Core.Std (** Functions with timeouts This module is here to add timeouts to any functions. *) exception Timeout (** Runs a function in a fork process to ensure a timeout. The function passed must not raise an exception not have any weird side effects. *) val run : timeout:Time.Span.t -> f:('a -> 'b) -> sexp_of:('b -> Sexp.t) -> of_sexp:(Sexp.t -> 'b) -> 'a -> 'b core_extended-113.00.00/src/trie.ml000066400000000000000000000113071256461102500167140ustar00rootroot00000000000000open Core.Std (* The type of things that can be put into a trie. We are nice to consumers of the library by only requiring them to produce an iter function. But this means that our internal code is more unpleasant (and more full of refs) because we don't really know when iteration will end *) module type Key = sig type t module Part : sig type t with sexp val hash : t -> int val compare : t -> t -> int end val iter : t -> f:(Part.t -> unit) -> unit end module type S = sig module Key : sig type t end module Part : sig type t include Hashable with type t := t end type t = Node of (bool * t) Part.Table.t val create : unit -> t (* [contains t key] returns true if [key] has previously been added to [t] and not subsequently removed *) val contains : t -> Key.t -> bool (* [add t key] add [key] to the [t] *) val add : t -> Key.t -> unit (* [remove t key] removes [key] from [t] *) val remove : t -> Key.t -> unit (* [render_as_regexp t f] renders the trie as an optimized regular expression *) val render_as_regexp : t -> capture_parts:bool -> to_quoted_string:(Part.t -> string) -> string end module Make(T : Key) = struct module Key = struct type t = T.t end module Part = struct module Z = struct include T.Part end include Z include (Hashable.Make (Z) : Hashable.S with type t := t) end type t = Node of (bool * t) Part.Table.t let create () = Node (Part.Table.create ()) let add (Node t) key = let t = ref t in let set_terminator = ref (fun () -> ()) in let last_part = ref None in T.iter key ~f:(fun part -> last_part := Some part; match Part.Table.find !t part with | Some (_,Node next) -> t := next | None -> let reified_t = !t in let next = Part.Table.create () in Part.Table.set reified_t ~key:part ~data:(false, Node next); set_terminator := (fun () -> Part.Table.set reified_t ~key:part ~data:(true, Node next)); t := next); !set_terminator (); ;; let contains (Node t) key = let t = ref t in let terminated = ref false in with_return (fun return -> T.iter key ~f:(fun part -> match Part.Table.find !t part with | None -> return.return false | Some (is_terminator, Node next) -> terminated := is_terminator; t := next); !terminated) ;; let remove (Node t) key = let t = ref t in let delete = ref (fun () -> ()) in let clear_terminator = ref (fun () -> ()) in with_return (fun return -> T.iter key ~f:(fun part -> match Part.Table.find !t part with | None -> return.return () | Some (_,Node next) -> if Part.Table.length !t = 1 then begin !delete (); return.return () end else begin let reified_t = !t in delete := (fun () -> Part.Table.remove reified_t part); clear_terminator := (fun () -> match Part.Table.find reified_t part with | None -> assert false | Some (_,Node next) -> Part.Table.set !t ~key:part ~data:(false,Node next)); t := next end); !clear_terminator ()) module Regexp = struct type t = | Token of Part.t | Alt of t list | Seq of t * t | Maybe of t with sexp (* not tail recursive *) let rec of_t (Node t) = Alt (List.map (Part.Table.to_alist t) ~f:(fun (c, (terminates, rest)) -> if terminates then Seq (Token c, Maybe (of_t rest)) else Seq (Token c, of_t rest))) let render t ~capture_parts ~to_quoted_string = let open_group = if capture_parts then "(" else "(?:" in let rec render = function | Token c -> (to_quoted_string c) | Alt [] -> "" | Alt [t] -> render t | Alt ts -> let sub_expressions = List.map ts ~f:render in if List.for_all sub_expressions ~f:(fun s -> String.length s = 1) then "[" ^ String.concat ~sep:"" sub_expressions ^ "]" else open_group ^ String.concat ~sep:"|" (List.map ~f:render ts) ^ ")" | Seq (t, t') -> render t ^ render t' | Maybe (Alt []) -> "" | Maybe t -> open_group ^ render t ^ ")?" in render t end let render_as_regexp t ~capture_parts ~to_quoted_string = Regexp.render (Regexp.of_t t) ~capture_parts ~to_quoted_string end module String_trie = Make(struct type t = String.t module Part = struct include Char end let iter = String.iter end) core_extended-113.00.00/src/trie.mli000066400000000000000000000020651256461102500170660ustar00rootroot00000000000000open Core.Std module type Key = sig type t module Part : sig type t with sexp val hash : t -> int val compare : t -> t -> int end val iter : t -> f:(Part.t -> unit) -> unit end module type S = sig module Key : sig type t end module Part : sig type t include Hashable with type t := t end type t = Node of (bool * t) Part.Table.t val create : unit -> t (* [contains t key] returns true if [key] has previously been added to [t] and not subsequently removed *) val contains : t -> Key.t -> bool (* [add t key] add [key] to the [t] *) val add : t -> Key.t -> unit (* [remove t key] removes [key] from [t] *) val remove : t -> Key.t -> unit (* [render_as_regexp t f] renders the trie as an optimized regular expression *) val render_as_regexp : t -> capture_parts:bool -> to_quoted_string:(Part.t -> string) -> string end module Make(T : Key) : S with type Key.t = T.t with type Part.t = T.Part.t module String_trie : S with type Key.t = String.t with type Part.t = Char.t core_extended-113.00.00/src/unix_utils.ml000066400000000000000000000060241256461102500201540ustar00rootroot00000000000000open Core.Std module RLimit = Unix.RLimit (* Handling RAM limits *) let physical_ram () = Int64.( * ) (Unix.sysconf Unix.PAGESIZE) (Unix.sysconf Unix.PHYS_PAGES) type ram_usage_limit = Unlimited | Absolute of int64 | Relative of float let set_ram_limit l = RLimit.set (Or_error.ok_exn RLimit.virtual_memory) { RLimit.cur = RLimit.Limit l; RLimit.max = RLimit.Infinity; } let apply_ram_usage_limit = function | Unlimited -> () | Absolute i -> set_ram_limit i | Relative f -> set_ram_limit (Int64.of_float (f *. Int64.to_float (physical_ram ()))) let ram_msg = "RAM limit should be either an integer or a float between 0 and 1, not " let string_to_ram_usage_limit s = try let i = Int64.of_string s in if i > Int64.zero then Absolute i else Unlimited with Failure _ -> let f = Float.of_string s in if f < 0. || f > 1. then raise (Arg.Bad (ram_msg ^ s)); if f > 0. then Relative f else Unlimited let ram_limit_spec = ( "-ram_limit", Arg.String (fun s -> apply_ram_usage_limit (string_to_ram_usage_limit s)), "num Limit RAM consumption either as an absolute number of bytes or as \ a fraction of the total RAM, 0 - no limit" ) (* Signal handling *) let all_sigs = [ Signal.abrt; Signal.alrm; Signal.fpe; Signal.hup; Signal.ill; Signal.int; Signal.kill; Signal.pipe; Signal.quit; Signal.segv; Signal.term; Signal.usr1; Signal.usr2; Signal.chld; Signal.cont; Signal.stop; Signal.tstp; Signal.ttin; Signal.ttou; Signal.vtalrm; Signal.prof; ] let wrap_block_signals f = let blocked_sigs = Signal.sigprocmask `Set all_sigs in protect ~f ~finally:(fun () -> ignore (Signal.sigprocmask `Set blocked_sigs)) (* at_exit functions are honored only when terminating by exit, not by signals, so we need to do some tricks to get it run by signals too. NB: Ctrl-C is _not_ handled by this function, i.e., it terminates a program without running at_exit functions. *) let ensure_at_exit () = let pid = Unix.getpid () in let handler signal = do_at_exit (); Signal.handle_default signal; Signal.send_i signal (`Pid pid) in List.iter ~f:(fun s -> Signal.Expert.set s (`Handle handler)) [ (* there are the signals which terminate a program due to "external circumstances" as opposed to "internal bugs" *) Signal.hup; Signal.quit; Signal.term; ] let getppid_exn pid = In_channel.read_lines ("/proc/" ^ Pid.to_string pid ^ "/status") |! List.find_exn ~f:(String.is_prefix ~prefix:"PPid:") |! String.split ~on:'\t' |! function | ["PPid:"; ppid] -> Pid.of_string ppid | _ -> failwithf "couldn't parse ppid from /proc/%s/status" (Pid.to_string pid) () let get_ppids pid = (* please indulge me *) let rec unfold ~init ~f = match f init with | Some value -> value :: unfold ~init:value ~f | None -> [] in Option.try_with (fun () -> unfold ~init:pid ~f:(fun p -> if p = Pid.init then None else Some (getppid_exn p))) core_extended-113.00.00/src/unix_utils.mli000066400000000000000000000016261256461102500203300ustar00rootroot00000000000000(** Interface to Unix utility functions *) open Core.Std (** {2 Handling RAM limits} *) (** [physical_ram ()] @return the total amount of physical RAM in bytes. *) val physical_ram : unit -> int64 (** [ram_limit_spec] command line arguments to set ram limits. *) val ram_limit_spec : Arg.t (** {2 Signal handling} *) (** [wrap_block_signals f] blocks all signals before execution of [f], and restores them afterwards. *) val wrap_block_signals : (unit -> 'a) -> 'a (** [ensure_at_exit ()]: catch all signals, run at_exit functions, then re-deliver the signal to self to ensure the default behavior. at_exit functions are honored only when terminating by exit, not by signals, so we need to do some tricks to get it run by signals too*) val ensure_at_exit : unit -> unit (** [get_ppids pid] returns the list of parent pids, up to init (1) for pid. *) val get_ppids : Pid.t -> Pid.t list option core_extended-113.00.00/src/update_queue.ml000066400000000000000000000025521256461102500204410ustar00rootroot00000000000000open Core.Std type ('perm, 'state) t = { mutable state : 'state option; updates : ('state -> 'state) Queue.t; mutable watchers : ('state -> unit) list; executing : Mutex.t; } let create ?init () = { state = init; updates = Queue.create (); watchers = []; executing = Mutex.create (); } let clear_queue t = match Mutex.try_lock t.executing with | `Acquired -> let rec loop () = match t.state with | None -> () | Some state -> match Queue.dequeue t.updates with | None -> () | Some f -> let new_state = f state in List.iter t.watchers ~f:(fun f -> f new_state); t.state <- Some new_state; loop () in Exn.protect ~f:loop ~finally:(fun () -> Mutex.unlock t.executing; Queue.clear t.updates) | `Already_held_by_me_or_other -> () let init t state = if Option.is_some t.state then failwith "Update_queue.init: Cannot call init twice" else begin t.state <- Some state; clear_queue t end let enqueue t f = Queue.enqueue t.updates f; clear_queue t let watch t ~f = t.watchers <- f :: t.watchers let map t ~f = let new_t = create ?init:(Option.map t.state ~f) () in watch t ~f:(fun x -> enqueue new_t (fun _ -> f x)); new_t let read_only t = let new_t = create ?init:t.state () in watch t ~f:(fun x -> enqueue new_t (fun _ -> x)); new_t core_extended-113.00.00/src/update_queue.mli000066400000000000000000000031361256461102500206110ustar00rootroot00000000000000open Core.Std (** A ['state t] keeps track of updates of type ['state -> 'state] queued to it and runs them sequentially. This has the primary feature that if an update itself schedules another update, that other update will be run after the first update has finished. For example, consider the code: {[let x = create ~init:1 () in enqueue_update x (fun x -> enqueue_update (fun x -> x + 1); x + 1)]} At the end, [x]'s state will be 2, as you would expect. However, suppose you did this with an [int ref]: {[let x = ref 1 in let update_x f = x := f !x in update_x (fun x -> update_x (fun x -> x + 1); x + 1 )]} At the end of this, [!x] would be 1. Another feature is that the initial value does not have to be specified at creation. If it is not, enqueued updates will be kept around until an initial value is specified with [init]. *) type ('perm, 'state) t val create : ?init:'state -> unit -> ([< _ perms], 'state) t val init : (read_write, 'state) t -> 'state -> unit val enqueue : (read_write, 'state) t -> ('state -> 'state) -> unit (** [watch t f] will call [f] every time that that [t]'s state is updated. [f] should not call [enqueue_update]. *) val watch : (_, 'state) t -> f:('state -> unit) -> unit (* This function will register a watcher with the input [t]. That means the return value will not be garbage-collected at least as long as the input [t] is not garbage-collected. *) val map : (_, 'state1) t -> f:('state1 -> 'state2) -> (read,'state2) t val read_only : ([> read ], 'state) t -> (read, 'state) t core_extended-113.00.00/test/000077500000000000000000000000001256461102500156055ustar00rootroot00000000000000core_extended-113.00.00/test/bench_bind.ml000066400000000000000000000021041256461102500202070ustar00rootroot00000000000000open Core.Std open Core_extended.Std.Deprecated_bench module F = struct let ok x = Ok x let bind_cascade () = let open Or_error.Monad_infix in (* let open Result.Monad_infix in *) let x = () in ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x >>= fun x -> ok x let match_cascade () = let x = () in match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> match ok x with Error _ as x -> x | Ok x -> ok x end let () = bench ~trials:(`Num 100) [ Test.create ~size:8 ~name:"bind" (fun () -> ignore (F.bind_cascade () : unit Or_error.t)) ; Test.create ~size:8 ~name:"match" (fun () -> ignore (F.match_cascade () : unit Or_error.t)) ] core_extended-113.00.00/test/bench_nano_mutex.ml000066400000000000000000000016471256461102500214630ustar00rootroot00000000000000open Core.Std module Bench = Core_extended.Std.Deprecated_bench module type Mutex = sig type t val create : unit -> t val lock : t -> unit val unlock : t -> unit end let concat = String.concat let make ~name (m : (module Mutex)) = let module M = (val m : Mutex) in [ concat [ name; " create"], (fun () -> ignore (M.create ())); concat [ name; " lock/unlock"], let l = M.create () in (fun () -> M.lock l; M.unlock l); ] ;; module Nano_mutex : Mutex = struct include Core.Std.Nano_mutex let lock = lock_exn let unlock t = unlock_exn t end let () = Bench.bench ~columns:[ `Name; `Cycles; `If_not_empty `Warnings ] (List.map ~f:(fun (name, thunk) -> Bench.Test.create ~name thunk) ( make ~name:"Caml.Mutex" (module Caml.Mutex : Mutex) @ make ~name:"Core.Mutex" (module Core.Std.Mutex : Mutex) @ make ~name:"Nano_mutex" (module Nano_mutex : Mutex) )) ;; core_extended-113.00.00/test/bin_io_utils_test.ml000066400000000000000000000007061256461102500216600ustar00rootroot00000000000000open Core.Std open Core_extended.Std open OUnit type el = [ `Test1 | `Test2 | `Test3 ] with bin_io type t = el list with bin_io let test = "Bin_io_utils_test" >::: [ "load/save" >:: (fun () -> let v = [ `Test1; `Test2; `Test3 ] in let file = "bin_io_test.bin" in Bin_io_utils.save file bin_writer_t v; let v' = Bin_io_utils.load file bin_read_t in Sys.remove file; "same" @? (v = v')); ] core_extended-113.00.00/test/cache_test.ml000066400000000000000000000020031256461102500202340ustar00rootroot00000000000000open Core_extended.Std open OUnit module Lru = Cache.Lru let seteq l1 l2 = List.sort ~cmp:compare l1 = List.sort ~cmp:compare l2 let str l = "[" ^ String.concat ~sep:", " (List.map ~f:string_of_int l) ^ "]" let dead = ref [] let clear_dead () = dead := [] let lru = Lru.create ~destruct:(Some (fun v -> dead := v::!dead)) 3 let touch v = Lru.add lru ~key:v ~data:v let test = "lru" >::: [ "1234-1" >:: (fun () -> clear_dead (); touch 1; touch 2; touch 3; touch 4; (str !dead) @? seteq !dead [1]); "235-4" >:: (fun () -> clear_dead (); touch 2; touch 3; touch 5; (str !dead) @? seteq !dead [4]); "36-2" >:: (fun () -> clear_dead (); touch 3; touch 6; (str !dead) @? seteq !dead [2]); "7-5" >:: (fun () -> clear_dead (); touch 7; (str !dead) @? seteq !dead [5]); "c-763" >:: (fun () -> clear_dead (); Lru.clear lru; (str !dead) @? seteq !dead [7;6;3]); "890-" >:: (fun () -> clear_dead (); touch 8; touch 9; touch 0; (str !dead) @? seteq !dead []); ] core_extended-113.00.00/test/core_extended_hello.ml000066400000000000000000000002531256461102500221320ustar00rootroot00000000000000module Core_std = Core.Std module Core_extended_std = Core_extended.Std let () = print_endline "This binary is only used to check what gets linked in by core_extended" core_extended-113.00.00/test/core_hello.ml000066400000000000000000000001651256461102500202540ustar00rootroot00000000000000module Core_std = Core.Std let () = print_endline "This binary is only used to check what gets linked in by core" core_extended-113.00.00/test/extended_float_test.ml000066400000000000000000000040761256461102500221720ustar00rootroot00000000000000open Core.Std open Core_extended.Std open OUnit let test = "extended_float" >::: [ "pretty" >:: (fun () -> List.iter ~f:(fun (f, s) -> Float.to_string f @? (s = Float.pretty ~on_negative:`Print_dir f)) [ (0.004, "0"); (0.0049, "0"); (0.005, "0.01"); (0.009, "0.01"); (0.01, "0.01"); (0.10, "0.1"); (0.99, "0.99"); (0.994, "0.99"); (0.995, "1"); (1.0, "1"); (1.001, "1"); (1.006, "1.01"); (1.01, "1.01"); (9.99, "9.99"); (9.994, "9.99"); (9.995, "10"); (9.996, "10"); (10.0, "10"); (10.1, "10.1"); (99.9, "99.9"); (99.94, "99.9"); (99.95, "100"); (99.96, "100"); (100.0, "100"); (100.6, "101"); (999.0, "999"); (999.4, "999"); (999.5, "1000"); (1000.0, "1000"); (9999.0, "9999"); (10_000.0, "10k"); (12_345.0, "12k3"); (12_500.0, "12k5"); (99_999.0, "100k"); (100_000.0, "100k"); (999_499.0, "999k"); (999_500.0, "1m"); (1_000_000.0, "1m"); (1_230_000.0, "1m23"); (999_499_000.0, "999m"); ]); "to_float_hum" >:: (fun () -> List.iter ~f:(fun (f, s) -> Float.to_string f @? (s = Float.to_string_hum f)) [ 1.00004e12, "1.000_04e+12"; -10004.0004,"-10_004.000_4"; -14.,"-14."; ]); "order_of_magnitude_difference" >:: (fun () -> let test (a, b, n) = (sprintf "((oom_diff %g %g = %d))" a b n) @? (Float.order_of_magnitude_difference a b = n) in List.iter ~f:test [ ( 11.0, 1001.0, 2); (1001.0, 11.0, 2); ( 131.0, 11.0, 1); ( 9.5, 9.0, 0); ( 9.5, 1.0, 1); ( 200.0, 0.003, 5); ]); ] core_extended-113.00.00/test/extended_list_test.ml000066400000000000000000000040611256461102500220320ustar00rootroot00000000000000open Core.Std open OUnit module L = Core_extended.Std.List let is_even x = x mod 2 = 0 let test = "Extended_list" >::: [ "number" >:: (fun () -> "base" @? (L.number [1;2;3;1;4] = [1,0;2,0;3,0;1,1;4,0])); "multimerge" >:: (fun () -> "base" @? (L.multimerge [[0;2];[2;3];[0;1];[1;2]] = [0;1;2;3]); "dup" @? (L.multimerge [[0;1;2;0];[0;1]] = [0;1;2;0]); (* There is no solution here: we just want to make sure that the result has all the fields. *) "circle" @? ( let header = L.multimerge [[0;1;2];[0;2;1;4]] in List.sort ~cmp:Int.compare header = [0;1;2;4])); ("take_while" >:: fun () -> "take evens" @? ( (L.take_while [2;4;6;7;8;9] ~f:is_even) = [2;4;6])); ("equal" >::: let equal xs ys = L.equal ~equal:Int.equal xs ys in let assert_equal xs ys = assert (equal xs ys) in let assert_not_equal xs ys = assert (not (equal xs ys)) in [ ("1" >:: fun () -> assert_equal [] []); ("2" >:: fun () -> assert_not_equal [2] []); ("3" >:: fun () -> assert_not_equal [] [3]); ("4" >:: fun () -> assert_equal [4] [4]); ("5" >:: fun () -> assert_not_equal [0; 5] [0]); ("6" >:: fun () -> assert_not_equal [0] [0; 6]); ("7" >:: fun () -> assert_equal [0; 7] [0; 7]); ]); ("compare" >::: let compare xs ys = L.compare Int.compare xs ys in let assert_eq xs ys = assert (compare xs ys = 0) in let assert_lt xs ys = assert (compare xs ys < 0) in let assert_gt xs ys = assert (compare xs ys > 0) in [ ("1" >:: fun () -> assert_eq [] []); ("2" >:: fun () -> assert_gt [2] []); ("3" >:: fun () -> assert_lt [] [3]); ("4" >:: fun () -> assert_eq [4] [4]); ("4" >:: fun () -> assert_lt [3] [4]); ("4" >:: fun () -> assert_gt [3] [2]); ("5" >:: fun () -> assert_gt [0; 5] [0]); ("6" >:: fun () -> assert_lt [0] [0; 6]); ("5" >:: fun () -> assert_lt [0; 5] [1]); ("6" >:: fun () -> assert_gt [1] [0; 6]); ("7" >:: fun () -> assert_eq [0; 7] [0; 7]); ]); ] core_extended-113.00.00/test/extended_string_test.ml000066400000000000000000000034101256461102500223620ustar00rootroot00000000000000open Core_extended.Std open OUnit open Core_extended.Quickcheck_deprecated let dup gen () = let x = gen () in x,x let true_count l = List.fold l ~f:(fun acc v -> if v then acc + 1 else acc) ~init:0 let definitive_clause l = true_count l = 1 let unescaped_test ~name s = name @? (String.unescaped (String.escaped s) = s) let test = "extended_string" >::: [ "collate" >:: (fun () -> let (!) s s' = String.collate s s' > 0 in let basic_tests = (fun (s,s') -> "invertible" @? ((s' ! s')); "total" @? (definitive_clause [s!s'])) in repeat 50 basic_tests (pg sg sg); repeat 2 basic_tests (dup sg); repeat 50 (fun (s,s',s'') -> let (s1,s2,s3) = match List.sort ~cmp:String.collate [s;s';s''] with | [s1;s2;s3] -> s1,s2,s3 | _ -> assert false in "transitive" @? (((s1 :: (fun () -> unescaped_test ~name:"empty" ""; repeat 50 (unescaped_test ~name:"random") sg; "hex" @? (String.unescaped "\\xff" = "\xff"); "strict illegal escape" @? (try ignore (String.unescaped "\\a"); false with Invalid_argument _ -> true); "non strict" @? (String.unescaped ~strict:false "\\a" = "\\a"); "non-strict illegal escape" @? (try ignore (String.unescaped ~strict:false "\\512"); false with Invalid_argument _ -> true) ); ] core_extended-113.00.00/test/extended_time_test.ml000066400000000000000000000010701256461102500220120ustar00rootroot00000000000000open OUnit open Core.Std module Time = Core_extended.Std.Time let test = "extended_time.Extended_span" >::: [ "to_string_hum" >:: (fun () -> let t secs str = (Float.to_string secs) @? (Time.Extended_span.to_string_hum (sec secs) = str) in t 0. "0:00:00.000"; t 0.075 "0:00:00.075"; t 3.075 "0:00:03.075"; t 163.075 "0:02:43.075"; t 3763.075 "1:02:43.075"; t 432163.075 "120:02:43.075"; t (-. 432163.075) "-120:02:43.075"; ); ] core_extended-113.00.00/test/iter_test.ml000066400000000000000000000016171256461102500201460ustar00rootroot00000000000000open OUnit open Core.Std open Core_extended.Std let test = "iter" >::: [ "main" >:: (fun () -> let l = [1;2;3;4;5] in let a = Array.of_list l in "list" @? (l = Iter.to_list (Iter.of_list l) ~f:ident); "array" @? (a = Iter.to_array (Iter.of_array a) ~f:ident); "print" @? (let b = Buffer.create 10 in Iter.i (Iter.of_list l) ~f:(fun x -> Printf.bprintf b "%d" x); Buffer.contents b = "12345"); "map1" @? (let f x = x * x in Iter.to_array (Iter.map (Iter.of_array a) ~f) ~f:ident = Array.map ~f a); "map2" @? (let f x = x * x * x and g n = String.length (string_of_int n) in Iter.to_list (Iter.map (Iter.of_list l) ~f) ~f:g = List.map l ~f:(fun n -> g (f n))); "reduce" @? (List.fold ~init:0 ~f:(+) l = Iter.reduce ~init:0 ~f:(+) (Iter.of_list l)); ); ] core_extended-113.00.00/test/ktee.ml000066400000000000000000000021721256461102500170710ustar00rootroot00000000000000(* OCaml-version of ktee.c in same directory *) (* Example usage: cat /etc/termcap | ktee.exe foo1.log | cat > foo2.log *) open Core.Std open Core_extended.Std open Unix open Linux_ext let main () = let ofd = openfile Sys.argv.(1) ~mode:[O_WRONLY; O_CREAT; O_TRUNC] ~perm:0o644 in let tee_flags = Splice.make_flags [| |] in let splice_flags = Splice.make_flags [| Splice.MOVE |] in let rec loop () = match try Some ( let tee = Or_error.ok_exn Splice.tee in tee ~assume_fd_is_nonblocking:true ~fd_in:stdin ~fd_out:stdout Int.max_value tee_flags) with Unix_error (EAGAIN, _, _) -> None with | None -> loop () | Some len when len = 0 -> () | Some len -> let rec splice_loop len = if len > 0 then let slen, _, _ = let splice = Or_error.ok_exn Splice.splice in splice ~fd_in:stdin ~fd_out:ofd ~len splice_flags in splice_loop (len - slen) else loop () in splice_loop len in loop () let () = try main () with exc -> printf "%s\n%!" (Exn.to_string exc) core_extended-113.00.00/test/ldd_test.ml000066400000000000000000000031671256461102500177500ustar00rootroot00000000000000open Core.Std open Core_extended.Std open OUnit (* This test checks that no new link dependencies have been added *) let libs pgm = Shell.run_lines "ldd" [pgm] |! List.map ~f:(String.strip) |! List.filter ~f:(fun s -> not (String.is_prefix ~prefix:"/lib64/ld-linux" s)) |! List.map ~f:(fun s -> match String.lsplit2 s ~on:'.' with | None -> assert_failure (sprintf "ldd_test:%s does not seem to be a valid library name" s) | Some (v,_) -> v) let whitelist = ["libpcre"] let core_hello = ref "core_hello" let core_extended_hello = ref "core_extended_hello" let args = ["--core-hello",Arg.Set_string core_hello,"PGM hello world program linked against core"; "--core-extended-hello",Arg.Set_string core_extended_hello,"PGM hello world program linked against core_extended" ] let check_exe f = let exts = [ ""; ".exe"; ".native" ] in match List.find exts ~f:(fun ext -> Sys.file_exists_exn (f ^ ext)) with | Some ext -> f ^ ext | None -> assert_failure (sprintf "could not find "^f) let test = "Ldd_test" >:: (fun () -> let core_hello = check_exe !core_hello in let core_extended_hello = check_exe !core_extended_hello in let base_libs = libs core_hello @ whitelist and ext_libs = libs core_extended_hello in let added_libs = List.filter ext_libs ~f:(fun l -> not (List.mem base_libs l)) in if added_libs <> [] then assert_failure (sprintf "Core_extended links in new external libraries %s" (String.concat ~sep:" " added_libs))); core_extended-113.00.00/test/numbers_test.ml000066400000000000000000000050601256461102500206520ustar00rootroot00000000000000open Core.Std open Core_extended.Std open OUnit type tests = { good_pos : Sexp.t list; bad_pos : Sexp.t list; good_pos0 : Sexp.t list; bad_pos0 : Sexp.t list; good_neg : Sexp.t list; bad_neg : Sexp.t list; good_neg0 : Sexp.t list; bad_neg0 : Sexp.t list; good_bound : Sexp.t list; bad_bound : Sexp.t list; } with sexp module type Spec = sig include Number.Spec include Number.Verified_std with type repr = t end let find_file ~dirs fname = List.find dirs ~f:(fun d -> Sys.file_exists_exn (d ^/ fname)) |! Option.map ~f:(fun d -> d ^/ fname) let tests = Memo.unit (fun () -> match find_file ~dirs:["."; "lib_test"] "numbers_test.sexp" with | None -> failwith "I can't find numbers_test.sexp" | Some fname -> Sexp.load_sexp_conv_exn fname tests_of_sexp) module Make_test (Spec : Spec) = struct open Spec let test_good name lst t_of_sexp = List.iter lst ~f:(fun sexp -> try ignore (t_of_sexp sexp) with _ -> failwithf "%s failed on good: %s" name (Spec.to_string (Spec.t_of_sexp sexp)) ()) let test_bad name lst t_of_sexp = List.iter lst ~f:(fun sexp -> try ignore (t_of_sexp sexp); failwithf "%s failed on bad: %s" name (Spec.to_string (Spec.t_of_sexp sexp)) () with Of_sexp_error _ -> ()) let test name good bad t_of_sexp = test_good name good t_of_sexp; test_bad name bad t_of_sexp let () = let tests = tests () in test "Pos" tests.good_pos tests.bad_pos Pos.t_of_sexp; test "Pos0" tests.good_pos0 tests.bad_pos0 Pos0.t_of_sexp; test "Neg" tests.good_neg tests.bad_neg Neg.t_of_sexp; test "Neg0" tests.good_neg0 tests.bad_neg0 Neg0.t_of_sexp; let module Bounded_spec = struct let name = "Bound" let lower = of_string "3" let upper = of_string "42" end in let module Bounded = Spec.Make_bounded (Bounded_spec) in test "Bounded" tests.good_bound tests.bad_bound Bounded.t_of_sexp; end let test = "Numbers_test" >::: [ "Int" >:: (fun () -> let module My_test = Make_test (Int) in ()); "Int32" >:: (fun () -> let module My_test = Make_test (Int32) in ()); "Int63" >:: (fun () -> let module My_test = Make_test (Int63) in ()); "Int64" >:: (fun () -> let module My_test = Make_test (Int64) in ()); "Nativeint" >:: (fun () -> let module My_test = Make_test (Nativeint) in ()); "Float" >:: (fun () -> let module My_test = Make_test (Float) in ()); ] core_extended-113.00.00/test/numbers_test.sexp000066400000000000000000000003501256461102500212160ustar00rootroot00000000000000( (good_pos (1 2 3)) (bad_pos (0 -1 -2)) (good_pos0 (0 1 2)) (bad_pos0 (-1 -2 -3)) (good_neg (-1 -2 -3)) (bad_neg (0 1 2)) (good_neg0 (0 -1 -2)) (bad_neg0 (1 2 3)) (good_bound (3 27 42)) (bad_bound (2 43)) ) core_extended-113.00.00/test/qtest.ml000066400000000000000000000002011256461102500172700ustar00rootroot00000000000000(** Regression test runner. *) let tests = Qtest_lib.Std.Test.tests_of_ounit Test.all let () = Qtest_lib.Std.Runner.main tests core_extended-113.00.00/test/readline_test.ml000066400000000000000000000007261256461102500207660ustar00rootroot00000000000000open Core.Std open Core_extended.Std (* interactive readline test *) let names = [ "Till"; "Bene"; "Mark"; "David"; "Markus" ] let rec loop f = match f () with | None -> () | Some line -> Printf.printf "%S\n%!" line; loop f let () = let tab_completion ~left ~right:_ = let last = List.last_exn (String.split left ~on:' ') in List.filter names ~f:(String.is_prefix ~prefix:last) in loop (Readline.input_line ~tab_completion) core_extended-113.00.00/test/search_test.ml000066400000000000000000000003521256461102500204430ustar00rootroot00000000000000open Core.Std open Core_extended.Std open OUnit let test = "search" >::: [ "max_len" >:: (fun () -> "1" @? ((Search.max_len ~key:Fn.id [|"a";"bb"|]) = 2); "2" @? ((Search.max_len ~key:fst [|("a",2);("bb",3)|]) = 2); ); ] core_extended-113.00.00/test/sexp_pp.ml000066400000000000000000000021401256461102500176120ustar00rootroot00000000000000open Core.Std open Core_extended.Std let engine : [`Alter | `New | `Old] ref = ref `New let alter sexp = Format.pp_set_margin Format.std_formatter 80; Sexp.pp_hum' Format.std_formatter sexp; Format.pp_print_newline Format.std_formatter () let pp sexp = match !engine with | `New -> Pp.to_file stdout (Sexp.format sexp) | `Old -> Sexp.output_hum stdout sexp | `Alter -> alter sexp let spec = [ "-old",Arg.Unit (fun () -> engine := `Old)," Pretty print with sexp's code"; "-alter",Arg.Unit (fun () -> engine := `Alter)," Pretty print with sexp's code" ] let usage = sprintf "%s [flags] [file]..." (Filename.basename Sys.executable_name) let main () = let is_piped = not (Unix.isatty Unix.stdin) in let args = ref [] in Arg.parse spec (fun s -> args:= s:: !args) usage ; match List.rev !args with | [] -> if is_piped then begin List.iter ~f:pp (Sexp.input_sexps stdin) end else begin Arg.usage spec usage; exit 1 end | l -> List.concat_map ~f:Sexp.load_sexps l |! List.iter ~f:pp let () = Exn.handle_uncaught ~exit:true main core_extended-113.00.00/test/shell_test.ml000066400000000000000000000004211256461102500203020ustar00rootroot00000000000000open Core.Std open OUnit module Sh = Core_extended.Shell let test = "shell" >::: [ "run" >:: (fun () -> "length" @? ((Sh.sh_lines "yes yes | head -n 200000") = List.init 200_000 ~f:(fun _num -> "yes"))); ] core_extended-113.00.00/test/strftime_test.ml000066400000000000000000000026651256461102500210440ustar00rootroot00000000000000open Core.Std let _ = _squelch_unused_module_warning_ open Core_extended.Std let () = let now = Time.now () in let crazy = Time.format now "\ %%a: %_25a\n\ %%A: %_25A\n\ %%b: %_25b\n\ %%B: %_25B\n\ %%c: %_25c\n\ %%C: %_25C\n\ %%d: %_25d\n\ %%D: %_25D\n\ %%e: %_25e\n\ %%Ec: %_25Ec\n\ %%EC: %_25EC\n\ %%Ex: %_25Ex\n\ %%EX: %_25EX\n\ %%Ey: %_25Ey\n\ %%EY: %_25EY\n\ %%F: %_25F\n\ %%G: %_25G\n\ %%g: %_25g\n\ %%h: %_25h\n\ %%H: %_25H\n\ %%I: %_25I\n\ %%j: %_25j\n\ %%k: %_25k\n\ %%l: %_25l\n\ %%m: %_25m\n\ %%M: %_25M\n\ %%n: %_25n\n\ %%Od: %_25Od\n\ %%Oe: %_25Oe\n\ %%OH: %_25OH\n\ %%OI: %_25OI\n\ %%Om: %_25Om\n\ %%OM: %_25OM\n\ %%OS: %_25OS\n\ %%Ou: %_25Ou\n\ %%OU: %_25OU\n\ %%OV: %_25OV\n\ %%Ow: %_25Ow\n\ %%OW: %_25OW\n\ %%Oy: %_25Oy\n\ %%p: %_25p\n\ %%P: %_25P\n\ %%r: %_25r\n\ %%R: %_25R\n\ %%s: %_25s\n\ %%S: %_25S\n\ %%t: %_25t\n\ %%T: %_25T\n\ %%u: %_25u\n\ %%U: %_25U\n\ %%V: %_25V\n\ %%w: %_25w\n\ %%W: %_25W\n\ %%x: %_25x\n\ %%X: %_25X\n\ %%y: %_25y\n\ %%Y: %_25Y\n\ %%z: %_25z\n\ %%Z: %_25Z\n\ %%%%: %_25%" in print_endline crazy core_extended-113.00.00/test/tables.ml000066400000000000000000000013111256461102500174050ustar00rootroot00000000000000open Core_extended.Std open Ascii_table let data = [ ["aaa"; "bbb"; "ccc ooo ooo\ntoto"; "ddd"; "eee"]; ["aaa"; "bbb"; "ccc"; "ddd"; "eee\ntoto"]; ["aaa"; "bbb"; "ccc"; "ddd"; "eee"]; ["aaa"; "bbb"; "ccc"; "ddd"; "eee"]; ["aaa"; "bbb"; "ccc"; "ddd"; "eee"]; ] let () = let col i = Column.create ("column " ^ Int.to_string i) (fun x -> List.nth_exn x i) in List.iter [ "short_box", Display.short_box; "tall_box", Display.tall_box; "line", Display.line; "blank", Display.blank; ] ~f:(fun (name, display) -> Printf.printf "* %s:\n" name; output ~oc:stdout ~limit_width_to:50 ~display ~bars:`Unicode [col 0; col 1; col 2; col 3; col 4] data) core_extended-113.00.00/test/test.ml000066400000000000000000000006721256461102500171230ustar00rootroot00000000000000open OUnit;; INCLUDE "../../core/src/config.mlh" let all = let tests = [ Extended_float_test.test; Extended_list_test.test; Extended_string_test.test; Extended_time_test.test; Iter_test.test; Cache_test.test; Shell_test.test; Search_test.test; Numbers_test.test; Bin_io_utils_test.test; ] in let tests = IFDEF LINUX_EXT THEN Ldd_test.test :: tests ELSE tests ENDIF in TestList tests core_extended-113.00.00/test/test_runner.ml000066400000000000000000000002061256461102500205050ustar00rootroot00000000000000open OUnit;; let () = ignore (run_test_tt_main ~arg_specs:Ldd_test.args Test.all: OUnit.test_result list)